;;; -*- Mode:LISP; Package:USER; Readtable:ZL; Base:10. -*- ;;;;;;;; *********** below from jb: k; simulation-packages************* ;(defpackage simulator ; :use '(global) ; (:nicknames sim)) efh says not used ;;Symbols to be investigated: multiple-value-list pairlist rplaca values-list and find-package ;;multiple-value-list has conflicting definitions in lisp-internals.lisp (a macro) and lambda version. ;; jb:k;lambda-list.lisp uses both versions one for k and one for lambda and has no way to ;; conditionalize it easily other than by hand. ;;removed follwing from global-imports since also in prims (DEFSUBST BYTE DEFMACRO BYTE-SIZE BYTE-POSITION INCF DECF) wkf. (defmacro global-imports () (quote '(:import-from global "UNSPECIAL" "*" "+" "-" "<" "<=" "=" ">" ">=" "1+" "1-" "&AUX" "&REST" "&BODY" "&ENVIRONMENT" "&WHOLE" "&OPTIONAL" "&KEY" "ASH" "AND" "APPEND" "BLOCK" "CASE" "CEILING" "COMPILE" "COMPILER-LET" "COND" "DECLARE" "DEFCONSTANT" "DEFUN" "DEFVAR" "DEFPARAMETER" "DO" "DO*" "DOTIMES" "EQ" "EQL" "ETYPECASE" "EVAL" "EVAL-WHEN" "EXPORT" "FERROR" "FLET" "FLOOR" "FUNCALL" "FUNCTION" "GO" "IMPORT" "IN-PACKAGE" "LAMBDA" "LABELS" "LET" "LET*" "LOAD" "LOGAND" "LOGANDC1" "LOGANDC2" "LOGEQV" "LOGIOR" "LOGNAND" "LOGNOR" "LOGNOT" "LOGORC1" "LOGORC2" "LOGXOR" "LOOP" "MACROLET" "MAX" "MINUSP" "MOD" "MULTIPLE-VALUE-BIND" "MULTIPLE-VALUE-SETQ" "NULL" "NOT" "OR" "PLUSP" "PROCLAIM" "PROG" "PROG1" "PROGN" "PSETQ" "QUOTE" "REMAINDER" "REST" "RETURN-FROM" "SETQ" "T" "TAGBODY" "UNLESS" "VALUES" "WHEN" "ZEROP" "CATCH" "THROW" "NIL" "SETF" "DEFSETF" "IGNORE" "RETURN" "VALUES-LIST"))) ;;This above list of global imports was created by finding all symbols in the system which were imported and then ;;taking those which had a home only in the global package (ignoring K-xxx packages) in a working system. wkf. (defmacro cli-imports () (quote '(:import-from cli "IF" "AREF"))) ;;This above list of cli imports was created by finding all symbols in the system which were imported and then ;;taking those which had a home in the cli package in a working system. wkf. ;; removed from cli-imports: "LISTP", "CHARACTER", "REM", "GETHASH", "MACROEXPAND-1", "MACROEXPAND", "TIME", ;; "MAKE-ARRAY", "MEMBER", "SUBST", "MAP", "CLOSE", "REMOVE", "READ", "DELETE", ;; "DEFSTRUCT", "ASSOC", "NLISTP", "NINTERSECTION", "INTERSECTION", "FUNCTIONP", ;; "ATAN", "AR-1-FORCE", "AR-1", "MAKE-PACKAGE", "UNION", "SOME", "READ-FROM-STRING", ;; "RASSOC", "NUNION", "EVERY", "//" (defmacro new-math-imports () (quote '(:import-from new-math "TRUNCATE" "ROUND" "REM"))) ;;"NUMERATOR" "DENOMINATOR" "GCD" "LCM" "DECODE-FLOAT" ;;"INTEGER-DECODE-FLOAT" "REALPART" "IMAGPART" "CONJGATE" (defmacro vinc-imports () (quote '(:import-from vinc "ATOM" "COMPLEXP" "ARRAYP" "COMPILED-FUNCTION-P" "CONSP" "INTEGERP" "RATIONALP" "FLOATP" "NUMBERP" "LISTP" "SYMBOLP" "COMMONP" "CHARACTERP"))) (defmacro cons-imports () (quote '(:import-from cons "RPLACA" "RPLACD" "CAAAAR" "CAAADR" "CAAAR" "CAADAR" "CAADDR" "CAADR" "CAAR" "CADAAR" "CADADR" "CADAR" "CADDAR" "CADDDR" "CADDR" "CADR" "CAR" "CDAAAR" "CDAADR" "CDAAR" "CDADAR" "CDADDR" "CDADR" "CDAR" "CDDAAR" "CDDADR" "CDDAR" "CDDDAR" "CDDDDR" "CDDDR" "CDDR" "CDR" "CONS" "ENDP"))) (defmacro array-imports () (quote '(:import-from array "ADJUSTABLE-ARRAY-P" "AREF" "ARRAY-DIMENSION" "ARRAY-DIMENSION-LIMIT" "ARRAY-DIMENSIONS" "ARRAY-ELEMENT-TYPE" "ARRAY-HAS-FILL-POINTER-P" "ARRAY-IN-BOUNDS-P" "ARRAY-RANK" "ARRAY-RANK-LIMIT" "ARRAY-ROW-MAJOR-INDEX" "ARRAY-TOTAL-SIZE" "ARRAY-TOTAL-SIZE-LIMIT" "ASET" "BIT-VECTOR-P" "FILL-POINTER" "LENGTH" "MAKE-ARRAY" "MAKE-STRING" "SIMPLE-BIT-VECTOR-P" "SIMPLE-STRING-P" "SIMPLE-VECTOR-P" "STRING=" "STRINGP" "SVREF" "VECTOR-POP" "VECTOR-PUSH" "VECTORP" "VECTOR"))) (defmacro symbol-imports () (quote '(:import-from symbol "BOUNDP" "FBOUNDP" "FMAKUNBOUND" "GET" "GET-PROPERTIES" "GETF" "MAKE-SYMBOL" "MAKUNBOUND" "REMF" "REMPROP" "SET" "SYMBOL-FUNCTION" "SYMBOL-NAME" "SYMBOL-PACKAGE" "SYMBOL-PLIST" "SYMBOL-VALUE"))) (defmacro prims-imports () (quote '(:import-from prims "DISPATCH" "BODY" "SUBST" "DEFSUBST" "BYTE" "DEFMACRO" "BYTE-SIZE" "BYTE-POSITION" "INCF" "DECF" "SELECT-PROCESSOR" ;;wkf added 5/4/88. ;;above line gleaned from imported symbols in old method which were in global and prims. "VALUE" "DEFINE-GLOBAL-FRAME" "DEFINE-GLOBAL-VARIABLE" "DEFINE-GLOBAL-CONSTANT"))) (defpackage k :use '() (:import-from lisp "OPEN" "RETURN" "OR" "AND") (:import-from global "IGNORE")) ;;added IGNORE wkf 5/4/88 (eval `(defpackage primitives :use '() (:nicknames prims) (:shadow "PRIMS::DEFAFUN" ;;wkf I wonder if this is correct??? "PRIMS::DEFINE-GLOBAL-FRAME" "PRIMS::DEFINE-GLOBAL-VARIABLE" "PRIMS::DEFINE-GLOBAL-CONSTANT") ,(global-imports) ,(cli-imports) )) (defpackage hardware :use '() ;(:import-from primitives "DEFCONSTANT" "BYTE") ;these are there but not needed to say here wkf. (:nicknames hw) (:shadow ":DISPATCH" ":DPB" ":LDB") ;(:auto-export-p t) ) (eval `(defpackage global-registers :use '(prims) (:nicknames GR) ,(prims-imports) ,(global-imports) ,(cli-imports) )) (eval `(defpackage vinculum :use '(prims) (:nicknames vinc) ,(prims-imports) ,(global-imports) ,(cli-imports) )) ;;; Auto export bites hard here. ; (:auto-export-p t) ;(defpackage primitive-arithmetic ; :use '(vinculum prims) ; (:nicknames parith)) efh says not used (eval `(defpackage timers :use '(vinculum prims) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage map :use '(vinculum prims) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage gc-ram :use '(vinculum prims) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage datatype-ram :use '(vinculum prims k) (:nicknames dt-ram) ,(vinc-imports) ,(prims-imports) ,(global-imports) ,(cli-imports) )) (eval `(defpackage paging-devices :use '(vinculum prims) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage virtual-memory :use '(vinculum prims) (:nicknames vmem) ,(vinc-imports) ,(prims-imports) ,(global-imports) ,(cli-imports) )) (eval `(defpackage physical-cluster-data :use '(virtual-memory vinculum prims) (:nicknames pcd) ,(vinc-imports) ,(prims-imports) ,(global-imports) ,(cli-imports) )) (eval `(defpackage quantum-map :use '(virtual-memory vinculum prims) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage memory-management :use '(vinculum prims) (:nicknames memlow) ,(vinc-imports) ,(prims-imports) ,(global-imports) ,(cli-imports) )) (eval `(defpackage region-bits :use '(memory-management virtual-memory vinculum prims) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage map-fault :use '(virtual-memory physical-cluster-data map vinculum prims) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage gc-fault :use '(map vinculum prims) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage region-data :use '(memory-management vinculum prims) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage area-data :use '(region-data memory-management vinculum prims) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage memory-management-interface :use '(vinculum prims) (:nicknames mem) ,(vinc-imports) ,(prims-imports) ,(global-imports) ,(cli-imports) )) (eval `(defpackage boot :use '(vinculum virtual-memory prims k) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage transporter-ram :use '(vinculum virtual-memory prims) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage cons :use '(memory-management-interface vinculum prims k) (:shadow "CONS") ,(vinc-imports) ,(prims-imports) ,(global-imports) ,(cli-imports) )) (eval `(defpackage new-math :use '(vinculum prims k) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage array :use '(vinculum prims k) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage trap :use '(vinculum prims k) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) ;;; This package has to have access to a ;;; running lisp to build an environment ;;; for booting. ;(defpackage sim-debug ; :use '(vinculum global)) efh says not used ;(defpackage kbug2-common ; definitions for KBUG2 and K2 ; :use '(vinculum prims k)) ;;;; Sorta similar to the above. ;;;; Things depend upon kbug being common to both package environments, but ;;;; we can't USE both versions of KBUG2-common. ;(if (boundp 'si::*current-package-environment*) ; (if (eq si::*current-package-environment* ; (si::find-package-environment "DEBUGGER" #'identity ; #'(lambda () (error "Package-environment not set up.")))) ; (defpackage kbug ; :use '(lisp k lam kbug2-common) ; (:import-from "ZETALISP" "DEFSUBST")) ; (defpackage kbug ; :use '(lisp k lam) ; (:import-from "ZETALISP" "DEFSUBST"))) ; (defpackage kbug ; :use '(lisp k lam) ; (:import-from "ZETALISP" "DEFSUBST"))) ;(defmacro hairy-defpackage (package-name k-use-list lambda-use-list &rest stuff) ; `(eval-when (compile load) ; (if (or (not (boundp 'si::*current-package-environment*)) ; (eq si::*current-package-environment* ; (si::find-package-environment "COMPILER" #'identity ; #'(lambda () (error "Package-environment not set up."))))) ; (defpackage ,package-name ; :use ,k-use-list ; ,@stuff) ; (if (eq si::*current-package-environment* ; (si::find-package-environment "DEBUGGER" #'identity ; #'(lambda () (error "Package-environment not set up.")))) ; (defpackage ,package-name ; :use ,lambda-use-list ; ,@stuff) ; (ferror nil "Random package environment!"))))) (defpackage kbug :use '(lisp k lam) (:import-from zetalisp "DEFSUBST")) (eval `(defpackage symbol :use '(cons vinculum prims) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage lisp-internals :use '(prims k) (:nicknames li) ,(prims-imports) ,(vinc-imports) ,(cons-imports) ,(array-imports) ,(symbol-imports) ,(new-math-imports) (:import-from k "SINGLE-FLOAT" "DOUBLE-FLOAT") ;;"IGNORE" removed by wkf. ,(global-imports) ,(cli-imports) (:import-from user "PARSE-LAMBDA-LIST" "PARSE-OPTIONAL-PARAMETER" "PARSE-AUX-PARAMETER") ;;wkf: should li:PARSE-LAMBDA-LIST be overwriting user:P-L-L??? )) (eval `(defpackage nlisp :use '(prims) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (defpackage setf :use '(lisp) (:import-from user "PARSE-LAMBDA-LIST") (:shadow ":PUSH" ":POP" ":GETF" "DEFINE-MODIFY-MACRO" "DEFINE-SETF-METHOD" "DEFSETF" "GET-SETF-METHOD" "GET-SETF-METHOD-MULTIPLE-VALUE" "SETF")) (eval `(defpackage k-debug :use '(vinc prims k) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage nubus-stuff :use '(vinc prims k) ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (defpackage cold :use '(k lisp)) (eval `(defpackage kbug-streams :use '(vinculum prims k) ; kbug2-common ,(vinc-imports) ,(global-imports) ,(prims-imports) ,(cli-imports) )) (eval `(defpackage k2 ; KBUG2/K2 stuff :use '(kbug-streams vinculum prims k) ; kbug2-common ,(vinc-imports) ,(prims-imports) ,(global-imports) ,(cli-imports) )) (defpackage fasdump :use '(;kbug2-common lisp)) ;;;;;;;; ***********above from jb: k; simulation-packages************* (defvar *k-packages* '(k-global (k primitives hardware global-registers vinculum timers map gc-ram datatype-ram paging-devices virtual-memory physical-cluster-data quantum-map memory-management region-bits map-fault gc-fault region-data area-data memory-management-interface boot transporter-ram cons new-math array trap ;kbug2-common kbug lisp-internals setf k-debug nubus-stuff cold kbug-streams k2 symbol fasdump user))) ; compiler system-internals system ;(k hardware vinculum primitives global-registers trap timers nubus-stuff ; data-type-ram boot map gc-ram paging-devices virtual-memory ; physical-cluster-data quantum-map memory-management map-fault gc-fault ; memory-management-interface transporter-ram region-bits region-data area-data ; cons new-math array lisp-internals symbol setf nlisp kbug2-common ; k-debug kbug-streams k2 ;;that was a list of k-machine packages as of 6-17-87, to be used with def-corresponding-packages ; fasdump cold kbug))) ;these three i found later (defun place-corr-package-to-new-environment (prefix pkg-name parent-pkg) ;;;this function takes a package and copies it to new ;;;environment, the parent package's. The pkg has prefix added to old name (let ((old-package (find-package pkg-name)) (new-package (if (find-package (intern (string-append prefix pkg-name))) (find-package (intern (string-append prefix pkg-name))) (make-package (intern (string-append prefix pkg-name)) :use ())))) (setf (get new-package ':root) parent-pkg) (setf (get new-package ':prefix) prefix) (unless (null old-package) (use-package (mapcar #'(lambda (pkg) (if (find-package (string-append prefix (package-name pkg))) (string-append prefix (package-name pkg)) pkg)) (package-use-list old-package)) new-package) (setf (si:pkg-nicknames new-package) (mapcar #'(lambda (nick) (string-append prefix nick)) (package-nicknames old-package)))) new-package)) (defun make-alist-of-package-names (pkg pre) ;;;takes a corresponding package and makes an alist out of the string for all possible names ;;;and the package ;;; ((pkg-name-or-nickname . package) (pkg-name-or-nickname . package) ....) (mapcar #'(lambda (name) (cons (subseq name (length (string pre))) pkg)) (cons (package-name pkg) (package-nicknames pkg)))) (defun make-refname-alist-of-packages (packages pre) ;;; takes all corresponding packages and creates refname-alist (loop for pkg in packages appending (make-alist-of-package-names pkg pre))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun def-corresponding-packages (prefix pkg-tree) ;;;this function takes a tree of package-names and creates new tree ;;;essentially used to copy local environment to remote. (let ((new-pkg (if (find-package (car pkg-tree)) (find-package (car pkg-tree)) (make-package (car pkg-tree) :use nil :import '(global:DEFSETF))))) ;;wkf: 5/5/88 added :import-from global "DEFSETF", arbitrary hack. (setf (get new-pkg ':root) new-pkg) (setf (get new-pkg ':prefix) prefix) (let* ((all-corresponding-packages (def-corresponding-packages-help prefix (cadr pkg-tree) new-pkg (list new-pkg))) (refname-alist (make-refname-alist-of-packages all-corresponding-packages prefix))) (loop for pkg in all-corresponding-packages (setf (si:pkg-refname-alist pkg) refname-alist)) all-corresponding-packages))) (defun def-corresponding-packages-help (prefix pkg-tree-children parent-pkg all-packages-so-far) (loop for child-pkg in pkg-tree-children do (if (listp child-pkg) (let ((new-pkg (place-corr-package-to-new-environment prefix child-pkg parent-pkg))) (setq all-packages-so-far (cons new-pkg (def-corresponding-packages-help prefix (cadr child-pkg) new-pkg all-packages-so-far)))) (setq all-packages-so-far (cons (place-corr-package-to-new-environment prefix child-pkg parent-pkg) all-packages-so-far)))) all-packages-so-far) (def-corresponding-packages "K-" *k-packages*) (pkg-bind (find-package "K-USER") (defpackage DIAG ;creates K-DIAG pacakge. :use '((global global)))) ;wants to be real global, not K-GLOBAL. (load "jb:k;imported-syms") (defun survey-for-symbol (symbol) (let ((string (cond ((stringp symbol) symbol) (t (symbol-name symbol)))) (ans nil) ;a list of lists, ea is ( ) sym tem) (dolist (pkg si:*all-packages*) (cond ((setq sym (intern-soft string pkg)) ;got something, what is it? (cond ((setq tem (assq sym ans)) (rplacd tem (nconc (cdr tem) (list (si:package-name pkg))))) (t (push (list sym (si:package-name pkg)) ans)))))) ans)) (defun survey-global-imports () (let ((ans nil)) (dolist (sym '( ;found out the hard way these needed from global. "NIL" "T" "&KEY" "&BODY" "&AUX" "&REST" "&OPTIONAL" "QUOTE" "CATCH" "THROW" "PROGN" "FUNCTION" "LAMBDA" "DEFUN" "DEFVAR" "DEFCONSTANT" "EXPORT" "IMPORT" "VALUES" "+" "-" "DO" "COND" ;contents of CLI package. "//" "*DEFAULT-PATHNAME-DEFAULTS*" "AR-1" "AR-1-FORCE" "AREF" "ASSOC" "ATAN" "CHARACTER" "CLOSE" "DEFSTRUCT" "DELETE" "FUNCTIONP" "EVERY" "INTERSECTION" "LISTP" "MAP" "MEMBER" "NINTERSECTION" "NLISTP" "NUNION" "RASSOC" "READ" "READ-FROM-STRING" "REM" "REMOVE" "SOME" "SUBST" "UNION" "MAKE-ARRAY" "GETHASH" "MAKE-PACKAGE" "TIME" "IF" )) (let ((survey (survey-for-symbol sym))) (dolist (elem ans (push (cons (list sym) (list survey)) ans)) (cond ((survey-equal survey (cadr elem)) (rplaca elem (cons sym (car elem))) (return nil)))) )) ans)) (defun survey-equal (s1 s2) (cond ((equal s1 s2) t) ((or (not (consp s1)) (not (consp s2))) nil) (t (and (survey-element-equal (car s1) (car s2)) (survey-equal (cdr s1) (cdr s2)))))) (defun survey-element-equal (e1 e2) (equal (cdr e1) (cdr e2)))