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

minor refactoring, clean-up

Browse source
This commit is contained in:
Helmut Merz 2024-05-30 19:36:40 +02:00
parent fa086ade6a
commit 2a29b0bd9c
1 changed files with 8 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
forge/forge.lisp
View file

@ -93,18 +93,11 @@
`(register ',sym #'(lambda () ,@body))) `(register ',sym #'(lambda () ,@body)))
(defun lit () (pushd (isq-next (fip)))) (defun lit () (pushd (isq-next (fip))))
(defun wrap () (pushd (list #'lit (popd))))
(defun defer () (comp-item (isq-next (fip))))
(defun do-reg () (defun do-reg (&optional (fn #'register))
(let* ((name (popd)) (let* ((name (popd))
(code (popd))) (code (popd)))
(register name #'(lambda () (call code)) :code code))) (funcall fn name #'(lambda () (call code)) :code code)))
(defun do-regc ()
(let* ((name (popd))
(code (popd)))
(register-comp-word name #'(lambda () (call code)) :code code)))
(defun do-quote () (defun do-quote ()
(let ((quoted (read-next))) (let ((quoted (read-next)))
@ -118,6 +111,9 @@
(comp-item (gethash w (comp-words))))) (comp-item (gethash w (comp-words)))))
(defun setup-builtins () (defun setup-builtins ()
(register 'lit #'lit)
(register 'reg #'do-reg)
(reg + (pushd (+ (popd) (popd)))) (reg + (pushd (+ (popd) (popd))))
(reg * (pushd (* (popd) (popd)))) (reg * (pushd (* (popd) (popd))))
(reg dup (pushd (car (dstack)))) (reg dup (pushd (car (dstack))))
@ -126,12 +122,9 @@
(reg ?? (format t "~a~%" (dstack))) (reg ?? (format t "~a~%" (dstack)))
(reg get (pushd (cadr (popd)))) (reg get (pushd (cadr (popd))))
(reg set (setf (cadr (popd)) (popd))) (reg set (setf (cadr (popd)) (popd)))
(reg wrap (pushd (list #'lit (popd))))
(register 'lit #'lit) (reg defer (comp-item (isq-next (fip))))
(register 'wrap #'wrap) (reg regc (do-reg #'register-comp-word))
(register 'defer #'defer)
(register 'reg #'do-reg)
(register 'regc #'do-regc)
(register-comp-word 'quote #'do-quote) (register-comp-word 'quote #'do-quote)
(register-comp-word 'comp #'do-comp) (register-comp-word 'comp #'do-comp)