cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

forge: clean-up, start next steps

Browse source
This commit is contained in:
Helmut Merz 2024-05-28 10:34:44 +02:00
parent 192c6c0fb9
commit 18203bd833
1 changed files with 22 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
forge/forge.lisp
View file

@ -92,6 +92,7 @@
(reg * (pushd (* (popd) (popd))))
(reg dup (pushd (car (dstack))))
(reg swap (let ((a (popd)) (b (popd))) (pushd a) (pushd b)))
(register 'lit #'lit)
@ -99,7 +100,6 @@
#'(lambda ()
(let* ((name (popd))
(code (popd)))
(format t "~%~a ~a" name code)
(register name #'(lambda () (call code))))))
(register-comp-word 'quote
@ -107,6 +107,10 @@
(let ((w (read-next)))
(comp-item #'lit) (comp-item w))))
(register-comp-word 'comp
#'(lambda ()
(comp-item (read-next))))
(register-comp-word 'def
#'(lambda ()
(let* ((name (read-next))
@ -129,35 +133,34 @@
(call (comp code)))
(defun call (code)
(let ((ip (make-iseq code)))
(let ((old-ip (fip))
(ip (make-iseq code)))
(setf (slot-value *forge-env* 'ip) ip)
(print (isq-all ip))
(do ((item (isq-next ip) (isq-next ip)))
((null item))
(funcall item))))
(funcall item))
(setf (slot-value *forge-env* 'ip) old-ip)))
(defun comp (slist)
(let ((cp (make-iseq)))
(let ((cp (make-iseq))
(inp (make-iseq slist)))
(setf (slot-value *forge-env* 'cp) cp)
(let ((inp (make-iseq slist)))
(setf (slot-value *forge-env* 'rp) inp)
(do ((item (isq-next inp) (isq-next inp)))
((null item))
(print item)
(typecase item
(symbol (comp-symbol item))
(cons (comp-item #'lit)
(let ((sub (comp item)))
(setf (slot-value *forge-env* 'cp) cp)
(setf (slot-value *forge-env* 'rp) inp)
(comp-item sub)))
(t (comp-item #'lit) (comp-item item))))))
(setf (slot-value *forge-env* 'rp) inp)
(do ((item (isq-next inp) (isq-next inp)))
((null item))
(typecase item
(symbol (comp-symbol item))
(cons (let ((sub (comp item)))
(setf (slot-value *forge-env* 'cp) cp)
(setf (slot-value *forge-env* 'rp) inp)
(comp-item #'lit)
(comp-item sub)))
(t (comp-item #'lit) (comp-item item)))))
(isq-all (fcp)))
(defun comp-symbol (sym)
(let* ((w (get-word sym))
(comp-fn (gethash w (comp-words))))
(format t "~%~a ~a ~a" sym w comp-fn)
(if comp-fn
(funcall comp-fn)
(comp-item (gethash w (words))))))