A tricky problem with XLISP is that the symbol *unbound* can be bound as a value to any Lisp symbol, also to a lexical parameter variable if passed as a value to a Lisp function:
(defun test (x) (print x)) (test '*unbound*) => error: unbound variable
The problem here is that the symbol
*unbound* has been bound to
the parameter variable 'x', so the expression
A symbol in the *obarray* is protected from garbage collection.
Lisp parameter variables together with local variables bound with
let and
let* and functions defined by
flet and
labels are not interned in the
*obarray*, instead they are
stored in the local lexical environment, maintained via an internal
association list.
Here are two Nyquist macros from 'evalenv.lsp':
(defmacro getenv () ; return the current environment '(progv '(*evalhook*) (list #'(lambda (exp env) env)) (eval nil))) (defmacro eval-env (arg) ; evaluate in the current environment `(evalhook ,arg nil nil (getenv)))
The 'getenv' macro returns the association list of the current lexical environment:
(let ((v1 1) ; first variable (v2 2)) ; second variable (flet ((f1 (a) a) ; first function (f2 (b) b)) ; second function (getenv))) => ((((V2 . 1) (V1 . 2))) ((F2 . #<Closure...>) (F1 . #<Closure...>)))
The asymmetric layout is produced by print, the real structure of the lexical environment is a cons of two association lists:
(defmacro print-env () (let ((env (gensym))) `(let ((,env (getenv))) (format t "(~s . ~s)~%" (car ,env) (cdr ,env)))))
Note: You could also use print-cons instead of format to print really all the details of the list, but format is enough for the examples here.
(let ((v1 1) ; first variable (v2 2)) ; second variable (flet ((f1 (a) a) ; first function (f2 (b) b)) ; second function (print-env))) ((((V2 . 2) (V1 . 1))) . (((F2 . #<Closure...>) (F1 . #<Closure...>))))
The basic
((((V2 . value) (V1 . value))) . (((F2 . value) (F1 . value)))) ((<----- variable-list ----->) . (<----- function-list ----->)) (car (getenv)) => (variable-list) (cdr (getenv)) => (function-list)
The different levels of bindings are maintained via multiple sublists:
(let ((v1 1)) ; first level variable (let ((v2 2)) ; second level variable (flet ((f1 (a) a)) ; first level function (flet ((f2 (b) b)) ; second level function (print-env))))) ((((V2 . value)) ((V1 . value))) . (((F2 . value)) ((F1 . value)))) (((<--level2-->) (<--level1-->)) . ((<--level2-->) (<--level1-->))) ((<------ variable-list ------>) . (<------ function-list ------>))
Variables appear always in the variable list, functions always in the function list:
(let ((v1 1)) ; first level variable (flet ((f1 (a) a)) ; first level function (let ((v2 2)) ; second level variable (flet ((f2 (b) b)) ; second level function (print-env))))) ((((V2 . value)) ((V1 . value))) . (((F2 . value)) ((F1 . value)))) (((<--level2-->) (<--level1-->)) . ((<--level2-->) (<--level1-->))) ((<------ variable-list ------>) . (<------ function-list ------>))
The
(let ((v1 1)) ; first level variable (let ((v2 2)) ; second level variable (flet ((f1 (a) a)) ; first level function (flet ((f2 (b) b)) ; second level function (let ((v3 3)) ; third level variable (print-env)))))) ((((V3 . value)) ((V2 . value)) ((V1 . value))) . (((F2 . value)) ((F1 . value)))) (((<--level3-->) (<--level2-->) (<--level1-->)) . ((<--level2-->) (<--level1-->))) ((<------------- variable-list -------------->) . (<------ function-list ------>))
There may appear several variable bindings in the same sublist:
(let ((v1 1) (v2 2)) ; first level variables (flet ((f1 (a) a) ; first level functions (f2 (b) b)) (let ((v3 3)) ; second level variable (print-env)))) ((((V3 . value)) ((V2 . value) (V1 . value))) . (((F2 . value) (F1 . value)))) (((<--level2-->) (<--------level1--------->)) . ((<---------level1-------->))) ((<------------ variable-list ------------->) . (<----- function-list ----->))
The basic principle is always the same:
(((level n ...) ... (level 1 variables)) . ((level n ...) ... (level 1 functions))) (car (getenv)) => ((level n ...) (level n-1 ...) ... (level 1 variables)) (cdr (getenv)) => ((level n ...) (level n-1 ...) ... (level 1 functions))
Also the function parameter variables appear in the the lexical environment association list:
(defun test (parameter-var) (let ((local-var 'value)) (print-env))) ((((LOCAL-VAR . value)) ((PARAMETER-VAR . value))) . NIL) ; NIL = no functions (((<-----level2------>) (<-------level1-------->)) . NIL) ((<--------------- variable-list --------------->) . NIL)
The variables bound by let appear
before the function's parameter variables, that's why
let bindings 'shadow' parameter variables
with the same name.
This still doen't work:
(setq x 'global) ; define a global variable 'x' (defun print-x () ; define a function PRINT-X in the global environment (print (getenv)) ; always prints ((NIL)), also with EVAL-ENV or EVALHOOK (print x)) ; always prints GLOBAL, also with EVAL-ENV or EVALHOOK (let ((x 'local)) ; create a lexical variable 'x' (print-x)) ; evaluate PRINT-X => GLOBAL ; value from the environment, where PRINT-X was defined (let ((x 'local)) ; create a lexical variable 'x' (eval-env (print-x)) ; evaluate PRINT-X in the current environment => GLOBAL ;wrong ; value from the environment, where PRINT-X was called (let ((x 'local)) ; create a lexical variable 'x' (eval-env (funcall 'print-x)) ; evaluate PRINT-X in the current environment => GLOBAL ;wrong ; value from the environment, where PRINT-X was called
The 'lboundp' function tests if a valid variable value is bound to a symbol in the current lexical environment:
(defmacro lboundp (symbol) (cond ((not (or (symbolp symbol) (and (consp symbol) (eq 'quote (car symbol)) (symbolp (cadr symbol))))) (error "bad argument type" symbol)) ((and (consp symbol) (cddr symbol)) (error "too many arguments")) (t (let ((a-cons (gensym)) (level (gensym)) (binding (gensym))) `(let ((,a-cons (dolist (,level (car (getenv)) nil) (let ((,binding (assoc ,symbol ,level))) (when ,binding (return ,binding)))))) (and ,a-cons (not (eq (cdr ,a-cons) '*unbound*))))))))
The XLISP boundp function only can test global variables, interned in the *obarray*, so it cannot be used to test if a symbol has a variable value bound to it in the lexical environment:
(defun test (x) ; bad example (if (boundp 'x) ; <- global test (print x) (print '*unbound*))) (test 'hello!) => *UNBOUND* ; bad result (test 123) => *UNBOUND* ; bad result (setq x t) => T ; create a global variable 'x' (test 'hello!) => 'HELLO! ; OK (test 123) => 123 ; OK (test '*unbound*) => error: unbound variable - X ; bad result
Here the same example with 'lboundp':
(defun test (x) ; good example (if (lboundp 'x) ; <- local test (print x) (print '*unbound*))) (test 'hello!) => 'HELLO! ; OK (test 123) => 123 ; OK (test '*unbound*) => *UNBOUND* ; OK
The 'lboundp' function cannot test symbol values at the
(setq x t) => T ; create a global variable 'x' (lboundp 'x) => NIL ; lexical test fails (boundp 'x) => T ; global test succeeds
The 'valuep' function tests if a valid variable value is bound to a symbol at any level:
(defmacro valuep (symbol) (cond ((not (or (symbolp symbol) (and (consp symbol) (eq 'quote (car symbol)) (symbolp (cadr symbol))))) (error "bad argument type" ,symbol)) ((and (consp symbol) (cddr symbol)) (error "too many arguments")) (t (let ((a-cons (gensym)) (level (gensym)) (binding (gensym))) `(let ((,a-cons (dolist (,level (car (getenv)) nil) (let ((,binding (assoc ,symbol ,level))) (when ,binding (return ,binding)))))) (if ,a-cons (not (eq (cdr ,a-cons) '*unbound*)) (boundp ,symbol)))))))
It's tricky to test if a symbol has a valid variable value bound to it because if the symbol is bound to *unbound* in a lexical environment, it still shadows a symbol with the same name in the *obarray*, making a possibly existing global variable inaccessible, like shown in the examples below.
Note: The lexical environment must be tested first, because this is the way how XLISP searches for symbol bindings.
Examples:
(when (valuep 'x) x) => NIL ; no global binding of 'x' found (setq x 'ok) => OK ; create a global variable 'x' (when (valuep 'x) x) => OK ; global binding of 'x' found (let ((x 'local)) ; create a lexical variable 'x' (when (valuep 'x) x)) ; try to access the lexical variable => LOCAL ; lexical binding of 'x' found
XLISP problems with *unbound* lexical variables:
(setq x 'ok) => OK ; create a global variable 'x' (when (valuep 'x) x) => OK ; global binding of 'x' found (let ((x '*unbound*)) ; create an unbound lexical variable 'x' (when (valuep 'x) x)) ; try to access the global variable => NIL ; global binding of 'x' NOT found (let ((x '*unbound*)) ; create an unbound lexical variable 'x' x) ; try to access the global variable error: unbound variable - X
The 'valuep' function recognizes if a global variable value is shadowed by an *unbound* lexical variable and returns NIL if the global variable is inaccessible..
The 'lfboundp' function tests if a valid function value is bound to a symbol in the current lexical environment:
(defmacro lfboundp (symbol) (cond ((not (or (symbolp symbol) (and (consp symbol) (eq 'quote (car symbol)) (symbolp (cadr symbol))))) (error "bad argument type" symbol)) ((and (consp symbol) (cddr symbol)) (error "too many arguments")) (t (let ((a-cons (gensym)) (level (gensym)) (binding (gensym))) `(let ((,a-cons (dolist (,level (cdr (getenv)) nil) (let ((,binding (assoc ,symbol ,level))) (when ,binding (return ,binding)))))) (and ,a-cons (not (eq (cdr ,a-cons) '*unbound*))))))))
The XLISP fboundp function only works with symbols interned in the *obarray*, so it cannot be used to test if a symbol has a function value bound to it in the lexical environment:
(flet ((my-function (x) 'hello)) (fboundp 'my-function)) ; <- global test => NIL (flet ((my-function (x) 'hello)) (lfboundp 'my-function)) ; <- local test => T
The 'lfboundp' function cannot test symbol function values at the
(lfboundp 'car) => NIL ; lexical test fails (fboundp 'car) => T ; global test succeeds
Problems with *unbound*
lexical functions are less likely then with
*unbound* parameter
variables, because there is no
See also:
The function 'lsymbol-value' returns a variable value from the lexical environment:
(defmacro lsymbol-value (symbol) (cond ((not (or (symbolp symbol) (and (consp symbol) (eq 'quote (car symbol)) (symbolp (cadr symbol))))) (error "bad argument type" symbol)) ((and (consp ,symbol) (cddr symbol)) (error "too many arguments")) (t (let ((a-cons (gensym)) (level (gensym)) (binding (gensym))) `(let ((,a-cons (dolist (,level (car (getenv)) nil) (let ((,binding (assoc ,symbol ,level))) (when ,binding (return ,binding)))))) (when ,a-cons (if (eq (cdr ,a-cons) '*unbound*) '*unbound* (cdr ,a-cons))))))))
The function 'lsymbol-function' returns a function value from the lexical environment:
(defmacro lsymbol-function (symbol) (cond ((not (or (symbolp symbol) (and (consp symbol) (eq 'quote (car symbol)) (symbolp (cadr symbol))))) (error "bad argument type" symbol)) ((and (consp symbol) (cddr symbol)) (error "too many arguments")) (t (let ((a-cons (gensym)) (level (gensym)) (binding (gensym))) `(let ((,a-cons (dolist (,level (cdr (getenv)) nil) (let ((,binding (assoc ,symbol ,level))) (when ,binding (return ,binding)))))) (when ,a-cons (if (eq (cdr ,a-cons) '*unbound*) '*unbound* (cdr ,a-cons))))))))
The XLISP function
(flet ((my-function (x) 'hello)) (symbol-function 'my-function)) ; <- searches the *obarray* => error: unbound function - MY-FUNCTION (flet ((my-function (x) 'hello)) (lsymbol-function 'my-function)) ; <- searches the lexical environment => #<Closure-MY-FUNCTION...>
(defmacro with-static-env (&rest body) (let ((env (gensym)) (rval (gensym))) `(let ((,env (getenv))) ; environment snapshot (progv '(*evalhook*) '((lambda (exp env) (labels ((,rval (exp env) ; recursive eval (format t "exp: ~a env: ~a ,env: ~a~%" exp env ,env) (evalhook exp #',rval NIL ,env))) (format t "exp: ~a env: ~a ,env: ~a~%" exp env ,env) (evalhook exp #',rval NIL ,env)))) ,@body))))
(defmacro with-dynamic-env (&rest body) (let ((env (gensym)) (rval (gensym))) `(let ((,env (getenv))) ; environment snapshot (progv '(*evalhook*) '((lambda (exp env) (labels ((,rval (exp env) ; recursive eval (format t "inner exp: ~a env: ~a~%" exp env) (evalhook exp #',rval NIL env))) (format t "outer exp: ~a env: ~a~%" exp env) (evalhook exp #',rval NIL env)))) ,@body))))
(defun display-env (env &optional (exp nil exp-p)) (flet ((display-bindings (name bindings) (format t " ~a bindings: ~s~%" name bindings) (let ((frame-counter 1)) (dolist (frame bindings) (format t " ~a frame ~a: ~a~%" name frame-counter frame) (let ((binding-counter 1)) (dolist (binding frame) (when (consp binding) (format t " ~a ~a: ~s - value: ~s~%" name binding-counter (car binding) (cdr binding)) (incf binding-counter)))) (incf frame-counter))))) (when exp-p (format t "eval: ~s~%" exp)) (format t "environment: ~s~%" env) (display-bindings "variable" (car env)) (display-bindings "function" (cdr env)))) (defmacro debug:env () '(progv '(*evalhook*) '(nil) (display-env (getenv)))) (defmacro debug:env () '(progv '(*evalhook*) '((lambda (exp env) (display-env env))) (eval nil))) (defmacro debug:env (&rest body) (when *evalhook* (format t "DEBUG:ENV ") (format t "*evalhook* was already modified~%")) (if (null body) '(progv '(*evalhook*) '((lambda (exp env) (display-env env))) (eval nil)) (let ((init (gensym)) (rval (gensym))) `(let ((,init (getenv))) ; environment snapshot (progv '(*evalhook*) '((lambda (exp env) (labels ((,rval (exp env) ; recursive eval (display-env env exp) (evalhook exp #',rval nil env))) (display-env ,init exp) (evalhook exp #',rval nil ,init)))) ,@body))))) (defmacro with-evalhook (&rest body) (let ((init (gensym)) (rval (gensym)) (hook (gensym)) debug) `(let ((,init (getenv))) ; environment snapshot (progv '(*evalhook*) '((lambda (exp env) (labels ((,rval (exp env) ; recursive eval ,(print *evalhook*) ,(when T `(funcall ,*evalhook* exp env)) (evalhook exp #',rval nil env))) (evalhook exp #',rval nil ,init)))) ,@body)))) (defmacro with-current-environment (&rest body) (when *evalhook* (error "*evalhook* already modified")) (let ((init (gensym)) (rval (gensym)) debug) (when (eq :debug (car body)) (setq debug t body (cdr body))) `(let ((,init (getenv))) ; environment snapshot (progv '(*evalhook*) '((lambda (exp env) (labels ((,rval (exp env) ; recursive eval ;; append environment from snapshot (setq env (cons (append (car env) (car ,init)) (append (cdr env) (cdr ,init)))) ,(when debug '(display-env env exp)) (evalhook exp #',rval nil env))) ;; start with environment snapshot ,(when debug `(display-env ,init exp)) (evalhook exp #',rval nil ,init)))) ,@body)))) (defmacro with-env (&rest body) (let ((init (gensym)) (rval (gensym))) `(let ((,init (getenv))) ; environment snapshot (progv '(*evalhook*) '((lambda (exp env) (labels ((,rval (exp env) ; recursive eval (display-env env exp) (evalhook exp #',rval nil env))) (display-env ,init exp) (evalhook exp #',rval nil ,init)))) ,@body))))
(with-current-environment (debug:env body)) (progv '(*evalhook) '((lambda (exp env) (labels ((rval (exp env) (append-current-environment) (debug:env ...) (evalhook exp #'rval nil env))) (evalhook exp #'rval nil init))))) (debug:env (with-current-environment body)) (progv '(*evalhook) '((lambda (exp env) (labels ((rval (exp env)
(defmacro with-current-environment (&rest body) (when *evalhook* (error "*evalhook* already modified")) (let ((debug nil) (init (gensym)) (rval (gensym))) (when (eq :debug (car body)) (setq debug t body (cdr body))) `(let ((,init (getenv))) ; environment snapshot (progv '(*evalhook*) '((lambda (exp env) (labels ((,rval (exp env) ; recursive eval ,(cond (debug `(setq env (cons (append (car env) (car ,init)) (append (cdr env) (cdr ,init)))) '(display-env env exp) `(evalhook exp #',rval nil env)) (t `(evalhook exp #',rval nil (cons (append (car env) (car ,init)) (append (cdr env) (cdr ,init)))))))) ,(when debug `(display-env ,init exp)) (evalhook exp #',rval nil ,init)))) ,@body))))
(setq *rvalhook* nil) (defmacro with-current-environment (&rest body) (let ((init (gensym))) `(let ((,init (getenv))) (rval-env #'(lambda (exp env) (cons exp (cons (append (car env) (car ,init)) (append (cdr env) (cdr ,init))))) ,@body)))) (defmacro debug:env (&rest body) (rval-env #'(lambda (exp env) (display-env env exp) (cons exp env)) ,@body)) (defmacro run-rvalhooks () (let ((func (gensym)) (result (gensym))) `(dolist (,func *rvalhook*) (format t "func: ~a~%" ,func) (format t "exp: ~a~%" exp) (format t "env: ~a~%" env) (let ((,result (eval (list ,func 'exp 'env) ))) (format t "result: ~a~%" ,result) (format t "exp: ~a~%" exp) (format t "car: ~a~%" (car ,result)) (format t "env: ~a~%" env) (format t "cdr: ~a~%" (cdr ,result)) (setq exp (car ,result) env (cdr ,result)) )))) (defmacro rval-env (function &rest body) (format t "function: ~a~%" function) (format t "body: ~a~%" body) (or *evalhook* (setq *rvalhook* nil)) (format t "*rvalhook*: ~a~%" *rvalhook*) (if *rvalhook* `(prog2 (push ,function *rvalhook*) (progn ,@body) (setq *rvalhook* (remove ,function *rvalhook*))) (let ((rval (gensym)) (func (gensym)) (result (gensym))) `(prog2 (push ,function *rvalhook*) (progv '(*evalhook*) `((lambda (exp env) (print 'hallo) (labels ((,rval (exp env) (run-rvalhooks) (evalhook exp #',rval nil env))) ; (run-rvalhooks) (evalhook exp #',rval nil env)))) ,@body) (setq *rvalhook* (remove ,function *rvalhook*))))))
*rvalhook* must be a list of functions, each taking two arguments 'exp'
[the Lisp expressions to evaluate] and 'env' [the environment], returning
a cons of the format
In case of an error, the
*evalhook* variable is
automatically reset by the XLISP
(defmacro lmacroexpand-1 (form) (if (not (and (consp form) (eq 'quote (car form)) (symbolp (caadr form)))) form ; if the form isn't '(symbol ... ) (let ((a-cons (gensym)) (l-expr (gensym))) `(let ((,a-cons (assoc ',(caadr form) (cadr (getenv))))) (if (null ,a-cons) ; (caadr form) = macro-name ,form ; if no lexical binding was found (let ((,l-expr (get-lambda-expression (cdr ,a-cons)))) (if (eq 'macro (car ,l-expr)) ; if l-expr is a macro (with-current-environment ;; create an *unbound* macro in the *obarray* (eval (append '(defmacro *unbound*) (cdr ,l-expr))) ;; expand the macro in the current environment (eval (list 'macroexpand-1 ; (cdadr form) = (list 'quote ; macro-arguments as list (cons '*unbound* ',(cdadr form)))))) ,form))))))) ; if l-expr is not a macro
(let ((x 1)) (macrolet ((test (arg) `(progn (print ,arg) (print ,(eval x))))) (lmacroexpand-1 '(test 'hallo)))) =>
A lexical variable with the symbol *unbound* as a variable value bound to it will continue to shadow a global variable with the same name, even if the the lexical variable is 'unbound':
(setq x t) => T ; create a global variable 'x' (let ((x '*unbound*)) ; create an unbound lexical variable 'x' (print x)) ; try to print the global variable error: unbound variable - X
Tested with
Nyquist Bug: let* causes infinite recursion problems with either progv, evalhook, or *evalhook* [still needs more investigation], so this doesnt work:
(let* ((init (getenv))) (progv '(*evalhook*) '((lambda (exp env) (labels ((rval (exp env) (print init) ; <- causes infinite recursion (evalhook exp #'rval nil env))) (evalhook exp #'rval nil init)))) (eval nil))) => infinite recursionwhile exactly the same form using let instead of let* works:
(let ((init (getenv))) (progv '(*evalhook*) '((lambda (exp env) (labels ((rval (exp env) (print init) ; <- no infinite recursion (evalhook exp #'rval nil env))) (evalhook exp #'rval nil init)))) (eval nil))) (NIL) ; PRINT output => NIL
Bug tested with