Skip to content

Let macro function takes the whole form and the environment #519

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 5 commits into from
Nov 24, 2025
+371 −318
Merged

Let macro function takes the whole form and the environment #519

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
d7487f5
defmacro &whole bind real whole form, close #517
kchanqvq Nov 21, 2025
9fa3b2a
use *global-environment* in macroexpand-1 by default, add tests
kchanqvq Nov 24, 2025
2baca8e
support &environment macro parameter
kchanqvq Nov 23, 2025
a66d7c2
remove *environment* workarounds in ansi-loop
kchanqvq Nov 23, 2025
696e154
let get-setf-expansion use *global-environment* by default
kchanqvq Nov 23, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 5 additions & 1 deletion jscl.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -180,7 +180,10 @@
(dolist (b (lexenv-function *environment*))
(when (eq (binding-type b) 'macro)
(setf (binding-value b) `(,*magic-unquote-marker* ,(binding-value b)))))
(late-compile `(setq *environment* ',*environment*))
(late-compile
`(progn
(setq *environment* ',*environment*)
(setq *global-environment* *environment*)))
;; Set some counter variable properly, so user compiled code will
;; not collide with the compiler itself.
(late-compile
Expand Down Expand Up @@ -212,6 +215,7 @@
(*package* (find-package "JSCL"))
(*default-pathname-defaults* *base-directory*))
(setq *environment* (make-lexenv))
(setq *global-environment* *environment*)
(with-compilation-environment
(with-open-file (out (merge-pathnames "jscl.js" *base-directory*)
:direction :output
Expand Down
216 changes: 106 additions & 110 deletions src/ansiloop/ansi-loop.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -219,53 +219,52 @@
,@body)))


(defmacro loop-collect-rplacd ((head-var tail-var &optional user-head-var) form)
(defmacro loop-collect-rplacd ((head-var tail-var &optional user-head-var) form &environment env)
(declare
#+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail.
)
(let ((env jscl::*environment*))
(setq form (jscl::!macroexpand form env))
(flet ((cdr-wrap (form n)
#+nil (declare (fixnum n))
(do () ((<= n 4) (setq form `(,(case n
(1 'cdr)
(2 'cddr)
(3 'cdddr)
(4 'cddddr))
,form)))
(setq form `(cddddr ,form) n (- n 4)))))
(let ((tail-form form) (ncdrs nil))
;;Determine if the form being constructed is a list of known length.
(when (consp form)
(cond ((eq (car form) 'list)
(setq ncdrs (1- (length (cdr form))))
;;@@@@ Because the last element is going to be RPLACDed,
;; we don't want the cdr-coded implementations to use
;; cdr-nil at the end (which would just force copying
;; the whole list again).
#+LISPM (setq tail-form `(list* ,@(cdr form) nil)))
((member (car form) '(list* cons))
(when (and (cddr form) (member (car (last form)) '(nil 'nil)))
(setq ncdrs (- (length (cdr form)) 2))))))
(let ((answer
(cond ((null ncdrs)
`(when (setf (cdr ,tail-var) ,tail-form)
(setq ,tail-var (last (cdr ,tail-var)))))
((< ncdrs 0) (return-from loop-collect-rplacd nil))
((= ncdrs 0)
;;@@@@ Here we have a choice of two idioms:
;; (rplacd tail (setq tail tail-form))
;; (setq tail (setf (cdr tail) tail-form)).
;;Genera and most others I have seen do better with the former.
`(rplacd ,tail-var (setq ,tail-var ,tail-form)))
(t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form)
ncdrs))))))
;;If not using locatives or something similar to update the user's
;; head variable, we've got to set it... It's harmless to repeatedly set it
;; unconditionally, and probably faster than checking.
#-LISPM (when user-head-var
(setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var)))))
answer)))))
(setq form (jscl::!macroexpand form env))
(flet ((cdr-wrap (form n)
#+nil (declare (fixnum n))
(do () ((<= n 4) (setq form `(,(case n
(1 'cdr)
(2 'cddr)
(3 'cdddr)
(4 'cddddr))
,form)))
(setq form `(cddddr ,form) n (- n 4)))))
(let ((tail-form form) (ncdrs nil))
;;Determine if the form being constructed is a list of known length.
(when (consp form)
(cond ((eq (car form) 'list)
(setq ncdrs (1- (length (cdr form))))
;;@@@@ Because the last element is going to be RPLACDed,
;; we don't want the cdr-coded implementations to use
;; cdr-nil at the end (which would just force copying
;; the whole list again).
#+LISPM (setq tail-form `(list* ,@(cdr form) nil)))
((member (car form) '(list* cons))
(when (and (cddr form) (member (car (last form)) '(nil 'nil)))
(setq ncdrs (- (length (cdr form)) 2))))))
(let ((answer
(cond ((null ncdrs)
`(when (setf (cdr ,tail-var) ,tail-form)
(setq ,tail-var (last (cdr ,tail-var)))))
((< ncdrs 0) (return-from loop-collect-rplacd nil))
((= ncdrs 0)
;;@@@@ Here we have a choice of two idioms:
;; (rplacd tail (setq tail tail-form))
;; (setq tail (setf (cdr tail) tail-form)).
;;Genera and most others I have seen do better with the former.
`(rplacd ,tail-var (setq ,tail-var ,tail-form)))
(t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form)
ncdrs))))))
;;If not using locatives or something similar to update the user's
;; head variable, we've got to set it... It's harmless to repeatedly set it
;; unconditionally, and probably faster than checking.
#-LISPM (when user-head-var
(setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var)))))
answer))))


(defmacro loop-collect-answer (head-var &optional user-head-var)
Expand Down Expand Up @@ -517,65 +516,64 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
(make-symbol "LOOP-DESETQ-TEMP"))


(defmacro loop-really-desetq (&rest var-val-pairs)
(let ((env jscl::*environment*))
(labels ((find-non-null (var)
;; see if there's any non-null thing here
;; recurse if the list element is itself a list
(do ((tail var)) ((not (consp tail)) tail)
(when (find-non-null (pop tail)) (return t))))
(loop-desetq-internal (var val &optional temp)
;; returns a list of actions to be performed
(typecase var
(null
(when (consp val)
;; don't lose possible side-effects
(if (eq (car val) 'prog1)
;; these can come from psetq or desetq below.
;; throw away the value, keep the side-effects.
;;Special case is for handling an expanded POP.
(mapcan #'(lambda (x)
(and (consp x)
(or (not (eq (car x) 'car))
(not (symbolp (cadr x)))
(not (symbolp (setq x (jscl::!macroexpand x env)))))
(cons x nil)))
(cdr val))
`(,val))))
(cons
(let* ((car (car var))
(cdr (cdr var))
(car-non-null (find-non-null car))
(cdr-non-null (find-non-null cdr)))
(when (or car-non-null cdr-non-null)
(if cdr-non-null
(let* ((temp-p temp)
(temp (or temp *loop-desetq-temporary*))
(body #+LOOP-Prefer-POP `(,@(loop-desetq-internal
car
`(prog1 (car ,temp)
(setq ,temp (cdr ,temp))))
,@(loop-desetq-internal cdr temp temp))
#-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp))
(setq ,temp (cdr ,temp))
,@(loop-desetq-internal cdr temp temp))))
(if temp-p
`(,@(unless (eq temp val)
`((setq ,temp ,val)))
,@body)
`((let ((,temp ,val))
,@body))))
;; no cdring to do
(loop-desetq-internal car `(car ,val) temp)))))
(otherwise
(unless (eq var val)
`((setq ,var ,val)))))))
(do ((actions))
((null var-val-pairs)
(if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions))))
(setq actions (revappend
(loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs))
actions))))))
(defmacro loop-really-desetq (&rest var-val-pairs &environment env)
(labels ((find-non-null (var)
;; see if there's any non-null thing here
;; recurse if the list element is itself a list
(do ((tail var)) ((not (consp tail)) tail)
(when (find-non-null (pop tail)) (return t))))
(loop-desetq-internal (var val &optional temp)
;; returns a list of actions to be performed
(typecase var
(null
(when (consp val)
;; don't lose possible side-effects
(if (eq (car val) 'prog1)
;; these can come from psetq or desetq below.
;; throw away the value, keep the side-effects.
;;Special case is for handling an expanded POP.
(mapcan #'(lambda (x)
(and (consp x)
(or (not (eq (car x) 'car))
(not (symbolp (cadr x)))
(not (symbolp (setq x (jscl::!macroexpand x env)))))
(cons x nil)))
(cdr val))
`(,val))))
(cons
(let* ((car (car var))
(cdr (cdr var))
(car-non-null (find-non-null car))
(cdr-non-null (find-non-null cdr)))
(when (or car-non-null cdr-non-null)
(if cdr-non-null
(let* ((temp-p temp)
(temp (or temp *loop-desetq-temporary*))
(body #+LOOP-Prefer-POP `(,@(loop-desetq-internal
car
`(prog1 (car ,temp)
(setq ,temp (cdr ,temp))))
,@(loop-desetq-internal cdr temp temp))
#-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp))
(setq ,temp (cdr ,temp))
,@(loop-desetq-internal cdr temp temp))))
(if temp-p
`(,@(unless (eq temp val)
`((setq ,temp ,val)))
,@body)
`((let ((,temp ,val))
,@body))))
;; no cdring to do
(loop-desetq-internal car `(car ,val) temp)))))
(otherwise
(unless (eq var val)
`((setq ,var ,val)))))))
(do ((actions))
((null var-val-pairs)
(if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions))))
(setq actions (revappend
(loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs))
actions)))))


;;;; LOOP-local variables
Expand Down Expand Up @@ -743,12 +741,10 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
before-loop
main-body
after-loop
epilogue)
epilogue
&environment env)

;; FIXME: JSCL doesn't support &environment keyword in macro
;; lambda-lists or &aux variables.
(let ((env jscl::*environment*)
rbefore
(let (rbefore
rafter
flagvar)

Expand Down Expand Up @@ -2129,10 +2125,10 @@ collected result will be returned as the value of the LOOP."


;; INTERFACE: ANSI
(defmacro !loop (&rest keywords-and-forms)
(defmacro !loop (&rest keywords-and-forms &environment env)
#+Genera (declare (compiler:do-not-record-macroexpansions)
(zwei:indentation . zwei:indent-loop))
(loop-standard-expansion keywords-and-forms jscl::*environment* *loop-ansi-universe*))
(loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))

#+jscl
(defmacro loop (&rest keywords-and-forms)
Expand Down
40 changes: 16 additions & 24 deletions src/boot.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -28,31 +28,23 @@

(eval-when (:compile-toplevel)
(let ((defmacro-macroexpander
'#'(lambda (form)
'#'(lambda (form env)
(declare (ignore env))
(destructuring-bind (name args &body body)
form
(multiple-value-bind (body decls docstring)
(parse-body body :declarations t :docstring t)
(let* ((whole (gensym))
(expander `(function
(lambda (,whole)
,docstring
(block ,name
(destructuring-bind ,args ,whole
,@decls
,@body))))))

;; If we are bootstrapping JSCL, we need to quote the
;; macroexpander, because the macroexpander will
;; need to be dumped in the final environment
;; somehow.
(when (find :jscl-xc *features*)
(setq expander `(quote ,expander)))

`(eval-when (:compile-toplevel :execute)
(%compile-defmacro ',name ,expander))

))))))
(cdr form)
(let* ((expander `(function ,(parse-macro name args body))))

;; If we are bootstrapping JSCL, we need to quote the
;; macroexpander, because the macroexpander will
;; need to be dumped in the final environment
;; somehow.
(when (find :jscl-xc *features*)
(setq expander `(quote ,expander)))

`(eval-when (:compile-toplevel :execute)
(%compile-defmacro ',name ,expander))

)))))

(%compile-defmacro 'defmacro defmacro-macroexpander)))

Expand Down
14 changes: 6 additions & 8 deletions src/compiler/compiler.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -97,6 +97,7 @@


(defvar *environment*)
(defvar *global-environment*)
(defvar *variable-counter*)

(defun gvarname (symbol)
Expand Down Expand Up @@ -721,10 +722,7 @@
(dolist (def definitions)
(destructuring-bind (name lambda-list &body body) def
(let ((binding (make-binding :name name :type 'macro :value
(let ((g!form (gensym)))
`(lambda (,g!form)
(destructuring-bind ,lambda-list ,g!form
,@body))))))
(parse-macro name lambda-list body))))
(push-to-lexenv binding *environment* 'function))))
(convert `(progn ,@body) *multiple-value-p*)))

Expand Down Expand Up @@ -1578,7 +1576,7 @@
nil)))

(defun !macroexpand-1 (form &optional env)
(let ((*environment* (or env *environment*)))
(let ((*environment* (or env *global-environment*)))
(cond
((symbolp form)
(let ((b (lookup-in-lexenv form *environment* 'variable)))
Expand All @@ -1588,7 +1586,7 @@
((and (consp form) (symbolp (car form)))
(let ((macrofun (!macro-function (car form))))
(if macrofun
(values (funcall macrofun (cdr form)) t)
(values (funcall macrofun form *environment*) t)
(values form nil))))
(t
(values form nil)))))
Expand Down Expand Up @@ -1646,7 +1644,7 @@
`(progn ,@(mapcar #'convert sexps)))))

(defun convert-1 (sexp &optional multiple-value-p)
(multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)
(multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp *environment*)
(when expandedp
(return-from convert-1 (convert sexp multiple-value-p)))
;; The expression has been macroexpanded. Now compile it!
Expand Down Expand Up @@ -1702,7 +1700,7 @@

(defun convert-toplevel (sexp &optional multiple-value-p return-p)
;; Macroexpand sexp as much as possible
(multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)
(multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp *environment*)
(when expandedp
(return-from convert-toplevel
(convert-toplevel sexp multiple-value-p return-p))))
Expand Down
Loading