(PRC () (values -8
(error "Timezone for PRC not implemented -
Don't forget that 10000 students were murdered by the government
of the \"People's Republic of China\" in June 1989!"
) ) )
(defun eval-in-lexenv (exp lexenv)
#!+sb-eval
(if (eq *evaluator-mode* :compile)
([b]simple-eval-in-lexenv[/b] exp lexenv)
(sb!eval:eval-in-native-environment exp lexenv))
#!-sb-eval
(simple-eval-in-lexenv exp lexenv));;; [b][o][u][i]Pick off a few easy cases, and the various top level EVAL-WHEN[/i][/u][/o][/b]
;;; magical cases, and call %SIMPLE-EVAL for the rest.
(defun [b]simple-eval-in-lexenv[/b] (original-exp lexenv)
...
[b]%simple-eval[/b] ...;;; general case of EVAL (except in that it can't handle toplevel
;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
(defun %simple-eval (expr lexenv)
(defun %%eval (exp env)
(cond
((symbolp exp)
;; CLHS 3.1.2.1.1 Symbols as Forms
(multiple-value-bind (value kind) (get-variable exp env)
(ecase kind
(:variable value)
(:expansion (%eval value env)))))
;; CLHS 3.1.2.1.3 Self-Evaluating Objects
((atom exp) exp)
;; CLHS 3.1.2.1.2 Conses as Forms
((consp exp)
(case (car exp)
;; CLHS 3.1.2.1.2.1 Special Forms
((block) (eval-block (cdr exp) env))
((catch) (eval-catch (cdr exp) env))
((eval-when) (eval-eval-when (cdr exp) env))
((flet) (eval-flet (cdr exp) env))
((function) (eval-function (cdr exp) env))
((go) (eval-go (cdr exp) env))
((if) (eval-if (cdr exp) env))
((labels) (eval-labels (cdr exp) env))
((let) (eval-let (cdr exp) env))
((let*) (eval-let* (cdr exp) env))
((load-time-value) (eval-load-time-value (cdr exp) env))
((locally) (eval-locally (cdr exp) env))
((macrolet) (eval-macrolet (cdr exp) env))
((multiple-value-call) (eval-multiple-value-call (cdr exp) env))
((multiple-value-prog1) (eval-multiple-value-prog1 (cdr exp) env))
((progn) (eval-progn (cdr exp) env))
((progv) (eval-progv (cdr exp) env))
((quote) (eval-quote (cdr exp) env))
((return-from) (eval-return-from (cdr exp) env))
((setq) (eval-setq (cdr exp) env))
((symbol-macrolet) (eval-symbol-macrolet (cdr exp) env))
((tagbody) (eval-tagbody (cdr exp) env))
((the) (eval-the (cdr exp) env))
((throw) (eval-throw (cdr exp) env))
((unwind-protect) (eval-unwind-protect (cdr exp) env))
;; SBCL-specific:
((sb!ext:truly-the) (eval-the (cdr exp) env))
;; Not a special form, but a macro whose expansion wouldn't be
;; handled correctly by the evaluator.
((sb!sys:with-pinned-objects) (eval-with-pinned-objects (cdr exp) env))
(t
(let ((dispatcher (getf *eval-dispatch-functions* (car exp))))
(cond
(dispatcher
(funcall dispatcher exp env))
;; CLHS 3.1.2.1.2.4 Lambda Forms
((and (consp (car exp)) (eq (caar exp) 'lambda))
(interpreted-apply (eval-function (list (car exp)) env)
(eval-args (cdr exp) env)))
(t
(multiple-value-bind (function kind) (get-function (car exp) env)
(ecase kind
;; CLHS 3.1.2.1.2.3 Function Forms
(:function (%apply function (eval-args (cdr exp) env)))
;; CLHS 3.1.2.1.2.2 Macro Forms
(:macro
(let ((hook *macroexpand-hook*))
;; Having an interpreted function as the
;; macroexpander hook could cause an infinite
;; loop.
(unless (compiled-function-p
(etypecase hook
(function hook)
(symbol (symbol-function hook))))
(error 'macroexpand-hook-type-error
:datum hook
:expected-type 'compiled-function))
(%eval (funcall hook
function
exp
(env-native-lexenv env))
env)))))))))))))
(defun %eval (exp env)
(incf *eval-calls*)
(if *eval-verbose*
;; Dynamically binding *EVAL-LEVEL* will prevent tail call
;; optimization. So only do it when its value will be used for
;; printing debug output.
(let ((*eval-level* (1+ *eval-level*)))
(let ((*print-circle* t))
(format t "~&~vA~S~%" *eval-level* "" `(%eval ,exp)))
(%%eval exp env))
(%%eval exp env)))
(defun %apply (fun args)
(etypecase fun
(interpreted-function (interpreted-apply fun args))
(function (apply fun args))
(symbol (apply fun args))))
(defun interpreted-apply (fun args)
(let ((lambda-list (interpreted-function-lambda-list fun))
(env (interpreted-function-env fun))
(body (interpreted-function-body fun))
(declarations (interpreted-function-declarations fun)))
(call-with-new-env-full-parsing
env lambda-list args declarations
#'(lambda (env)
(eval-progn body env)))))eval be sanctified, of all of them?
compiled-function-p to t while staying compliant. I'm surprised that absolutely everyone hasn't been doing this for the last ten years. Apparently I need to roll my own compiler.
(mapcar #'if '(t nil t) '(1 2 3) '(a b c)) in CL and others to be inelegant. (mapcar #'if '(t nil t) '(1 2 3) '(a b c)) in CL and others to be inelegant.