Port to CMUCL.

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)