Unify the cross & native package definitions.

compiler/cross-boot.lisp

@@ -3,7 +3,45 @@
 
 ;;;; Bootstrap macros and functions for the cross-compiler.
 
-(in-package :sys.c)
+(in-package :cross-support)
+
+(defvar *system-macros* (make-hash-table :test 'eq))
+(defvar *system-compiler-macros* (make-hash-table :test 'equal))
+(defvar *system-symbol-macros* (make-hash-table :test 'eq))
+(defvar *system-symbol-declarations* (make-hash-table :test 'eq))
+(defvar *structure-types* (make-hash-table :test 'eq))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun remove-&environment (orig-lambda-list)
+    (do* ((lambda-list (copy-list orig-lambda-list))
+          (prev nil i)
+          (i lambda-list (cdr i)))
+         ((null i) (values lambda-list nil))
+      (when (eql (first i) '&environment)
+        (assert (not (null (cdr i))) ()
+                "Missing variable after &ENVIRONMENT.")
+        (if prev
+            (setf (cdr prev) (cddr i))
+            (setf lambda-list (cddr i)))
+        (assert (not (member '&environment lambda-list)) ()
+                "Duplicate &ENVIRONMENT variable in lambda-list ~S." orig-lambda-list)
+        (return (values lambda-list (second i)))))))
+
+(cl:defmacro def-x-macro (name lambda-list &body body)
+  (let ((whole))
+    (multiple-value-bind (fixed-lambda-list env)
+        (remove-&environment lambda-list)
+      (when (null env)
+        (setf env (gensym)))
+      (if (eql (first fixed-lambda-list) '&whole)
+          (setf whole (second fixed-lambda-list)
+                fixed-lambda-list (cddr fixed-lambda-list))
+          (setf whole (gensym)))
+      `(setf (gethash ',name *system-macros*)
+             (lambda (,whole ,env)
+               (declare (ignorable ,whole ,env))
+               (destructuring-bind ,fixed-lambda-list (cdr ,whole)
+                 (block ,name ,@body)))))))
 
 (setf (gethash 'cross-cl:defconstant *system-macros*)
       (cl:macro-function 'cross-cl:defconstant))
@@ -44,10 +82,6 @@
     (setf (fdefinition name) lambda))
   name)
 
-(defun function-inline-info (name)
-  (values (gethash name *inline-modes*)
-          (gethash name *inline-forms*)))
-
 (defvar *variable-types* (make-hash-table))
 
 ;; Enough to load the full DEFMACRO.
@@ -219,6 +253,77 @@
   :test 'equal)
 (defvar sys.int::*features* '(:unicode :little-endian :mezzano :ieee-floating-point :ansi-cl :common-lisp))
 
+;; Replicated from system/package.lisp. Needed to define packages in package.lisp
+(in-package :sys.int)
+(defmacro defpackage (defined-package-name &rest options)
+  (let ((nicknames '())
+        (documentation nil)
+        (use-list '())
+        (import-list '())
+        (export-list '())
+        (intern-list '())
+        (shadow-list '())
+        (shadow-import-list '())
+        (local-nicknames '()))
+    (dolist (o options)
+      (ecase (first o)
+        (:nicknames
+         (dolist (n (rest o))
+           (pushnew (string n) nicknames)))
+        (:documentation
+         (when documentation
+           (error "Multiple documentation options in DEFPACKAGE form."))
+         (unless (or (eql 2 (length o))
+                     (not (stringp (second o))))
+           (error "Invalid documentation option in DEFPACKAGE form."))
+         (setf documentation (second o)))
+        (:use
+         (dolist (u (rest o))
+           (if (packagep u)
+               (pushnew u use-list)
+               (pushnew (string u) use-list))))
+        (:import-from
+         (let ((package (find-package-or-die (second o))))
+           (dolist (name (cddr o))
+             (multiple-value-bind (symbol status)
+                 (find-symbol (string name) package)
+               (unless status
+                 (error "No such symbol ~S in package ~S." (string name) package))
+               (pushnew symbol import-list)))))
+        (:export
+         (dolist (name (cdr o))
+           (pushnew name export-list)))
+        (:intern
+         (dolist (name (cdr o))
+           (pushnew name intern-list)))
+        (:shadow
+         (dolist (name (cdr o))
+           (pushnew name shadow-list)))
+        (:shadowing-import-from
+         (let ((package (find-package-or-die (second o))))
+           (dolist (name (cddr o))
+             (multiple-value-bind (symbol status)
+                 (find-symbol (string name) package)
+               (unless status
+                 (error "No such symbol ~S in package ~S." (string name) package))
+               (pushnew symbol shadow-import-list)))))
+        (:size)
+        (:local-nicknames
+         (setf local-nicknames (append local-nicknames (rest o))))))
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (%defpackage ,(string defined-package-name)
+                    :nicknames ',nicknames
+                    :documentation ',documentation
+                    :uses ',use-list
+                    :imports ',import-list
+                    :exports ',export-list
+                    :interns ',intern-list
+                    :shadows ',shadow-list
+                    :shadowing-imports ',shadow-import-list
+                    :local-nicknames ',local-nicknames))))
+
+(in-package :cross-support)
+
 (defun sys.int::%defpackage (name &key
                                     nicknames
                                     documentation
@@ -299,9 +404,6 @@
 (defun sys.int::binary-logxor (x y) (logxor x y))
 (defun mezzano.runtime::%fixnum-< (x y) (< x y))
 
-(defun mezzano.clos:class-precedence-list (class)
-  (sb-mop:class-precedence-list class))
-
 (defun convert-internal-time-units (time)
   (* time
      (/ internal-time-units-per-second

compiler/cross-compile.lisp

@@ -11,13 +11,11 @@
 
 (defvar *target-architecture*)
 
-(defvar *system-macros* (make-hash-table :test 'eq))
-(defvar *system-compiler-macros* (make-hash-table :test 'equal))
-(defvar *system-symbol-macros* (make-hash-table :test 'eq))
-(defvar *system-symbol-declarations* (make-hash-table :test 'eq))
-
 (in-package :sys.int)
 
+(defun mezzano.clos:class-precedence-list (class)
+  (sb-mop:class-precedence-list class))
+
 (defstruct (structure-definition
              (:constructor sys.int::make-struct-definition
                            (name slots parent area size layout)))
@@ -49,8 +47,6 @@
 (defun mezzano.runtime::%unpack-structure-header (header)
   (sys.int::structure-header-definition header))
 
-(defvar *structure-types* (make-hash-table :test 'eq))
-
 (defun ldb (bytespec integer)
   (logand (ash integer (- (byte-position bytespec)))
           (1- (ash 1 (byte-size bytespec)))))
@@ -333,7 +329,7 @@
 
 (defmethod lookup-variable-in-environment (symbol (environment null))
   (multiple-value-bind (expansion expandedp)
-      (gethash symbol *system-symbol-macros*)
+      (gethash symbol cross-support::*system-symbol-macros*)
     (if expandedp
         (make-instance 'symbol-macro :name symbol :expansion expansion)
         (make-instance 'special-variable
@@ -356,10 +352,10 @@
   nil)
 
 (defmethod compiler-macro-function-in-environment (name (environment null))
-  (gethash name *system-compiler-macros*))
+  (gethash name cross-support::*system-compiler-macros*))
 
 (defmethod macro-function-in-environment (symbol (environment null))
-  (gethash symbol *system-macros*))
+  (gethash symbol cross-support::*system-macros*))
 
 (defmethod lookup-variable-declared-type-in-environment (symbol (environment null))
   (mezzano.runtime::symbol-type symbol))
@@ -376,7 +372,7 @@
 
 (defun (setf compiler-macro-function) (value name &optional env)
   (assert (eql env nil))
-  (setf (gethash name *system-compiler-macros*) value))
+  (setf (gethash name cross-support::*system-compiler-macros*) value))
 
 (defun macro-function (symbol &optional env)
   (macro-function-in-environment symbol env))
@@ -404,37 +400,6 @@
                (values form nil))))
         (t (values form nil))))
 
-(defun remove-&environment (orig-lambda-list)
-  (do* ((lambda-list (copy-list orig-lambda-list))
-        (prev nil i)
-        (i lambda-list (cdr i)))
-       ((null i) (values lambda-list nil))
-    (when (eql (first i) '&environment)
-      (assert (not (null (cdr i))) ()
-              "Missing variable after &ENVIRONMENT.")
-      (if prev
-          (setf (cdr prev) (cddr i))
-          (setf lambda-list (cddr i)))
-      (assert (not (member '&environment lambda-list)) ()
-              "Duplicate &ENVIRONMENT variable in lambda-list ~S." orig-lambda-list)
-      (return (values lambda-list (second i))))))
-
-(defmacro def-x-macro (name lambda-list &body body)
-  (let ((whole))
-    (multiple-value-bind (fixed-lambda-list env)
-        (remove-&environment lambda-list)
-      (when (null env)
-        (setf env (gensym)))
-      (if (eql (first fixed-lambda-list) '&whole)
-          (setf whole (second fixed-lambda-list)
-                fixed-lambda-list (cddr fixed-lambda-list))
-          (setf whole (gensym)))
-      `(setf (gethash ',name *system-macros*)
-             (lambda (,whole ,env)
-               (declare (ignorable ,whole ,env))
-               (destructuring-bind ,fixed-lambda-list (cdr ,whole)
-                 (block ,name ,@body)))))))
-
 (defvar *macroexpand-hook* 'funcall)
 
 (defun constantp (form &optional env)
@@ -451,7 +416,7 @@
              (cl:constantp symbol))
          :constant)
         (t
-         (values (gethash symbol *system-symbol-declarations*)))))
+         (values (gethash symbol cross-support::*system-symbol-declarations*)))))
 
 (defvar *output-fasl*)
 (defvar *output-map*)
@@ -989,7 +954,7 @@
       (let* ((*readtable* (copy-readtable *cross-readtable*))
              (*output-map* (make-hash-table))
              (*pending-llf-commands* nil)
-             (*package* (find-package "CL-USER"))
+             (*package* (find-package "CROSS-CL-USER"))
              (*compile-print* print)
              (*compile-verbose* verbose)
              (*compile-file-pathname* (pathname (merge-pathnames input-file)))
@@ -1030,7 +995,7 @@
                            (external-format :default))
   (with-open-file (input input-file :external-format external-format)
     (let* ((*readtable* (copy-readtable *cross-readtable*))
-           (*package* (find-package "CL-USER"))
+           (*package* (find-package "CROSS-CL-USER"))
            (*compile-print* print)
            (*compile-verbose* verbose)
            (*compile-file-pathname* (pathname (merge-pathnames input-file)))
@@ -1058,7 +1023,7 @@
     (let* ((*readtable* (copy-readtable *cross-readtable*))
            (*output-map* (make-hash-table))
            (*pending-llf-commands* nil)
-           (*package* (find-package "CL-USER"))
+           (*package* (find-package "CROSS-CL-USER"))
            (*compile-print* *compile-print*)
            (*compile-verbose* *compile-verbose*)
            (*compile-file-pathname* nil)
@@ -1135,3 +1100,7 @@
             (rest (pathname-directory p))
             (pathname-name p)
             (pathname-type p))))
+
+(defun function-inline-info (name)
+  (values (gethash name cross-support::*inline-modes*)
+          (gethash name cross-support::*inline-forms*)))