| LispmFPGA |
| LispmFPGA |
Home
Project Log
The code
Videos
Sample
The following module provides the basic Lisp data structures and their manipulation functions in terms of functions that directly compile into machine instructions of the LispmFPGA.
Therefore it can be seen as an innermost kernel of a still to write LispOS. Nevertheless it already contains a simple stop and copy garbage-collector that seems to work (at least in emulation).
(setf *basis02*
'(let ()
(setq valuescntq -1)
(setq valuesq (%make-vector 20))
;(set-word 200 24 (get-word 50 12))
(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))
;;
;; the irq routine has to here to be protected against the access
;; of garbage collection
;;
;;
;; keyboard interface routines
;;
;;
(defun next-i (i m)
(addr-and (%+ i 1) m))
(defun mod-m (i m)
(if (%>= i m)
(%- i m)
i))
;;
;; irq puts characters into a fifo
;; get pointer - located at (100 0)
;; insert pointer - located at (100 4)
;;
(setq base_ctrl (p-constr 57344 0))
(defconstant *raw-queue* 112)
;; get point and insert point in der raw-queue
(set-word 100 0 0)
(set-word 100 4 0)
(defun irq (x)
(let ((ch (get-word base_ctrl 8))
(get-pt (get-word 100 0))
(insrt-pt (get-word 100 4)))
(set-byte *raw-queue* insrt-pt (p-shiftl ch 2))
(let ((insrt-pt1 (next-i insrt-pt 31)))
(if (not (%= insrt-pt1 get-pt))
(set-word 100 4 insrt-pt1)))
(let ((s (get-status)))
(set-status (addr-ior s 128))
x)))
;;
;; at (0 16) is the pointer to the interrupt routine
;;
(set-word (p-constr 0 16) 0 (%symbol-function 'irq))
;;
;; the print routines
;;
(defun to-ascii (val)
(if (%<= val 9)
(%+ val 48)
(%+ val 55)))
(defun print-hex-digit (pos val)
(set-byte base_vga (p-shiftl pos 2) (to-ascii val)))
(defun print-hex-byte (pos val)
(print-hex-digit (%+ pos 1) (addr-and val 15))
(print-hex-digit pos (addr-and (tag-and (p-shiftr val 4) 0) 15)))
(defun print-hex (pos val)
(let ((v val))
(print-hex-byte (%+ pos 6) (addr-and (p-shiftl val 2) 255))
(print-hex-byte (%+ pos 4) (addr-and (setq v (tag-and (p-shiftr v 6) 0)) 255))
(print-hex-byte (%+ pos 2) (addr-and (setq v (tag-and (p-shiftr v 8) 0)) 255))
(print-hex-byte pos (addr-and (tag-and (p-shiftr v 8) 0) 255))))
(setq base_vga (p-constr 61440 0))
(defun qprint (str obj)
(cond ((numberp obj)
(print-number str obj))
((stringp obj)
(print-string str obj)))
(new-line))
(defun print-number (str num)
)
(defconstant +out-pos-base+ 5453)
(defconstant +out-pos-last+ 5984)
(defun print-string (str s)
(let ((len (length s)))
(funcall str #\")
(do ((i 0 (%+ i 1)))
((%>= i len))
(funcall str (char s i)))
(funcall str #\")))
(let ((out-pos +out-pos-base+))
(defun set-outpos (pos)
(setf out-pos pos))
(setq sout #'(lambda (c)
(set-byte base_vga (p-shiftl out-pos 2) (char-code c))
(setq out-pos (if (%< out-pos +out-pos-last+) (%+ out-pos 1) +out-pos-base+))))
(defun new-line ()
(let ((dpos (%- 133 (%rem out-pos 133))))
(do ((i 0 (%+ i 1)))
((%>= i dpos))
(funcall sout #\Space)))))
;;
;; now follows the usual basis02 stuff
;;
(defun min (a b)
(if (%< a b) a b))
(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)))
(defun mul-1 (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 b 1))
(setq a (p-shiftl a 1))
(setq i (%- i 1)))))
(defun mul (a b)
(if (%< b 0)
(%- 0 (mul-1 a (%- 0 b)))
(mul-1 a b)))
(defun p-shiftr-1 (x)
(p-shiftr x 1))
(defun p-shiftl-1 (x)
(p-shiftl x 1))
(defun %/= (a b)
(if (%= a b) nil -1))
(defun get-info (x)
x)
; vergleichsfunktionen allgemein
(setq t 't)
(defun eq (x y)
(and (addr-eq x y) (%= (get-tag x) (get-tag y))))
(defun null (x)
(if x nil 1))
(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 wait (a)
(do ((i 0 (%+ i 1))) ((%>= i 100000)) (do ((j 0 (%+ j 1))) ((%>= j a)))))
(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 14197)
(%print dsp-start)
(%print csp-start)
(qprint sout "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))))
(qprint sout "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)))
(qprint sout "after do, tosp-follow =")
(%print tosp-follow)
(qprint sout "start csp process:")
(%print 2222)
(do ((p csp-start (p-add p 8)))
((%>= p csp-top))
(%print p)
(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))))))
(%print 2220)
(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))))
(qprint sout "after *base-pkg*")
(%print 2219)
(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)
(%print 0)
(%print tosp-follow)
(setq r (get-word tosp-follow 0))
(%print r)
(cond ((and (not (%= (get-tag r) 0)) (addr-eqi (addr-and r 1) 1)) ; composite block begin at tosp-follow
(progn
(%print (get-csp))
(setq tosp-follow (tag-set tosp-follow 2))
(cond ((stringp tosp-follow)(%print 1)
(setq tosp-follow (p-add tosp-follow (get-size tosp-follow)))
(setq sc (%+ 1 sc)))
((arrayp tosp-follow)(%print 2)
(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 3)
(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))
(setq tosp-follow (p-add tosp-follow (get-size tosp-follow)))
(setq cc (%+ 1 cc)))
((symbolp tosp-follow)(%print 4)
(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 (%+ 1 syc)))
((templatep tosp-follow)(%print 5)
(let ((len (length-d tosp-follow)))
(%print 50)
(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)))
(%print 51)
(set-word tosp-follow 4 (p-add (tag-set tosp-follow 0) (%+ 16 (p-shiftl len 2))))
(%print 52)
(setq tosp-follow (p-add tosp-follow (get-size tosp-follow)))
(%print 53)
(setq tc (%+ 1 tc))))
(1 (%print 10)(qprint sout "error fall through")(wait 100)
))))
((characterp r) (%print 6) ; char
(setq tosp-follow (p-add tosp-follow 4)))
((numberp r) (%print 7); fixnum
(setq tosp-follow (p-add tosp-follow 4)))
((null r) (%print 8) ; nil
(setq tosp-follow (p-add tosp-follow 4)))
(1 (%print 9); non const part of cons
(setq csc (%+ 1 csc))
(set-word tosp-follow 0 (transport-to-tosp-1 r tosp-allocate in-tosp-p in-frosp-p))
(setq tosp-follow (p-add tosp-follow 4)))))
(%print 2210)
(qprint sout "gc-finished phase 1")
(qprint sout "ac / tc /sc / cc / csc / syc = ")
(%print ac)
(%print tc)
(%print sc)
(%print cc)
(%print csc)
(%print syc)
(%print 1111111)
(qprint sout "gc 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 (and (consp (car r)) (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 (tag-eq (get-word r 4) 2)))
((templatep r)
(setq moved-flag (tag-eq (get-word r 4) 2))))
; (%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
(qprint sout ">>>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) (%+ 48000 48000)))
; 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
; Übergangslösung
(set-word 200 48 (get-word 200 24))
; 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 "vla"))))
(%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)))
)
(setf *aaa* "12345")
(do ((i 0 (%+ i 1)))
((%>= i (length *aaa*)))
(%print (char *aaa* i))
(set-char *aaa* i (code-char (%+ 55 i)))
(%print (char *aaa* i)))
(%print 111111)
;;;; (let ((tp (get-word 50 4)))
;;;; (let ((fun (%make-closure tp nil)))
;;;; (funcall fun)))
;;;; (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))
;;;; (collect-garbage)
;;;; (setq lis (app (car lis) (cdr lis)))
;;;; (%print lis))
;;;; )
;;;; (%print (car (f1 '(9 . nil))))
;;;; (%print (car (f1 '(12 . nil))))
;;;; (%print 22222)
))
The following is a little Lisp interpreter written in Lisp itself. It provides full FUNARG capability but does not need these for implementation. So it reduces the complexity of implementing a full featured lisp with lexical closures.
(in-package "MEVAL")
(defun eval (expr env)
(let ((res nil))
; (format t "eval:expr = ~S~%" (funarg-chop expr))
(setf 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 (loop
for pair in env do
(if (eq expr (car pair))
(return pair))
finally (return nil))))
(if (null erg)
(throw nil "eval-atom:atom not found in env")
(cdr erg))))
(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 'funcall) (eval-funcall 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 (throw nil "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)))
(eval (cons (eval head env) rest) env))
(defun eval-labels (rest env)
(let ((env-new env)
(res nil)
(result nil))
(loop
for def in (car rest) do
(setf env-new (cons (cons (car def) nil) env-new)))
(loop
for def in (car rest) do
; (format t "~%~S~%" def)
(setf res (cons (make-funarg
(list 'lambda (car (cdr def))
(car (cdr (cdr def)))) env-new) res)))
; (format t "~%~S~%" env-new)
(loop
with env-end = env-new
for defval in res do
(setf (cdr (car env-end)) defval)
(setf env-end (cdr env-end)))
; (format t "~%~S~%" (funarg-chop env-new))
(loop
for form in (cdr rest) do
(setf result (eval form env-new)))
result))
(defun eval-funcall (rest env)
(let ((fval (eval (car rest) env))
(argl (list-eval (cdr rest) env)))
(eval (cons fval argl) env)))
(defun eval-cond (rest env)
(loop
for cond-line in rest do
(if (not (null (eval (car cond-line) env)))
(return (eval (car (cdr cond-line)) env)))
finally (throw nil "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 equal)))
(defun is-list-fun (head)
(listp head))
(defun eval-expr-fun (head rest env)
(let ((args (list-eval rest env)))
(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 (throw nil "eval-list-fun: case not implemented")))))
(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)
(loop
for x in args
collect (eval x env)))
(defun env-bind (vars vals old-env)
(loop
for x in vars and y in vals do
(push (cons x y) old-env)
finally (return old-env)))
(defun eval-funarg (funarg-rest args env)
(let ((arg-vals (list-eval args env)))
(progn
(setf arg-vals
(loop
for x in arg-vals
collect (list 'quote x)))
(eval (cons (car funarg-rest) arg-vals) (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 nil))
(loop
(format t ">")
(let ((r (read-from-string (read-line)))
(e nil))
(if (equal r '(quit))
(return-from main nil))
(setf e (eval r global-env))
(format t "~%~%res = ~S~%~%" e)))))
Two test-expressions for the interpreter:
(labels
((fak (n) (cond ((<= n 1) 1) (1 (* n (fak (- n 1))))))
(g (n) (* 2 n)))
(g (fak (g 6))))
(labels ((addn (n)
(function (lambda (x) (+ x n))))
(c (f g)
(function (lambda (x) (funcall f (funcall g x))))))
(funcall (c (addn 12) (addn 21)) 22))
Note the use of 1 (one!) instead of the usual t as t is unknown in the Lisp-X1 environment so far. (besides numbers only nil is a globally known atom). The second expression demonstrates functional values (addn, c) and functional arguments (c). (c stands for "compose").
Zuletzt geändert - 17 02 2008