diff --git a/tools/setup.lisp b/tools/setup.lisp index 019d566a0591f683101e67dccbf4e4a360837a92..8e7fc1875043935ff48645b905738b4302240dac 100644 --- a/tools/setup.lisp +++ b/tools/setup.lisp @@ -5,246 +5,124 @@ ;;; (in-package "USER") -;;; ### Patch... -(in-package "LISP") -(defun keyword-argument (keyword key-list) - "If keyword is present in the keylist, return it's associated value." - (do ((keys key-list (cddr keys))) - ((endp keys)) - (when (eq (car keys) keyword) - (return (cadr keys))))) - -#+new-compiler -(proclaim '(optimize (debug-info 2))) - -(in-package "EXT") -(export '(debug *gc-verbose*)) - -(in-package "EVAL") -(export '(internal-eval interpreted-function-p - interpreted-function-lambda-expression - interpreted-function-closure - interpreted-function-name - interpreted-function-arglist - make-interpreted-function)) -#-new-compiler -(import '*eval-stack-top* (find-package "LISP")) - -#-new-compiler -(defmacro indirect-value (value-cell) - `(car ,value-cell)) - -#-new-compiler -(defmacro eval-stack-local (fp offset) - `(svref *eval-stack* (+ ,fp ,offset))) - - -#-new-compiler -(in-package "C" :use '("EXTENSIONS" "SYSTEM" "LISP")) - -#-new-compiler -(export '(compile-for-eval lambda-eval-info-frame-size - lambda-eval-info-args-passed lambda-eval-info-entries - entry-node-info-st-top entry-node-info-nlx-tag - *compile-time-define-macros*)) - -#-new-compiler -(setq clc::*peep-enable* t) -#-new-compiler -(setq clc::*inline-enable* t) -#-new-compiler -(setq ext:*safe-defstruct-accessors* nil) - -#-new-compiler -(import '(lisp::boolean lisp::enumeration)) - -;;; ### system patch... -#-new-compiler -(load "/../fred/usr/ram/hash.fasl") - -(defun zap-sym (name pkg) - (let ((found (find-symbol name (find-package pkg)))) - (when (and found - (eq (symbol-package found) (find-package pkg))) - (unintern found pkg)))) - -#-new-compiler -(progn - (zap-sym "ABORT" "C") - (zap-sym "CONCAT-PNAMES" "LISP") - (zap-sym "ARG" "LISP") - (zap-sym "VAR" "LISP") - (zap-sym "ONCE-ONLY" "COMPILER")) + +;;; DUMP-PACKAGE-STATE -- Public +;;; +(defun dump-package-state (packages file) + (declare (type (or list package symbol string) packages) + (type (or pathname symbol string) file)) + (let* ((packages (lisp::package-listify packages))) + (collect ((forms)) + (dolist (pkg packages) + (let ((nicks (package-nicknames pkg)) + (name (package-name pkg)) + (shad (package-shadowing-symbols pkg))) + (forms `(unless (find-package ,name) + (make-package ,name :nicknames ',nicks :use nil))) + (when shad + (forms `(shadow ',(mapcar #'string shad) ,name))))) + + (dolist (pkg packages) + (forms `(use-package ',(mapcar #'package-name + (package-use-list pkg)) + ,(package-name pkg)))) + + (dolist (old packages) + (collect ((exports)) + (let ((imports (make-hash-table :test #'eq))) + (do-symbols (sym old) + (let ((pkg (symbol-package sym)) + (name (symbol-name sym))) + (multiple-value-bind (found how) + (find-symbol name old) + (assert (and (eq found sym) how)) + (cond + ((not pkg) + (warn "Not dumping uninterned symbol ~S." sym)) + ((eq how :inherited)) + (t + (unless (eq pkg old) + (pushnew name (gethash pkg imports) :test #'string=)) + (when (eq how :external) + (exports name))))))) + (forms `(defpackage ,(package-name old) + ,@(loop for pkg being each hash-key in imports + for names being each hash-value in imports + collect `(:import-from ,(package-name pkg) + ,@names)) + ,@(when (exports) + `((:export ,@(exports))))))))) + + (with-open-file (s file :direction :output :if-exists :new-version) + (dolist (form (forms)) + (write form :stream s :pretty t) + (terpri s))))) + + (values)) -#-new-compiler -(let ((sym (find-symbol "%CHARACTER-TYPE" (find-package "SYSTEM")))) - (when sym - (makunbound sym) - (unintern sym (find-package "SYSTEM")))) - - -#-new-compiler -(in-package "EXTENSIONS") -#-new-compiler -(export '(info clear-info define-info-class define-info-type)) -#-new-compiler -(export '(ignorable truly-the maybe-inline)) - -#-new-compiler -(export '(lisp::with-compilation-unit lisp::debug-info) "LISP") - -#-new-compiler -(export '(system::%g-vector-structure-name-slot - system::find-if-in-closure - system::*file-input-handlers*) - "SYSTEM") - -#-new-compiler -(let ((found (find-symbol "CONCAT-PNAMES" (find-package "LISP")))) - (when found - (unintern found (find-package "LISP")))) - -#-new-compiler -(in-package "DEBUG") -#-new-compiler -(export '(var arg)) - - -(in-package "DEBUG-INTERNALS" :nicknames '("DI")) - -;;; The compiler's debug-source structure is almost exactly what we want, so -;;; just get these symbols and export them. + +;;; COPY-PACKAGES -- Public ;;; -(import '(c::debug-source-from c::debug-source-name c::debug-source-created - c::debug-source-compiled c::debug-source-start-positions - c::debug-source c::debug-source-p)) - -(export '(debug-variable-name debug-variable-package debug-variable-symbol - debug-variable-id debug-variable-value debug-variable-validity - debug-variable-valid-value debug-variable debug-variable-p - - top-frame frame-down frame-up frame-debug-function - frame-code-location eval-in-frame return-from-frame frame-catches - frame-number frame frame-p - - do-blocks debug-function-lambda-list do-debug-function-variables - debug-function-symbol-variables ambiguous-debug-variables - preprocess-for-eval function-debug-function debug-function-function - debug-function-kind debug-function-name debug-function - debug-function-p - - do-debug-block-locations debug-block-successors debug-block - debug-block-p debug-block-elsewhere-p - - make-breakpoint activate-breakpoint deactivate-breakpoint - breakpoint-hook-function breakpoint-info breakpoint-kind - breakpoint-what breakpoint breakpoint-p - - code-location-debug-function code-location-debug-block - code-location-top-level-form-offset code-location-form-number - code-location-debug-source code-location code-location-p - unknown-code-location unknown-code-location-p - - debug-source-from debug-source-name debug-source-created - debug-source-compiled debug-source-root-number - debug-source-start-positions form-number-translations - source-path-context debug-source debug-source-p - - debug-condition no-debug-info no-debug-function-returns - no-debug-blocks lambda-list-unavailable - - debug-error unhandled-condition invalid-control-stack-pointer - unknown-code-location unknown-debug-variable invalid-value)) - - -#-new-compiler -(in-package "LISP") -#-new-compiler -(import '( - ct-a-val-sap ct-a-val-type ct-a-val-offset ct-a-val-size - ct-a-val-p ct-a-val make-ct-a-val ct-a-val-alien - check<= check= %alien-indirect %bind-aligned-sap - naturalize-integer deport-integer naturalize-boolean deport-boolean - sap-ref-8 sap-ref-16 sap-ref-32 - signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32 int-sap sap-int - %set-sap-ref-8 %set-sap-ref-16 %set-sap-ref-32 - %set-alien-access %standard-char-p %string-char-p +(defun copy-packages (packages) + "Rename all the of the Named packages to OLD-Name, and then create new + packages for each name that have the same names, nicknames, imports, shadows + and exports. If any of the OLD-Name packages already exist, then we quietly + do nothing." + (let* ((packages (lisp::package-listify packages)) + (names (mapcar #'package-name packages)) + (new-names (mapcar #'(lambda (x) + (concatenate 'string "OLD-" x)) + names))) + (unless (some #'find-package new-names) + (collect ((new-packages)) + (flet ((trans-pkg (x) + (or (cdr (assoc x (new-packages))) x))) + (loop for pkg in packages and new in new-names do + (let ((nicks (package-nicknames pkg)) + (name (package-name pkg))) + (rename-package pkg new) + (let ((new-pkg (make-package name :nicknames nicks :use nil)) + (shad (package-shadowing-symbols pkg))) + (when shad + (shadow shad new-pkg)) + (new-packages (cons pkg new-pkg))))) - *alien-eval-when* make-alien alien-type alien-size alien-address - copy-alien dispose-alien defalien alien-value - alien-bind defoperator alien-index alien-indirect - bits bytes words long-words port perq-string - boolean defenumeration enumeration - system-area-pointer pointer alien alien-access - alien-assign alien-sap define-alien-stack - with-stack-alien null-terminated-string c-procedure - unstructured record-size - ) - (find-package "C")) - -(export 'function-lambda-expression) - -;;; Hack to prevent SETF from expanding these macros out of the environment, -;;; since these are functions in the new system. -;;; -#-new-compiler -(dolist (x '(sap-ref-8 sap-ref-16 sap-ref-32)) - (fmakunbound x)) - -(in-package "C") -(define-condition parse-unknown-type (condition) - (specifier)) - -(in-package "USER") - -;;; Hack until real definition exists: -;;; -#-new-compiler -(defmacro with-compilation-unit (glue &rest body) - (declare (ignore glue)) - `(let ((lisp::*in-compilation-unit* t)) - (declare (special lisp::*in-compilation-unit*)) - ,@body)) -;;; -;;; So the real WCU won't die in bootstrap env. -#-new-compiler -(defvar lisp::*in-compilation-unit* nil) -#-new-compiler -(defun c::print-summary (a b) - (declare (ignore a b))) - - -#-new-compiler -(setq lisp::*maximum-interpreter-error-checking* nil) + (loop for (old . new) in (new-packages) do + (dolist (use (package-use-list old)) + (use-package (trans-pkg use) new))) + + (loop for (old . new) in (new-packages) do + (do-symbols (sym old) + (let ((pkg (symbol-package sym)) + (name (symbol-name sym))) + (multiple-value-bind (found how) + (find-symbol name old) + (assert (and (eq found sym) how)) + (cond + ((not pkg) + (warn "Not copying uninterned symbol ~S." sym)) + ((or (eq how :inherited) + (and (eq how :internal) (eq pkg old)))) + (t + (let* ((npkg (trans-pkg pkg)) + (nsym (intern name npkg))) + (multiple-value-bind (ignore new-how) + (find-symbol name new) + (declare (ignore ignore)) + (unless new-how (import nsym new))) + (when (eq how :external) + (export nsym new))))))))))))) + (values)) ;;;; Compile utility: ;;; Switches: ;;; -(defvar *interactive* nil) ; Batch compilation mode? -(defvar *new-compile* t) ; Use new compiler? - -(setq *bytes-consed-between-gcs* 1500000) - -(setq *gc-notify-before* - #'(lambda (&rest foo) - (cond (*interactive* - (apply #'lisp::default-gc-notify-before foo)) - (t - (write-char #\. *terminal-io*) - (force-output *terminal-io*))))) - -(setq *gc-notify-after* - #'(lambda (&rest foo) - (when *interactive* - (apply #'lisp::default-gc-notify-after foo)))) - +(defvar *interactive* t) ; Batch compilation mode? (defvar *log-file* nil) (defvar *last-file-position*) -(defvar *compiled-files* (make-hash-table :test #'equal)) - (defmacro with-compiler-log-file ((name) &body forms) `(if *interactive* @@ -261,11 +139,7 @@ (close *log-file*))))) -(proclaim '(special lisp::*bootstrap-defmacro*)) - -(defun comf (name &key always-once proceed load output-file - ((:bootstrap-macros lisp::*bootstrap-defmacro*) nil)) - #+new-compiler +(defun comf (name &key always-once proceed load output-file assem) (declare (ignore always-once)) (when (and *log-file* (> (- (file-position *log-file*) *last-file-position*) 10000)) @@ -276,48 +150,44 @@ (obj (if output-file (pathname output-file) (make-pathname :defaults src - :type (c:backend-fasl-file-type - c:*target-backend*)))) - (obj-pn (probe-file obj))) + :type + (if assem + "assem" + (c:backend-fasl-file-type c:*backend*)))))) - (unless (and obj-pn - (>= (file-write-date obj-pn) (file-write-date src)) - #+nil - (equalp (pathname-directory - (lisp::sub-probe-file (first (search-list src)))) - (pathname-directory obj-pn)) - #-new-compiler - (or (gethash src *compiled-files*) - (not always-once))) + (unless (and (probe-file obj) + (>= (file-write-date obj) (file-write-date src))) (write-line name) (format *error-output* "~2&Start time: ~A, compiling ~A.~%" (ext:format-universal-time nil (get-universal-time)) name) - (cond - (*interactive* - (compile-file src :error-file nil :output-file obj) - (when load - (load name :verbose t))) - (t - (handler-bind ((error #'(lambda (condition) - (format *error-output* "~2&~A~2&" - condition) - (when proceed - (format *error-output* "Proceeding...~%") - (continue)) - (format *error-output* "Aborting...~%") - (handler-case - (let ((*debug-io* *error-output*)) - (debug:backtrace)) - (error (condition) - (declare (ignore condition)) - (format t "Error in backtrace!~%"))) - (format t "Error abort.~%") - (return-from comf)))) - (compile-file src :error-file nil :output-file obj) + (catch 'blow-this-file + (cond + (*interactive* + (if assem + (c::assemble-file src :output-file obj) + (compile-file src :error-file nil :output-file obj)) (when load - (load name :verbose t))))) - (setf (gethash src *compiled-files*) t)) + (load name :verbose t))) + (t + (handler-bind ((error #'(lambda (condition) + (format *error-output* "~2&~A~2&" + condition) + (when proceed + (format *error-output* "Proceeding...~%") + (continue)) + (format *error-output* "Aborting...~%") + (handler-case + (let ((*debug-io* *error-output*)) + (debug:backtrace)) + (error (condition) + (declare (ignore condition)) + (format t "Error in backtrace!~%"))) + (format t "Error abort.~%") + (return-from comf)))) + (if assem + (c::assemble-file src :output-file obj) + (compile-file src :error-file nil :output-file obj)) + (when load + (load name :verbose t))))))))) - ;; Only set after compilation so that it can be bound around the call. - (setq lisp::*bootstrap-defmacro* nil)))