summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--sb-eval2.lisp133
1 files changed, 95 insertions, 38 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 67e6207..1dd988c 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -16,6 +16,12 @@
collect
`((,x) ,(cl:eval `(let ((,var ,x)) ,@body))))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ #+sbcl
+ (setf (find-class 'simple-program-error) (find-class 'sb-int:simple-program-error))
+ #+cmu
+ (setf (find-class 'simple-program-error) (find-class 'kernel:simple-program-error)))
+
(declaim (inline %make-environment))
(defstruct (environment (:constructor %make-environment))
(parent nil :type (or null environment))
@@ -66,18 +72,26 @@
;;
;; FIXME: This doesn't do macro expansion, so it's probably
;; incorrect.
- (let ((sb-walker::*walk-form-expand-macros-p* t))
- (sb-walker:walk-form
+ #+(or cmu sbcl)
+ (let (#+sbcl (sb-walker::*walk-form-expand-macros-p* t))
+ (#+sbcl sb-walker:walk-form
+ #+cmu walker:walk-form
form
env
(lambda (x ctx env)
(declare (ignore ctx))
(when (and (member x vars :test #'equal)
- (not (sb-walker:var-special-p x env))
- (not (sb-walker:var-lexical-p x env)))
+ (not (#+sbcl sb-walker:var-special-p
+ #+cmu walker:variable-special-p
+ x env))
+ (not (#+sbcl sb-walker:var-lexical-p
+ #+cmu walker:variable-lexical-p
+ x env)))
(return-from maybe-references-p/env t))
x)))
- nil)
+ nil
+ #-(or cmu sbcl)
+ t)
(defun maybe-closes-over-p (context form vars)
(handler-case
@@ -85,8 +99,10 @@
(serious-condition () t)))
(defun maybe-closes-over-p/env (form vars env)
- (let ((sb-walker::*walk-form-expand-macros-p* t))
- (sb-walker:walk-form
+ #+(or sbcl cmu)
+ (let (#+sbcl (sb-walker::*walk-form-expand-macros-p* t))
+ (#+sbcl sb-walker:walk-form
+ #+cmu walker:walk-form
form
env
(lambda (x ctx env)
@@ -95,7 +111,7 @@
(cons
(destructuring-bind (a . b) x
(case a
- ((lambda sb-int:named-lambda)
+ ((lambda #+sbcl sb-int:named-lambda)
(when (maybe-references-p/env form vars env)
(return-from maybe-closes-over-p/env t)))
((flet labels)
@@ -109,7 +125,9 @@
(when (maybe-closes-over-p/env b vars env)
(return-from maybe-closes-over-p/env t)))))))))
x)))
- nil)
+ nil
+ #-(or sbcl cmu)
+ t)
(defstruct (context (:constructor make-context (&optional parent)))
parent
@@ -319,10 +337,17 @@
(offset (lexical-offset lexical)))
(lambda (env)
(environment-value env nesting offset)))
- (let ((f* (sb-c::fdefinition-object function-name t)))
+ #-(or sbcl cmu)
+ (lambda (env)
+ (declare (ignore env))
+ (fdefinition function-name))
+ #+(or sbcl cmu)
+ (let ((f* #+sbcl (sb-c::fdefinition-object function-name t)
+ #+cmu (kernel:fdefn-or-lose function-name)))
(lambda (env)
(declare (ignore env))
- (or (sb-c::fdefn-fun f*)
+ (or #+sbcl (sb-c::fdefn-fun f*)
+ #+cmu (kernel:fdefn-function f*)
(error 'undefined-function :name function-name))))))
@@ -362,7 +387,8 @@
(declaim (ftype (function ((or symbol list) list context) eval-closure) prepare-global-call))
(defun prepare-global-call (f args context)
(let ((args* (mapcar (lambda (form) (prepare-form form context)) args))
- (f* (sb-c::fdefinition-object f t)))
+ #+sbcl (f* (sb-c::fdefinition-object f t))
+ #+cmu (f* (kernel:fdefn-or-lose f)))
(if (< (length args) 20)
(specialize m% (length args) (loop for i from 0 below 20 collect i)
(let ((argvars (loop for i from 0 below m%
@@ -372,12 +398,16 @@
collect `(,var (nth ,i args*)))
(lambda (env)
(declare (ignorable env))
- (funcall (or (sb-c::fdefn-fun f*)
+ (funcall (or #+sbcl (sb-c::fdefn-fun f*)
+ #+cmu (kernel:fdefn-function f*)
+ #-(or sbcl cmu) f
(error 'undefined-function :name f))
,@(loop for var in argvars
collect `(funcall (the eval-closure ,var) env)))))))
(lambda (env)
- (apply (or (sb-c::fdefn-fun f*)
+ (apply (or #+sbcl (sb-c::fdefn-fun f*)
+ #+cmu (kernel:fdefn-function f*)
+ #-(or sbcl cmu) f
(error 'undefined-function :name f))
(mapcar (lambda (x) (funcall (the eval-closure x) env))
args*))))))
@@ -456,12 +486,14 @@
lambda-form
(let* ((whole (gensym "WHOLE"))
(env (gensym "ENV"))
- (body-form (sb-kernel:parse-defmacro lambda-list
- whole
- body
- name
- 'macrolet
- :environment env)))
+ (body-form (#+sbcl sb-kernel:parse-defmacro
+ #+cmu lisp::parse-defmacro
+ lambda-list
+ whole
+ body
+ name
+ 'macrolet
+ :environment env)))
(prepare-lambda `((,whole ,env) ,body-form)
context
;;:name name
@@ -484,15 +516,26 @@
(declare (dynamic-extent #',loop-var))
(,loop-var ,@(mapcar #'second bindings))))
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (fdefinition 'fun-name-block-name) sb-int:fun-name-block-name))
+#-sbcl
+(defun fun-name-block-name (function-name)
+ (ctypecase function-name
+ (symbol function-name)
+ (cons (cadr function-name))))
+
(declaim (ftype (function * eval-closure) prepare-lambda))
(defun prepare-lambda (lambda-form context &key (name nil namep))
(destructuring-bind (lambda-list &rest exprs) lambda-form
(with-parsed-body (body specials) exprs
(multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
- morep more-context more-count)
- (sb-int:parse-lambda-list lambda-list)
- (declare (ignore more-context more-count))
+ #+sbcl morep #+sbcl more-context #+sbcl more-count)
+ #+sbcl (sb-int:parse-lambda-list lambda-list)
+ #+cmu (kernel:parse-lambda-list lambda-list)
+ #+sbcl (declare (ignore more-context more-count))
(declare (ignorable auxp))
+ #+sbcl
(when morep
(error "The interpreter does not support the lambda-list keyword ~S"
'sb-int:&more))
@@ -541,7 +584,7 @@
(body-context (context-add-specials new-context specials))
(body* (prepare-form
(if namep
- `(block ,(sb-int:fun-name-block-name name) ,@body)
+ `(block ,(fun-name-block-name name) ,@body)
`(progn ,@body))
body-context))
(unbound (gensym)))
@@ -606,7 +649,7 @@
(go positional)
missing-optionals
(unless (>= argi required-num)
- (error 'sb-int:simple-program-error
+ (error 'simple-program-error
:format-control "invalid number of arguments: ~D (expected: >=~D)"
:format-arguments (list (length args) required-num)))
(when (>= i (the fixnum (+ required-num
@@ -628,12 +671,12 @@
keys
(unless keyp
(unless (or restp (= argi (length args)))
- (error 'sb-int:simple-program-error
+ (error 'simple-program-error
:format-control "invalid number of arguments: ~D (expected: <=~D)"
:format-arguments (list (length args) (+ required-num optional-num))))
(go aux))
(unless (evenp restnum)
- (error 'sb-int:simple-program-error
+ (error 'simple-program-error
:format-control "odd number of keyword arguments: ~S"
:format-arguments (list rest)))
(when (>= i
@@ -650,7 +693,7 @@
(loop for (k v) on rest by #'cddr
unless (or (eq k :allow-other-keys)
(member k keywords :test #'eq))
- do (error 'sb-int:simple-program-error
+ do (error 'simple-program-error
:format-control "unknown &KEY argument: ~A"
:format-arguments (list k)))
(setq keys-checked-p t))
@@ -700,13 +743,17 @@
(defun context->native-environment (context)
(let ((functions
(loop for (name . expander) in (context-collect context 'context-macros)
- collect `(,name . (sb-c::macro . ,expander))))
+ collect `(,name . (#+sbcl sb-c::macro #+cmu c::macro . ,expander))))
(vars
(loop for (name . form) in (context-collect context 'context-symbol-macros)
- collect `(,name . (sb-c::macro . ,form)))))
- (sb-c::internal-make-lexenv functions vars nil nil nil nil nil nil nil nil nil)))
+ collect `(,name . (#+sbcl sb-c::macro #+cmu c::macro . ,form)))))
+ #+sbcl (sb-c::internal-make-lexenv functions vars nil nil nil nil nil nil nil nil nil)
+ #+cmu (c::make-lexenv :default (c::make-null-environment)
+ :functions functions
+ :variables vars)))
(defun native-environment->context (lexenv)
+ #+sbcl
(with-accessors ((functions sb-c::lexenv-funs)
(vars sb-c::lexenv-vars))
lexenv
@@ -723,13 +770,18 @@
context
(setq macros macros%)
(setq symbol-macros symbol-macros%))
- context)))
+ context))
+ #-sbcl
+ (error "NYI"))
(defun globally-special-p (var)
- (eq :special (sb-int:info :variable :kind var)))
+ #+sbcl (eq :special (sb-int:info :variable :kind var))
+ #+cmu (walker:variable-special-p var nil)
+ #-(or sbcl cmu) (error "NYI"))
(defun globally-constant-p (var)
- (eq :constant (sb-int:info :variable :kind var)))
+ #+sbcl (eq :constant (sb-int:info :variable :kind var))
+ #-sbcl (constantp var))
(defun assume-special (context var)
(unless (or (globally-special-p var)
@@ -750,7 +802,8 @@
;;(print form)
(values
(cond
- ((sb-int:self-evaluating-p form)
+ (#+sbcl (sb-int:self-evaluating-p form)
+ #-sbcl (not (or (symbolp form) (consp form)))
(lambda (env) (declare (ignore env)) form))
(t
(etypecase form
@@ -776,10 +829,11 @@
(case (first fun-form)
((lambda)
(prepare-lambda (rest fun-form) context))
+ #+sbcl
((sb-int:named-lambda)
(prepare-lambda (cddr fun-form) context))
(t
- (assert (sb-int:valid-function-name-p fun-form))
+ #+sbcl (assert (sb-int:valid-function-name-p fun-form))
(prepare-function-ref fun-form context)))))))
((lambda)
(prepare-lambda (rest form) context))
@@ -1088,8 +1142,10 @@
(lambda (env)
(unwind-protect (funcall protected* env)
(funcall body* env))))))
+ #+sbcl
((sb-ext:truly-the)
(prepare-form (third form) context))
+ #+sbcl
((sb-int:named-lambda)
(prepare-lambda (cddr form) context))
((symbol-macrolet)
@@ -1099,11 +1155,11 @@
(destructuring-bind (var macro-form) form
(when (or (globally-special-p var)
(member var specials))
- (error 'sb-int:simple-program-error
+ (error 'simple-program-error
:format-control "Attempt to bind a special variable with SYMBOL-MACROLET: ~S"
:format-arguments (list var)))
(when (constantp var)
- (error 'sb-int:simple-program-error
+ (error 'simple-program-error
:format-control "Attempt to bind a special variable with SYMBOL-MACROLET: ~S"
:format-arguments (list var)))
(cons var macro-form)))
@@ -1201,6 +1257,7 @@
until (eq form eof)
do (eval-tlf form)))))
+#+sbcl
(defun install ()
(sb-ext:without-package-locks
(defun sb-impl::eval-in-lexenv (exp lexenv)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 09:35:46 +0000