Skip to content
Snippets Groups Projects
Commit 2032e050 authored by ram's avatar ram
Browse files

Merged in many changes from william's play area (mostly ripping out

old hacks.)  Also, added some package hacks for renaming packages
and dumping package state.
parent ebf74cb0
No related branches found
No related tags found
No related merge requests found
......@@ -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)))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment