;;;; INITIALIZATION FILE ;; German comments translated into English: Stefan Kain 2001-08-27 (eval-when (compile load eval) (setq *package* (sys::%find-package "COMMON-LISP"))) ;;; Exports: (export '(;; types: array atom base-char base-string bignum bit bit-vector boolean character compiled-function complex cons double-float extended-char fixnum float function hash-table integer keyword list list* char-code-limit #+LOGICAL-PATHNAMES logical-pathname long-float nil null number package pathname random-state ratio rational readtable real sequence short-float simple-array simple-base-string simple-bit-vector simple-string simple-vector single-float standard-char stream file-stream synonym-stream broadcast-stream concatenated-stream two-way-stream echo-stream string-stream string symbol t vector satisfies values mod signed-byte unsigned-byte ;; constants: lambda-list-keywords lambda-parameters-limit nil t call-arguments-limit multiple-values-limit pi boole-clr boole-set boole-1 boole-2 boole-c1 boole-c2 boole-and boole-ior boole-xor boole-eqv boole-nand boole-nor boole-andc1 boole-andc2 boole-orc1 boole-orc2 most-positive-fixnum most-negative-fixnum most-positive-short-float least-positive-short-float least-negative-short-float most-negative-short-float most-positive-single-float least-positive-single-float least-negative-single-float most-negative-single-float most-positive-double-float least-positive-double-float least-negative-double-float most-negative-double-float most-positive-long-float least-positive-long-float least-negative-long-float most-negative-long-float least-positive-normalized-short-float least-negative-normalized-short-float least-positive-normalized-single-float least-negative-normalized-single-float least-positive-normalized-double-float least-negative-normalized-double-float least-positive-normalized-long-float least-negative-normalized-long-float short-float-epsilon single-float-epsilon double-float-epsilon long-float-epsilon short-float-negative-epsilon single-float-negative-epsilon double-float-negative-epsilon long-float-negative-epsilon array-rank-limit array-dimension-limit array-total-size-limit internal-time-units-per-second ;; variables: *macroexpand-hook* *gensym-counter* *package* *modules* *random-state* + ++ +++ - * ** *** / // /// *standard-input* *standard-output* *error-output* *query-io* *debug-io* *terminal-io* *trace-output* *read-base* *read-suppress* *read-eval* *readtable* *print-readably* *print-escape* *print-pretty* *print-circle* *print-base* *print-radix* *print-case* *print-gensym* *print-level* *print-length* *print-lines* *print-miser-width* *print-pprint-dispatch* *print-array* *print-right-margin* *read-default-float-format* *default-pathname-defaults* *load-verbose* *load-print* *load-pathname* *load-truename* *compile-verbose* *compile-print* *compile-file-pathname* *compile-file-truename* *features* ;; functions: coerce type-of upgraded-array-element-type upgraded-complex-part-type typep subtypep null symbolp atom consp listp numberp integerp rationalp floatp realp complexp characterp stringp bit-vector-p vectorp simple-vector-p simple-string-p simple-bit-vector-p arrayp packagep functionp compiled-function-p eq eql equal equalp not symbol-value symbol-function fdefinition boundp fboundp special-operator-p set makunbound fmakunbound get-setf-expansion apply funcall mapcar maplist mapc mapl mapcan mapcon values values-list macro-function macroexpand macroexpand-1 proclaim get remprop symbol-plist getf get-properties symbol-name make-symbol copy-symbol gensym gentemp symbol-package keywordp make-package in-package find-package package-name package-nicknames rename-package package-use-list package-used-by-list package-shadowing-symbols list-all-packages delete-package intern find-symbol unintern export unexport import shadowing-import shadow use-package unuse-package find-all-symbols provide require zerop plusp minusp oddp evenp = /= < > <= >= max min + - * / 1+ 1- conjugate gcd lcm exp expt log sqrt isqrt abs phase signum sin cos tan cis asin acos atan sinh cosh tanh asinh acosh atanh float rational rationalize numerator denominator floor ceiling truncate round mod rem ffloor fceiling ftruncate fround decode-float scale-float float-radix float-sign float-digits float-precision integer-decode-float complex realpart imagpart logior logxor logand logeqv lognand lognor logandc1 logandc2 logorc1 logorc2 boole lognot logtest logbitp ash logcount integer-length byte byte-size byte-position ldb ldb-test mask-field dpb deposit-field random make-random-state random-state-p standard-char-p graphic-char-p alpha-char-p upper-case-p lower-case-p both-case-p digit-char-p alphanumericp char= char/= char< char> char<= char>= char-equal char-not-equal char-lessp char-greaterp char-not-greaterp char-not-lessp char-code code-char character char-upcase char-downcase digit-char char-int char-name name-char complement constantly elt subseq copy-seq length reverse nreverse make-sequence concatenate map map-into some every notany notevery reduce fill replace remove remove-if remove-if-not delete delete-if delete-if-not remove-duplicates delete-duplicates substitute substitute-if substitute-if-not nsubstitute nsubstitute-if nsubstitute-if-not find find-if find-if-not position position-if position-if-not count count-if count-if-not mismatch search sort stable-sort merge car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr cons tree-equal endp list-length nth first second third fourth fifth sixth seventh eighth ninth tenth rest nthcdr last list make-list append copy-list copy-alist copy-tree revappend nconc nreconc butlast nbutlast ldiff rplaca rplacd subst subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis member member-if member-if-not tailp adjoin union nunion intersection nintersection set-difference nset-difference set-exclusive-or nset-exclusive-or subsetp acons pairlis assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not make-hash-table hash-table-p gethash remhash maphash clrhash hash-table-count hash-table-rehash-size hash-table-rehash-threshold hash-table-size hash-table-test sxhash make-array vector aref svref array-element-type array-rank array-dimension array-dimensions array-total-size array-in-bounds-p array-row-major-index row-major-aref adjustable-array-p array-displacement bit sbit bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2 bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p fill-pointer vector-push vector-push-extend vector-pop adjust-array char schar string= string-equal string< string> string<= string>= string/= string-lessp string-greaterp string-not-greaterp string-not-lessp string-not-equal make-string string-trim string-left-trim string-right-trim string-upcase string-downcase string-capitalize nstring-upcase nstring-downcase nstring-capitalize string copy-structure eval constantp make-synonym-stream make-broadcast-stream make-concatenated-stream make-two-way-stream make-echo-stream make-string-input-stream make-string-output-stream get-output-stream-string streamp open-stream-p input-stream-p output-stream-p stream-element-type stream-external-format close broadcast-stream-streams concatenated-stream-streams echo-stream-input-stream echo-stream-output-stream synonym-stream-symbol two-way-stream-input-stream two-way-stream-output-stream interactive-stream-p copy-readtable readtablep set-syntax-from-char set-macro-character get-macro-character make-dispatch-macro-character set-dispatch-macro-character get-dispatch-macro-character readtable-case read read-preserving-whitespace read-delimited-list read-line read-char unread-char peek-char listen read-char-no-hang clear-input read-from-string parse-integer read-byte write prin1 print pprint princ write-to-string pprint-dispatch copy-pprint-dispatch set-pprint-dispatch pprint-fill pprint-indent pprint-linear pprint-newline pprint-tab pprint-tabular pprint-exit-if-list-exhausted pprint-logical-block pprint-pop prin1-to-string princ-to-string write-char write-string write-line terpri fresh-line finish-output force-output clear-output write-byte format y-or-n-p yes-or-no-p wild-pathname-p pathname-match-p translate-pathname #+LOGICAL-PATHNAMES logical-pathname #+LOGICAL-PATHNAMES translate-logical-pathname #+LOGICAL-PATHNAMES logical-pathname-translations #+LOGICAL-PATHNAMES load-logical-pathname-translations compile-file-pathname pathname truename parse-namestring merge-pathnames make-pathname pathnamep pathname-host pathname-device pathname-directory pathname-name pathname-type pathname-version namestring file-namestring directory-namestring host-namestring enough-namestring user-homedir-pathname open rename-file delete-file probe-file file-write-date file-author file-position file-length file-string-length load directory ensure-directories-exist error cerror warn break compile compile-file disassemble with-compilation-unit variable structure type ; three documentation-types describe inspect room ed dribble apropos apropos-list get-decoded-time get-universal-time decode-universal-time encode-universal-time get-internal-run-time get-internal-real-time sleep lisp-implementation-type lisp-implementation-version machine-type machine-version machine-instance software-type software-version short-site-name long-site-name identity ;; Special-forms: eval-when quote function setq progn let let* locally progv flet labels macrolet symbol-macrolet if block return-from tagbody go multiple-value-call multiple-value-prog1 catch unwind-protect throw declare the load-time-value ;; Macros: deftype defun defvar defparameter defconstant and or psetq setf psetf shiftf rotatef define-modify-macro defsetf define-setf-expander prog1 prog2 when unless cond nth-value function-lambda-expression case typecase otherwise ; otherwise is the marker for the catchall-clause return loop do do* dolist dotimes prog prog* multiple-value-list multiple-value-bind multiple-value-setq defmacro remf do-symbols do-external-symbols do-all-symbols with-package-iterator incf decf push pushnew pop defstruct with-open-stream with-input-from-string with-output-to-string print-unreadable-object with-standard-io-syntax with-open-file define-symbol-macro check-type assert etypecase ctypecase ecase ccase trace untrace step time formatter compiler-macro compiler-macro-function define-compiler-macro ;; other markers: ;; EVAL-WHEN situations: eval load compile ;; DECLARE specifiers: special type ftype function inline notinline ignore ignorable optimize speed space safety compilation-speed debug declaration dynamic-extent compile ;; exports from condition.lisp make-condition ; pre-drawn for clos.lisp handler-bind ; pre-drawn for compiler.lisp end-of-file restart ; avoid conflict with defs2.lisp abort ; avoid conflict with gray.lisp ;; types for error-of-type: condition warning serious-condition error storage-condition type-error program-error control-error package-error print-not-readable parse-error stream-error end-of-file reader-error file-error cell-error unbound-variable undefined-function unbound-slot arithmetic-error division-by-zero floating-point-overflow floating-point-underflow floating-point-inexact floating-point-invalid-operation)) (sys::%proclaim-constant 'lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux &body &whole &environment)) (export lambda-list-keywords) (proclaim '(special *features*)) (use-package '("COMMON-LISP" "EXT") "SYSTEM") ;; (in-package "SYSTEM") (common-lisp:eval-when (common-lisp:compile common-lisp:load common-lisp:eval) (common-lisp:setq common-lisp:*package* (sys::%find-package "SYSTEM"))) (proclaim '(special sys::*compiling* sys::*compiling-from-file* sys::*c-error-output*)) ; for load/compiling (setq sys::*compiling* nil) #-COMPILER ; only for bootstrapping (progn ;; preliminary, no expansion at GET_CLOSURE: (sys::%putd '%expand-lambdabody-main (function %expand-lambdabody-main (lambda (lambdabody venv fenv) (declare (source nil) (ignore venv fenv)) lambdabody))) ;; preliminary, defun is to be expanded trivially: (sys::%putd 'defun (sys::make-macro (function defun (lambda (form env) (declare (ignore env)) #| (let ((name (cadr form)) (lambdalist (caddr form)) (body (cdddr form))) `(SYS::%PUTD ',name (FUNCTION ,name (LAMBDA ,lambdalist ,@body)))) |# (let ((name (cadr form))) (list 'sys::%putd (list 'quote name) (list 'function name (cons 'lambda (cddr form))))))) '(function-name lambda-list &body forms))) ) (sys::%putd 'sys::make-preliminary (function sys::make-preliminary (lambda (closure) ; ABI (sys::\(setf\ closure-name\) (list 'ext::preliminary (sys::closure-name closure)) closure) closure))) (sys::%putd 'in-package (sys::make-macro (function in-package (lambda (form env) (declare (ignore env)) (let ((package-name (string (cadr form)))) (list 'EVAL-WHEN '(:COMPILE-TOPLEVEL LOAD EVAL) (list 'SETQ 'COMMON-LISP::*PACKAGE* (list 'SYS::%FIND-PACKAGE package-name)))))) '(package-name))) ;; A preliminary definition that understands only ~S, ~A and ~C. (sys::%putd 'format (sys::make-preliminary (function format (lambda (destination control-string &rest arguments &aux stream) (cond ((null destination) (setq stream (make-string-output-stream))) ((eq destination 'T) (setq stream *standard-output*)) ((streamp destination) (setq stream destination)) (t (error (TEXT "The destination argument ~S is invalid (not NIL or T or a stream or a string).") destination))) (cond ((stringp control-string) (let ((i 0) (n (length control-string))) (tagbody next (when (< i n) (when (eq (char control-string i) #\~) (when (< (1+ i) n) (let ((c (char control-string (1+ i)))) (cond ((eq c #\S) (prin1 (car arguments) stream) (setq arguments (cdr arguments)) (setq i (+ i 2)) (go next)) ((eq c #\A) (princ (car arguments) stream) (setq arguments (cdr arguments)) (setq i (+ i 2)) (go next)) ((eq c #\C) (write-char (car arguments) stream) (setq arguments (cdr arguments)) (setq i (+ i 2)) (go next)))))) (write-char (char control-string i) stream) (setq i (+ i 1)) (go next))))) ((functionp control-string) (apply control-string stream arguments)) (t (error (TEXT "~S: The control-string must be a string, not ~S") 'format control-string))) (if (null destination) (get-output-stream-string stream) nil))))) ;; Yet another preliminary definition. (sys::%putd 'cerror (sys::make-preliminary (function cerror (lambda (continue-format-string error-format-string &rest args) (fresh-line *error-output*) (write-string "** - " *error-output*) (write-string (TEXT "Continuable Error") *error-output*) (terpri *error-output*) (apply #'format *error-output* error-format-string args) (ext::elastic-newline *error-output*) (fresh-line *debug-io*) (apply #'format *debug-io* continue-format-string args) (ext::elastic-newline *debug-io*) nil)))) (use-package '("COMMON-LISP" "CUSTOM") "EXT") (in-package "EXT") (sys::%putd 'exit #'sys::%exit) (sys::%putd 'quit #'sys::%exit) (sys::%putd 'bye #'sys::%exit) (export '(re-export featurep make-encoding encoding encoding-line-terminator #+UNICODE encoding-charset times show-stack gc exit quit bye expand-form xor mapcap maplap proper-list-p elastic-newline absolute-pathname default-directory cd dir probe-directory make-directory delete-directory rename-directory xgcd exquo mod-expt ! evalhook applyhook substring string-concat string-char make-char string-width char-width probe-pathname int-char char-bits char-font char-bit set-char-bit char-key base-char-code-limit char-font-limit char-bits-limit char-control-bit char-meta-bit char-super-bit char-hyper-bit string-char-p char-invertcase string-invertcase nstring-invertcase long-float-digits package-lock hash-table-weak-p weak-key-value-table the-environment arglist getenv special-variable-p list-length-dotted list-length-proper *driver* *break-driver* *args* *keyboard-input* shell execute fasthash-eq stablehash-eq fasthash-eql stablehash-eql fasthash-equal stablehash-equal define-hash-table-test package-case-sensitive-p package-case-inverted-p argv hash-table-warn-if-needs-rehash-after-gc package-shortest-name symbol-macro-expand ;; declarations constant-inline constant-notinline notspecial ;; pseudo-types: simple-2bit-vector 2bit-vector simple-4bit-vector 4bit-vector simple-8bit-vector 8bit-vector simple-16bit-vector 16bit-vector simple-32bit-vector 32bit-vector special-form system-function function-macro foreign-pointer symbol-macro global-symbol-macro designator address special-operator finalize finalizer ;; weak containers weak-pointer make-weak-pointer weak-pointer-p weak-pointer-value weak-list make-weak-list weak-list-p weak-list-list weak-and-relation make-weak-and-relation weak-and-relation-p weak-and-relation-list weak-or-relation make-weak-or-relation weak-or-relation-p weak-or-relation-list weak-mapping make-weak-mapping weak-mapping-p weak-mapping-pair weak-mapping-value weak-and-mapping make-weak-and-mapping weak-and-mapping-p weak-and-mapping-pair weak-and-mapping-value weak-or-mapping make-weak-or-mapping weak-or-mapping-p weak-or-mapping-pair weak-or-mapping-value weak-alist make-weak-alist weak-alist-p weak-alist-type weak-alist-contents weak-alist-assoc weak-alist-rassoc weak-alist-value ;; structure MOP structure-slots structure-direct-slots ; structure-instance-size structure-keyword-constructor structure-boa-constructors structure-copier structure-predicate ;; i/o read-integer read-float write-integer write-float read-byte-lookahead read-byte-will-hang-p read-byte-no-hang read-char-will-hang-p read-char-sequence write-char-sequence read-byte-sequence write-byte-sequence convert-string-from-bytes convert-string-to-bytes make-stream #+(or UNIX WIN32) make-pipe-output-stream #+(or UNIX WIN32) make-pipe-input-stream #+(or UNIX WIN32) make-pipe-io-stream make-buffered-input-stream make-buffered-output-stream stream-handles get-setf-method preliminary local module-info source-program-error source-program-error-form source-program-error-detail compiler-let load-time-eval compile-time-value) "EXT") (common-lisp:in-package "CUSTOM") (common-lisp:export '(*load-paths* *editor* *clhs-root-default* *browsers* *browser* *http-proxy* *http-log-stream* clhs-root *impnotes-root-default* impnotes-root *saveinitmem-verbose* *load-echo* *applyhook* *evalhook* *load-compiling* *compile-warnings* *load-obsolete-action* *suppress-check-redefinition* *eq-hashfunction* *eql-hashfunction* *equal-hashfunction* ;; places.lisp *ansi* *current-language* *lib-directory* *default-file-encoding* #+UNICODE *misc-encoding* #+UNICODE *terminal-encoding* #+UNICODE *pathname-encoding* *source-file-types* *compiled-file-types*) "CUSTOM") (common-lisp:in-package "SYSTEM") (ext:re-export "CUSTOM" "EXT") (in-package "COMMON-LISP") (proclaim '(ext::constant-notinline ;; These constants are platform dependent and therefore shouldn't be ;; inlined in compiled bytecode files. lambda-parameters-limit call-arguments-limit system::*jmpbuf-size* system::*big-endian* most-positive-fixnum most-negative-fixnum most-positive-short-float most-negative-short-float least-positive-short-float least-negative-short-float most-positive-single-float most-negative-single-float least-positive-single-float least-negative-single-float most-positive-double-float most-negative-double-float least-positive-double-float least-negative-double-float short-float-epsilon short-float-negative-epsilon single-float-epsilon single-float-negative-epsilon double-float-epsilon double-float-negative-epsilon char-code-limit array-total-size-limit array-dimension-limit array-rank-limit internal-time-units-per-second)) (use-package '("COMMON-LISP") "CLOS") (in-package "CLOS") ;;; Exports: (export '(;; names of functions and macros: slot-value slot-boundp slot-makunbound slot-exists-p with-slots with-accessors documentation find-class class-of defclass defmethod call-next-method next-method-p defgeneric generic-function class-name no-applicable-method no-next-method find-method add-method remove-method compute-applicable-methods method-qualifiers function-keywords slot-missing slot-unbound print-object describe-object make-instance allocate-instance initialize-instance reinitialize-instance shared-initialize ensure-generic-function make-load-form make-load-form-saving-slots change-class update-instance-for-different-class update-instance-for-redefined-class make-instances-obsolete ;; names of classes: class standard-class structure-class built-in-class standard-object structure-object generic-function standard-generic-function method standard-method ;; method combinations standard method-combination define-method-combination method-combination-error invalid-method-error call-method make-method)) (use-package '("CLOS") "COMMON-LISP") (ext:re-export "CLOS" "COMMON-LISP") (progn ; not in ANSI - export separately, after `re-export' above (export #1='(metaobject ;; MOP for dependents add-dependent remove-dependent map-dependents update-dependent ;; MOP for slot definitions slot-definition standard-slot-definition direct-slot-definition standard-direct-slot-definition effective-slot-definition standard-effective-slot-definition slot-definition-name slot-definition-initform slot-definition-initfunction slot-definition-type slot-definition-allocation slot-definition-initargs slot-definition-readers slot-definition-writers slot-definition-location ;; MOP for slot access slot-value-using-class slot-boundp-using-class slot-makunbound-using-class standard-instance-access funcallable-standard-instance-access ;; MOP for classes class forward-referenced-class built-in-class structure-class standard-class class-name class-direct-superclasses class-precedence-list class-direct-subclasses class-direct-slots class-slots class-direct-default-initargs class-default-initargs class-prototype class-finalized-p finalize-inheritance compute-direct-slot-definition-initargs direct-slot-definition-class compute-class-precedence-list compute-slots compute-effective-slot-definition compute-effective-slot-definition-initargs effective-slot-definition-class compute-default-initargs validate-superclass add-direct-subclass remove-direct-subclass standard-accessor-method standard-reader-method standard-writer-method reader-method-class writer-method-class ensure-class ensure-class-using-class ;; MOP for specializers specializer eql-specializer specializer-direct-generic-functions specializer-direct-methods add-direct-method remove-direct-method eql-specializer-object intern-eql-specializer ;; MOP for methods method standard-method method-function method-generic-function method-lambda-list method-specializers method-qualifiers accessor-method-slot-definition extract-lambda-list extract-specializer-names ;; MOP for method combinations find-method-combination compute-effective-method ;; MOP for generic functions funcallable-standard-class funcallable-standard-object set-funcallable-instance-function generic-function-name generic-function-methods generic-function-method-class generic-function-lambda-list generic-function-method-combination generic-function-argument-precedence-order generic-function-declarations compute-discriminating-function compute-applicable-methods compute-applicable-methods-using-classes compute-effective-method-as-function ensure-generic-function ensure-generic-function-using-class ;; CLISP specific symbols generic-flet generic-labels no-primary-method method-call-error method-call-type-error method-call-error-generic-function method-call-error-method method-call-error-argument-list standard-stablehash structure-stablehash clos-warning gf-already-called-warning gf-replacing-method-warning clos-novice-warning clos-style-warning class-obsolescence-warning) "CLOS") ;; so that they are available in CL-USER even though it does not use CLOS (import #1# "EXT") (export #1# "EXT")) (in-package "SYSTEM") (use-package '("COMMON-LISP" "EXT") "CL-USER") (sys::%putd 'sys::preliminary-p (function sys::preliminary-p (lambda (name) (and (consp name) (eq (car name) 'ext:preliminary))))) (sys::%putd 'sys::fbound-string (function sys::fbound-string (lambda (sym) (cond ((special-operator-p sym) (TEXT "special operator")) ((macro-function sym) (if (not (and (sys::closurep (macro-function sym)) (sys::preliminary-p (sys::closure-name (macro-function sym))))) (TEXT "macro") nil)) ((fboundp sym) (if (not (and (sys::closurep (symbol-function sym)) (sys::preliminary-p (sys::closure-name (symbol-function sym))))) (TEXT "function") nil)))))) ;; Mapping funname -> symbol (required by PROCLAIM SPECIAL) (sys::%putd 'get-funname-symbol (function get-funname-symbol (lambda (funname) (if (atom funname) funname (get-setf-symbol (second funname)))))) ;; return the SYMBOL on whose plist the object's documentation will be kept ;; and the CALLER that indicates what the doc pertains to. ;; OBJECT can be a symbol, (setf symbol), or (func-name quals specs) ;; CALLER is a symbol ;; the doc entity symbol is a symbol from object ;; and doc entity caller is a symbol or list from caller ;; e.g.: (defun foo ...) ==> (FOO DEFUN/DEFMACRO) -> (FOO DEFUN/DEFMACRO) ;; (defmethod foo ...) ==> ((FOO ...) DEFMETHOD) -> (FOO (DEFMETHOD ...)) (sys::%putd 'sys::get-doc-entity-symbol (function sys::get-doc-entity-symbol (lambda (object) (get-funname-symbol (if (function-name-p object) object (first object)))))) (sys::%putd 'sys::get-doc-entity-caller (function sys::get-doc-entity-caller (lambda (object caller) (if (function-name-p object) caller (cons caller (rest object)))))) (sys::%putd 'sys::%set-documentation (function sys::%set-documentation (lambda (object doctype value) ; ABI (let* ((symbol (sys::get-doc-entity-symbol object)) (rec (get symbol 'sys::doc))) (if value (let ((new-val (sys::%putf rec doctype value))) (when new-val (sys::%put symbol 'sys::doc new-val))) (when rec (setq rec (sys::%remf rec doctype)) (cond ((null rec) (remprop symbol 'sys::doc)) ((atom rec) (sys::%put symbol 'sys::doc rec)))))) value))) (proclaim '(special *load-truename* custom:*suppress-check-redefinition* *current-source-line-1* *current-source-line-2* *current-source-file*)) (setq *load-truename* nil custom:*suppress-check-redefinition* nil *current-source-line-1* nil *current-source-line-2* nil *current-source-file* nil) (sys::%putd 'sys::check-special-operator (function sys::check-special-operator (lambda (caller symbol) (when (special-operator-p symbol) (error-of-type 'source-program-error ;; note that caller may be SYS::DEFUN/DEFMACRO ! ;; maybe (SETF FDEFINITION) is better? :form (list caller symbol) :detail symbol (TEXT "~A: ~S is a special operator and may not be redefined.") caller symbol))))) ;; sys::file doc is an alist ((caller . file-location) ...) (sys::%putd 'sys::get-file-doc (function sys::get-file-doc (lambda (object caller) (assoc (sys::get-doc-entity-caller object caller) (getf (get (sys::get-doc-entity-symbol object) 'sys::doc) 'sys::file) ;; caller can be (list* funname qualifiers spec-list) :test #'equal)))) (sys::%putd 'sys::set-file-doc (function sys::set-file-doc (lambda (object caller value) (let* ((symbol (sys::get-doc-entity-symbol object)) (caller (sys::get-doc-entity-caller object caller)) (doc-plist (get symbol 'sys::doc)) (file-alist (getf doc-plist 'sys::file)) (old-pair (assoc caller file-alist :test #'equal))) (if old-pair ;; In theory, we should remove the OLD-PAIR from FILE-ALIST ;; and then maybe remove the SYS::FILE & SYS::DOC properties... ;; Alas, DELETE does not work at this point yet, so it is not trivial. ;; Note however that VALUE=NIL & OLD-PAIR/=NIL ==> top-level ;; ==> performance non-critical (rplacd old-pair value) (when value ; VALUE=NIL, OLD-PAIR=NIL => do nothing (let ((new-doc-plist ; nil if %PUTF worked in-place (sys::%putf doc-plist 'sys::file (acons caller value file-alist)))) (when new-doc-plist (sys::%put symbol 'sys::doc new-doc-plist))))))))) (sys::%putd 'sys::check-redefinition (function sys::check-redefinition (lambda (object caller what) (when (and (symbolp object) (not (eq caller 'define-setf-expander)) (not (equal caller '(setf find-class)))) ;; see (define-setf-expander THE) in places.lisp ;; and (def ...) in clos-class3.lisp (sys::check-special-operator caller object)) (let ((cur-file *current-source-file*) (old-file ; distinguish between undefined and defined at top-level (if (and (not (or (eq caller 'define-setf-expander) (eq caller 'defsetf))) (sys::subr-info object)) "C" (cdr (sys::get-file-doc object caller))))) (when (consp old-file) (setq old-file (car old-file))) (unless (or custom:*suppress-check-redefinition* (equalp old-file cur-file) (and (pathnamep old-file) (pathnamep cur-file) (equal (pathname-name old-file) (pathname-name cur-file)))) (sys::check-package-lock caller (cond ((atom object) (symbol-package object)) ((function-name-p object) (symbol-package (second object))) ((mapcar #'(lambda (obj) ; handle (setf NAME) and (eql NAME) (let ((oo (if (atom obj) obj (second obj)))) (when (symbolp oo) (symbol-package oo)))) object))) object) (when what ; when not yet defined, `what' is NIL (warn-of-type 'simple-style-warning (TEXT "~A: redefining ~A ~S in ~A, was defined in ~A") caller what object (or cur-file #2="top-level") (or old-file #2#)))) (sys::set-file-doc object caller ;; note that when CUR-FILE is "foo.fas", ;; *current-source-line-[12]* point into "foo.lisp"! (and cur-file (list cur-file *current-source-line-1* *current-source-line-2*))))))) ;; in-package has to be defined very early, so we have to do it now (let ((sys::*current-source-file* "init")) ; still using C load at this time (sys::check-redefinition 'in-package 'defmacro nil)) (sys::%putd 'sys::remove-old-definitions (function sys::remove-old-definitions (lambda (symbol &optional (preliminary nil)) ; ABI ;; removes the old function-definitions of a symbol (if preliminary (sys::check-special-operator 'defun/defmacro symbol) (sys::check-redefinition symbol 'defun/defmacro (sys::fbound-string symbol))) (fmakunbound symbol) ; discard function & macro definition (remprop symbol 'sys::definition) ; discard function lambda expression (remprop symbol 'sys::macro) ; discard macro definition (remprop symbol 'sys::defstruct-reader) ; discard DEFSTRUCT information (sys::%set-documentation symbol 'FUNCTION nil) (when (get symbol 'sys::inline-expansion) (sys::%put symbol 'sys::inline-expansion t)) (when (get symbol 'sys::traced-definition) ; discard Trace (warn-of-type 'simple-style-warning (TEXT "~A: redefining ~S; it was traced!") 'defun/defmacro symbol) (untrace2 symbol))))) ;; THE-ENVIRONMENT as in SCHEME (sys::%putd '%the-environment (function %the-environment (lambda (form env) ; ABI (declare (ignore form)) (sys::svstore env 0 (svref (svref env 0) 2)) ; nuke *evalhook* binding env))) (sys::%putd '%uncompilable (function %uncompilable (lambda (form) ; ABI (error-of-type 'source-program-error :form form :detail form (TEXT "~S is impossible in compiled code") form)))) (sys::%putd 'the-environment (sys::make-macro (function the-environment (lambda (form env) (declare (ignore form env)) '(progn (eval-when ((not eval)) (%uncompilable 'the-environment)) (let ((*evalhook* #'%the-environment)) 0)))) '())) (let ((sys::*current-source-file* "init")) (sys::check-redefinition 'the-environment 'defmacro nil)) ;; The toplevel environment (proclaim '(special *toplevel-environment*)) (setq *toplevel-environment* (eval '(the-environment))) (proclaim '(special *toplevel-denv*)) ; ABI (setq *toplevel-denv* (svref *toplevel-environment* 4)) ;;; functions for expansion of macros within a piece of code ;;; ;;; Altogether, the whole Code (of a function) is walked through and ;;; global and local Macros are expanded. ;;; #'(lambda lambdalist . body) ;;; becomes #'(lambda expanded-lambdalist ;;; (declare (source (lambdalist . body))) . expanded-body ;;; ) ;;; This declaration guarantees, that a formerly processed ;;; function is recognized as such and not unnecessarily processed ;;; a second time. ;; Caution! For bootstrapping purposes (recognizable with #-COMPILER) some ;; of the functions have to be written in a more primitive Lisp ;; (without do, do*, case). (PROGN (proclaim '(special *keyword-package*)) (setq *keyword-package* (find-package "KEYWORD")) (defun symbol-to-keyword (s) (intern (symbol-name s) *keyword-package*)) (proclaim '(special *fenv*)) ;; *FENV* = the current function environment during expansion of a form. ;; structure: NIL or a 2n+1-element vector ;; (n1 f1 ... nn fn next), ;; where the ni are function-names, ;; the fi are their functional meanings ;; (closure or macro or function-macro or still NIL) ;; continued similarly at 'next'. ;; (fenv-assoc s fenv) searches symbol S in function-environment FENV. ;; the search routine uses EQUAL (defun fenv-assoc (s fenv &optional (from-inside-macrolet nil)) (if fenv (if (simple-vector-p fenv) #+COMPILER (do ((l (1- (length fenv))) (i 0 (+ i 2))) ((= i l) (fenv-assoc s (svref fenv i) from-inside-macrolet)) (if (equal s (svref fenv i)) (if (and from-inside-macrolet (not (macrop (svref fenv (1+ i))))) (error-of-type 'source-program-error :form (list 'FUNCTION s) :detail s (TEXT "Invalid access to the local function definition of ~S from within a ~S definition") s 'macrolet) (return (svref fenv (1+ i)))))) #-COMPILER (let ((l (1- (length fenv))) (i 0)) (block nil (tagbody 1 (if (= i l) (return-from nil (fenv-assoc s (svref fenv i) from-inside-macrolet))) (if (equal s (svref fenv i)) (if (and from-inside-macrolet (not (macrop (svref fenv (1+ i))))) (error-of-type 'source-program-error :form (list 'FUNCTION s) :detail s (TEXT "Invalid access to the local function definition of ~S from within a ~S definition") s 'macrolet) (return-from nil (svref fenv (1+ i))))) (setq i (+ i 2)) (go 1)))) (if (and (consp fenv) (eq (car fenv) 'MACROLET)) (fenv-assoc s (cdr fenv) t) (error-of-type 'type-error :datum fenv :expected-type '(or null simple-vector (cons (eql macrolet) t)) (TEXT "~S is an invalid function environment") fenv))) 'T)) ; not found ;; Determines, if a function-name S in function-environment FENV is not ;; defined and thus refers to the global function. (sys::%putd 'global-in-fenv-p (sys::make-preliminary (function global-in-fenv-p (lambda (s fenv) ; preliminary (eq (fenv-assoc s fenv) 'T))))) (proclaim '(special *venv*)) ;; *VENV* = the current variable-environment during the expansion of a form. ;; Structure: NIL or a 2n+1-element Vector ;; (n1 v1 ... nn vn next), ;; where the ni are Symbols, ;; the vi are their syntactic meanings (symbol-macro-object or sth. else) ;; continued similarly at 'next'. ;; (venv-assoc s venv) searches symbol S in variable-environment VENV. ;; Returns the value (or NIL if there's no value). ;; Caution: The value can be # or # , thus ;; may not be temporarily saved in a variable in interpreted Code. ;; the search routine uses EQ (defun venv-assoc (s venv &optional (from-inside-macrolet nil)) (if venv (if (simple-vector-p venv) #+COMPILER (do ((l (1- (length venv))) (i 0 (+ i 2))) ((= i l) (venv-assoc s (svref venv i) from-inside-macrolet)) (if (eq s (svref venv i)) (if (and from-inside-macrolet (not (eq (svref venv (1+ i)) sys::specdecl)) (not (symbol-macro-p (svref venv (1+ i))))) (error-of-type 'source-program-error :form s :detail s (TEXT "Invalid access to the value of the lexical variable ~S from within a ~S definition") s 'macrolet) (return (svref venv (1+ i)))))) #-COMPILER (let ((l (1- (length venv))) (i 0)) (block nil (tagbody 1 (if (= i l) (return-from nil (venv-assoc s (svref venv i) from-inside-macrolet))) (if (eq s (svref venv i)) (if (and from-inside-macrolet (not (symbol-macro-p (svref venv (1+ i))))) (error-of-type 'source-program-error :form s :detail s (TEXT "Invalid access to the value of the lexical variable ~S from within a ~S definition") s 'macrolet) (return-from nil (svref venv (1+ i))))) (setq i (+ i 2)) (go 1)))) (if (and (consp venv) (eq (car venv) 'MACROLET)) (venv-assoc s (cdr venv) t) (error-of-type 'type-error :datum venv :expected-type '(or null simple-vector) (TEXT "~S is an invalid variable environment") venv))) ; not found (if (symbol-macro-expand s) (global-symbol-macro-definition (get s 'SYMBOLMACRO)) (and (boundp s) (symbol-value s))))) ;; Most of the Expansion-functions return two values: ;; (1) the expansion result, ;; (2) (NIL or T) indicates, if something was changed within it. (proclaim '(special %whole-form)) ; the whole form being expanded ;; (%expand-cons ...) composes a cons. returns 2 values. ;; form=old Form, ;; expf,flagf = expansion of the first-part, ;; expr,flagr = expansion of the rest-part. (defun %expand-cons (form expf flagf expr flagr) (if (or flagf flagr) (values (cons expf expr) t) (values form nil))) ;; cons specs on top of *fenv* (defun cons-*fenv* (specs) (apply #'vector (nreverse (cons *fenv* specs)))) (defun illegal-syntax (detail form-name &optional (whole-form %whole-form)) (error-of-type 'source-program-error :form whole-form :detail detail (TEXT "Illegal syntax in ~A: ~S") form-name detail)) ;; (%expand-form form) expands a whole Form. returns 2 values. (defun %expand-form (form &aux (%whole-form form)) (if (atom form) #+COMPILER (let (h) (if (and (symbolp form) (symbol-macro-p (setq h (venv-assoc form *venv*)))) (values (%expand-form (sys::%record-ref h 0)) t) (values form nil))) #-COMPILER (if (and (symbolp form) (symbol-macro-p (venv-assoc form *venv*))) (values (%expand-form (sys::%record-ref (venv-assoc form *venv*) 0)) t) (values form nil)) ;; form is a CONS (let ((f (first form))) (if (function-name-p f) (let ((h (fenv-assoc f *fenv*))) ;; f is in *fenv* associated to h (if (eq h 'T) ;; f has no local definition ;; Now the separate expanders for the special-forms: (case f ((RETURN-FROM THE) ; skip the 1st argument, expand the rest (multiple-value-call #'%expand-cons form (first form) nil (multiple-value-call #'%expand-cons (rest form) (second form) nil (%expand-list (cddr form))))) ((QUOTE GO DECLARE LOAD-TIME-VALUE) ; expand nothing (values form nil)) ((FUNCTION) ;; if 1st or 2nd argument is a list, ;; expand as lambda expression. (multiple-value-call #'%expand-cons form 'FUNCTION nil (if (atom (cddr form)) (if (function-name-p (second form)) (let ((h (fenv-assoc (second form) *fenv*))) (cond ((or (eq h 'T) (closurep h) (function-macro-p h) (null h)) (values (rest form) nil)) ((macrop h) (error-of-type 'source-program-error :form form :detail (second form) (TEXT "~S: ~S is illegal since ~S is a local macro") '%expand form (second form))) (t (error-of-type 'error (TEXT "~S: invalid function environment ~S") '%expand *fenv*)))) (if (atom (second form)) (error-of-type 'source-program-error :form form :detail (second form) (TEXT "~S: ~S is invalid since ~S is not a symbol") '%expand form (second form)) (multiple-value-call #'%expand-cons (rest form) (%expand-lambda (second form)) (cddr form) nil))) (multiple-value-call #'%expand-cons (rest form) (second form) nil (multiple-value-call #'%expand-cons (cddr form) (%expand-lambda (third form)) (cdddr form) nil))))) ((EVAL-WHEN) (let ((situations (second form))) (if (or (member 'EVAL situations) (member ':EXECUTE situations)) (multiple-value-call #'%expand-cons form (first form) nil (multiple-value-call #'%expand-cons (rest form) (second form) nil (%expand-list (cddr form)))) (values 'NIL t)))) ((LET) ; expand variable-list and body (let ((*venv* *venv*)) (%expand-special-declarations (cddr form)) (multiple-value-call #'%expand-cons form (first form) nil (multiple-value-call #'%expand-cons (rest form) (%expand-varspez (second form)) (%expand-list (cddr form)))))) ((LET*) ; expand variable-list and body (let ((*venv* *venv*)) (%expand-special-declarations (cddr form)) (multiple-value-call #'%expand-cons form (first form) nil (multiple-value-call #'%expand-cons (rest form) (%expand-varspez* (second form)) (%expand-list (cddr form)))))) ((LOCALLY) ; expand body (let ((*venv* *venv*)) (%expand-special-declarations (cdr form)) (multiple-value-call #'%expand-cons form (first form) nil (%expand-list (cdr form))))) ((MULTIPLE-VALUE-BIND) ; expand form and body, separately (let ((*venv* *venv*)) (%expand-special-declarations (cdddr form)) (multiple-value-call #'%expand-cons form 'MULTIPLE-VALUE-BIND nil (multiple-value-call #'%expand-cons (rest form) (second form) nil (multiple-value-call #'%expand-cons (cddr form) (%expand-form (third form)) (progn (%expand-lexical-variables (second form)) (%expand-list (cdddr form)))))))) ((COMPILER-LET) ; expand var-list in empty environment and body (progv (mapcar #'%expand-varspec-var (second form)) (mapcar #'%expand-varspec-val (second form)) (values (%expand-form (cons 'PROGN (cddr form))) t))) ((COND) ; expand all Sub-Forms of the clauses: (multiple-value-call #'%expand-cons form (first form) nil (%expand-cond (rest form)))) ((CASE) ; expand 1st argument and all sub-forms of the clauses (multiple-value-call #'%expand-cons form (first form) nil (multiple-value-call #'%expand-cons (rest form) (%expand-form (second form)) (%expand-case (cddr form))))) ((BLOCK) ;; expand body. If there is a RETURN-FROM in this ;; block, keep BLOCK, else turn it into a PROGN. (multiple-value-bind (body flagb) (%expand-list (cddr form)) (if (%return-p (second form) body) (multiple-value-call #'%expand-cons form (first form) nil (multiple-value-call #'%expand-cons (rest form) (second form) nil body flagb)) (values (cond ((atom body) body) ((null (cdr body)) (car body)) (t (cons 'progn body))) t)))) ((SETQ PSETQ) ; expand each second Argument (if (%expand-setqlist-macrop (rest form)) (let ((new (if (eq (first form) 'SETQ) 'SETF 'PSETF))) (values (%expand-form (funcall (macro-function new) (cons new (rest form)) (vector *venv* *fenv*))) t)) (multiple-value-call #'%expand-cons form (first form) nil (%expand-setqlist (rest form))))) ((MULTIPLE-VALUE-SETQ) ; skip 1st argument, expand the rest (if (%expand-varlist-macrop (second form)) (values (%expand-form (cons 'MULTIPLE-VALUE-SETF (rest form))) t) (multiple-value-call #'%expand-cons form 'MULTIPLE-VALUE-SETQ nil (multiple-value-call #'%expand-cons (rest form) (second form) nil (%expand-list (cddr form)))))) ((TAGBODY) ;; expand all arguments, ;; skip atoms that are created during expansion (multiple-value-call #'%expand-cons form (first form) nil (%expand-tagbody (rest form)))) ((PROGN) ; expand all arguments, possibly simplify them. (if (null (rest form)) (values nil t) (if (null (cddr form)) (values (%expand-form (second form)) t) (multiple-value-call #'%expand-cons form (first form) nil (%expand-list (rest form)))))) ((FLET) ; expand function definitions (if (null (second form)) (values (%expand-form (cons 'LOCALLY (cddr form))) t) (let ((newfenv (%expand-fundefs-1 (second form))) (*venv* *venv*)) (%expand-special-declarations (cddr form)) (multiple-value-call #'%expand-cons form (first form) nil (multiple-value-call #'%expand-cons (rest form) (%expand-fundefs-2 (second form)) (let ((*fenv* (apply #'vector newfenv))) (%expand-list (cddr form)))))))) ((LABELS) ;; expand function definitions and body ;; in the extended environment (if (null (second form)) (values (%expand-form (cons 'LOCALLY (cddr form))) t) (let ((newfenv (%expand-fundefs-1 (second form))) (*venv* *venv*)) (%expand-special-declarations (cddr form)) (let ((*fenv* (apply #'vector newfenv))) (multiple-value-call #'%expand-cons form (first form) nil (multiple-value-call #'%expand-cons (rest form) (%expand-fundefs-2 (second form)) (%expand-list (cddr form)))))))) ((MACROLET) ; expand the body in the extended environment (do ((L1 (second form) (cdr L1)) (L2 nil)) ((atom L1) (if L1 (error-of-type 'source-program-error :form form :detail L1 (TEXT "code after MACROLET contains a dotted list, ending with ~S") L1) (let ((*fenv* (cons-*fenv* L2)) (*venv* *venv*)) (%expand-special-declarations (cddr form)) (values (%expand-form (cons 'PROGN (cddr form))) t)))) (let ((macrodef (car L1))) (if (and (consp macrodef) (symbolp (car macrodef)) (consp (cdr macrodef))) (setq L2 (list* (make-macro-expander macrodef form) (car macrodef) L2)) (illegal-syntax macrodef 'MACROLET))))) ((FUNCTION-MACRO-LET) ;; expand function-definitions, ;; expand body in extended environment (if (null (second form)) (values (%expand-form (cons 'PROGN (cddr form))) t) (let ((newfenv (%expand-funmacdefs-1 (second form)))) (multiple-value-call #'%expand-cons form (first form) nil (multiple-value-call #'%expand-cons (rest form) (%expand-funmacdefs-2 (second form)) (let ((*fenv* (apply #'vector newfenv))) (%expand-list (cddr form)))))))) ((SYMBOL-MACROLET) ; expand body in extended environment (do ((L1 (second form) (cdr L1)) (L2 nil)) ((atom L1) (if L1 (error-of-type 'source-program-error :form form :detail L1 (TEXT "code after SYMBOL-MACROLET contains a dotted list, ending with ~S") L1) (let ((*venv* (apply #'vector (nreverse (cons *venv* L2))))) (let ((specials (%expand-special-declarations (cddr form)))) (do ((L3 (second form) (cdr L3))) ((atom L3)) (if (memq (caar L3) specials) (error-of-type 'source-program-error :form form :detail (caar L3) (TEXT "~S: symbol ~S must not be declared SPECIAL and a macro at the same time") 'symbol-macrolet (caar L3))))) (values (%expand-form (cons 'LOCALLY (cddr form))) t)))) (let ((symdef (car L1))) (if (and (consp symdef) (symbolp (car symdef)) (consp (cdr symdef)) (null (cddr symdef))) (let ((symbol (car symdef)) (expansion (cadr symdef))) (if (special-variable-p symbol) (error-of-type 'program-error (TEXT "~S: symbol ~S is declared special and must not be declared a macro") 'symbol-macrolet symbol) (setq L2 (list* (make-symbol-macro expansion) symbol L2)))) (illegal-syntax symdef 'SYMBOL-MACROLET))))) (t (cond ((and (symbolp f) (special-operator-p f)) ;; other Special-forms, ;; e.g. IF, CATCH, THROW, PROGV, UNWIND-PROTECT, PROGN, ;; PROG1, PROG2, WHEN, UNLESS, MULTIPLE-VALUE-LIST, ;; MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-PROG1, AND, OR: (multiple-value-call #'%expand-cons form f nil (%expand-list (rest form)))) ((and (symbolp f) (setq h (macro-function f))) ;; global Macro-Definition (%expand-macro h form)) (t ; normal function-call (multiple-value-call #'%expand-cons form f nil (%expand-list (rest form))))))) ;; f has a local definition (cond ((or (closurep h) (function-macro-p h) (null h)) ;; function to be called (multiple-value-call #'%expand-cons form f nil (%expand-list (rest form)))) ((macrop h) ; macro to be expanded (%expand-macro (macro-expander h) form)) ; call expander (t (error-of-type 'error (TEXT "bad function environment occurred in ~S: ~S") '%expand-form *fenv*))))) (if (consp f) (multiple-value-call #'%expand-cons form (%expand-lambda f) (%expand-list (rest form))) (error-of-type 'source-program-error :form form :detail form (TEXT "~S: invalid form ~S") '%expand-form form)))))) ;; Auxiliary functions for the the expansion: ;; call the macro-expander on the form (expanding after) (defun %expand-macro (macro-expander form) (values (%expand-form (funcall macro-expander form (vector *venv* *fenv*))) t)) ;; expands a list of forms. returns 2 values. (defun %expand-list (l) (if (atom l) (if l (error-of-type 'source-program-error :form %whole-form :detail l (TEXT "code contains a dotted list, ending with ~S") l) (values nil nil)) (multiple-value-call #'%expand-cons l (%expand-form (first l)) (%expand-list (rest l))))) ;; Adds lexical variables to *venv* . ;; (only used for shadowing symbol-macros.) (defun %expand-lexical-variables (vars) (if vars (setq *venv* (apply #'vector (nconc (mapcan #'(lambda (v) (declare (source nil)) (list v nil)) vars) (list *venv*)))))) ;; Adds SPECIAL-Declarations at the beginning of a Body to *venv* . (defun %expand-special-declarations (body) (multiple-value-bind (body-rest declarations) (sys::parse-body body) (declare (ignore body-rest)) ; do not throw away declarations! (let ((specials nil)) (mapc #'(lambda (declspec) (declare (source nil)) (if (and (consp declspec) (null (cdr (last declspec)))) (if (eq (car declspec) 'SPECIAL) (mapc #'(lambda (x) (declare (source nil)) (if (symbolp x) (setq specials (cons x specials)))) (cdr declspec))))) (nreverse declarations)) (setq specials (nreverse specials)) (%expand-lexical-variables specials) ; specdecl doesn't matter here specials))) ;; expands a function-name, that is a Cons (that must be a ;; Lambda-Expression). returns 2 values. (defun %expand-lambda (l) (unless (eq (first l) 'lambda) (error-of-type 'source-program-error :form %whole-form :detail l (TEXT "~S: ~S should be a lambda expression") '%expand-form l)) (multiple-value-call #'%expand-cons l 'lambda nil ; LAMBDA (%expand-lambdabody (rest l)))) ;; expands the CDR of a Lambda-Expression, a (lambdalist . body). ;; returns 2 values. (defun %expand-lambdabody (lambdabody &optional name blockp) (let ((body (rest lambdabody))) (if (and (consp body) (let ((form (car body))) (and (consp form) (eq (car form) 'DECLARE) (let ((declspecs (cdr form))) (and (consp declspecs) (let ((declspec (car declspecs))) (and (consp declspec) (eq (car declspec) 'SOURCE)))))))) (values lambdabody nil) ; already expanded -> leave untouched (let ((*venv* *venv*)) (if blockp (setq lambdabody (add-implicit-block name lambdabody))) (values (list* (%expand-lambdalist (first lambdabody)) (list 'DECLARE (list 'SOURCE lambdabody)) (%expand-list (rest lambdabody))) t))))) ;; expands a Lambda-list. returns 2 values. (defun %expand-lambdalist (ll) (if (atom ll) (if ll (error-of-type 'source-program-error :form %whole-form :detail ll (TEXT "lambda list must not end with the atom ~S") ll) (values nil nil)) (multiple-value-call #'%expand-cons ll (%expand-parspez (first ll)) (progn (let ((v (first ll))) (if (not (memq v lambda-list-keywords)) (setq *venv* (vector (%expand-varspec-var v) nil *venv*)))) (%expand-lambdalist (rest ll)))))) ;; expands an element of a lambda-list. returns 2 values. ;; (expands only on lists, and then only the second element.) (defun %expand-parspez (ps) (if (or (atom ps) (atom (rest ps))) (values ps nil) (multiple-value-call #'%expand-cons ps (first ps) nil (multiple-value-call #'%expand-cons (rest ps) (%expand-form (second ps)) (cddr ps) nil)))) ;; expand a Variable-list for LET. returns 2 values. (defun %expand-varspez (vs &optional (nvenv nil)) (if (atom vs) (if vs (error-of-type 'source-program-error :form %whole-form :detail vs (TEXT "~S: variable list ends with the atom ~S") 'let vs) (progn (setq *venv* (apply #'vector (nreverse (cons *venv* nvenv)))) (values nil nil))) (multiple-value-call #'%expand-cons vs (%expand-parspez (first vs)) ; For List: Expand 2nd Element (%expand-varspez (rest vs) (list* nil (%expand-varspec-var (first vs)) nvenv))))) ;; expands a Variable-list for LET*. returns 2 values. (defun %expand-varspez* (vs) (if (atom vs) (if vs (error-of-type 'source-program-error :form %whole-form :detail vs (TEXT "~S: variable list ends with the atom ~S") 'let* vs) (values nil nil)) (multiple-value-call #'%expand-cons vs (%expand-parspez (first vs)) ; for list: expand 2nd Element (progn (setq *venv* (vector (%expand-varspec-var (first vs)) nil *venv*)) (%expand-varspez* (rest vs)))))) (defun %expand-varspec-var (varspec) (if (atom varspec) varspec (first varspec))) (defun %expand-varspec-val (varspec) (if (atom varspec) nil (eval (second varspec)))) ;; expands a cond-clause-list. returns 2 values. (defun %expand-cond (clauses) (if (atom clauses) (values clauses nil) (multiple-value-call #'%expand-cons clauses (%expand-list (first clauses)) (%expand-cond (rest clauses))))) ;; expands a case-clause-list. returns 2 values. (defun %expand-case (clauses) (if (atom clauses) (values clauses nil) (multiple-value-call #'%expand-cons clauses (multiple-value-call #'%expand-cons (first clauses) (caar clauses) nil (%expand-list (cdar clauses))) (%expand-case (rest clauses))))) ;; Apply the following to the already expanded body: ;; (%return-p name list) determines, if the form-list list contains ;; a (RETURN-FROM name ...) somewhere. (defun %return-p (name body) (block return-p (tagbody 1 (if (atom body) (return-from return-p nil)) (let ((form (car body))) (if ; determine, if form contains a (RETURN-FROM name ...) : (and (consp form) (not (eq (first form) 'quote)) (or (and (eq (first form) 'return-from) ; (RETURN-FROM name ...) (eq (second form) name)) (and (consp (first form)) ; lambda-list (%return-p name (first form))) (and (not ; no new definition of the same block ? (and (eq (first form) 'block) (eq (second form) name))) (%return-p name (rest form))))) ; function call (return-from return-p t))) (setq body (cdr body)) (go 1)))) (defun %expand-varlist-macrop (l) (and (consp l) (or (and (symbolp (car l)) (symbol-macro-p (venv-assoc (car l) *venv*))) (%expand-varlist-macrop (cdr l))))) (defun %expand-setqlist-macrop (l) (and (consp l) (consp (cdr l)) (or (and (symbolp (car l)) (symbol-macro-p (venv-assoc (car l) *venv*))) (%expand-setqlist-macrop (cddr l))))) (defun %expand-setqlist (l) (if (or (atom l) (atom (cdr l))) (values l nil) (multiple-value-call #'%expand-cons l (first l) nil (multiple-value-call #'%expand-cons (rest l) (%expand-form (second l)) (%expand-setqlist (cddr l)))))) ;; (%expand-tagbody list) expands the elements of a list ;; and leaves atoms, that are created meanwhile, untouched. ;; (thus no new tags are created that could hide other tags). ;; returns 2 values. (defun %expand-tagbody (body) (cond ((atom body) (values body nil)) ((atom (first body)) (multiple-value-call #'%expand-cons body (first body) nil (%expand-tagbody (rest body)))) (t (multiple-value-bind (exp flag) (%expand-form (first body)) (if (atom exp) (values (%expand-tagbody (rest body)) t) ; omit (multiple-value-call #'%expand-cons body exp flag (%expand-tagbody (rest body)))))))) ;; returns a list (name1 nil ... namek nil *fenv*) (defun %expand-fundefs-1 (fundefs) (if (atom fundefs) (if fundefs (error-of-type 'source-program-error :form %whole-form :detail fundefs (TEXT "FLET/LABELS: code contains a dotted list, ending with ~S") fundefs) (list *fenv*)) (let ((fundef (car fundefs))) (if (and (consp fundef) (function-name-p (car fundef)) (consp (cdr fundef))) (list* (car fundef) nil (%expand-fundefs-1 (cdr fundefs))) (illegal-syntax fundef "FLET/LABELS"))))) ;; (%expand-fundefs-2 fundefs) expands a function-definition-list, ;; like in FLET, LABELS. returns 2 values. (defun %expand-fundefs-2 (fundefs) (if (atom fundefs) (values fundefs nil) (let ((fundef (car fundefs))) (multiple-value-call #'%expand-cons fundefs (multiple-value-call #'%expand-cons fundef (car fundef) nil (%expand-lambdabody (cdr fundef) (car fundef) t)) (%expand-fundefs-2 (rest fundefs)))))) ;; returns a list (name1 nil ... namek nil *fenv*) (defun %expand-funmacdefs-1 (funmacdefs) (if (atom funmacdefs) (if funmacdefs (error-of-type 'source-program-error :form %whole-form :detail funmacdefs (TEXT "FUNCTION-MACRO-LET: code contains a dotted list, ending with ~S") funmacdefs) (list *fenv*)) (let ((funmacdef (car funmacdefs))) (if (and (consp funmacdef) (symbolp (car funmacdef)) (consp (cdr funmacdef)) (consp (second funmacdef)) (consp (cddr funmacdef)) (consp (third funmacdef)) (null (cdddr funmacdef))) (list* (car funmacdef) nil (%expand-funmacdefs-1 (cdr funmacdefs))) (illegal-syntax funmacdef 'FUNCTION-MACRO-LET))))) ;; (%expand-funmacdefs-2 funmacdefs) expands a function-macro- ;; definition-list, like in FUNCTION-MACRO-LET. returns 2 values. (defun %expand-funmacdefs-2 (funmacdefs) (if (atom funmacdefs) (values funmacdefs nil) (let ((funmacdef (car funmacdefs))) (multiple-value-call #'%expand-cons funmacdefs (multiple-value-call #'%expand-cons funmacdef (car funmacdef) nil (multiple-value-call #'%expand-cons (cdr funmacdef) (%expand-lambdabody (cadr funmacdef)) (multiple-value-call #'%expand-cons (cddr funmacdef) (let ((*venv* nil) (*fenv* nil)) (%expand-lambdabody (caddr funmacdef))) (cdddr funmacdef) nil))) (%expand-funmacdefs-2 (rest funmacdefs)))))) ;; expands (lambdalist . body) in a given function-environment. ;; Is called by GET_CLOSURE. (defun %expand-lambdabody-main (lambdabody *venv* *fenv*) (%expand-lambdabody lambdabody)) (VALUES) ) ;; from now on, FUNCTION is operational, ;; as long as no MACROLET occurs within it. (PROGN (proclaim '(special *load-paths*)) ; defined in spvw.d (proclaim '(special *source-file-types*)) (setq *source-file-types* '("lisp" "lsp" "cl")) (proclaim '(special *internal-compiled-file-type*)) (setq *internal-compiled-file-type* "fas") (proclaim '(special *compiled-file-types*)) (setq *compiled-file-types* (list *internal-compiled-file-type*)) ;; for the time being the files don't have to be searched: (sys::%putd 'search-file (sys::make-preliminary (function search-file (lambda (filename &optional extensions (keep-dirs t)) (declare (ignore keep-dirs)) (mapcan #'(lambda (directory) (let ((directory (pathname-directory directory))) (mapcan #'(lambda (extension) (let ((filename (merge-pathnames filename (make-pathname :directory directory :type extension)))) (if (probe-file filename) (list filename) '()))) extensions))) (cons #"" *load-paths*)))))) (proclaim '(special *compile-verbose*)) (setq *compile-verbose* t) ; defined in spvw.d (proclaim '(special *load-verbose*)) (setq *load-verbose* t) ; defined in spvw.d (proclaim '(special *load-print*)) (setq *load-print* nil) ; defined in spvw.d (proclaim '(special *load-echo*)) (setq *load-echo* nil) ; defined in spvw.d (proclaim '(special *load-compiling*)) (setq *load-compiling* nil) ; defined in spvw.d (proclaim '(special *load-pathname*)) (setq *load-pathname* nil) (proclaim '(special *load-input-stream*)) (setq *load-input-stream* nil) (proclaim '(special *load-level*)) (setq *load-level* 0) (proclaim '(special *load-obsolete-action*)) (setq *load-obsolete-action* nil) #+ffi ; the default :language for DEF-CALL-* & C-FUNCTION -- see foreign1.lisp (proclaim '(special ffi::*foreign-language*)) #+ffi (setq ffi::*foreign-language* nil) #+ffi ; default :LIBRARY argument for DEF-CALL-OUT and DEF-C-VAR (proclaim '(special ffi::*foreign-library*)) #+ffi (setq ffi::*foreign-library* nil) ;; preliminary; needed here for open-for-load (sys::%putd 'warn (sys::make-preliminary (function warn (lambda (format-string &rest args) (fresh-line *error-output*) (write-string (TEXT "WARNING:") *error-output*) (terpri *error-output*) (apply #'format *error-output* format-string args) (elastic-newline *error-output*) nil)))) ;; preliminary definition of warn-of-type for CLOS before CLCS (sys::%putd 'warn-of-type (sys::make-preliminary (function warn-of-type (lambda (type format-string &rest args) (declare (ignore type)) (apply #'warn format-string args))))) (unless (fboundp 'ext::muffle-cerrors) ; predef for bootstrap (sys::%putd 'ext::muffle-cerrors #'identity)) (defun open-for-load (filename extra-file-types external-format ignore-pathname-defaults &aux stream (present-files t) obj path bad-file) (block open-for-load (when (and (streamp filename) (open-stream-p filename) (input-stream-p filename)) (return-from open-for-load (values filename filename))) (labels ((compiledp (name) (member (pathname-type name) *compiled-file-types* :test #'string=)) (my-open (name) (open name :direction :input-immutable :element-type 'character #+UNICODE :external-format #+UNICODE (if (compiledp name) charset:utf-8 external-format) :if-does-not-exist nil)) (bad (error-p stream message) (sys::built-in-stream-close stream) (when (eq *load-obsolete-action* :delete) (delete-file stream)) (setq bad-file (pathname stream)) (if error-p (error-of-type 'file-error :pathname (pathname stream) message 'load (pathname stream)) (warn message 'load (pathname stream)))) (check-compiled-file (stream last-p obj) (and (or (and (consp obj) (eq (car obj) 'system::version)) (bad last-p stream (TEXT "~S: compiled file ~A lacks a version marker"))) (or (= 2 (length obj)) (bad last-p stream (TEXT "~S: compiled file ~A has a corrupt version marker ~S"))) (or (equal (system::version) (eval (second obj))) (bad last-p stream (TEXT "~S: compiled file ~A was created by an older CLISP version and needs to be recompiled")))))) (setq filename (if ignore-pathname-defaults (pathname filename) (merge-pathnames filename)) path filename) ;; (OPEN "foo") errors out if we do (LOAD "foo") ;; and both "foo.lisp" and "foo/" are present (let ((truename? (probe-pathname path))) (unless (and truename? (null (pathname-name truename?))) (setq stream (my-open path)))) (tagbody proceed (when (and stream (if (compiledp stream) (check-compiled-file stream (or (eq *load-obsolete-action* :error) (eq present-files t) (cdr present-files)) (setq obj #+compiler ; normal operation; handler-bind works (block nil (handler-bind ((error (lambda (c) (return c)))) (read stream))) #-compiler (read stream))) ; bootstrap #+compiler (if (and bad-file (eq *load-obsolete-action* :compile)) ;; assume that BAD-FILE was compiled from STREAM (let ((compiled-file ; try to compile (compile-file stream :output-file bad-file))) (if compiled-file ; ==> compiled-file == bad-file (progn (sys::built-in-stream-close stream) (setq stream (my-open compiled-file) path compiled-file)) ;; compilation failed - try to load the source stream)) stream) #-compiler stream)) (return-from open-for-load (values stream path))) (when (eq present-files t) ;; File with precisely this name not present OR bad ;; Search among the files the most recent one ;; with the same name and the Extensions "LISP", "FAS": (setq present-files (ext::muffle-cerrors ; ignore encoding errors in DIRECTORY (search-file filename (append extra-file-types *compiled-file-types* *source-file-types*) nil)))) (if present-files ;; proceed with the next present file (setq path (car present-files) present-files (cdr present-files) stream (my-open path)) (if stream ;; bad compiled STREAM, nowhere else to look ==> die (check-compiled-file stream t obj) ;; no file - return NIL (return-from open-for-load (values nil filename)))) (go proceed))))) ;; in theory this is a good idea: ;; (proclaim '(inline eval-loaded-form-low)) ;; unfortunately, when condition.lisp is compiled, ;; this function is not necessarily already compiled ;; due to our bootstrapping process, ;; so it will not be inlined there (in eval-loaded-form), ;; therefore the "test" target (self-recompilation) will fail (defun eval-loaded-form-low (obj) (multiple-value-list (cond ((compiled-function-p obj) ;; assume that this is a top-level form compiled by COMPILE-FILE ;; then its name starts with the source file line numbers -- ;; extract them and put into *current-source-line-[12]* (let ((name (and (closurep obj) (symbol-name (closure-name obj))))) (multiple-value-bind (l1 pos) (parse-integer name :junk-allowed t) (when l1 (let ((l2 (parse-integer name :junk-allowed t :start pos))) (when l2 (setq *current-source-line-1* l1 *current-source-line-2* l2)))))) (funcall obj)) (*load-compiling* (funcall (compile-form-in-toplevel-environment obj))) (t (eval obj))))) ;; redefined in condition.lisp (proclaim '(notinline eval-loaded-form)) (sys::%putd 'eval-loaded-form (sys::make-preliminary (function eval-loaded-form (lambda (obj file) (declare (ignore file)) (eval-loaded-form-low obj))))) (defun loading-message (format &rest arguments) (when *load-verbose* (fresh-line) (write-string ";;") (write-spaces *load-level*) (apply #'format t format arguments) (elastic-newline))) ;; (LOAD filename [:verbose] [:print] [:if-does-not-exist] [:external-format] ;; [:echo] [:compiling] [:extra-file-types] [:obsolete-action]), ;; CLTL p. 426 (defun load (filename &key ((:verbose *load-verbose*) *load-verbose*) ((:print *load-print*) *load-print*) (if-does-not-exist t) (external-format ':default) ((:echo *load-echo*) *load-echo*) ((:compiling *load-compiling*) *load-compiling* c-top) ((:obsolete-action *load-obsolete-action*) *load-obsolete-action*) (extra-file-types '()) (ignore-pathname-defaults nil) &aux stream) (multiple-value-setq (stream filename) (open-for-load filename extra-file-types external-format ignore-pathname-defaults)) (if (null stream) (if if-does-not-exist (error-of-type 'file-error :pathname filename (TEXT "~S: A file with name ~A does not exist") 'load filename) nil) (let* ((input-stream (if *load-echo* (make-echo-stream stream *standard-output*) stream)) (*load-level* (1+ *load-level*)) (*load-input-stream* input-stream) (*load-pathname* (if (pathnamep filename) filename nil)) (*load-truename* (if (pathnamep filename) (truename filename) nil)) (*current-source-file* *load-truename*) (*current-source-line-1* nil) (*current-source-line-2* nil) #+ffi (ffi::*foreign-language* ffi::*foreign-language*) #+ffi (ffi::*foreign-library* ffi::*foreign-library*) (*package* *package*) ; bind *PACKAGE* (*readtable* *readtable*) ; bind *READTABLE* (*c-error-output* *error-output*) ; for compiling (eof-indicator input-stream)) (loading-message (TEXT "Loading file ~A ...") filename) (when *load-compiling* (sys::c-reset-globals)) ;; see `with-compilation-unit' -- `:compiling' sets a compilation unit ;; the user might set `*load-compiling*' to T either directly ;; or using the -C option, so we have to check that ;; `*error-output*' et al are already bound (progv (when (and *load-compiling* (or c-top (not (boundp '*error-count*)))) '(*error-count* *warning-count* *style-warning-count*)) '(0 0 0) (unwind-protect (tagbody proceed (when *load-echo* (fresh-line)) (peek-char t input-stream nil eof-indicator) (setq *current-source-line-1* (line-number input-stream)) (let ((obj (read input-stream nil eof-indicator)) res) (setq *current-source-line-2* (line-number input-stream)) (when (eql obj eof-indicator) (go done)) (tagbody ext::retry ; exported in condition.lisp (case (setq res (eval-loaded-form obj *load-truename*)) (skip (go proceed)) (ext::retry (go ext::retry)) (stop (go done)))) (when *load-print* (when res (fresh-line) (prin1 (first res)) (elastic-newline)))) (go proceed) done) (or (eq input-stream stream) (sys::built-in-stream-close input-stream)) (or (eq stream filename) (sys::built-in-stream-close stream)) (when (and *load-compiling* *load-verbose* *compile-verbose*) (c-report-problems)))) (loading-message (TEXT "Loaded file ~A") filename) ;; filename could be a non-file stream, so (truename filename) is unsafe (or *load-truename* filename)))) (let ((sys::*current-source-file* "init")) (sys::check-redefinition 'load 'defun nil)) (sys::%putd 'defun ; preliminary: (sys::make-macro (function defun (lambda (form env) (declare (ignore env)) (unless (and (consp (cdr form)) (consp (cddr form))) (error-of-type 'source-program-error :form form :detail form (TEXT "~S: missing function name and/or parameter list") 'defun)) (let ((name (cadr form)) (lambdalist (caddr form)) (body (cdddr form))) (setq name (check-symbol name 'defun)) (when (special-operator-p name) (error-of-type 'source-program-error :form form :detail name (TEXT "~S: special operator ~S cannot be redefined.") 'defun name)) (multiple-value-bind (body-rest declarations) (sys::parse-body body t) #| `(PROGN (SYS::%PUT ',name 'SYS::DEFINITION (CONS ',form (THE-ENVIRONMENT))) (SYS::%PUTD ',name (FUNCTION ,name (LAMBDA ,lambdalist (DECLARE (SYS::IN-DEFUN ,name) ,@declarations) (BLOCK ,name ,@body-rest)))) ',name) |# (list 'progn (list 'sys::%put (list 'quote name) ''sys::definition (list 'cons (list 'quote form) '(the-environment))) (list 'sys::%putd (list 'quote name) (list 'FUNCTION name (list 'LAMBDA lambdalist (list* 'DECLARE (list 'SYS::IN-DEFUN name) declarations) (list* 'BLOCK name body-rest)))) (list 'quote name)))))) '(function-name lambda-list &body forms))) (sys::%putd 'do ; preliminary definition of the macro DO (sys::make-macro (function do (lambda (form env) (declare (ignore env)) (let ((varclauselist (second form)) (exitclause (third form)) (body (cdddr form))) (when (atom exitclause) (error-of-type 'source-program-error :form form :detail exitclause (TEXT "exit clause in ~S must be a list") 'do)) (let ((bindlist nil) (reinitlist nil) (bodytag (gensym)) (exittag (gensym))) (multiple-value-bind (body-rest declarations) (sys::parse-body body) (block do (tagbody 1 (when (atom varclauselist) (return-from do #| `(block nil (let ,(nreverse bindlist) (declare ,@declarations) (tagbody (go ,exittag) ,bodytag ,@body-rest (psetq ,@(nreverse reinitlist)) ,exittag (or ,(first exitclause) (go ,bodytag)) (return-from nil (progn ,@(rest exitclause)))))) |# (list 'block 'nil (list 'let (nreverse bindlist) (cons 'declare declarations) (list* 'tagbody (list 'go exittag) bodytag (append body-rest (list (cons 'psetq (nreverse reinitlist)) exittag (list 'or (first exitclause) (list 'go bodytag)) (list 'return-from 'nil (cons 'progn (rest exitclause)))))))))) (let ((varclause (first varclauselist))) (setq varclauselist (rest varclauselist)) (cond ((atom varclause) (setq bindlist (cons varclause bindlist))) ((atom (cdr varclause)) (setq bindlist (cons (first varclause) bindlist))) ((atom (cddr varclause)) (setq bindlist (cons varclause bindlist))) (t (setq bindlist (cons (list (first varclause) (second varclause)) bindlist)) (setq reinitlist (list* (third varclause) (first varclause) reinitlist))))) (go 1)))))))) '((&body var-init-step-forms) (end-test-form &body result-forms) &body statements))) (sys::%putd 'dotimes ; preliminary Definition of the Macro DOTIMES (sys::make-macro (function dotimes (lambda (form env) (declare (ignore env)) (let ((var (first (second form))) (countform (second (second form))) (resultform (third (second form))) (body (cddr form))) (multiple-value-bind (body-rest declarations) (sys::parse-body body) (let ((g (gensym))) #| `(DO ((,var 0 (1+ ,var)) (,g ,countform)) ((>= ,var ,g) ,resultform) (declare ,@declarations) ,@body-rest) |# (list* 'do (list (list var '0 (list '1+ var)) (list g countform)) (list (list '>= var g) resultform) (cons 'declare declarations) body-rest)))))) '((var count-form &optional result-form) &body statements))) (VALUES) ) ;; from now on LOAD, DEFUN, DO, DOTIMES are operational (with limitations) . (LOAD "defseq") ; Definitions of Standard-Sequences (LOAD "backquote") ; backquote readmacro ;; from now on Backquote is operational (LOAD "defmacro") ;; from now on FUNCTION is operational (without limitations). (PROGN (sys::%putd 'sys::maybe-arglist ; arglist if permitted by compiler optimizations (function sys::maybe-arglist (lambda (arglist) (if (and sys::*compiling* (< 2 (sys::declared-optimize 'space))) 0 arglist)))) (sys::%putd 'defmacro (sys::%putd 'sys::predefmacro ; predefmacro means "preliminary defmacro" (sys::make-macro (function defmacro (lambda (form env) (declare (ignore env)) (let ((preliminaryp (eq (car form) 'sys::predefmacro))) (multiple-value-bind (expansion expansion-lambdabody name lambdalist docstring) (sys::make-macro-expansion (cdr form) form) (declare (ignore expansion-lambdabody docstring)) `(LET () (EVAL-WHEN ,(if preliminaryp '(LOAD EVAL) '(COMPILE LOAD EVAL)) (SYSTEM::REMOVE-OLD-DEFINITIONS ',name ,@(if preliminaryp '('T))) (SYSTEM::%PUTD ',name (SYSTEM::MAKE-MACRO ,(if preliminaryp `(SYSTEM::MAKE-PRELIMINARY ,expansion) expansion) ',(sys::maybe-arglist lambdalist)))) (EVAL-WHEN (EVAL) (SYSTEM::%PUT ',name 'SYSTEM::DEFINITION (CONS ',form (THE-ENVIRONMENT)))) ',name))))) '(macro-name macro-lambda-list &body forms)))) (let ((sys::*current-source-file* "init")) (sys::check-redefinition 'defmacro 'defmacro nil)) #-compiler (predefmacro SYS::EVAL-WHEN-COMPILE (&body body) ; preliminary `(eval-when (compile) ,@body)) ;; return 2 values: ordinary lambda list and reversed list of type declarations (sys::%putd 'sys::specialized-lambda-list-to-ordinary (function sys::specialized-lambda-list-to-ordinary (lambda (spelalist caller) (multiple-value-bind (lalist speclist) #+clos (clos::decompose-specialized-lambda-list spelalist (clos::program-error-reporter caller)) #-clos (copy-list spelalist) ; pacify "make check-recompile" (values lalist ; MAPCAN needs a LAMBDA which leads to infinite recursion (let ((decls '())) (block spelalist-to-ordinary (tagbody start (when (null lalist) (return-from spelalist-to-ordinary decls)) (when (null speclist) (return-from spelalist-to-ordinary decls)) (let ((arg (car lalist)) (spec (car speclist))) (if (not (eq spec 'T)) (setq decls (cons (list spec arg) decls)))) (setq lalist (cdr lalist) speclist (cdr speclist)) (go start))))))))) (sys::%putd 'defun (sys::%putd 'sys::predefun ; predefun means "preliminary defun" (sys::make-macro (function defun (lambda (form env) (if (atom (cdr form)) (error-of-type 'source-program-error :form form :detail (cdr form) (TEXT "~S: cannot define a function from that: ~S") (car form) (cdr form))) (unless (function-name-p (cadr form)) (error-of-type 'source-program-error :form form :detail (cadr form) (TEXT "~S: the name of a function must be a symbol, not ~S") (car form) (cadr form))) (if (atom (cddr form)) (error-of-type 'source-program-error :form form :detail (cddr form) (TEXT "~S: function ~S is missing a lambda list") (car form) (cadr form))) (let ((preliminaryp (eq (car form) 'sys::predefun)) (name (cadr form)) (lambdalist (caddr form)) (body (cdddr form))) (multiple-value-bind (body-rest declarations docstring) (sys::parse-body body t) (when *defun-accept-specialized-lambda-list* (multiple-value-bind (lalist decl-list) (sys::specialized-lambda-list-to-ordinary lambdalist (car form)) (setq lambdalist lalist declarations (nreconc decl-list declarations)))) (let ((symbolform (if (atom name) `',name `(LOAD-TIME-VALUE (GET-SETF-SYMBOL ',(second name))))) (lambdabody `(,lambdalist ,@(if docstring `(,docstring) '()) (DECLARE (SYS::IN-DEFUN ,name) ,@declarations) (BLOCK ,(function-block-name name) ,@body-rest)))) `(LET () (SYSTEM::REMOVE-OLD-DEFINITIONS ,symbolform ,@(if preliminaryp '('T))) ,@(if ; Is name declared inline? (if (and sys::*compiling* sys::*compiling-from-file*) (member name sys::*inline-functions* :test #'equal) (eq (get (get-funname-symbol name) 'inlinable) 'inline)) ;; Is the lexical environment the top-level environment? ;; If yes, save the lambdabody for inline compilation. (if sys::*compiling* (if (and (null sys::*venv*) (null sys::*fenv*) (null sys::*benv*) (null sys::*genv*) (eql sys::*denv* *toplevel-denv*)) `((SYS::EVAL-WHEN-COMPILE (SYS::C-DEFUN ',name (lambda-list-to-signature ',lambdalist) ',lambdabody)) (EVAL-WHEN (LOAD) (SYSTEM::%PUT ,symbolform 'SYSTEM::INLINE-EXPANSION ',lambdabody))) `((SYS::EVAL-WHEN-COMPILE (SYS::C-DEFUN ',name (lambda-list-to-signature ',lambdalist))))) (if (and (null (svref env 0)) ; venv (null (svref env 1))) ; fenv `((EVAL-WHEN (EVAL) (LET ((%ENV (THE-ENVIRONMENT))) (IF (AND (NULL (SVREF %ENV 0)) ; venv (NULL (SVREF %ENV 1)) ; fenv (NULL (SVREF %ENV 2)) ; benv (NULL (SVREF %ENV 3)) ; genv (EQL (SVREF %ENV 4) *TOPLEVEL-DENV*)) ; denv (SYSTEM::%PUT ,symbolform 'SYSTEM::INLINE-EXPANSION ',lambdabody))))) '())) `((SYS::EVAL-WHEN-COMPILE (SYS::C-DEFUN ',name (lambda-list-to-signature ',lambdalist))))) (SYSTEM::%PUTD ,symbolform ,(if preliminaryp `(SYSTEM::MAKE-PRELIMINARY (FUNCTION ,name (LAMBDA ,@lambdabody))) `(FUNCTION ,name (LAMBDA ,@lambdabody)))) (EVAL-WHEN (EVAL) (SYSTEM::%PUT ,symbolform 'SYSTEM::DEFINITION (CONS ',form (THE-ENVIRONMENT)))) ',name)))))) '(function-name lambda-list &body forms)))) (let ((sys::*current-source-file* "init")) (sys::check-redefinition 'defun 'defmacro nil)) ;; see condition.lisp for the final definition (predefun check-not-declaration (symbol caller) (check-symbol symbol caller)) (VALUES) ) ;; from now on DEFMACRO and DEFUN are operational. (in-package "SYSTEM") (LOAD "macros1") ; control-structure - macros (LOAD "macros2") ; further macros (LOAD "defs1") ; definitions for symbols, numbers, characters, time #-(or UNIX WIN32) (LOAD "timezone") ; Definition of the time zone (LOAD "lambdalist") ; parsing ordinary lambda lists (LOAD "places") ; SETF-places: definitions and macros ;; from now on SETF etc. are working. (LOAD "floatprint") ; output of floating-points (LOAD "defpackage") ; DEFPACKAGE (LOAD "type") ; TYPEP (LOAD "clos-package") ; Early CLOS (LOAD "clos-macros") (LOAD "clos-class0") (LOAD "clos-metaobject1") (LOAD "clos-slotdef1") (LOAD "clos-stablehash1") (LOAD "clos-specializer1") (LOAD "clos-class1") (LOAD "clos-class2") (LOAD "clos-class3") (LOAD "defstruct") ; DEFSTRUCT-macro (LOAD "format") ; FORMAT ;; from now on FORMATTER is working. (LOAD "international") ; internationalization (in-package "SYSTEM") ;; A piece of "DO-WHAT-I-MEAN": ;; Searches for a program file. ;; We search in the current directory and then in the directories ;; listed in *load-paths*. ;; If an extension is specified in the filename, we search only for ;; files with this extension. If no extension is specified, we additionally ;; search for files with an extension from the given list. ;; The return value is a list of all matching files from the FIRST directory ;; [because otherwise every load will mean a full traversal of ~/lisp/**/] ;; containing any matching file, sorted according to decreasing FILE-WRITE-DATE ;; (i.e. from new to old), or NIL if no matching file was found. ;; The file names are NOT truenames, this is important so that symlinks ;; are compiled into the target directory, not the original one. ;; If the searched filename is a directory, the directory pathname ;; is returned, NOT its contents. (defun ppn-fwd (f keep-dirs) ; probe-pathname + file-write-date (multiple-value-bind (true-name phys-name fwd) (probe-pathname f) (when (and true-name (or keep-dirs (pathname-name true-name))) (cons phys-name fwd)))) (defun search-file (filename &optional extensions (keep-dirs t)) ;; ;; ;; ;; we use DIRECTORY only for *LOAD-PATHS* elements with wild components ;; to avoid the denial-of-service attack whereas a file in $HOME ;; with a name incompatible with *PATHNAME-ENCODING* prevents CLISP from ;; starting up (unless -norc or -E 1:1 is passed) ;; because (DIRECTORY "~/*") fails (let* ((already-searched nil) found ;; not (merge-pathnames filename) because filename can come ;; from `load-logical-pathname-translations' or `require' ;; and must be searched in "implementation-defined" locations ;; while `*default-pathname-defaults*' may contain a directore ;; which would preclude searching (path-nonW (pathname filename)) (path-wild (if (pathname-name path-nonW) (merge-pathnames path-nonW '#P"*.*") ;; do not append *.* to directories path-nonW)) (use-extensions (null (pathname-type path-nonW)))) (dolist (dir (cons '#P"" ;; when filename has "..", ignore *load-paths* ;; (to avoid errors with "**/../foo"): (if (memq :UP (pathname-directory path-nonW)) '() (mapcar #'pathname *load-paths*)))) (let* ((wild-p (wild-pathname-p dir)) (search-filename (merge-pathnames (if wild-p path-wild path-nonW) dir))) (unless (member search-filename already-searched :test #'equal) (push search-filename already-searched) (let ((xpathnames (if wild-p (nconc (directory search-filename :full t :circle t :if-does-not-exist :ignore) (and (eq :wild (pathname-type search-filename)) (nconc (directory (make-pathname :type nil :defaults search-filename) :if-does-not-exist :ignore :full t :circle t) (directory (make-pathname :type nil :name nil :directory (append (pathname-directory search-filename) (list (pathname-name search-filename))) :defaults search-filename) :if-does-not-exist :ignore :full t :circle t)))) (let ((f (ppn-fwd search-filename keep-dirs)) (e (and use-extensions extensions (mapcan #'(lambda (ext) (let ((f (ppn-fwd (make-pathname :type ext :defaults search-filename) keep-dirs))) (and f (list f)))) extensions)))) (if f (cons f e) e))))) (when wild-p (when (and use-extensions extensions) ; filter the extensions (setq xpathnames (delete-if-not #'(lambda (xpathname) (let ((ext (pathname-type (first xpathname)))) (or (null ext) ; no extension - good! (member ext extensions :test #+WIN32 #'string-equal #-WIN32 #'string=)))) xpathnames)))) (when xpathnames (setq found (if wild-p (dolist (xpathname xpathnames xpathnames) (setf (rest xpathname) (apply #'encode-universal-time (third xpathname)))) xpathnames)) (return)))))) (mapcar #'car (sort (delete-duplicates found :test #'equal) #'> :key #'cdr)))) (LOAD "room") ; room, space ;; preliminary definition of CERROR, CLtL2 p. 887 (predefun cerror (continue-format-string error-format-string &rest args) (if *error-handler* (apply *error-handler* (or continue-format-string t) error-format-string args) (progn (fresh-line *error-output*) (write-string "** - " *error-output*) (write-string (TEXT "Continuable Error") *error-output*) (terpri *error-output*) (apply #'format *error-output* error-format-string args) (elastic-newline *error-output*) (fresh-line *debug-io*) (if (interactive-stream-p *debug-io*) (progn (write-string (TEXT "If you continue (by typing 'continue'): ") *debug-io*) (apply #'format *debug-io* continue-format-string args) (initial-break-driver t)) (progn (apply #'format *debug-io* continue-format-string args) (elastic-newline *debug-io*)))))) (LOAD "functions") ; function objects (LOAD "trace") ; TRACE (load "cmacros") ; compiler macros (LOAD "compiler") ; compiler (LOAD "defs2") ; CLtL2-definitions, optional (LOAD "loop") ; CLtL2/ANSI-CL-LOOP, optional (LOAD "clos") ; CLOS (LOAD "gray") ; STREAM-DEFINITION-BY-USER:GENERIC-FUNCTIONS (LOAD "fill-out") ; FILL-OUTPUT-STREAM (for condition & describe) (LOAD "disassem") ; Disassembler (LOAD "condition") ; Conditions (load "loadform") ; `make-load-form' ;; At this point the core Common Lisp is complete. #+mt (load "threads") ; Multi-Threading ;; Fancy streams: #+generic-streams (LOAD "gstream") ; generic streams, optional (LOAD "xcharin") ; extended character input, optional (LOAD "keyboard") ; keyboard stream, optional #+SCREEN (LOAD "screen") ; screen-package, optional ;; Environmental facilities: #+sockets (use-package '("SOCKET") "EXT") #+sockets (in-package "SOCKET") #+sockets (common-lisp:export '(socket-server socket-server-close socket-server-port socket-server-host socket-accept socket-wait socket-status socket-connect socket-options socket-stream-host socket-stream-port socket-stream-peer socket-stream-local) "SOCKET") #+sockets (ext:re-export "SOCKET" "EXT") (common-lisp:in-package "SYSTEM") (LOAD "runprog") ; run-program and friends, optional ;; User interface: (LOAD "query") ; querying the user (LOAD "reploop") ; prompt, debugger, stepper (LOAD "savemem") ; saveinitmem (LOAD "dribble") ; dribble (load "pprint") ; pretty printer (LOAD "describe") ; apropos, describe (LOAD "edit") ; edit-file, ed, uncompile (LOAD "clhs") ; HyperSpec access (load "inspect") ; inspector ;; Random extensions: (LOAD "macros3") ; more macros, optional (LOAD "complete") ; gnu readline completion (requires macros3) (LOAD "case-sensitive") ; case-sensitive packages #+FFI ; when (find-package "FFI") (LOAD "foreign1") ; foreign function interface, optional (LOAD "exporting") ; auto-exporting defining macros #+(and GETTEXT UNICODE) (LOAD "danish") ; Danish messages #+(and GETTEXT UNICODE) (LOAD "german") ; German messages #+(and GETTEXT UNICODE) (LOAD "french") ; French messages #+(and GETTEXT UNICODE) (LOAD "spanish") ; Spanish messages #+(and GETTEXT UNICODE) (LOAD "dutch") ; Dutch messages #+(and GETTEXT UNICODE) (LOAD "russian") ; Russian messages (load "deprecated") ; the deprecated functionality -- optional (LOAD "config") ; configuration parameters to be adjusted by the user (setq *defun-accept-specialized-lambda-list* t);was disabled for bootstrapping (setq sys::*home-package* nil ext:*command-index* 0) (in-package "CL-USER") ; make the default package the current one