(setf *bonsai01*

'(let ()

(defun %align (x i)
  (let ((y 0)
        (j i))
    (do-until ((%= i 0))
              (setq y (addr-ior y (addr-and x 1)))
              (setq x (p-shiftr-1 x))
              (setq i (%- i 1)))
    (p-shiftl (%+ x y) j)))
                    

(defun p-shiftr (x i)
  (do-until ((%<= i 0) x)
            (setq x (p-shiftr-1 x))
            (setq i (%- i 1))))


(defun p-shiftl (x i)
  (do-until ((%<= i 0) x)
            (setq x (p-shiftl-1 x))
            (setq i (%- i 1))))

;(defun %rem (a b)
;  (do-until ((%> b a) a) (setq a (%- a b)))) 

(defun %rem (a b)
  (let ((res (%- a (%* b (%div a b)))))
    (if (%< res 0)
        (if (%< b 0) (%- res b)
          (%+ res b))
      res)))


; vergleichsfunktionen allgemein


(setq t 't)

(defun null (x)
  (eq x nil))

(defun atom (x)
  (not (consp x)))

; logische funktionen


(defun not (x)
  (cond ((null x) t)
        (t nil)))



; die conses, lese und schreibfunktionen


(defun cons (x y)
  (let ((p (%allocate-space 8)))
    (set-word p 0 x)
    (set-word p 4 y)
    (setq p (tag-set p 1))
    p))


(defun car (x)
  (if (null x)
        nil
      (get-word x 0)))
     

(defun cdr (x)
  (if (null x)
      nil
    (get-word x 4)))


(defun set-car (x v)
  (set-word x 0 v))


(defun set-cdr (x v)
  (set-word x 4 v))

; die conses, testfunktionen

(setq *cons-tag* 1)

(defun consp (x)
  (tag-eq x *cons-tag*))

(defun listp (x)
  (or (null x) (consp x)))



; die strings, lesen und schreiben von zeichenpositionen


(setq *string-head-tag* 2)
(setq *string-tag* 2)

(defun make-string (n)
  (let ((len (p-shiftr (%align n 2) 2)))
    (let ((n-align (%align (%+ (%* len 4) 8) 3)))
      (let ((p (%allocate-space n-align)))
        (set-word p 0 (tag-set (addr-ior (p-shiftl n-align 2) 1) *string-head-tag*))
        (set-word p 4 n)
        (do ((i 0 (%+ i 1)))
            ((%>= i n))
          (set-char p i (code-char 0)))
        (setq p (tag-set p *string-tag*))
        p))))
        

(defun char (str i)
  (let ((byte-val (get-byte str (%+ i 8))))
    (code-char byte-val)))

(defun set-char (str i c)
  (let ((byte-val (char-code c)))
    (set-byte str (%+ i 8) byte-val)))


; die strings, testfunktionen


(defun stringp (x)
  (and (tag-eq x *string-tag*)
       (let ((h (get-word x 0)))
         (and
          (addr-eqi (addr-and h 2) 0)
          (tag-eq h *string-head-tag*)))))
          


; die strings, vergleichsfunktionen

(defun length (s)
  (if (or (stringp s) (arrayp s))
      (get-word s 4)
    -1))
        

(defun string< (x y)
  )

(defun string> (x y)
  )

(defun string= (x y)
  )

(defun string-cmp-code (x y)
  (let ((len-x (length x))
        (len-y (length y))
        (res-code 0))
    (do ((i 0 (%+ i 1)))
        ((or (%>= i len-x) (%>= i len-y) (%/= res-code 0)) res-code)
      (let ((cc-1 (char-code (char x i)))
            (cc-2 (char-code (char y i))))
        (if (%< cc-1 cc-2)
            (setq res-code -1)
          (if (%> cc-1 cc-2)
              (setq res-code +1)))))
    (if (%= res-code 0)
        (cond ((%< len-x len-y) -1)
              ((%= len-x len-y) 0)
              ((%> len-x len-y) +1))
      res-code)))

(defun get-hash (str n)
  (let ((len (length str))
        (res 2))
    (do ((i 0 (%+ i 2)))
        ((%>= i (%- len 1)) (%rem res n))
      (setq res (%rem (%+ res (%+ (char-code (char str i)) (%* (char-code (char str (%+ i 1))) 256))) n)))))


; die vectoren, lesen und schreiben von elementen

(setq *array-head-tag* 1)
(setq *array-tag* 2)
(setq *array-lead* 12)


(defun make-vector (n)
  (let ((n-bytes (%align (%+ (%* 4 n) *array-lead*) 3)))
    (let ((p (%allocate-space n-bytes)))
      (set-word p 0 (tag-set (addr-ior (p-shiftl n-bytes 2) 1) *array-head-tag*))
      (set-word p 4 n)
      (set-word p 8 0)
      (do ((i 0 (%+ i 1)))
          ((%>= i n))
        (set-svref p i nil))
      (setq p (tag-set p *array-tag*)))))

(defun svref (vect i)
  (get-word vect (%+ (%* i 4) *array-lead*)))

(defun set-svref (vect i val)
  (set-word vect (%+ (%* i 4) *array-lead*) val))


; die vectoren, testfunktionen

(defun arrayp (x)
  (and (tag-eq x *array-tag*)
       (let ((h (get-word x 0)))
         (and
          (addr-eqi (addr-and h 2) 0)
          (tag-eq h *array-head-tag*)))))




; die chars

(setq *char-mark* 0)
(setq *char-tag* 3)


(defun char-code (c)
  (p-shiftr c 14))

(defun code-char (x)
  (tag-set (p-shiftl x 14) *char-tag*))

(defun characterp (x)
  (tag-eq x *char-tag*))



; die atome


(setq *symbol-head-addr* 3)
(setq *symbol-head-tag* 2)
(setq *symbol-tag* 2)


(defun make-symbol (str)
  (let ((p (%allocate-space 24)))
    (set-word p 0 (tag-set *symbol-head-addr* *symbol-head-tag*))
    (set-word p 4 str)
    (set-word p 8 nil)
    (set-word p 12 nil)
    (set-word p 16 nil)
    (set-word p 20 nil)
    (tag-set p *symbol-tag*)))

(defun intern (str)
  (let ((hash-val (get-hash str *base-pkg-len*)))
    (let ((slot (svref *base-pkg* hash-val))
          (p-old nil)
          (p-akt nil)
          (str-cmp-val -1)
          (test-str str))
      (do ((akt-atom slot (cdr akt-atom)))
          ((or (null akt-atom) (%>= str-cmp-val 0)))
        (setq str-cmp-val (string-cmp-code str (symbol-name (car akt-atom))))
        (setq p-old p-akt)
        (setq p-akt akt-atom))
      (cond ((%= 0 str-cmp-val)
             (car p-akt))
            ((%>= str-cmp-val 0)
             (let* ((new-sym (make-symbol str))
                    (new-holder (cons new-sym p-akt)))
               (set-symbol-package new-sym *base-pkg*)
               (if (null p-old)
                   (let ()
                     (set-svref *base-pkg* hash-val new-holder))
                 (set-cdr p-old new-holder))
               new-sym))
            ((%< str-cmp-val 0)
             (let* ((new-sym (make-symbol str))
                    (new-holder (cons new-sym nil)))
                (set-symbol-package new-sym *base-pkg*)
                (if (null p-akt)
                    (let ()
                      (set-svref *base-pkg* hash-val new-holder))
                  (set-cdr p-akt new-holder))
                new-sym))))))


; die atom attribute, lesen

(defun symbol-name (sym)
  (get-word sym 4))

(defun symbol-value (sym)
  (get-word sym 8))

(defun symbol-function (sym)
  (get-word sym 12))

(defun symbol-plist (sym)
  (get-word sym 16))

(defun symbol-package (sym)
  (get-word sym 20))

; die atom attribute, schreiben

(defun set-symbol-value (sym val)
  (set-word sym 8 val))

(defun set-symbol-function (sym val)
  (set-word sym 12 val))

(defun set-symbol-plist (sym val)
  (set-word sym 16 val))

(defun set-symbol-package (sym val)
  (set-word sym 20 val))


; die atome, testfunktion

; symbol hat |10 als tag im zeiger und 1|00 im header


(defun symbolp (x)
  (and (tag-eq x *symbol-tag*)
       (let ((h (get-word x 0)))
         (and
          (addr-eqi (addr-and h 2) 2)
          (tag-eq h *symbol-head-tag*)))))



; die (fix)nums

(setq *fixnum-tag* 0)

  
(defun numberp (x)
  (tag-eq x *fixnum-tag*))




(defun %* (a b)
  (let ((acc 0)
        (i 32))
    (do-until ((%= i 0) acc)
              (if (%= (tag-and (addr-and b 1) 0) 1)
                  (setq acc (%+ acc a)))
              (setq b (p-shiftr-1 b))
              (setq a (p-shiftl-1 a))
              (setq i (%- i 1)))))


(defun %div-0 (a b)
  (let ((acc 0)
        (p 1))
    (do-until ((%> b a))
              (setq b (p-shiftl-1 b))
              (setq p (p-shiftl-1 p)))
    (setq p (tag-and (p-shiftr-1 p) 0))
    (if (%> p 0)
        (setq b (p-shiftr-1 b)))
    (do-until ((%= p 0) acc)
              (if (%>= a b)
                  (progn 
                    (setq a (%- a b))
                    (setq acc (%+ acc p))))
              (setq b (p-shiftr-1 b))
              (setq p (tag-and (p-shiftr-1 p) 0)))))
           

(defun %div (a b)
  (if (%< a 0) (%- 0 (%div (%- 0 a) b))
    (if (%< b 0) (%- 0 (%div-0 a (%- 0 b)))
      (%div-0 a b))))
              
              


; die closures

(setq *closure-head-addr* 3)
(setq *closure-head-tag* 1)
(setq *closure-tag* 2)
(setq *closure-slots* 2)

(defun make-closure (templ vect)
  (let ((p (%allocate-space (%+ (%* *closure-slots* 4) 8))))
    (set-word p 0 (tag-set *closure-head-addr* *closure-head-tag*))
    (set-closure-ref p 0 templ)
    (set-closure-ref p 1 vect)
    (setq p (tag-set p *closure-tag*))
    p))


(defun closure-ref (cl i)
  (get-word cl (%+ 4 (%* i 4))))

(defun set-closure-ref (cl i x)
  (set-word cl (%+ 4 (%* i 4)) x))

(defun closurep (x)
  (and (tag-eq x *closure-tag*)
       (let ((h (get-word x 0)))
         (and
          (addr-eqi (addr-and h 2) 2)
          (tag-eq h *closure-head-tag*)))))



; die templates

(setq *template-head-tag* 3)
(setq *template-tag* 2)

(setq *template-leader* 4)

; d und c sind anzahl von 32 bit worten

(defun make-template (d c)
  (let ((n-bytes (%align (%+ (%* (%+ d c) 4) (%* 4 *template-leader*)) 3)))
    (let ((p (%allocate-space n-bytes)))
      (set-word p 0 (tag-set (addr-ior (p-shiftl n-bytes 2) 1) *template-head-tag*))
      (set-word p 4 (p-add p (%+ (%* *template-leader* 4) (%* d 4))))
      (set-word p 8 d)
      (set-word p 12 c)
      (do ((i 0 (+ i 1)))
          ((%>= i d))
        (set-templ-ref-d p i nil))
      (do ((i 0 (+ i 1)))
          ((%>= i c))
        (set-templ-ref-c p i 0 0))
      (setq p (tag-set p *template-tag*))
      p)))

(defun length-d (templ)
  (get-word templ 8))

(defun templ-ref-d (templ i)
  (get-word templ (%+ (%* *template-leader* 4) (%* i 4))))


(defun templ-ref-c (templ i)
  (let ((pc (get-word templ 4)))
    (get-word pc (%* i 4))))


(defun set-templ-ref-d (templ i val)
  (set-word templ (%+ (%* *template-leader* 4) (%* i 4)) val))

(defun set-templ-ref-c (templ i v-high v-low)
  (let ((pc (get-word templ 4)))
    (set-word pc (%* i 4) (p-constr v-high v-low))))



(defun templatep (x)
  (and (tag-eq x *template-tag*)
       (let ((h (get-word x 0)))
         (and
          (addr-eqi (addr-and h 2) 0)
          (tag-eq h *template-head-tag*)))))




; allgemeiner heap allokator. ruft (später: inkrementellen) garbage collector auf


;(defun %allocate-space (n)
;  (let ((ret *alloc-pointer*))
;    (setf *alloc-pointer* (+ *alloc-pointer* (p-shiftr n 2)))
;    ret))

(defun %allocate-space (n)
  (%reserve-space n))



; system-erzeugung

;(defun create-nil (str)
;  (let ((nil-add (make-symbol str)))
;    (set-symbol-value nil-add nil-add)
;    (set-symbol-function nil-add nil-add)
;    (set-symbol-plist nil-add nil-add)
;    (set-symbol-package nil-add nil-add)
;    nil-add))

;(setq nil (create-nil "nil"))

(defun create-nil ()
  (let ()
    (set-symbol-value nil nil)
    (set-symbol-function nil nil)
    (set-symbol-plist nil nil)
    (set-symbol-package nil nil)
    nil))


(setq nil (get-word 200 32))


(setq *base-pkg-len* 53)
;(setq *base-pkg* (make-vector *base-pkg-len*))

(setq *base-pkg* (get-word 200 28))


;(setq str "juergen")



; tests




(setq *rl* nil)

(defun read-main (read-ch)
  (let ((ini-ch nil)
        (next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same)))
    (consume-whitespace read-ch)
    (setq ini-ch (funcall same-ch))
    (cond ((is-symbol-start ini-ch) (read-symbol read-ch))
          ((is-quote-start ini-ch) 
           (funcall next-ch)
           (list 'quote (read-main read-ch)))
          ((is-macro-start ini-ch) (read-macro read-ch))
          ((is-lparen ini-ch) 
           (let ((lv nil)
                 (rv nil))
             (funcall next-ch)
             (consume-whitespace read-ch)
             (cond ((is-rparen (funcall same-ch))
                    (let ()
                      (funcall next-ch)
                      nil))
                   (t (let ()
                        (setq lv (read-main read-ch))
                        (setq rv (read-rest-list read-ch))
                        (cons lv rv))))))
          (t (throw 'read-error "read:err:unknown form"))))) 
                      
(defun read-rest-list (read-ch)
  (let ((lv nil)
        (rv nil)
        (next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same))
        (peek-ch (funcall read-ch 'peek)))
    (consume-whitespace read-ch)
    (cond ((is-dot (funcall same-ch))
           (let ()
             (cond ((is-whitespace (funcall peek-ch))
                    (funcall next-ch)
                    (setq rv (read-main read-ch))
                    (consume-whitespace read-ch)
                    (cond ((is-rparen (funcall same-ch))
                           (funcall next-ch)
                           rv)
                          (t (throw 'read-error "read:err:missing rparen:1"))))
                   (t 
                    (setq lv (read-main read-ch))
                    (setq rv (read-rest-list read-ch))
                    (cons lv rv)))))
          (t (cond ((is-rparen (funcall same-ch))
                    (funcall next-ch)
                    nil)
                   (t 
                    (setq lv (read-main read-ch))
                    (setq rv (read-rest-list read-ch))
                    (cons lv rv)))))))
                   

(defun is-quote-start (ch)
  (eq ch #\'))

(defun is-macro-start (ch)
  (eq ch #\#))

(defun is-atom-start (ch)
  (or (is-alpha ch) (is-digit ch) (member ch '( #\* #\\ #\+ #\- #\% #\&))))

(defun is-fixnum-start (ch)
  (or (is-digit ch) (member ch '(#\- #\+))))

(defun is-float-start (ch)
  (or (is-fixnum-start ch) (eq ch #\.)))

(defun is-symbol-start (ch)
  (or (is-fixnum-start ch) (is-float-start ch) (is-atom-start ch)))

(defun is-symbol-ch (ch)
  (or (is-alpha ch) (is-digit ch) (member ch '( #\* #\\ #\+ #\- #\. #\< #\> #\= #\? #\_ #\% #\:))))

(defun is-lparen (ch)
  (eq ch #\())

(defun is-rparen (ch)
  (eq ch #\)))

(defun is-dot (ch)
  (eq ch #\.))

(defun is-sign (ch)
  (or (eq ch #\+) (eq ch #\-)))

(defun is-whitespace (ch)
  (member ch '(#\Space)))

(defun is-atom-char (ch)
  (or (is-alpha ch) (is-digit ch) (member ch '(#\- #\+))))

(defun is-digit (ch)
  (and (>= (char-code ch) (char-code #\0)) (<= (char-code ch) (char-code #\9))))

(defun is-hex-digit (ch)
  (or (is-digit ch) (and (>= (char-code ch) (char-code #\a)) (<= (char-code ch) (char-code #\f))))) 

(defun is-alpha (ch)
  (and (>= (char-code ch) (char-code #\a)) (<= (char-code ch) (char-code #\z))))

(defun is-expo-init (ch)
  (member ch '( #\e #\E )))


(defun consume-whitespace (read-ch)
  (let ((next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same)))
    (do ((akt-ch (funcall same-ch) (funcall next-ch)))
        ((not (is-whitespace akt-ch))))))


(defun read-symbol (read-ch)
  (let ((sym-cl nil)
        (num nil)
        (next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same)))
    (do ((akt-ch (funcall same-ch) (funcall next-ch)))
        ((not (is-symbol-ch akt-ch)))
      (setq sym-cl (cons akt-ch sym-cl)))
    (setq sym-cl (reverse sym-cl))
    (setq num (read-cl-as-number sym-cl))
    (if num
        num
      (make-atom-str (make-string-cl sym-cl)))))
      



(defun make-string-cl (cl)
  (let ((s (make-string (length cl))))
    (do ((i 0 (1+ i))
         (clx cl (cdr clx)))
        ((null clx) s)
      (setq (char s i) (car clx)))))

(defun make-atom-str (str)
  (list 'atom str))

(defun read-macro (read-ch)
  (let ((next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same))
        (akt-ch nil)
        (res nil))
    (setq akt-ch (funcall next-ch))
    (cond ((eq akt-ch #\')
           (let ()
             (funcall next-ch)
             (list 'function (read-main read-ch))))
          ((eq akt-ch #\Q)
           (let ()
             (setq res nil)
             (do ((i 0 (+ 1 i)))
                 ((> i 7))
               (setq akt-ch (funcall next-ch))
               (if (not (is-hex-digit akt-ch))
                   (throw 'read-error "read:err:Q malformed:001"))
               (setq res (cons akt-ch res)))
             (funcall next-ch)
             (setq res (reverse res))
             (make-q res)))
          ((eq akt-ch #\\)
           (setq akt-ch (funcall next-ch))
           (funcall next-ch)
           akt-ch)
          (t (throw 'read-error "read:err:undefined macro:001")))))

(defun make-q (hexl)
  (list 'Q hexl))


(defun digit-to-num (ch)
  (- (char-code ch) (char-code #\0)))

(defun read-cl-as-number (cl)
  (let ((sign +1)
        (sign-exp +1)
        (cll cl)
        (pre-dot 0)
        (post-dot 0)
        (exp-val 0)
        (dig-cnt 0)
        (akt-ch nil))
    (cond ((eq (car cll) #\+)
           (let ()
             (setq cll (cdr cll))))
          ((eq (car cll) #\-)
           (let ()
             (setq cll (cdr cll))
             (setq sign -1))))
    (setq dig-cnt 
          (do ((pre-digs 0 (+ pre-digs 1)))
              ((or (not cll) (not (is-digit (car cll)))) pre-digs)
            (setq akt-ch (car cll))
            (setq pre-dot (+ (* pre-dot 10) (digit-to-num akt-ch)))
            (setq cll (cdr cll))))
    (if (and (null cll) (> dig-cnt 0))
        (return-from read-cl-as-number (* sign pre-dot)))
;    (if (eq (car cll) #\.)
;        (let ()
;          (setq cll (cdr cll))
;          (do ((dez-fact 0.1 (* 0.1 dez-fact))
;               (post-digs 0 (+ post-digs 1)))
;              ((or (not cll) (not (is-digit (car cll)))))
;            (setq akt-ch (car cll))
;            (setq cll (cdr cll))
;            (if (< post-digs 6)
;                (setq post-dot (+ post-dot (* dez-fact (digit-to-num akt-ch))))))))
    (if (null cll)
        (return-from read-cl-as-number (* sign (+ pre-dot post-dot))))
    (if (is-expo-init (car cll))
        (let ()
          (setq cll (cdr cll))
          (if (is-sign (car cll))
              (let ()
                (if (eq (car cll) #\-)
                    (setq sign-exp -1))
                (setq cll (cdr cll))))
          (do ((exp-digs 0 (+ exp-digs 1)))
              ((or (not cll) (not (is-digit (car cll)))))
            (setq akt-ch (car cll))
            (setq exp-val (+ (* exp-val 10) (digit-to-num akt-ch)))
            (setq cll (cdr cll)))
;          (setq exp-val (expt 10.0 (* sign-exp exp-val)))))
          (setq exp-val (expt 10 (* sign-exp exp-val)))))
    (if (null cll)
        (return-from read-cl-as-number (* sign (+ pre-dot post-dot) exp-val)))
    nil))
         






  


(defun eval (expr env)
  (let ((res nil))
;    (format t "eval:expr = ~S~%" (funarg-chop expr))
    (setq res
          (cond ((numberp expr) expr)
                ((atom expr) (eval-atom expr env))
                (t (eval-list expr env))))
;    (format t "eval:result = ~S~%" (funarg-chop res))
    res))

(defun eval-atom (expr env)

  (let ((erg (env-assoc expr env)))
    (if (eq (car erg) '&empty)
        (symbol-value expr)
      (cdr erg))))

(defun env-assoc (atm env)
  (do
      ((p env (cdr p))
       (pold nil p))
      ((or (null p) (eq (caar p) atm))
       (cond ((null p) (cons '&empty pold))
             (t (car p))))))


;
;

(defun eval-list (expr env)

  (let ((head (car expr))
        (rest (cdr expr)))
    (cond ((eq head 'cond) (eval-cond rest env))
          ((eq head 'quote) (car rest))

          ((eq head 'function) (make-funarg (car rest) env))

          ((eq head 'lambda) (eval-lambda expr env))

          ((eq head 'labels) (eval-labels rest env))

          ((eq head 'let) (eval-let rest env))

          ((eq head 'setq) (eval-setq rest env))

          ((eq head 'defun) (eval-defun rest env))
          
          ((eq head 'defmacro) (eval-defmacro rest env))

          ((eq head 'progn) (eval-progn rest env))

          ((eq head 'do) (eval-do rest env))
          
          ((eq head 'do-until) (eval-do-until rest env))

          ((eq head 'funcall) (eval-funcall rest env))

          ((eq head 'and) (eval-and rest env))

          ((eq head 'or) (eval-or rest env))
          
          ((is-expr-fun head) (eval-expr-fun head rest env))
          ((is-list-fun head) (eval-list-fun head rest env))
          
          ((atom head) (eval-atom-head head rest env))
          (t (error "eval-list: wrong list header")))))



(defun make-funarg (fun env)
  (list 'funarg fun env))


(defun eval-atom-head (head rest env)
;  (format t "~%~S : ~S ~%" head rest)
;  (format t "~%~S~%" (funarg-chop env))
;  (format t "eval-atom-head:~S~%" (funarg-chop (eval head env)))
  (let ((fn (env-assoc head env))
        (fn-expr))
    (setq fn-expr
          (cond ((eq (car fn) '&empty)
                 (symbol-function head))
                (t (cdr fn))))
    (if (is-macro fn-expr)
        (eval (apply (macro-fun fn-expr) rest env) env)
      (eval (cons fn-expr rest) env))))

(defun protect-quote (args)
  (do ((args1 args (cdr args1))
       (res nil (cons (list 'quote (car args1)) res)))
      ((null args1) (reverse res))))

(defun is-macro (fn-expr)
  (and (listp fn-expr) (eq (car fn-expr) '&&macro)))

(defun macro-fun (fn-expr)
  (cdr fn-expr))



(defun eval-labels (rest env)
  (let ((env-new env)
        (res nil)
        (result nil)
        (env-end nil))
    (dolist (def (car rest))
      (setq env-new (cons (cons (car def)  nil) env-new)))
    (dolist (def (car rest))
;    (format t "~%~S~%" def)
      (setq res (cons (make-funarg (list 'lambda (car (cdr def)) (car (cdr (cdr def)))) env-new) res)))
;   (format t "~%~S~%" env-new)
    (setq env-end env-new)
    (dolist (defval res)
      (set-cdr (car env-end) defval)
      (setq env-end (cdr env-end)))
;   (format t "~%~S~%" (funarg-chop env-new))
    (dolist (form (cdr rest))
      (setq result (eval form env-new)))
    result))

(defun eval-let (rest env)
  (let ((var-term nil)
        (vars nil)
        (vals nil))
;    (format t "rest = ~S ~%" rest)
    (setq var-term (car rest))
    (dolist (x var-term)
      (cond ((null (cdr x))
             (setq vars (cons (car x) vars))
             (setq vals (cons nil vals)))
            (t 
             (setq vars (cons (car x) vars))
             (setq vals (cons (cadr x) vals)))))
;    (format t "vars = ~S vals = ~S ~%" vars vals)
    (eval (append (list (list 'lambda vars (cons 'progn (cdr rest)))) vals) env)))


(defun eval-setq (rest env)
  (let ((val (eval (cadr rest) env))
        (pair (env-assoc (car rest) env)))
    (if (not (eq (car pair) '&empty))
        (progn (set-cdr pair val)
          val)
      (set-symbol-value (car rest) val))))

(defun eval-defun (rest env)
  (set-symbol-function (car rest)
                       (make-funarg (list 'lambda (cadr rest) (caddr rest)) env)))

(defun eval-defmacro (rest env)
  (set-symbol-function (car rest) 
                       (cons '&&macro
                             (make-funarg (list 'lambda (cadr rest) (caddr rest)) env))))

(defun eval-progn (rest env)
  (let ((res nil))
    (dolist (x rest)
      (setq res (eval x env)))
    res))


(defun eval-do (rest env)
  (let ((pre (car rest))
        (tst-res (cadr rest))
        (body (cddr rest))
        (new-expr nil)
        (assign nil)
        (update nil))
    (dolist (x pre)
      (setq assign (cons (list (car x) (cadr x)) assign)))
    (dolist (x pre)
      (setq update (cons (list 'setq (car x) (caddr x)) update)))
    (setq body (append body update))
    (setq new-expr (append (list 'do-until tst-res) body))
    (setq new-expr (list 'let assign new-expr))
    (eval new-expr env)))

(defun eval-do-until (rest env)
  (let ((tst (caar rest))
        (res (cadar rest))
        (body (cons 'progn (cdr rest))))
    (do ()
        ((eval tst env) (eval res env))
      (eval body env))))


(defun eval-funcall (rest env)
  (let ((fval (eval (car rest) env))
        (argl (list-eval (cdr rest) env)))
    (eval (cons fval argl) env)))


(defun eval-and (rest env)
  (labels ((eval-and-1 (rest env acc)
             (if (null rest)
                 acc
               (let ((v1 (eval (car rest) env)))
                 (if v1
                     (eval-and-1 (cdr rest) env v1)
                   nil))))) (eval-and-1 rest env nil)))

(defun eval-or (rest env)
  (if (null rest)
      nil
    (let ((v1 (eval (car rest) env)))
      (if v1
          v1
        (eval-or (cdr rest) env)))))


(defun eval-cond (rest env)
  (let ((res nil))
    (dolist (cond-line rest)
      (if (not (null (eval (car cond-line) env)))
          (do ((cond-expr (cdr cond-line) (cdr cond-expr)))
              ((null cond-expr) (return-from eval-cond res))
            (setq res (eval (car cond-expr) env)))))
    (error "eval-cond:run out of conditions")))


(defun eval-lambda (expr env)

  (list 'funarg expr env))

(defun is-expr-fun (head)

  (member head '(%+ %- %*  %= %<= %>= %< %> null cons car cdr atom numberp not listp list eq)))

(defun is-list-fun (head)

  (listp head))


(defun eval-expr-fun (head rest env)
  
  (let ((args (list-eval rest env)))
    (cond ((eq head 'cons)
           (apply 'cons args))
          ((eq head 'list)
           (apply 'list args))
          (t (apply head args)))))


(defun eval-list-fun (head rest env)
  (progn
;    (format t "head = ~S rest = ~S ~%" head rest)
    (cond ((eq (car head) 'lambda) (eval-lambda-list (cdr head) rest env))
          ((eq (car head) 'funarg) (eval-funarg (cdr head) rest env))
          (t (error "eval-list-fun: case not implemented")))))


(defun apply (fn args env)
  (cond ((listp fn)
         (cond ((eq (car fn) 'lambda) (apply-lambda (cdr fn) args env))
               ((eq (car fn) 'funarg) (apply-funarg (cdr fn) args env))
                (t (apply (eval fn env) args env))))
         ((atom fn)
          (let ((fn1 (env-assoc fn env))
                (fn-expr))
            (setq fn-expr
                  (cond ((eq (car fn1) '&empty)
                         (symbol-function fn))
                        (t (cdr fn1))))
            (if (not (is-macro fn-expr))
                (apply fn-expr args env)
              (error "apply: try to apply macro"))))
         (t (error "apply: case not implemented"))))


(defun apply-lambda (lambda-rest args env)
  (let ((new-env (env-bind (car lambda-rest) args env)))
    (eval (car (cdr lambda-rest)) new-env)))



(defun eval-lambda-list (lambda-rest args env)

  (let ((new-env (env-bind (car lambda-rest) (list-eval args env) env)))
;    (format t "~S / " (funarg-chop new-env))
    (eval (car (cdr lambda-rest)) new-env)))

(defun list-eval (args env)
  (let ((acc nil))   
    (dolist (x args) (setq acc (cons (eval x env) acc)))
    (reverse acc)))

(defun env-bind (vars vals old-env)
  (do
      ((vars-akt vars (cdr vars-akt))
       (vals-akt vals (cdr vals-akt))
       (res old-env old-env))
      ((or (null vars-akt)
           (eq (car vars-akt) '&rest))
       (if (not (null vars-akt))
         (push (cons (cadr vars-akt)
                     vals-akt) old-env)
         old-env))
    (push (cons (car vars-akt) (car vals-akt)) old-env)))


(defun eval-funarg (funarg-rest args env)
  (apply-funarg funarg-rest (list-eval args env) env))


(defun apply-funarg (funarg-rest args env)
  (apply (car funarg-rest) args (car (cdr funarg-rest))))





(defun funarg-chop (e)
  (cond ((atom e) e)
        ((eq (car e) 'FUNARG) (list (car e) (car (cdr e))))
        (t (cons (funarg-chop (car e)) (funarg-chop (cdr e))))))




(defun main ()

  (let ((global-env (list (cons t t) (cons nil nil)))
        (stop nil))
    (do-until (stop)
              (%print ">")
              (let ((r (%read))
                    (e nil))
                (if (and (eq (car r) 'quit) (null (cdr r)))
                    (setq stop 1)
                  (progn
                    (setq e (eval r global-env))
                    (%print (funarg-chop e))))))))

(do ((i 0 (%+ i 1)))
    ((%>= i 10) (%print (%+ i i)))
  (%print (setq j (%* i -6)))
  (%print (%div j -5)))
 


(defun tst1 ()   

(%print (symbol-value nil))

(%print (get-hash "juergen" *base-pkg-len*))

(%print (null nil))

(setq *xx1* 'juergen)

(setq *xx* (intern "JUERGEN"))

(%print *xx1*)

(%print (eq *xx* *xx1*))

(%print (symbolp *xx*))

(%print (eq *xx* (setq *yy* (intern "vessela"))))
(%print (eq *xx* (intern "juergen")))

(%print *yy*))

(tst1)


))