From bb783a02882dfcc599a9e43f17ed6eb0116c8368 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 21 Jul 2013 16:45:50 +0200 Subject: Port to CMUCL. --- sb-eval2.lisp | 133 +++++++++++++++++++++++++++++++++++++++++----------------- 1 file 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) -- cgit v1.2.3