(setf *basis01*

'(let ()


(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))




(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 (tag-and (%+ x y) 0) 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 eq (x y)
  (and (addr-eq x y) (%= (get-tag x) (get-tag y))))

(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 %neg (x)
  (%- 0 x))


(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-word p 4 0)
    (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 (%+ 8 (%* i 4))))

(defun set-closure-ref (cl i x)
  (set-word cl (%+ 8 (%* 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))





; der stop-and-copy garbage collector



(defun tosp-move (p q psize)
;  (%print "in-tosp-move")
;  (%print (get-type p))
;  (%print "size = ")
;  (%print (get-size p))
;  (%print psize) 
  (do ((i 0 (%+ i 4)))
      ((%>= i psize))
;    (%print "i = ")
;    (%print i)
    (set-word q i (get-word p i))))

(defun allocate-down (n)
   (if (%< (p-add (get-word 200 48) n) (get-word 200 100))
       (tosp-allocate-up n)
     (progn
       (collect-garbage)
       (allocate-up n))))

(defun allocate-up (n)
  (if (%< (p-add (get-word 200 48) n) (get-word 200 92))
      (progn
        (tosp-allocate-up n))
    (progn
      (collect-garbage)
      (allocate-down n))))
                        
(defun tosp-allocate-down (n)
  (let ((lead-tosp (get-word 200 48)))
    (set-word 200 48 (p-add lead-tosp (%neg n)))))


(defun tosp-allocate-up (n)
   (let ((lead-tosp (get-word 200 48)))
     (set-word 200 48 (p-add lead-tosp n))
     lead-tosp))

(setq *tosp-allocate-down* (symbol-function 'tosp-allocate-up))

(setq *tosp-allocate-up* (symbol-function 'tosp-allocate-up))

(defun in-tosp-down-p (p)
  (and (%>= p (get-word 200 92)) (%<= p (get-word 200 100))))

(defun in-tosp-up-p (p)
  (and (%>= p (get-word 200 96)) (%< p (get-word 200 92))))

(setq *in-tosp-down-p* (symbol-function 'in-tosp-down-p))
(setq *in-tosp-up-p* (symbol-function 'in-tosp-up-p))

         
(defun get-size (p)
   (cond ((consp p) 8)
         ((stringp p) (get-size-head p))
         ((arrayp p) (get-size-head p))
         ((characterp p) 4)
         ((symbolp p) 24)
         ((numberp p) 4)
         ((closurep p) 16)
         ((templatep p) (get-size-head p))))

(defun get-type (p)
   (cond ((consp p) "cons ")
         ((stringp p) "string  ")
         ((arrayp p) "array ")
         ((characterp p) "character ")
         ((symbolp p) "symbol ")
         ((numberp p) "number ")
         ((closurep p) "closure ")
         ((templatep p) "template ")))

(defun get-size-head (p)
   (let ((ph (get-word p 0)))
     (tag-and (p-shiftr ph 2) 0)))
  
        
(defun collect-garbage ()
  (let ((dsp-start (get-dsp))
        (csp-start (get-csp)))
    (let ((tosp-dir (get-word 200 40))
          (tosp-allocate nil)
          (in-tosp-p nil)
          (in-frosp-p nil)
          (tosp-follow nil)
          (dsp-top (p-shiftr 8192 2))
          (csp-top (p-shiftr 4096 2)))
      (%print "tosp-dir = ")
      (%print tosp-dir)
      (%print 1111)
      (if (%> tosp-dir 0)
          (progn
            (setq tosp-allocate *tosp-allocate-down*)
            (setq in-tosp-p *in-tosp-down-p*)
            (setq in-frosp-p *in-tosp-up-p*)
            (setq tosp-follow (get-word 200 92))
            (set-word 200 48 (get-word 200 92))
            (set-word 200 40 -1)
            (set-word 200 44 (symbol-function 'allocate-down)))
        (progn
          (setq tosp-allocate *tosp-allocate-up*)
          (setq in-tosp-p *in-tosp-up-p*)
          (setq in-frosp-p *in-tosp-down-p*)
          (setq tosp-follow (get-word 200 96))
          (set-word 200 48 (get-word 200 96))
          (set-word 200 40 +1)
          (set-word 200 44 (symbol-function 'allocate-up))))

      (%print "before do, dsp = ")
      (%print (get-dsp))

      (do ((p dsp-start (p-add p 4)))
          ((%>= p dsp-top))
;      (%print "p / (p) / (p)size = ")
;      (%print p)
;      (%print (get-word p 0))
;      (%print (get-size (get-word p 0)))
        (set-word p 0 (transport-to-tosp-1 (get-word p 0) tosp-allocate in-tosp-p in-frosp-p)))
      (%print "after do, tosp-follow =")
      (%print tosp-follow)

      (%print "start csp process:")
      (%print 2222)

      (do ((p csp-start (p-add p 8)))
          ((%>= p csp-top))
        (let ((pc4 (get-word p 0))
              (tp (get-word p 4)))
          (let* ((tpn (transport-to-tosp-1 tp tosp-allocate in-tosp-p in-frosp-p))
                 (pcn (%+ (tag-and tpn 0) (%- pc4 (tag-and tp 0)))))
;            (%print pc4)
;            (%print pcn)
;            (%print (tag-and tpn 0))
;            (%print (tag-and tp 0))

            (set-word p 0 pcn)
            
;            (%print "move template")

            (set-word p 4 tpn))))

      (%print 2221)

      (do ((i 0 (%+ 1 i)))
          ((%>= i *base-pkg-len*))
        (do ((p (svref *base-pkg* i) (cdr p)))
            ((null p))
          (let ((q (car p)))
            (do ((j 4 (%+ j 4)))
                ((%>= j 24))
              (set-word q j (transport-to-tosp-1 (get-word q j) tosp-allocate in-tosp-p in-frosp-p))))))

      (let ((len *base-pkg-len*))
        (do ((i 0 (%+ 1 i)))
            ((%>= i len))
          (set-svref *base-pkg* i (transport-to-tosp-1 (svref *base-pkg* i) tosp-allocate in-tosp-p in-frosp-p))))
      (%print "after *base-pkg*")

      (let ((ac 0) (tc 0) (cc 0) (sc 0) (csc 0) (syc 0)
            (r nil))
        (do-until ((%<= (get-word 200 48) tosp-follow))
                  (setq tosp-follow (tag-and tosp-follow 0))
;                  (%print tosp-follow)
                  (setq r (get-word tosp-follow 0))
                  (cond ((and (not (%= (get-tag r) 0)) (addr-eqi (addr-and r 1) 1)) ; composite block begin at tosp-follow
                         (progn
                           (setq tosp-follow (tag-set tosp-follow 2))
                           (cond ((stringp tosp-follow)
                                  (setq tosp-follow (p-add tosp-follow (get-size tosp-follow)))
                                  (setq sc (%+ 1 sc)))
                                 ((arrayp tosp-follow)
                                  (let ((len (length tosp-follow)))
                                    (do ((i 0 (%+ i 1)))
                                        ((%>= i len))
                                      (set-svref tosp-follow i (transport-to-tosp-1 (svref tosp-follow i)
                                                                                    tosp-allocate in-tosp-p in-frosp-p)))
                                    (setq tosp-follow (p-add tosp-follow (get-size tosp-follow))))
                                  (setq ac (%+ 1 ac)))
                                 ((closurep tosp-follow)
                                  (%print "start closure 01 move")
                                  (set-closure-ref tosp-follow 0 (transport-to-tosp-1 (closure-ref tosp-follow 0)
                                                                                      tosp-allocate in-tosp-p in-frosp-p))  
                                  (set-closure-ref tosp-follow 1 (transport-to-tosp-1 (closure-ref tosp-follow 1)
                                                                                      tosp-allocate in-tosp-p in-frosp-p))
                                  (%print "end closure 01 move")
                                  (setq tosp-follow (p-add tosp-follow (get-size tosp-follow)))
                                  (setq cc (%+ 1 cc))
                                  (%print "real end of closure 01 move"))
                                 ((symbolp tosp-follow)
                                  (do ((i 4 (%+ i 4)))
                                      ((%>= i 24))
                                    (set-word tosp-follow i (transport-to-tosp-1 (get-word tosp-follow i)
                                                                                 tosp-allocate in-tosp-p in-frosp-p)))
                                  (setq tosp-follow (p-add tosp-follow (get-size tosp-follow)))
                                  (setq syc (%print (%+ 1 syc))))
                                 ((templatep tosp-follow) 
                                  (%print "start template 01 move")
                                  (let ((len (length-d tosp-follow)))
                                    (do ((i 0 (%+ i 1)))
                                        ((%>= i len))
                                      (set-templ-ref-d tosp-follow i (transport-to-tosp-1 (templ-ref-d tosp-follow i)
                                                                                          tosp-allocate in-tosp-p in-frosp-p)))
                                    (set-word tosp-follow 4 (p-add tosp-follow (%+ 16 (p-shiftl len 2)))) 
                                    (setq tosp-follow (p-add tosp-follow (get-size tosp-follow)))
                                    (setq tc (%+ 1 tc)))
                                  (%print "end template 01 move"))
                                 (1 (%print "error fall through")))))
                                
                        ((characterp r) ; char
                         (setq tosp-follow (p-add tosp-follow 4)))
                        ((numberp r) ; fixnum
                         (setq tosp-follow (p-add tosp-follow 4)))
                        ((null r) ; nil
                         (setq tosp-follow (p-add tosp-follow 4)))
                        (1 ; non const part of cons
                         (setq csc (%+ 1 csc))
                         (set-word tosp-follow 0 (transport-to-tosp r tosp-allocate in-tosp-p in-frosp-p))
                         (setq tosp-follow (p-add tosp-follow 4)))))
        (%print "gc-finished phase 1")
        (%print "ac / tc /sc / cc / csc / syc = ")
        (%print ac)
        (%print tc)
        (%print sc)
        (%print cc)
        (%print csc)
        (%print syc)
        (%print "gc phase 2 csp")
;        (do ((p csp-start (p-add p 8)))
;            ((%>= p csp-top))
;          (let ((pc4 (get-word p 0))
;                (tp (get-word p 4)))
;            (if (funcall in-frosp-p tp)
;                (let ((tpn (get-word tp 4)))
;                  (%print "move template")
;                  (set-word p 4 tpn)
;                  (set-word p 0 (%+ (tag-and tpn 0) (%- pc4 (tag-and tp 0))))))))
        (%print "gc-phase 2 end")
        (%print "gc-phase 3 begin")
;        (do ((i 0 (%+ 1 i)))
;            ((%>= i *base-pkg-len*))
;          (%print "i = ")
;          (%print i)
;          (%print (svref *base-pkg* i))
;          (do ((p (svref *base-pkg* i) (cdr p)))
;              ((%= p 0))
;            (let ((q (car p)))
;              (do ((j 4 (%+ j 4)))
;                  ((%>= j 24))
;                (set-word q j (transport-to-tosp-1 (get-word q j) tosp-allocate in-tosp-p in-frosp-p))))))
        (%print "gc-phase 3 end")))))

(defun transport-to-tosp-1 (r tosp-allocate in-tosp-p in-frosp-p)
  (cond ((or (tag-eq r 3) (tag-eq r 0) (null r))
         r)
        (1 (transport-to-tosp r tosp-allocate in-tosp-p in-frosp-p))))


(setq *bit31* (p-shiftl 1 29))

(%print *bit31*)

(defun transport-to-tosp (r tosp-allocate in-tosp-p in-frosp-p)
  (let ((moved-flag nil))
;    (%print "to move / in frosp = ")
;    (%print (get-type r))
;    (%print (funcall in-frosp-p r))
    (if (funcall in-frosp-p r)
        (progn
          (cond ((consp r)
                 (setq moved-flag (funcall in-tosp-p (car r))))
                ((or (stringp r) (arrayp r))
                 (setq moved-flag (addr-eq (addr-and (get-word r 0) *bit31*) *bit31*)))
                ((symbolp r)
                 (setq moved-flag (funcall in-tosp-p (get-word r 16))))
                ((closurep r)
                 (setq moved-flag (funcall in-tosp-p (get-word r 4))))
                ((templatep r)
                 (setq moved-flag (funcall in-tosp-p (get-word r 4)))))
 ;         (%print "moved-flag = ")
 ;         (%print moved-flag)
          (if moved-flag
              (cond ((consp r)
                     (car r))
                    ((or (stringp r) (arrayp r))
                     (get-word r 4))
                    ((symbolp r)
                     (get-word r 16))
                    ((closurep r)
                     (get-word r 4))
                    ((templatep r)
                     (get-word r 4)))
            (let ((r-move (funcall tosp-allocate (get-size r))))
;              (%print "pre-move r-move = ")
;              (%print (tag-and r-move 0))
;              (%print "moved ,..")
;              (%print (get-type r))
              (tosp-move r r-move (get-size r))
;              (%print "r-move = ")
              (cond ((consp r)
                     (setq r-move (tag-set r-move 1)))
                    (1 
                     (setq r-move (tag-set r-move 2))))
              (cond ((consp r)
                     (set-car r r-move))
                     ((or (stringp r) (arrayp r))
                     (set-word r 0 (addr-ior (get-word r 0) *bit31*))
                     (set-word r 4 r-move))
                    ((symbolp r)
                     (set-word r 16 r-move))
                    ((closurep r)
                     (set-word r 4 r-move))
                    ((templatep r) (progn (%print ">>>moved template")
                     (set-word r 4 r-move))))
;               (%print (tag-and r-move 0))
              r-move)))
      r)))

 (defun copy-list (l)
   (if (null l)
       nil
     (let* ((p l)
            (s (cons (car l) nil))
            (e s))
       (setq p (cdr p))
       (do-until ((null p) s)
                 (set-cdr e (cons (car p) nil))
                 (setq e (cdr e))
                 (setq p (cdr p))))))
             

;(defun copy-list (l)
;  (cond ((null l) nil)
;        (t (cons (car l) (copy-list (cdr l))))))


(setq xx (%print nil))
(%print (copy-list xx))

(setq xx (%print (cons 2(cons 1 nil))))
(%print (copy-list xx))

(%print (svref *base-pkg* 0))
    
(setq *reserve-space-1* #'(lambda (n)
                            (funcall (get-word 200 44) n)))
       


; untere Grenze der Allokationsarena

(set-word 200 96 (get-word 200 24))

; in Zukunft
; (set-word 200 96 (get-word 50 16)) ;; lower limit of second template

  ; obere Grenze der Allokationsarena

(set-word 200 100 (%+ (get-word 200 96) (%+ 1024 1024)))

  ; Mitte der Allokationsarena

(set-word 200 92 (%+ (p-shiftr (%- (get-word 200 100) (get-word 200 96)) 1) (get-word 200 96)))

  ; Anfangs-To-Space aufwärts von unten an:

(set-word 200 40 1)

  ; tosp-alloc-lead-pointer

(set-word 200 48 (get-word 200 96))

; in Zukunft
; (set-word 200 48 (get-word 50 20)) ;; upper limit of second template

  ; Allokationsfunktion

(set-word 200 44 (symbol-function 'allocate-up))

(%print (get-word 200 96)) ; ap

(%print (get-word 200 44)) ; allocate-up function


; Übertragung der Allokationsfunktion

; (set-word 200 48 (get-word 200 24))

(set-word 200 8 *reserve-space-1*)

; Ausgabe der neuen Allokationsroutine

(%print (get-word 200 8))


(%print "Lower Arena = ")
(%print (get-word 200 96))

(%print "Mid Arena = ")
(%print (get-word 200 92))


; Übertragung von *base-pkg*

(%print "base pkg length = ")

(%print (length *base-pkg*))

(%print (get-word *base-pkg* 4))




(do ((i 0 (%+ i 1)))
    ((%>= i *base-pkg-len*))
  (%print "i = ")
  (%print i)
  (%print (svref *base-pkg* i))
  (set-svref *base-pkg* i (copy-list (svref *base-pkg* i)))
  (%print (svref *base-pkg* i)))



; tests




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

(%print *base-pkg*)

(%print (get-word *base-pkg* 0))

(%print (get-word *base-pkg* 4))
 
(%print "base pkg length = ")

(%print (length *base-pkg*))

(%print (get-word *base-pkg* 4))

(%print (make-symbol "mysymbol"))

(%print (get-word 200 48))




(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)

(%print (%* 12 12))


(defun f (n) 
  (cond ((%<= n 1) 1) (1 (%+ (f (%- n 1)) (f (%- n 2))))))

(defun f1 (n)
  (cond ((%<= (car n) 1) (cons 1 nil))
        (1 (cons (%+ (car (f1 (cons (%- (car n) 1) nil))) (car (f1 (cons (%- (car n) 2) nil )))) nil))))



(defun app (x l)
  (cond ((null l) (cons x l))
        (1 (cons (car l) (app x (cdr l))))))

(defun rev (l)
  (cond ((null l) nil)
        (1 (app (car l) (rev (cdr l))))))


(defun p-low (p)
  (p-shiftl (tag-and (addr-and p (p-constr 0 65535)) 3) 2))

(defun p-high (p)
  (p-shiftr (tag-and (addr-and p (p-constr 65535 0)) 0) 14))


(defun copy-template (templ)
  (let ((ld (length-d templ)))
    (let ((lc (get-word templ 12)))
      (%print "here 0")
      (%print ld)
      (%print lc)
      (let ((new-templ (make-template ld lc)))
        (%print "here 1")
        (do ((i 0 (%+ i 1)))
            ((%>= i ld))
          (set-templ-ref-d new-templ i (templ-ref-d templ i)))
        (%print "here 2")
        (do ((i 0 (%+ i 1)))
            ((%>= i lc))
          (set-templ-ref-c new-templ i (p-high (templ-ref-c templ i)) (p-low (templ-ref-c templ i))))
;          (%print (tag-and (templ-ref-c templ i) 0))
;          (%print (tag-and (templ-ref-c new-templ i) 0)))
        new-templ))))

(%print (setq ttx (closure-ref (symbol-function 'app) 0)))

(%print (length-d ttx))
(%print (get-word ttx 8))
(%print (get-word ttx 12))

(setq ttx (%print (copy-template ttx)))

(let ((revclos (symbol-function 'rev)))
  (set-symbol-function 'rev (make-closure (copy-template (closure-ref revclos 0)) (closure-ref revclos 1)))
)


(setq xx (%print (rev '(1 2 3 4 5 6 7 8))))

(%print (f1 '(9. nil)))

(%print 111)

(let ((lis nil))
  (do ((i 0 (%+ i 1)))
      ((%>= i 10))
    (setq lis (cons (make-vector 10) lis))
    (set-svref (car lis) 0 i)
    (set-svref (car lis) 1 "vjb"))

  (%print lis)

  (do ((j 0 (%+ j 1)))
      ((%>= j 203))
    (setq lis (app (car lis) (cdr lis)))
    (%print lis))


)

(%print (car (f1 '(9 . nil))))
(%print (car (f1 '(12 . nil))))
(%print 22222)))