home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.faslsp.lha / init.lsp < prev    next >
Text File  |  1996-06-17  |  89KB  |  2,256 lines
  1. ;;;   INITIALISIERUNGS-FILE
  2.  
  3. (in-package "LISP")
  4.  
  5. (shadow 'system::debug (find-package "SYSTEM"))
  6.  
  7. ;;; Exportierungen:
  8. (export '(
  9. ;; Typen:
  10. array atom bignum bit bit-vector character common compiled-function
  11. complex cons double-float fixnum float function hash-table integer keyword
  12. list #+LOGICAL-PATHNAMES logical-pathname long-float nil null number package
  13. pathname random-state ratio rational readtable real sequence short-float
  14. simple-array simple-bit-vector simple-string simple-vector single-float
  15. standard-char stream file-stream synonym-stream broadcast-stream
  16. concatenated-stream two-way-stream echo-stream string-stream string
  17. string-char symbol t vector satisfies values mod signed-byte unsigned-byte
  18. ;; Konstanten:
  19. lambda-list-keywords lambda-parameters-limit nil t call-arguments-limit
  20. multiple-values-limit pi boole-clr boole-set boole-1 boole-2 boole-c1 boole-c2
  21. boole-and boole-ior boole-xor boole-eqv boole-nand boole-nor boole-andc1
  22. boole-andc2 boole-orc1 boole-orc2 most-positive-fixnum most-negative-fixnum
  23. most-positive-short-float least-positive-short-float least-negative-short-float
  24. most-negative-short-float most-positive-single-float
  25. least-positive-single-float least-negative-single-float
  26. most-negative-single-float most-positive-double-float
  27. least-positive-double-float least-negative-double-float
  28. most-negative-double-float most-positive-long-float least-positive-long-float
  29. least-negative-long-float most-negative-long-float
  30. least-positive-normalized-short-float least-negative-normalized-short-float
  31. least-positive-normalized-single-float least-negative-normalized-single-float
  32. least-positive-normalized-double-float least-negative-normalized-double-float
  33. least-positive-normalized-long-float least-negative-normalized-long-float
  34. short-float-epsilon single-float-epsilon double-float-epsilon
  35. long-float-epsilon short-float-negative-epsilon single-float-negative-epsilon
  36. double-float-negative-epsilon long-float-negative-epsilon
  37. char-code-limit char-font-limit char-bits-limit char-control-bit char-meta-bit
  38. char-super-bit char-hyper-bit array-rank-limit array-dimension-limit
  39. array-total-size-limit internal-time-units-per-second
  40. ;; Variablen:
  41. *macroexpand-hook* *gensym-counter* *package* *modules* *random-state*
  42. *evalhook* *applyhook* + ++ +++ - * ** *** / // /// *standard-input*
  43. *standard-output* *error-output* *query-io* *debug-io* *terminal-io*
  44. *trace-output* *read-base* *read-suppress* *readtable* *print-readably*
  45. *print-escape* *print-pretty* *print-circle* *print-base* *print-radix*
  46. *print-case* *print-gensym* *print-level* *print-length* *print-array*
  47. *read-default-float-format* *default-pathname-defaults* *load-paths*
  48. *load-verbose* *load-print* *load-echo* *load-pathname* *load-truename*
  49. *break-on-warnings* *compile-warnings* *compile-verbose* *compile-print*
  50. *compile-file-pathname* *compile-file-truename* *features*
  51. ;; Funktionen:
  52. coerce type-of upgraded-array-element-type typep subtypep null symbolp
  53. atom consp listp numberp integerp rationalp floatp realp complexp characterp
  54. stringp bit-vector-p vectorp simple-vector-p simple-string-p
  55. simple-bit-vector-p arrayp packagep functionp compiled-function-p commonp eq
  56. eql equal equalp not symbol-value symbol-function fdefinition boundp fboundp
  57. special-form-p set makunbound fmakunbound get-setf-method
  58. get-setf-method-multiple-value apply funcall mapcar maplist mapc mapl mapcan
  59. mapcon values values-list macro-function macroexpand macroexpand-1 proclaim
  60. get remprop symbol-plist getf get-properties symbol-name make-symbol
  61. copy-symbol gensym gentemp symbol-package keywordp make-package in-package
  62. find-package package-name package-nicknames rename-package package-use-list
  63. package-used-by-list package-shadowing-symbols list-all-packages delete-package
  64. intern find-symbol unintern export unexport import shadowing-import shadow
  65. use-package unuse-package find-all-symbols provide require zerop plusp minusp
  66. oddp evenp = /= < > <= >= max min + - * / 1+ 1- conjugate gcd lcm exp expt
  67. log sqrt isqrt abs phase signum sin cos tan cis asin acos atan sinh cosh tanh
  68. asinh acosh atanh float rational rationalize numerator denominator floor
  69. ceiling truncate round mod rem ffloor fceiling ftruncate fround decode-float
  70. scale-float float-radix float-sign float-digits float-precision
  71. integer-decode-float complex realpart imagpart logior logxor logand logeqv
  72. lognand lognor logandc1 logandc2 logorc1 logorc2 boole lognot logtest logbitp
  73. ash logcount integer-length byte byte-size byte-position ldb ldb-test mask-field
  74. dpb deposit-field random make-random-state random-state-p standard-char-p
  75. graphic-char-p string-char-p alpha-char-p upper-case-p lower-case-p
  76. both-case-p digit-char-p alphanumericp char= char/= char< char> char<= char>=
  77. char-equal char-not-equal char-lessp char-greaterp char-not-greaterp
  78. char-not-lessp char-code char-bits char-font code-char make-char character
  79. char-upcase char-downcase digit-char char-int int-char char-name name-char
  80. char-bit set-char-bit complement elt subseq copy-seq length reverse nreverse
  81. make-sequence concatenate map map-into some every notany notevery reduce fill
  82. replace remove remove-if remove-if-not delete delete-if delete-if-not
  83. remove-duplicates delete-duplicates substitute substitute-if
  84. substitute-if-not nsubstitute nsubstitute-if nsubstitute-if-not find find-if
  85. find-if-not position position-if position-if-not count count-if count-if-not
  86. mismatch search sort stable-sort merge car cdr caar cadr cdar cddr caaar
  87. caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
  88. cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
  89. cons tree-equal endp list-length nth first second third fourth fifth sixth
  90. seventh eighth ninth tenth rest nthcdr last list list* make-list append
  91. copy-list copy-alist copy-tree revappend nconc nreconc butlast nbutlast ldiff
  92. rplaca rplacd subst subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis
  93. nsublis member member-if member-if-not tailp adjoin union nunion intersection
  94. nintersection set-difference nset-difference set-exclusive-or
  95. nset-exclusive-or subsetp acons pairlis assoc assoc-if assoc-if-not rassoc
  96. rassoc-if rassoc-if-not make-hash-table hash-table-p gethash remhash maphash
  97. clrhash hash-table-count hash-table-rehash-size hash-table-rehash-threshold
  98. hash-table-size hash-table-test sxhash make-array vector aref svref
  99. array-element-type array-rank array-dimension array-dimensions array-total-size
  100. array-in-bounds-p array-row-major-index row-major-aref adjustable-array-p
  101. bit sbit bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
  102. bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p fill-pointer vector-push
  103. vector-push-extend vector-pop adjust-array char schar string= string-equal
  104. string< string> string<= string>= string/= string-lessp string-greaterp
  105. string-not-greaterp string-not-lessp string-not-equal make-string string-trim
  106. string-left-trim string-right-trim string-upcase string-downcase
  107. string-capitalize nstring-upcase nstring-downcase nstring-capitalize string
  108. eval evalhook applyhook constantp make-synonym-stream make-broadcast-stream
  109. make-concatenated-stream make-two-way-stream make-echo-stream
  110. make-string-input-stream make-string-output-stream get-output-stream-string
  111. streamp open-stream-p input-stream-p output-stream-p stream-element-type close
  112. broadcast-stream-streams concatenated-stream-streams echo-stream-input-stream
  113. echo-stream-output-stream synonym-stream-symbol two-way-stream-input-stream
  114. two-way-stream-output-stream interactive-stream-p
  115. copy-readtable readtablep set-syntax-from-char set-macro-character
  116. get-macro-character make-dispatch-macro-character
  117. set-dispatch-macro-character get-dispatch-macro-character readtable-case
  118. read read-preserving-whitespace read-delimited-list read-line read-char
  119. unread-char peek-char listen read-char-no-hang clear-input read-from-string
  120. parse-integer read-byte write prin1 print pprint princ write-to-string
  121. prin1-to-string princ-to-string write-char write-string write-line terpri
  122. fresh-line finish-output force-output clear-output write-byte format y-or-n-p
  123. yes-or-no-p wild-pathname-p pathname-match-p translate-pathname
  124. #+LOGICAL-PATHNAMES logical-pathname
  125. #+LOGICAL-PATHNAMES translate-logical-pathname
  126. #+LOGICAL-PATHNAMES logical-pathname-translations
  127. #+LOGICAL-PATHNAMES load-logical-pathname-translations
  128. compile-file-pathname pathname truename parse-namestring merge-pathnames
  129. make-pathname pathnamep pathname-host pathname-device pathname-directory
  130. pathname-name pathname-type pathname-version namestring file-namestring
  131. directory-namestring host-namestring enough-namestring user-homedir-pathname
  132. open rename-file delete-file probe-file file-write-date file-author
  133. file-position file-length load directory error cerror warn break compile
  134. compile-file disassemble
  135. documentation  variable structure type ; drei Dokumentations-Typen
  136. describe inspect room ed dribble apropos apropos-list get-decoded-time
  137. get-universal-time decode-universal-time encode-universal-time
  138. get-internal-run-time get-internal-real-time sleep lisp-implementation-type
  139. lisp-implementation-version machine-type machine-version machine-instance
  140. software-type software-version short-site-name long-site-name identity
  141. ;; Special-forms:
  142. eval-when quote function setq progn let let* locally compiler-let progv flet
  143. labels macrolet symbol-macrolet if block return-from tagbody go
  144. multiple-value-call multiple-value-prog1 catch unwind-protect throw declare
  145. the load-time-value
  146. ;; Macros:
  147. deftype defun defvar defparameter defconstant and or psetq setf psetf shiftf
  148. rotatef define-modify-macro defsetf define-setf-method prog1 prog2
  149. when unless cond
  150. case typecase  otherwise ; otherwise als Marker für die catchall-clause
  151. return loop do do* dolist dotimes prog prog* multiple-value-list
  152. multiple-value-bind multiple-value-setq defmacro remf do-symbols
  153. do-external-symbols do-all-symbols incf decf push pushnew pop defstruct
  154. with-open-stream with-input-from-string with-output-to-string
  155. with-standard-io-syntax with-open-file
  156. check-type assert etypecase ctypecase ecase ccase trace untrace step time
  157. formatter
  158. english deutsch francais
  159. ;; sonstige Markierer:
  160. eval load compile ; EVAL-WHEN-Situationen
  161. special type ftype function inline notinline ignore ignorable optimize speed
  162. space safety compilation-speed debug declaration dynamic-extent compile ; DECLARE-Specifier
  163. interpreter compiler ; Features
  164. ))
  165.  
  166. (sys::%proclaim-constant 'lambda-list-keywords
  167.   '(&optional &rest &key &allow-other-keys &aux &body &whole &environment)
  168. )
  169. (export lambda-list-keywords)
  170.  
  171. (sys::%putd 'exit #'sys::%exit)
  172. (sys::%putd 'quit #'sys::%exit)
  173. (sys::%putd 'bye #'sys::%exit)
  174. (export '(exit quit bye))
  175.  
  176. (export 'the-environment)
  177.  
  178. (proclaim '(special *features*))
  179. ; Nach der Initialisierung (in IO.Q bzw. SPVW.D) enthält *features*
  180. ; als drittes Symbol  (first (sys::version)) = SYS::CLISP2/3 .
  181. (import *features*)
  182. (export *features*)
  183.  
  184. (in-package "SYSTEM" :nicknames '("SYS" "COMPILER"))
  185. (proclaim '(special compiler::*compiling*))
  186. (setq compiler::*compiling* nil)
  187.  
  188. (in-package "CLOS" :use '("LISP"))
  189. ;;; Exportierungen:
  190. (export '(
  191.   ;; Namen von Funktionen und Macros:
  192.   slot-value slot-boundp slot-makunbound slot-exists-p with-slots with-accessors
  193.   find-class class-of defclass defmethod call-next-method next-method-p
  194.   defgeneric generic-function generic-flet generic-labels
  195.   class-name
  196.   no-applicable-method no-primary-method no-next-method
  197.   find-method add-method remove-method
  198.   compute-applicable-methods method-qualifiers function-keywords
  199.   slot-missing slot-unbound
  200.   print-object describe-object
  201.   make-instance initialize-instance reinitialize-instance shared-initialize
  202.   ;; Namen von Klassen:
  203.   standard-class structure-class built-in-class
  204.   standard-object standard-generic-function standard-method
  205.   ;; andere Symbole:
  206.   standard ; Methoden-Kombination
  207. ))
  208.  
  209. (in-package "LISP")
  210. ; Exportierungen von conditio.lsp
  211. (export '(
  212.   handler-bind                  ; vorgezogen für compiler.lsp
  213.   find-restart compute-restarts ; vorgezogen für user1.lsp
  214.   invoke-restart-interactively  ; dito
  215.   restart                       ; vermeide Konflikt mit user1.lsp
  216.   continue                      ; vermeide Konflikt mit user1.lsp
  217.   end-of-file                   ; vermeide Konflikt mit init.lsp, user2.lsp
  218.   ; Typen für error-of-type:
  219.   condition warning serious-condition error storage-condition type-error
  220.   program-error control-error package-error print-not-readable stream-error
  221.   end-of-file file-error cell-error unbound-variable undefined-function
  222.   arithmetic-error division-by-zero floating-point-overflow
  223.   floating-point-underflow
  224. ))
  225.  
  226. ; Optionale Files wie macros3.lsp, defs2.lsp, loop.lsp, defs3.lsp machen ihre
  227. ; Exportierungen selber.
  228.  
  229.  
  230. (in-package "SYSTEM")
  231.  
  232. #-COMPILER ; nur beim Bootstrappen
  233. (progn
  234.  
  235. ; vorläufig soll bei GET_CLOSURE nicht expandiert werden:
  236. (sys::%putd '%expand-lambdabody-main
  237.   (function %expand-lambdabody-main
  238.     (lambda (lambdabody venv fenv)
  239.       (declare (source nil) (ignore venv fenv))
  240.       lambdabody
  241. ) ) )
  242.  
  243. ; vorläufig soll defun ganz trivial expandiert werden:
  244. (sys::%putd 'defun
  245.   (cons 'sys::macro
  246.     (function defun
  247.       (lambda (form env)
  248.         (declare (ignore env))
  249.         #|
  250.         (let ((name (cadr form))
  251.               (lambdalist (caddr form))
  252.               (body (cdddr form)))
  253.           `(SYS::%PUTD ',name (FUNCTION ,name (LAMBDA ,lambdalist ,@body)))
  254.         )
  255.         |#
  256.         (let ((name (cadr form)))
  257.           (list 'sys::%putd (list 'quote name)
  258.             (list 'function name (cons 'lambda (cddr form)))
  259.         ) )
  260.     ) )
  261. ) )
  262.  
  263. )
  264.  
  265. (proclaim '(special sys::*msg-list*))
  266. (setq sys::*msg-list* nil)
  267.  
  268. (let ((h (cons 'sys::macro
  269.            (function
  270.              (lambda (form env)
  271.                (declare (ignore env))
  272.                (apply #'(lambda (&key &allow-other-keys)) form)
  273.                (list 'SYS::LANGUAGE
  274.                      (getf form 'ENGLISH)
  275.                      (getf form 'DEUTSCH)
  276.                      (getf form 'FRANCAIS)
  277.       )) ) ) ) )
  278.   (sys::%putd 'ENGLISH h)
  279.   (sys::%putd 'DEUTSCH h)
  280.   (sys::%putd 'FRANCAIS h)
  281. )
  282.  
  283. (set-dispatch-macro-character 
  284.  #\# #\L
  285.  #'(lambda (s c n)
  286.      (declare (ignore c n))
  287.      (labels ((match-p (ch end-char)
  288.               (or
  289.                (and (eq end-char :white) (or (eql ch #\Space) (eql ch #\NewLine)))
  290.                (and (eq end-char :white-or-end) (or (eql ch #\Space) (eql ch #\NewLine) (eql ch #\})))
  291.                (and (eq end-char :alpha-or-end) (or (alpha-char-p ch) (eql ch #\})))
  292.                (eql ch end-char)))
  293.             (skip-until (match-p)
  294.               (let (ch)
  295.                 (tagbody 1
  296.                    (setq ch (read-char s))
  297.                    (unless (funcall match-p ch)
  298.                      (go 1)))
  299.                 (unread-char ch s)))
  300.             (read-string (end-char)
  301.               (let ((string "") ch last-ch)
  302.                 (tagbody 1
  303.                    (setq ch (read-char s))
  304.                    (unless (and (match-p ch end-char) (not (eql last-ch #\\ )))
  305.                      (setq string (string-concat string (string ch)))
  306.                      (setq last-ch ch)
  307.                      (go 1)))
  308.                 (unread-char ch s)
  309.                 string)))
  310.        (let (deutsch-msg english-msg francais-msg)
  311.          (skip-until #'(lambda (ch) (match-p ch :alpha-or-end)))
  312.          (let ((language (read-string :white)))
  313.            (tagbody 1 
  314.               (read-string #\")
  315.               (read-char s)
  316.               (let ((message (read-string #\")))
  317.                 (cond 
  318.                   ((string= language "DEUTSCH") (setq deutsch-msg message))
  319.                   ((string= language "ENGLISH") (setq english-msg message))
  320.                   ((string= language "FRANCAIS") (setq francais-msg message)))
  321.                 (skip-until #'(lambda (ch) (match-p ch :alpha-or-end)))
  322.                 (setq language (read-string :white-or-end))
  323.                 (if (eql (peek-char nil s) #\})
  324.                     (read-char s)
  325.                     (go 1)))))
  326.          (when sys::*load-input-stream*
  327.            (setq sys::*msg-list* 
  328.                  (cons (list 
  329.                         (string-concat (pathname-name sys::*load-input-stream*) ".lsp")
  330.                         (sys::line-number sys::*load-input-stream*)
  331.                         (list (cons 'DEUTSCH deutsch-msg)
  332.                               (cons 'ENGLISH english-msg)
  333.                               (cons 'FRANCAIS francais-msg)))
  334.                        sys::*msg-list*)))
  335.          #-nls (list 'SYS::LANGUAGE english-msg deutsch-msg francais-msg)
  336.          #+nls (list 'SYS::LANGUAGE english-msg nil nil)
  337.        ))))
  338.  
  339. (sys::%putd 'sys::exported-lisp-symbol-p
  340.   (function sys::exported-lisp-symbol-p
  341.     (lambda (symbol)
  342.       (let ((string (symbol-name symbol)))
  343.         (or (let ((p (find-package "LISP")))
  344.               (and p
  345.                 (multiple-value-bind (s f) (find-symbol string p)
  346.                   (and (eq s symbol) (eq f ':external))
  347.             ) ) )
  348.             (let ((p (find-package "COMMON-LISP")))
  349.               (and p
  350.                 (multiple-value-bind (s f) (find-symbol string p)
  351.                   (and (eq s symbol) (eq f ':external))
  352.     ) ) )   ) ) )
  353. ) )
  354.  
  355. (sys::%putd 'sys::remove-old-definitions
  356.   (function sys::remove-old-definitions
  357.     (lambda (symbol) ; entfernt die alten Funktionsdefinitionen eines Symbols
  358.       (if (special-form-p symbol)
  359.         (error-of-type 'error
  360.           #L{
  361.           DEUTSCH "~S ist eine Special-Form und darf nicht umdefiniert werden."
  362.           ENGLISH "~S is a special form and may not be redefined."
  363.           FRANCAIS "~S est une forme spéciale et ne peut pas être redéfinie."
  364.           }
  365.           symbol
  366.       ) )
  367.       (if (and (or (fboundp symbol) (macro-function symbol))
  368.                (sys::exported-lisp-symbol-p symbol)
  369.           )
  370.         (cerror
  371.          #L{
  372.          DEUTSCH "Die alte Definition wird weggeworfen."
  373.          ENGLISH "The old definition will be lost"
  374.          FRANCAIS "L'ancienne définition sera perdue."
  375.          }
  376.          #L{
  377.          DEUTSCH "D~2@*~:[ie~;er~]~0@* COMMON-LISP-~A ~S wird umdefiniert."
  378.          ENGLISH "Redefining the COMMON LISP ~A ~S"
  379.          FRANCAIS "L~2@*~:[a~;e~]~0@* ~A ~S de COMMON-LISP va être redéfini~:[e~;~]."
  380.          }
  381.          (fbound-string symbol) ; "Funktion" bzw. "Macro"
  382.          symbol
  383.          (macro-function symbol)
  384.       ) )
  385.       (fmakunbound symbol) ; Funktions-/Macro-Definition streichen
  386.       ; Property sys::definition wird nicht entfernt, da sie sowieso
  387.       ; bald neu gesetzt wird.
  388.       (remprop symbol 'sys::macro) ; Macro-Definition streichen
  389.       (when (get symbol 'sys::documentation-strings) ; Dokumentation streichen
  390.         (sys::%set-documentation symbol 'FUNCTION nil)
  391.       )
  392.       (when (get symbol 'sys::inline-expansion)
  393.         (sys::%put symbol 'sys::inline-expansion t)
  394.       )
  395.       (when (get symbol 'sys::traced-definition) ; Trace streichen
  396.         (warn 
  397.          #L{
  398.          DEUTSCH "DEFUN/DEFMACRO: ~S war getraced und wird umdefiniert!"
  399.          ENGLISH "DEFUN/DEFMACRO: redefining ~S; it was traced!"
  400.          FRANCAIS "DEFUN/DEFMACRO : ~S était tracée et est redéfinie!"
  401.          }
  402.          symbol
  403.         )
  404.         (untrace2 symbol)
  405.     ) )
  406. ) )
  407.  
  408. ; THE-ENVIRONMENT wie in SCHEME
  409. (sys::%putd '%the-environment
  410.   (function %the-environment
  411.     (lambda (form env)
  412.       (declare (ignore form))
  413.       (sys::svstore env 0 (svref (svref env 0) 2)) ; *evalhook*-Bindung streichen
  414.       env
  415.     )
  416. ) )
  417. (sys::%putd '%the-environment-error
  418.   (function %the-environment-error
  419.     (lambda ()
  420.       (error-of-type 'program-error
  421.         #L{
  422.         DEUTSCH "~S ist in compiliertem Code unmöglich."
  423.         ENGLISH "~S is impossible in compiled code"
  424.         FRANCAIS "~S est impossible dans du code compilé."
  425.         }
  426.         'the-environment
  427.     ) )
  428. ) )
  429. (sys::%putd 'the-environment
  430.   (cons 'sys::macro
  431.     (function the-environment
  432.       (lambda (form env)
  433.         (declare (ignore form env))
  434.         '(progn
  435.            (eval-when ((not eval)) (%the-environment-error))
  436.            (let ((*evalhook* #'%the-environment)) 0)
  437.          )
  438. ) ) ) )
  439.  
  440. ; liefert den Namen des impliziten Blocks zu einem Funktionsnamen
  441. (defun block-name (funname)
  442.   (if (atom funname) funname (second funname))
  443. )
  444.  
  445. ;;; Funktionen zum Expandieren von Macros innerhalb eines Codestückes
  446. ;;;
  447. ;;; Insgesamt wird der gesamte Code (einer Funktion) durchgegangen und
  448. ;;; globale und lokale Macros expandiert.
  449. ;;; Aus       #'(lambda lambdalist . body)
  450. ;;; wird so   #'(lambda expanded-lambdalist
  451. ;;;               (declare (source (lambdalist . body))) . expanded-body
  452. ;;;             )
  453. ;;; Durch diese Deklaration ist gewährleistet, daß eine bereits einmal
  454. ;;; durchlaufene Funktion als solche erkannt und nicht unnötigerweise ein
  455. ;;; zweites Mal durchlaufen wird.
  456.  
  457. ; Vorsicht! Fürs Bootstrappen (erkennbar an #-COMPILER) müssen manche der
  458. ; Funktionen in primitiverem Lisp (ohne do, do*, case) geschrieben werden.
  459.  
  460. (PROGN
  461.  
  462. (proclaim '(special *keyword-package*))
  463. (setq *keyword-package* (find-package "KEYWORD"))
  464.  
  465. (proclaim '(special *fenv*))
  466. ; *fenv* = Das aktuelle Function-Environment während der Expansion
  467. ; einer Form. Struktur: NIL oder ein 2n+1-elementiger Vektor
  468. ; (n1 f1 ... nn fn next), wo die ni Funktionsnamen sind, die fi ihre funktionale
  469. ; Bedeutung sind (Closure oder (MACRO . Closure) oder noch NIL); bei next
  470. ; geht's ebenso weiter.
  471.  
  472. ; (fenv-assoc s fenv) sucht Symbol s in Function-Environment fenv.
  473. (defun fenv-assoc (s fenv)
  474.   (if fenv
  475.     (if (simple-vector-p fenv)
  476.       #+COMPILER
  477.       (do ((l (1- (length fenv)))
  478.            (i 0 (+ i 2)))
  479.           ((= i l) (fenv-assoc s (svref fenv i)))
  480.         (if (equal s (svref fenv i))
  481.           (return (svref fenv (1+ i)))
  482.       ) )
  483.       #-COMPILER
  484.       (let ((l (1- (length fenv)))
  485.             (i 0))
  486.         (block nil
  487.           (tagbody
  488.             1 (if (= i l) (return-from nil (fenv-assoc s (svref fenv i))))
  489.               (if (equal s (svref fenv i))
  490.                 (return-from nil (svref fenv (1+ i)))
  491.               )
  492.               (setq i (+ i 2))
  493.               (go 1)
  494.       ) ) )
  495.       (error-of-type 'type-error
  496.         :datum fenv :expected-type '(or null simple-vector)
  497.         #L{
  498.         DEUTSCH "~S ist kein korrektes Function-Environment."
  499.         ENGLISH "~S is an invalid function environment"
  500.         FRANCAIS "~S n'est pas un environnement de fonctions correct."
  501.         }
  502.         fenv
  503.     ) )
  504.     'T ; nicht gefunden
  505. ) )
  506. ; Stellt fest, ob ein Funktionsname im Function-Environment fenv nicht
  507. ; definiert ist und daher auf die globale Funktion verweist.
  508. (defun global-in-fenv-p (s fenv) ; vorläufig
  509.   (eq (fenv-assoc s fenv) 'T)
  510. )
  511.  
  512. (proclaim '(special *venv*))
  513. ; *venv* = Das aktuelle Variablen-Environment während der Expansion
  514. ; einer Form. Struktur: NIL oder ein 2n+1-elementiger Vektor
  515. ; (n1 v1 ... nn vn next), wo die ni Symbole sind, die vi ihre
  516. ; syntaktische Bedeutung (Symbol-Macro-Objekt oder sonstiges); bei next
  517. ; geht's ebenso weiter.
  518.  
  519. ; (venv-assoc s venv) sucht Symbol s in Variablen-Environment venv.
  520. ; Liefert den Wert (oder NIL falls kein Wert).
  521. ; Vorsicht: Der Wert kann #<SPECDECL> oder #<SYMBOL-MACRO ...> sein, darf
  522. ; daher in interpretiertem Code nicht in einer Variablen zwischengespeichert
  523. ; werden.
  524. (defun venv-assoc (s venv)
  525.   (if venv
  526.     (if (simple-vector-p venv)
  527.       #+COMPILER
  528.       (do ((l (1- (length venv)))
  529.            (i 0 (+ i 2)))
  530.           ((= i l) (venv-assoc s (svref venv i)))
  531.         (if (eq s (svref venv i))
  532.           (return (svref venv (1+ i)))
  533.       ) )
  534.       #-COMPILER
  535.       (let ((l (1- (length venv)))
  536.             (i 0))
  537.         (block nil
  538.           (tagbody
  539.             1 (if (= i l) (return-from nil (venv-assoc s (svref venv i))))
  540.               (if (eq s (svref venv i))
  541.                 (return-from nil (svref venv (1+ i)))
  542.               )
  543.               (setq i (+ i 2))
  544.               (go 1)
  545.       ) ) )
  546.       (error-of-type 'type-error
  547.         :datum venv :expected-type '(or null simple-vector)
  548.         #L{
  549.         DEUTSCH "~S ist kein korrektes Variablen-Environment."
  550.         ENGLISH "~S is an invalid variable environment"
  551.         FRANCAIS "~S n'est pas un environnement de variables correct."
  552.         }
  553.         venv
  554.     ) )
  555.     (and (boundp s) (%symbol-value s)) ; nicht gefunden
  556. ) )
  557.  
  558. ; Die meisten Expansionsfunktionen liefern zwei Werte: Das Expansions-
  559. ; ergebnis, der zweite Wert (NIL oder T) zeigt an, ob darin etwas verändert
  560. ; wurde.
  561.  
  562. ; (%expand-cons ...) setzt ein cons zusammen. 2 Werte.
  563. ; form=alte Form,
  564. ; expf,flagf = Expansion des First-Teils,
  565. ; expr,flagr = Expansion des Rest-Teils.
  566. (defun %expand-cons (form expf flagf expr flagr)
  567.   (if (or flagf flagr)
  568.     (values (cons expf expr) t)
  569.     (values form nil)
  570. ) )
  571.  
  572. #+COMPILER
  573.  
  574. ; (%expand-form form) expandiert eine ganze Form. 2 Werte.
  575. (defun %expand-form (form)
  576.   (if (atom form)
  577.     (let (h)
  578.       (if (and (symbolp form) (symbol-macro-p (setq h (venv-assoc form *venv*))))
  579.         (values (sys::%record-ref h 0) t)
  580.         (values form nil)
  581.     ) )
  582.     ; form ist CONS
  583.     (let ((f (first form)))
  584.       (if (function-name-p f)
  585.         (let ((h (fenv-assoc f *fenv*)))
  586.           ; f ist in *fenv* assoziiert zu h
  587.           (if (eq h 'T)
  588.             ; f hat keine lokale Definition
  589.             ; Nun die einzelnen Expander für die Special-forms:
  590.             (case f
  591.               ((RETURN-FROM THE)
  592.                 ; 1. Argument lassen, alle weiteren expandieren
  593.                 (multiple-value-call #'%expand-cons form
  594.                   (first form) nil
  595.                   (multiple-value-call #'%expand-cons (rest form)
  596.                     (second form) nil
  597.                     (%expand-list (cddr form))
  598.               ) ) )
  599.               ((QUOTE GO DECLARE LOAD-TIME-VALUE) ; nichts expandieren
  600.                 (values form nil)
  601.               )
  602.               (FUNCTION
  603.                 ; Falls erstes bzw. zweites Argument Liste,
  604.                 ; als Lambda-Ausdruck expandieren.
  605.                 (multiple-value-call #'%expand-cons form
  606.                   'FUNCTION nil
  607.                   (if (atom (cddr form))
  608.                     (if (function-name-p (second form))
  609.                       (let ((h (fenv-assoc (second form) *fenv*)))
  610.                         (cond ((or (eq h 'T) (closurep h) (null h)) (values (rest form) nil))
  611.                               ((and (consp h) (eq (first h) 'MACRO))
  612.                                (error-of-type 'program-error 
  613.                                  #L{
  614.                                  DEUTSCH "~S: ~S unzulässig, da ~S ein lokaler Macro ist"
  615.                                  ENGLISH "~S: ~S is illegal since ~S is a local macro"
  616.                                  FRANCAIS "~S : ~S est illégal car ~S est un macro local"
  617.                                  }
  618.                                  '%expand form (second form)
  619.                               ))
  620.                               (t (error-of-type 'error
  621.                                    #L{
  622.                                    DEUTSCH "~S: Falscher Aufbau eines Function-Environment: ~S"
  623.                                    ENGLISH "~S: invalid function environment ~S"
  624.                                    FRANCAIS "~S : mauvais environnement de fonction ~S"
  625.                                    }
  626.                                    '%expand *fenv*
  627.                               )  )
  628.                       ) )
  629.                       (if (atom (second form))
  630.                         (error-of-type 'program-error
  631.                           #L{
  632.                           DEUTSCH "~S: ~S unzulässig, da ~S kein Symbol"
  633.                           ENGLISH "~S: ~S is invalid since ~S is not a symbol"
  634.                           FRANCAIS "~S : ~S est illégal car ~S n'est pas un symbole"
  635.                           }
  636.                           '%expand form (second form)
  637.                         )
  638.                         (multiple-value-call #'%expand-cons (rest form)
  639.                           (%expand-lambda (second form))
  640.                           (cddr form) nil
  641.                     ) ) )
  642.                     (multiple-value-call #'%expand-cons (rest form)
  643.                       (second form) nil
  644.                       (multiple-value-call #'%expand-cons (cddr form)
  645.                         (%expand-lambda (third form))
  646.                         (cdddr form) nil
  647.               ) ) ) ) )
  648.               (EVAL-WHEN
  649.                 ; Falls die Situation COMPILE angegeben ist, führe den Body
  650.                 ; als PROGN aus, gib eine Form zurück, die ohne Seiteneffekte
  651.                 ; dieselben Werte liefert.
  652.                 ; Sonst expandiere alle Argumente ab dem zweiten als Formen.
  653.                 (if (member 'COMPILE (second form))
  654.                   (values
  655.                     (list 'values-list
  656.                       (list 'quote
  657.                         (multiple-value-list (eval (cons 'PROGN (cddr form))))
  658.                     ) )
  659.                     t
  660.                   )
  661.                   (multiple-value-call #'%expand-cons form
  662.                     (first form) nil
  663.                     (multiple-value-call #'%expand-cons (rest form)
  664.                       (second form) nil
  665.                       (%expand-list (cddr form))
  666.               ) ) ) )
  667.               (LET ; Variablenliste und Body expandieren
  668.                 (let ((*venv* *venv*))
  669.                   (%expand-special-declarations (cddr form))
  670.                   (multiple-value-call #'%expand-cons form
  671.                     (first form) nil
  672.                     (multiple-value-call #'%expand-cons (rest form)
  673.                       (%expand-varspez (second form))
  674.                       (%expand-list (cddr form))
  675.               ) ) ) )
  676.               (LET* ; Variablenliste und Body expandieren
  677.                 (let ((*venv* *venv*))
  678.                   (%expand-special-declarations (cddr form))
  679.                   (multiple-value-call #'%expand-cons form
  680.                     (first form) nil
  681.                     (multiple-value-call #'%expand-cons (rest form)
  682.                       (%expand-varspez* (second form))
  683.                       (%expand-list (cddr form))
  684.               ) ) ) )
  685.               (LOCALLY ; Body expandieren
  686.                 (let ((*venv* *venv*))
  687.                   (%expand-special-declarations (cdr form))
  688.                   (multiple-value-call #'%expand-cons form
  689.                     (first form) nil
  690.                     (%expand-list (cdr form))
  691.               ) ) )
  692.               (MULTIPLE-VALUE-BIND ; Form und Body getrennt expandieren
  693.                 (let ((*venv* *venv*))
  694.                   (%expand-special-declarations (cdddr form))
  695.                   (multiple-value-call #'%expand-cons form
  696.                     'MULTIPLE-VALUE-BIND nil
  697.                     (multiple-value-call #'%expand-cons (rest form)
  698.                       (second form) nil
  699.                       (multiple-value-call #'%expand-cons (cddr form)
  700.                         (%expand-form (third form))
  701.                         (progn
  702.                           (%expand-lexical-variables (second form))
  703.                           (%expand-list (cdddr form))
  704.               ) ) ) ) ) )
  705.               (COMPILER-LET
  706.                 ; Variablenliste im leeren Environment und Body expandieren
  707.                 (progv
  708.                   (mapcar #'%expand-varspec-var (second form))
  709.                   (mapcar #'%expand-varspec-val (second form))
  710.                   (values (%expand-form (cons 'PROGN (cddr form))) t)
  711.               ) )
  712.               (COND ; Alle Teilformen der Klauseln expandieren:
  713.                 (multiple-value-call #'%expand-cons form
  714.                   (first form) nil
  715.                   (%expand-cond (rest form))
  716.               ) )
  717.               (BLOCK
  718.                 ; Body expandieren. Falls darin ein RETURN-FROM auf diesen
  719.                 ; Block vorkommt, behalte BLOCK. Sonst mache ein PROGN daraus.
  720.                 (multiple-value-bind (body flagb) (%expand-list (cddr form))
  721.                   (if (%return-p (second form) body)
  722.                     (multiple-value-call #'%expand-cons form
  723.                       (first form) nil
  724.                       (multiple-value-call #'%expand-cons (rest form)
  725.                         (second form) nil
  726.                         body flagb
  727.                     ) )
  728.                     (values
  729.                       (cond ((atom body) body)
  730.                             ((null (cdr body)) (car body))
  731.                             (t (cons 'progn body))
  732.                       )
  733.                       t
  734.               ) ) ) )
  735.               ((SETQ PSETQ) ; jedes zweite Argument expandieren
  736.                 (if (%expand-setqlist-macrop (rest form))
  737.                   (let ((new (if (eq (first form) 'SETQ) 'SETF 'PSETF)))
  738.                     (values
  739.                       (%expand-form
  740.                         (funcall (macro-function new) (cons new (rest form)) (vector *venv* *fenv*))
  741.                       )
  742.                       t
  743.                   ) )
  744.                   (multiple-value-call #'%expand-cons form
  745.                     (first form) nil
  746.                     (%expand-setqlist (rest form))
  747.               ) ) )
  748.               (MULTIPLE-VALUE-SETQ ; 1. Argument lassen, alle weiteren expandieren
  749.                 (if (%expand-varlist-macrop (second form))
  750.                   (values (%expand-form (cons 'MULTIPLE-VALUE-SETF (rest form))) t)
  751.                   (multiple-value-call #'%expand-cons form
  752.                     'MULTIPLE-VALUE-SETQ nil
  753.                     (multiple-value-call #'%expand-cons (rest form)
  754.                       (second form) nil
  755.                       (%expand-list (cddr form))
  756.               ) ) ) )
  757.               (TAGBODY
  758.                 ; alle Argumente expandieren, dabei entstehende Atome weglassen
  759.                 (multiple-value-call #'%expand-cons form
  760.                   (first form) nil
  761.                   (%expand-tagbody (rest form))
  762.               ) )
  763.               (PROGN ; alle Argumente expandieren, evtl. vereinfachen.
  764.                 (if (null (rest form))
  765.                   (values nil t)
  766.                   (if (null (cddr form))
  767.                     (values (%expand-form (second form)) t)
  768.                     (multiple-value-call #'%expand-cons form
  769.                       (first form) nil
  770.                       (%expand-list (rest form))
  771.               ) ) ) )
  772.               (FLET ; Funktionsdefinitionen expandieren,
  773.                     ; Body im erweiterten Environment expandieren
  774.                 (if (null (second form))
  775.                   (values (%expand-form (cons 'PROGN (cddr form))) t)
  776.                   (let ((newfenv (%expand-fundefs-1 (second form))))
  777.                     (multiple-value-call #'%expand-cons form
  778.                       (first form) nil
  779.                       (multiple-value-call #'%expand-cons (rest form)
  780.                         (%expand-fundefs-2 (second form))
  781.                         (let ((*fenv* (apply #'vector newfenv)))
  782.                           (%expand-list (cddr form))
  783.               ) ) ) ) ) )
  784.               (LABELS ; Funktionsdefinitionen und Body im erweiterten Environment expandieren
  785.                 (if (null (second form))
  786.                   (values (%expand-form (cons 'PROGN (cddr form))) t)
  787.                   (let ((newfenv (%expand-fundefs-1 (second form))))
  788.                     (let ((*fenv* (apply #'vector newfenv)))
  789.                       (multiple-value-call #'%expand-cons form
  790.                         (first form) nil
  791.                         (multiple-value-call #'%expand-cons (rest form)
  792.                           (%expand-fundefs-2 (second form))
  793.                           (%expand-list (cddr form))
  794.               ) ) ) ) ) )
  795.               (MACROLET ; Body im erweiterten Environment expandieren
  796.                 (do ((L1 (second form) (cdr L1))
  797.                      (L2 nil))
  798.                     ((atom L1)
  799.                      (if L1
  800.                        (error-of-type 'program-error
  801.                          #L{
  802.                          DEUTSCH "Dotted list im Code von MACROLET, endet mit ~S"
  803.                          ENGLISH "code after MACROLET contains a dotted list, ending with ~S"
  804.                          FRANCAIS "Le code de MACROLET contient une paire pointée, terminée par ~S"
  805.                          }
  806.                          L1
  807.                        )
  808.                        (let ((*fenv* (apply #'vector (nreverse (cons *fenv* L2)))))
  809.                          (values (%expand-form (cons 'PROGN (cddr form))) t)
  810.                     )) )
  811.                   (let ((macrodef (car L1)))
  812.                     (if (and (consp macrodef)
  813.                              (symbolp (car macrodef))
  814.                              (consp (cdr macrodef))
  815.                         )
  816.                       (setq L2
  817.                         (cons (make-macro-expandercons macrodef)
  818.                               (cons (car macrodef) L2)
  819.                       ) )
  820.                       (error-of-type 'program-error
  821.                         #L{
  822.                         DEUTSCH "Falsche Syntax in MACROLET: ~S"
  823.                         ENGLISH "illegal syntax in MACROLET: ~S"
  824.                         FRANCAIS "syntaxe illégale dans MACROLET : ~S"
  825.                         }
  826.                         macrodef
  827.               ) ) ) ) )
  828.               (SYMBOL-MACROLET ; Body im erweiterten Environment expandieren
  829.                 (do ((L1 (second form) (cdr L1))
  830.                      (L2 nil))
  831.                     ((atom L1)
  832.                      (if L1
  833.                        (error-of-type 'program-error
  834.                          #L{
  835.                          DEUTSCH "Dotted list im Code von SYMBOL-MACROLET, endet mit ~S"
  836.                          ENGLISH "code after SYMBOL-MACROLET contains a dotted list, ending with ~S"
  837.                          FRANCAIS "Le code de SYMBOL-MACROLET contient une paire pointée, terminée par ~S"
  838.                          }
  839.                          L1
  840.                        )
  841.                        (let ((*venv* (apply #'vector (nreverse (cons *venv* L2)))))
  842.                          (values (%expand-form (cons 'LOCALLY (cddr form))) t)
  843.                     )) )
  844.                   (let ((symdef (car L1)))
  845.                     (if (and (consp symdef)
  846.                              (symbolp (car symdef))
  847.                              (consp (cdr symdef))
  848.                              (null (cddr symdef))
  849.                         )
  850.                       (setq L2
  851.                         (cons (make-symbol-macro (cadr symdef)) (cons (car symdef) L2))
  852.                       )
  853.                       (error-of-type 'program-error
  854.                         #L{
  855.                         DEUTSCH "Falsche Syntax in SYMBOL-MACROLET: ~S"
  856.                         ENGLISH "illegal syntax in SYMBOL-MACROLET: ~S"
  857.                         FRANCAIS "syntaxe illégale dans SYMBOL-MACROLET : ~S"
  858.                         }
  859.                         symdef
  860.               ) ) ) ) )
  861.               (%HANDLER-BIND ; Handlerliste und Body expandieren
  862.                 (multiple-value-call #'%expand-cons form
  863.                   (first form) nil
  864.                   (multiple-value-call #'%expand-cons (rest form)
  865.                     (%expand-handlers (second form))
  866.                     (%expand-list (cddr form))
  867.               ) ) )
  868.               (t
  869.                 (cond ((and (symbolp f) (special-form-p f))
  870.                        ; sonstige Special-forms,
  871.                        ; z.B. IF, CATCH, THROW, PROGV, UNWIND-PROTECT, PROGN,
  872.                        ; PROG1, PROG2, WHEN, UNLESS, MULTIPLE-VALUE-LIST,
  873.                        ; MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-PROG1, AND, OR:
  874.                        (multiple-value-call #'%expand-cons form
  875.                          f nil
  876.                          (%expand-list (rest form))
  877.                       ))
  878.                       ((and (symbolp f) (setq h (macro-function f))) ; globale Macro-Definition
  879.                        (values (%expand-form (funcall h form (vector *venv* *fenv*))) t)
  880.                       )
  881.                       (t ; normaler Funktionsaufruf
  882.                        (multiple-value-call #'%expand-cons form
  883.                          f nil
  884.                          (%expand-list (rest form))
  885.             ) ) )     ))
  886.             ; f hat eine lokale Definition
  887.             (cond ((or (closurep h) (null h)); aufzurufende Funktion
  888.                    (multiple-value-call #'%expand-cons form
  889.                      f nil
  890.                      (%expand-list (rest form))
  891.                   ))
  892.                   ((and (consp h) (eq (car h) 'MACRO)) ; zu expandierender Macro
  893.                    (values (%expand-form (funcall (cdr h) form *fenv*)) t)
  894.                   ) ; Expander aufrufen
  895.                   (t (error-of-type 'error
  896.                        #L{
  897.                        DEUTSCH "Falscher Aufbau eines Function-Environment in ~S: ~S"
  898.                        ENGLISH "bad function environment occurred in ~S: ~S"
  899.                        FRANCAIS "mauvais environnement de fonction dans ~S : ~S"
  900.                        }
  901.                        '%expand-form *fenv*
  902.         ) ) )     )  )
  903.         (if (consp f)
  904.           (multiple-value-call #'%expand-cons form
  905.             (%expand-lambda f)
  906.             (%expand-list (rest form))
  907.           )
  908.           (error-of-type 'program-error
  909.             #L{
  910.             DEUTSCH "~S: ~S ist keine korrekte Form"
  911.             ENGLISH "~S: invalid form ~S"
  912.             FRANCAIS "~S : forme Lisp incorrecte ~S"
  913.             }
  914.             '%expand-form form
  915. ) ) ) ) ) )
  916.  
  917. #-COMPILER
  918. (progn
  919.  
  920. ; (%expand-form form) expandiert eine ganze Form. 2 Werte.
  921. (defun %expand-form (form)
  922.   (if (atom form)
  923.     (if (and (symbolp form) (symbol-macro-p (venv-assoc form *venv*)))
  924.       (values (sys::%record-ref (venv-assoc form *venv*) 0) t)
  925.       (values form nil)
  926.     )
  927.     ; form ist CONS
  928.     (let ((f (first form)))
  929.       (if (function-name-p f)
  930.         (let ((h (fenv-assoc f *fenv*)))
  931.           ; f ist in *fenv* assoziiert zu h
  932.           (if (eq h 'T)
  933.             ; f hat keine lokale Definition
  934.             (cond ((setq h (get '%expand f)) ; special forms u.ä.
  935.                    (funcall h form)
  936.                   )
  937.                   ((and (symbolp f) (special-form-p f))
  938.                    ; sonstige Special-forms,
  939.                    ; z.B. IF, CATCH, THROW, PROGV, UNWIND-PROTECT, PROGN,
  940.                    ; PROG1, PROG2, WHEN, UNLESS, MULTIPLE-VALUE-LIST,
  941.                    ; MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-PROG1, AND, OR:
  942.                    (multiple-value-call #'%expand-cons form
  943.                      f nil
  944.                      (%expand-list (rest form))
  945.                   ))
  946.                   ((and (symbolp f) (setq h (macro-function f))) ; globale Macro-Definition
  947.                    (values (%expand-form (funcall h form (vector *venv* *fenv*))) t)
  948.                   )
  949.                   (t ; normaler Funktionsaufruf
  950.                    (multiple-value-call #'%expand-cons form
  951.                      f nil
  952.                      (%expand-list (rest form))
  953.             )     ))
  954.             ; f hat eine lokale Definition
  955.             (cond ((or (closurep h) (null h)); aufzurufende Funktion
  956.                    (multiple-value-call #'%expand-cons form
  957.                      f nil
  958.                      (%expand-list (rest form))
  959.                   ))
  960.                   ((and (consp h) (eq (car h) 'MACRO)) ; zu expandierender Macro
  961.                    (values (%expand-form (funcall (cdr h) form *fenv*)) t)
  962.                   ) ; Expander aufrufen
  963.                   (t (error-of-type 'error
  964.                        #L{
  965.                        DEUTSCH "Falscher Aufbau eines Function-Environment in ~S: ~S"
  966.                        ENGLISH "bad function environment occurred in ~S: ~S"
  967.                        FRANCAIS "mauvais environnement de fonction dans ~S : ~S"
  968.                        }
  969.                        '%expand-form *fenv*
  970.         ) ) )     )  )
  971.         (if (consp f)
  972.           (multiple-value-call #'%expand-cons form
  973.             (%expand-lambda f)
  974.             (%expand-list (rest form))
  975.           )
  976.           (error-of-type 'program-error
  977.             #L{
  978.             DEUTSCH "~S: ~S ist keine korrekte Form"
  979.             ENGLISH "~S: invalid form ~S"
  980.             FRANCAIS "~S : forme Lisp incorrecte ~S"
  981.             }
  982.             '%expand-form form
  983. ) ) ) ) ) )
  984.  
  985. ; Nun die einzelnen Expander für die Special-forms:
  986.  
  987. ; RETURN-FROM, THE:
  988. ; 1. Argument lassen, alle weiteren expandieren
  989. (defun %expand-ab2 (form)
  990.   (multiple-value-call #'%expand-cons form
  991.       (first form) nil
  992.       (multiple-value-call #'%expand-cons (rest form)
  993.           (second form) nil
  994.           (%expand-list (cddr form))
  995. ) )   )
  996. (%put '%expand 'RETURN-FROM #'%expand-ab2)
  997. (%put '%expand 'THE #'%expand-ab2)
  998.  
  999. ; QUOTE, GO, DECLARE, LOAD-TIME-VALUE: nichts expandieren
  1000. (let ((fun
  1001.         (function %expand-quote/go/declare (lambda (form) (values form nil)))
  1002.      ))
  1003.   (%put '%expand 'QUOTE fun)
  1004.   (%put '%expand 'GO fun)
  1005.   (%put '%expand 'DECLARE fun)
  1006.   (%put '%expand 'LOAD-TIME-VALUE fun)
  1007. )
  1008.  
  1009. ; FUNCTION:
  1010. ; Falls erstes bzw. zweites Argument Liste, als Lambda-Ausdruck expandieren.
  1011. (%put '%expand 'FUNCTION
  1012.   (function %expand-function
  1013.     (lambda (form)
  1014.       (multiple-value-call #'%expand-cons form
  1015.           'FUNCTION nil
  1016.           (if (atom (cddr form))
  1017.             (if (function-name-p (second form))
  1018.               (let ((h (fenv-assoc (second form) *fenv*)))
  1019.                 (cond ((or (eq h 'T) (closurep h) (null h)) (values (rest form) nil))
  1020.                       ((and (consp h) (eq (first h) 'MACRO))
  1021.                        (error-of-type 'program-error
  1022.                          #L{
  1023.                          DEUTSCH "~S: ~S unzulässig, da ~S ein lokaler Macro ist"
  1024.                          ENGLISH "~S: ~S is illegal since ~S is a local macro"
  1025.                          FRANCAIS "~S : n'est pas permis car ~S est un macro local"
  1026.                          }
  1027.                          '%expand form (second form)
  1028.                       ))
  1029.                       (t (error-of-type 'error
  1030.                            #L{
  1031.                            DEUTSCH "~S: Falscher Aufbau eines Function-Environment: ~S"
  1032.                            ENGLISH "~S: invalid function environment ~S"
  1033.                            FRANCAIS "~S : mauvais environnement de fonction ~S"
  1034.                            }
  1035.                            '%expand *fenv*
  1036.                       )  )
  1037.               ) )
  1038.               (if (atom (second form))
  1039.                 (error-of-type 'program-error
  1040.                   #L{
  1041.                   DEUTSCH "~S: ~S unzulässig, da ~S kein Symbol"
  1042.                   ENGLISH "~S: ~S is invalid since ~S is not a symbol"
  1043.                   FRANCAIS "~S : ~S est inadmissible car ~S n'est pas un symbole"
  1044.                   }
  1045.                   '%expand form (second form)
  1046.                 )
  1047.                 (multiple-value-call #'%expand-cons (rest form)
  1048.                     (%expand-lambda (second form))
  1049.                     (cddr form) nil
  1050.             ) ) )
  1051.             (multiple-value-call #'%expand-cons (rest form)
  1052.                 (second form) nil
  1053.                 (multiple-value-call #'%expand-cons (cddr form)
  1054.                     (%expand-lambda (third form))
  1055.                     (cdddr form) nil
  1056.   ) ) )   ) )   )
  1057. )
  1058.  
  1059. ; EVAL-WHEN:
  1060. ; Falls die Situation COMPILE angegeben ist, führe den Body als PROGN aus,
  1061. ;   gib eine Form zurück, die ohne Seiteneffekte dieselben Werte liefert.
  1062. ; Sonst expandiere alle Argumente ab dem zweiten als Formen.
  1063. (%put '%expand 'EVAL-WHEN
  1064.   (function %expand-eval-when
  1065.     (lambda (form)
  1066.       (if (member 'COMPILE (second form))
  1067.         (values
  1068.           (list 'values-list
  1069.             (list 'quote
  1070.               (multiple-value-list (eval (cons 'PROGN (cddr form))))
  1071.           ) )
  1072.           t
  1073.         )
  1074.         (%expand-ab2 form)
  1075.   ) ) )
  1076. )
  1077.  
  1078. ; LET: Variablenliste und Body expandieren
  1079. (%put '%expand 'LET
  1080.   (function %expand-let
  1081.     (lambda (form)
  1082.       (let ((*venv* *venv*))
  1083.         (%expand-special-declarations (cddr form))
  1084.         (multiple-value-call #'%expand-cons form
  1085.           (first form) nil
  1086.           (multiple-value-call #'%expand-cons (rest form)
  1087.             (%expand-varspez (second form))
  1088.             (%expand-list (cddr form))
  1089.   ) ) ) ) )
  1090. )
  1091.  
  1092. ; LET*: Variablenliste und Body expandieren
  1093. (%put '%expand 'LET*
  1094.   (function %expand-let*
  1095.     (lambda (form)
  1096.       (let ((*venv* *venv*))
  1097.         (%expand-special-declarations (cddr form))
  1098.         (multiple-value-call #'%expand-cons form
  1099.           (first form) nil
  1100.           (multiple-value-call #'%expand-cons (rest form)
  1101.             (%expand-varspez* (second form))
  1102.             (%expand-list (cddr form))
  1103.   ) ) ) ) )
  1104. )
  1105.  
  1106. ; LOCALLY: Body expandieren
  1107. (%put '%expand 'LOCALLY
  1108.   (function %expand-locally
  1109.     (lambda (form)
  1110.       (let ((*venv* *venv*))
  1111.         (%expand-special-declarations (cdr form))
  1112.         (multiple-value-call #'%expand-cons form
  1113.           (first form) nil
  1114.           (%expand-list (cdr form))
  1115.   ) ) ) )
  1116. )
  1117.  
  1118. ; MULTIPLE-VALUE-BIND: Form und Body getrennt expandieren
  1119. (%put '%expand 'MULTIPLE-VALUE-BIND
  1120.   (function %expand-multiple-value-bind
  1121.     (lambda (form)
  1122.       (let ((*venv* *venv*))
  1123.         (%expand-special-declarations (cdddr form))
  1124.         (multiple-value-call #'%expand-cons form
  1125.           'MULTIPLE-VALUE-BIND nil
  1126.           (multiple-value-call #'%expand-cons (rest form)
  1127.             (second form) nil
  1128.             (multiple-value-call #'%expand-cons (cddr form)
  1129.               (%expand-form (third form))
  1130.               (progn
  1131.                 (%expand-lexical-variables (second form))
  1132.                 (%expand-list (cdddr form))
  1133.   ) ) ) ) ) ) )
  1134. )
  1135.  
  1136. ; COMPILER-LET: Variablenliste im leeren Environment und Body expandieren
  1137. (%put '%expand 'COMPILER-LET
  1138.   (function %expand-compiler-let
  1139.     (lambda (form)
  1140.       (progv
  1141.         (mapcar #'%expand-varspec-var (second form))
  1142.         (mapcar #'%expand-varspec-val (second form))
  1143.         (values (%expand-form (cons 'PROGN (cddr form))) t)
  1144.   ) ) )
  1145. )
  1146.  
  1147. ; COND: Alle Teilformen der Klauseln expandieren:
  1148. (%put '%expand 'cond
  1149.   (function %expand-cond
  1150.     (lambda (form)
  1151.       (multiple-value-call #'%expand-cons form
  1152.           (first form) nil
  1153.           (%expand-cond (rest form))
  1154.   ) ) )
  1155. )
  1156.  
  1157. ; BLOCK: Body expandieren. Falls darin ein RETURN-FROM auf diesen Block
  1158. ; vorkommt, behalte BLOCK. Sonst mache ein PROGN daraus.
  1159. (%put '%expand 'block
  1160.   (function %expand-block
  1161.     (lambda (form)
  1162.       (multiple-value-bind (body flagb) (%expand-list (cddr form))
  1163.         (if (%return-p (second form) body)
  1164.           (multiple-value-call #'%expand-cons form
  1165.               (first form) nil
  1166.               (multiple-value-call #'%expand-cons (rest form)
  1167.                   (second form) nil
  1168.                   body flagb
  1169.           )   )
  1170.           (values
  1171.             (cond ((atom body) body)
  1172.                   ((null (cdr body)) (car body))
  1173.                   (t (cons 'progn body))
  1174.             )
  1175.             t
  1176.   ) ) ) ) )
  1177. )
  1178.  
  1179. ; SETQ, PSETQ: jedes zweite Argument expandieren
  1180. (let ((fun
  1181.         (function %expand-setq/psetq
  1182.           (lambda (form)
  1183.             (if (%expand-setqlist-macrop (rest form))
  1184.               (let ((new (if (eq (first form) 'SETQ) 'SETF 'PSETF)))
  1185.                 (values
  1186.                   (%expand-form
  1187.                     (funcall (macro-function new) (cons new (rest form)) (vector *venv* *fenv*))
  1188.                   )
  1189.                   t
  1190.               ) )
  1191.               (multiple-value-call #'%expand-cons form
  1192.                 (first form) nil
  1193.                 (%expand-setqlist (rest form))
  1194.         ) ) ) )
  1195.      ))
  1196.   (%put '%expand 'SETQ fun)
  1197.   (%put '%expand 'PSETQ fun)
  1198. )
  1199.  
  1200. ; MULTIPLE-VALUE-SETQ : 1. Argument lassen, alle weiteren expandieren
  1201. (%put '%expand 'multiple-value-setq
  1202.   (function %expand-multiple-value-setq
  1203.     (lambda (form)
  1204.       (if (%expand-varlist-macrop (second form))
  1205.         (values (%expand-form (cons 'MULTIPLE-VALUE-SETF (rest form))) t)
  1206.         (%expand-ab2 form)
  1207.   ) ) )
  1208. )
  1209.  
  1210. ; TAGBODY: alle Argumente expandieren, dabei entstehende Atome weglassen
  1211. (%put '%expand 'tagbody
  1212.   (function %expand-tagbody
  1213.     (lambda (form)
  1214.       (multiple-value-call #'%expand-cons form
  1215.           (first form) nil
  1216.           (%expand-tagbody (rest form))
  1217.   ) ) )
  1218. )
  1219.  
  1220. ; PROGN: alle Argumente expandieren, evtl. vereinfachen.
  1221. (%put '%expand 'progn
  1222.   (function %expand-progn
  1223.     (lambda (form)
  1224.       (if (null (rest form))
  1225.         (values nil t)
  1226.         (if (null (cddr form))
  1227.           (values (%expand-form (second form)) t)
  1228.           (multiple-value-call #'%expand-cons form
  1229.               (first form) nil
  1230.               (%expand-list (rest form))
  1231.   ) ) ) ) )
  1232. )
  1233.  
  1234. ; FLET: Funktionsdefinitionen expandieren,
  1235. ; Body im erweiterten Environment expandieren
  1236. (%put '%expand 'flet
  1237.   (function %expand-flet
  1238.     (lambda (form)
  1239.       (if (null (second form))
  1240.         (values (%expand-form (cons 'PROGN (cddr form))) t)
  1241.         (let ((newfenv (%expand-fundefs-1 (second form))))
  1242.           (multiple-value-call #'%expand-cons form
  1243.             (car form) nil
  1244.             (multiple-value-call #'%expand-cons (cdr form)
  1245.               (%expand-fundefs-2 (second form))
  1246.               (let ((*fenv* (apply #'vector newfenv)))
  1247.                 (%expand-list (cddr form))
  1248.   ) ) ) ) ) ) )
  1249. )
  1250.  
  1251. ; LABELS: Funktionsdefinitionen und Body im erweiterten Environment expandieren
  1252. (%put '%expand 'labels
  1253.   (function %expand-labels
  1254.     (lambda (form)
  1255.       (if (null (second form))
  1256.         (values (%expand-form (cons 'PROGN (cddr form))) t)
  1257.         (let ((newfenv (%expand-fundefs-1 (second form))))
  1258.           (let ((*fenv* (apply #'vector newfenv)))
  1259.             (multiple-value-call #'%expand-cons form
  1260.               (car form) nil
  1261.               (multiple-value-call #'%expand-cons (cdr form)
  1262.                 (%expand-fundefs-2 (second form))
  1263.                 (%expand-list (cddr form))
  1264.   ) ) ) ) ) ) )
  1265. )
  1266.  
  1267. ; MACROLET: Body im erweiterten Environment expandieren
  1268. (%put '%expand 'macrolet
  1269.   (function %expand-macrolet
  1270.     (lambda (form)
  1271.       (do ((L1 (second form) (cdr L1))
  1272.            (L2 nil))
  1273.           ((atom L1)
  1274.            (if L1
  1275.              (error-of-type 'program-error
  1276.                #L{
  1277.                DEUTSCH "Dotted list im Code von MACROLET, endet mit ~S"
  1278.                ENGLISH "code after MACROLET contains a dotted list, ending with ~S"
  1279.                FRANCAIS "Le code de MACROLET contient une paire pointée, terminée par ~S"
  1280.                }
  1281.                L1
  1282.              )
  1283.              (let ((*fenv* (apply #'vector (nreverse (cons *fenv* L2)))))
  1284.                (values (%expand-form (cons 'PROGN (cddr form))) t)
  1285.           )) )
  1286.         (let ((macrodef (car L1)))
  1287.           (if (and (consp macrodef) (symbolp (car macrodef)) (consp (cdr macrodef)))
  1288.             (setq L2
  1289.               (cons (make-macro-expandercons macrodef)
  1290.                     (cons (car macrodef) L2)
  1291.             ) )
  1292.             (error-of-type 'program-error
  1293.               #L{
  1294.               DEUTSCH "Falsche Syntax in MACROLET: ~S"
  1295.               ENGLISH "illegal syntax in MACROLET: ~S"
  1296.               FRANCAIS "syntaxe illégale dans MACROLET : ~S"
  1297.               }
  1298.               macrodef
  1299.   ) ) ) ) ) )
  1300. )
  1301.  
  1302. ; SYMBOL-MACROLET: Body im erweiterten Environment expandieren
  1303. (%put '%expand 'symbol-macrolet
  1304.   (function %expand-symbol-macrolet
  1305.     (lambda (form)
  1306.       (do ((L1 (second form) (cdr L1))
  1307.            (L2 nil))
  1308.           ((atom L1)
  1309.            (if L1
  1310.              (error-of-type 'program-error
  1311.                #L{
  1312.                DEUTSCH "Dotted list im Code von SYMBOL-MACROLET, endet mit ~S"
  1313.                ENGLISH "code after SYMBOL-MACROLET contains a dotted list, ending with ~S"
  1314.                FRANCAIS "Le code de SYMBOL-MACROLET contient une paire pointée, terminée par ~S"
  1315.                }
  1316.                L1
  1317.              )
  1318.              (let ((*venv* (apply #'vector (nreverse (cons *venv* L2)))))
  1319.                (values (%expand-form (cons 'LOCALLY (cddr form))) t)
  1320.           )) )
  1321.         (let ((symdef (car L1)))
  1322.           (if (and (consp symdef)
  1323.                    (symbolp (car symdef))
  1324.                    (consp (cdr symdef))
  1325.                    (null (cddr symdef))
  1326.               )
  1327.             (setq L2
  1328.               (cons (make-symbol-macro (cadr symdef)) (cons (car symdef) L2))
  1329.             )
  1330.             (error-of-type 'program-error
  1331.               #L{
  1332.               DEUTSCH "Falsche Syntax in SYMBOL-MACROLET: ~S"
  1333.               ENGLISH "illegal syntax in SYMBOL-MACROLET: ~S"
  1334.               FRANCAIS "syntaxe illégale dans SYMBOL-MACROLET : ~S"
  1335.               }
  1336.               symdef
  1337.   ) ) ) ) ) )
  1338. )
  1339.  
  1340. ; %HANDLER-BIND: Handlerliste und Body expandieren
  1341. (%put '%expand '%handler-bind
  1342.   (function %expand-%handler-bind
  1343.     (lambda (form)
  1344.       (multiple-value-call #'%expand-cons form
  1345.         (first form) nil
  1346.         (multiple-value-call #'%expand-cons (rest form)
  1347.           (%expand-handlers (second form))
  1348.           (%expand-list (cddr form))
  1349.   ) ) ) )
  1350. )
  1351.  
  1352. )
  1353.  
  1354. ; Hilfsfunktionen für die Expansion:
  1355.  
  1356. ; expandiert eine Liste von Formen. 2 Werte.
  1357. (defun %expand-list (l)
  1358.   (if (atom l)
  1359.     (if l
  1360.       (error-of-type 'program-error
  1361.         #L{
  1362.         DEUTSCH "Dotted list im Code, endet mit ~S"
  1363.         ENGLISH "code contains a dotted list, ending with ~S"
  1364.         FRANCAIS "une paire pointée dans le code, terminée par ~S"
  1365.         }
  1366.         l
  1367.       )
  1368.       (values nil nil)
  1369.     )
  1370.     (multiple-value-call #'%expand-cons l
  1371.                          (%expand-form (first l))
  1372.                          (%expand-list (rest l))
  1373. ) ) )
  1374.  
  1375. ; Fügt lexikalische Variablen zu *venv* hinzu.
  1376. ; (Wird nur dazu benutzt, um Symbol-Macros zu überdecken.)
  1377. (defun %expand-lexical-variables (vars)
  1378.   (if vars
  1379.     (setq *venv*
  1380.       (apply #'vector
  1381.         (nconc (mapcan #'(lambda (v) (list v nil)) vars) (list *venv*))
  1382. ) ) ) )
  1383.  
  1384. ; Fügt SPECIAL-Deklarationen am Anfang eines Body zu *venv* hinzu.
  1385. (defun %expand-special-declarations (body)
  1386.   (multiple-value-bind (body-rest declarations)
  1387.       (sys::parse-body body nil (vector *venv* *fenv*))
  1388.     (declare (ignore body-rest)) ; Deklarationen nicht wegwerfen!
  1389.     (let ((specials nil))
  1390.       (mapc #'(lambda (declspec)
  1391.                 (if (and (consp declspec) (null (cdr (last declspec))))
  1392.                   (if (eq (car declspec) 'SPECIAL)
  1393.                     (mapc #'(lambda (x) (if (symbolp x) (setq specials (cons x specials))))
  1394.                           (cdr declspec)
  1395.               ) ) ) )
  1396.             (nreverse declarations)
  1397.       )
  1398.       (%expand-lexical-variables (nreverse specials)) ; auf specdecl kommt es hier nicht an
  1399. ) ) )
  1400.  
  1401. ; expandiert einen Funktionsnamen, der ein Cons ist (das muß ein
  1402. ; Lambda-Ausdruck sein). 2 Werte.
  1403. (defun %expand-lambda (l)
  1404.   (unless (eq (first l) 'lambda)
  1405.     (error-of-type 'program-error
  1406.       #L{
  1407.       DEUTSCH "~S: ~S sollte LAMBDA-Ausdruck sein"
  1408.       ENGLISH "~S: ~S should be a lambda expression"
  1409.       FRANCAIS "~S : ~S devrait être une expression LAMBDA"
  1410.       }
  1411.       '%expand-form l
  1412.   ) )
  1413.   (multiple-value-call #'%expand-cons l
  1414.       'lambda nil ; LAMBDA
  1415.       (%expand-lambdabody (rest l))
  1416. ) )
  1417.  
  1418. ; expandiert den CDR eines Lambda-Ausdrucks, ein (lambdalist . body). 2 Werte.
  1419. (defun %expand-lambdabody (lambdabody)
  1420.   (let ((body (rest lambdabody)))
  1421.     (if (and (consp body)
  1422.              (let ((form (car body)))
  1423.                (and (consp form)
  1424.                     (eq (car form) 'DECLARE)
  1425.                     (let ((declspecs (cdr form)))
  1426.                       (and (consp declspecs)
  1427.                            (let ((declspec (car declspecs)))
  1428.                              (and (consp declspec)
  1429.                                   (eq (car declspec) 'SOURCE)
  1430.         )    ) )    ) )    ) )
  1431.       (values lambdabody nil) ; bereits expandiert -> unberührt lassen
  1432.       (let ((*venv* *venv*))
  1433.         (values (list*
  1434.                   (%expand-lambdalist (first lambdabody))
  1435.                   (list 'DECLARE (list 'SOURCE lambdabody))
  1436.                   (%expand-list (rest lambdabody))
  1437.                 )
  1438.                 t
  1439. ) ) ) ) )
  1440.  
  1441. ; expandiert eine Lambdaliste. 2 Werte.
  1442. (defun %expand-lambdalist (ll)
  1443.   (if (atom ll)
  1444.     (if ll
  1445.       (error-of-type 'program-error
  1446.         #L{
  1447.         DEUTSCH "Lambdaliste darf nicht mit dem Atom ~S enden"
  1448.         ENGLISH "lambda list must not end with the atom ~S"
  1449.         FRANCAIS "La liste lambda ne peut pas se terminer par l'atome ~S"
  1450.         }
  1451.         ll
  1452.       )
  1453.       (values nil nil)
  1454.     )
  1455.     (multiple-value-call #'%expand-cons ll
  1456.         (%expand-parspez (first ll))
  1457.         (progn
  1458.           (let ((v (first ll)))
  1459.             (if (not (member v lambda-list-keywords :test #'eq))
  1460.               (setq *venv* (vector (%expand-varspec-var v) nil *venv*))
  1461.           ) )
  1462.           (%expand-lambdalist (rest ll))
  1463. ) ) )   )
  1464.  
  1465. ; expandiert ein Element einer Lambdaliste. 2 Werte.
  1466. ; (Expandiert dabei nur bei Listen, und dann auch nur das zweite Element.)
  1467. (defun %expand-parspez (ps)
  1468.   (if (or (atom ps) (atom (rest ps)))
  1469.     (values ps nil)
  1470.     (multiple-value-call #'%expand-cons ps
  1471.         (first ps) nil
  1472.         (multiple-value-call #'%expand-cons (rest ps)
  1473.             (%expand-form (second ps))
  1474.             (cddr ps) nil
  1475. ) ) )   )
  1476.  
  1477. ; expandiert eine Variablenliste für LET. 2 Werte.
  1478. (defun %expand-varspez (vs &optional (nvenv nil))
  1479.   (if (atom vs)
  1480.     (if vs
  1481.       (error-of-type 'program-error
  1482.         #L{
  1483.         DEUTSCH "~S: Variablenliste endet mit dem Atom ~S"
  1484.         ENGLISH "~S: variable list ends with the atom ~S"
  1485.         FRANCAIS "~S : La liste de variables se termine par l'atome ~S"
  1486.         }
  1487.         'let vs
  1488.       )
  1489.       (progn
  1490.         (setq *venv* (apply #'vector (nreverse (cons *venv* nvenv))))
  1491.         (values nil nil)
  1492.     ) )
  1493.     (multiple-value-call #'%expand-cons vs
  1494.         (%expand-parspez (first vs)) ; Bei Liste 2. Element expandieren
  1495.         (%expand-varspez (rest vs) (list* nil (%expand-varspec-var (first vs)) nvenv))
  1496. ) ) )
  1497.  
  1498. ; expandiert eine Variablenliste für LET*. 2 Werte.
  1499. (defun %expand-varspez* (vs)
  1500.   (if (atom vs)
  1501.     (if vs
  1502.       (error-of-type 'program-error
  1503.         #L{
  1504.         DEUTSCH "~S: Variablenliste endet mit dem Atom ~S"
  1505.         ENGLISH "~S: variable list ends with the atom ~S"
  1506.         FRANCAIS "~S : La liste de variables se termine par l'atome ~S"
  1507.         }
  1508.         'let* vs
  1509.       )
  1510.       (values nil nil)
  1511.     )
  1512.     (multiple-value-call #'%expand-cons vs
  1513.         (%expand-parspez (first vs)) ; Bei Liste 2. Element expandieren
  1514.         (progn
  1515.           (setq *venv* (vector (%expand-varspec-var (first vs)) nil *venv*))
  1516.           (%expand-varspez* (rest vs))
  1517. ) ) )   )
  1518.  
  1519. (defun %expand-varspec-var (varspec)
  1520.   (if (atom varspec) varspec (first varspec))
  1521. )
  1522.  
  1523. (defun %expand-varspec-val (varspec)
  1524.   (if (atom varspec) nil (eval (second varspec)))
  1525. )
  1526.  
  1527. ; Expandiert eine Cond-Klausel-Liste. 2 Werte.
  1528. (defun %expand-cond (clauses)
  1529.   (if (atom clauses)
  1530.     (values clauses nil)
  1531.     (multiple-value-call #'%expand-cons clauses
  1532.         (%expand-list (first clauses))
  1533.         (%expand-cond (rest clauses))
  1534. ) ) )
  1535.  
  1536. ; Auf den bereits expandierten Body wird folgendes angewandt:
  1537. ; (%return-p name list) stellt fest, ob die Formenliste list irgendwo ein
  1538. ; (RETURN-FROM name ...) enthält.
  1539. (defun %return-p (name body)
  1540.   (block return-p
  1541.     (tagbody 1
  1542.       (if (atom body) (return-from return-p nil))
  1543.       (let ((form (car body)))
  1544.         (if
  1545.           ; stelle fest, ob form ein (RETURN-FROM name ...) enthält:
  1546.           (and (consp form)
  1547.                (or (and (eq (first form) 'return-from) ; (RETURN-FROM name ...)
  1548.                         (eq (second form) name)
  1549.                    )
  1550.                    (and (consp (first form))           ; Lambdaliste
  1551.                         (%return-p name (first form))
  1552.                    )
  1553.                    (and (not ; keine neue Definition desselben Blocks ?
  1554.                           (and (eq (first form) 'block) (eq (second form) name))
  1555.                         )
  1556.                         (%return-p name (rest form)) ; Funktionsaufruf
  1557.           )    )   )
  1558.           (return-from return-p t)
  1559.       ) )
  1560.       (setq body (cdr body))
  1561.       (go 1)
  1562. ) ) )
  1563.  
  1564. (defun %expand-varlist-macrop (l)
  1565.   (and (consp l)
  1566.        (or (and (symbolp (car l)) (symbol-macro-p (venv-assoc (car l) *venv*)))
  1567.            (%expand-varlist-macrop (cdr l))
  1568. ) )    )
  1569.  
  1570. (defun %expand-setqlist-macrop (l)
  1571.   (and (consp l) (consp (cdr l))
  1572.        (or (and (symbolp (car l)) (symbol-macro-p (venv-assoc (car l) *venv*)))
  1573.            (%expand-setqlist-macrop (cddr l))
  1574. ) )    )
  1575.  
  1576. (defun %expand-setqlist (l)
  1577.   (if (or (atom l) (atom (cdr l)))
  1578.     (values l nil)
  1579.     (multiple-value-call #'%expand-cons l
  1580.         (first l) nil
  1581.         (multiple-value-call #'%expand-cons (rest l)
  1582.             (%expand-form (second l))
  1583.             (%expand-setqlist (cddr l))
  1584. ) ) )   )
  1585.  
  1586. ; (%expand-tagbody list) expandiert die Elemente einer Liste und läßt dabei
  1587. ; entstehende Atome fest (damit keine neuen Tags entstehen, die andere Tags
  1588. ; verdecken könnten). 2 Werte.
  1589. (defun %expand-tagbody (body)
  1590.   (cond ((atom body) (values body nil))
  1591.         ((atom (first body))
  1592.          (multiple-value-call #'%expand-cons body
  1593.              (first body) nil
  1594.              (%expand-tagbody (rest body))
  1595.         ))
  1596.         (t (multiple-value-bind (exp flag) (%expand-form (first body))
  1597.              (if (atom exp)
  1598.                (values (%expand-tagbody (rest body)) t) ; weglassen
  1599.                (multiple-value-call #'%expand-cons body
  1600.                    exp flag
  1601.                    (%expand-tagbody (rest body))
  1602. ) )     )  ) ) )
  1603. ; (%expand-fundefs-1 fundefs) liefert eine Liste (name1 nil ... namek nil *fenv*)
  1604. (defun %expand-fundefs-1 (fundefs)
  1605.   (if (atom fundefs)
  1606.     (if fundefs
  1607.       (error-of-type 'program-error
  1608.         #L{
  1609.         DEUTSCH "FLET/LABELS: Dotted list im Code, endet mit ~S"
  1610.         ENGLISH "FLET/LABELS: code contains a dotted list, ending with ~S"
  1611.         FRANCAIS "FLET/LABELS : une paire pointée dans le code, terminée par ~S"
  1612.         }
  1613.         fundefs
  1614.       )
  1615.       (list *fenv*)
  1616.     )
  1617.     (let ((fundef (car fundefs)))
  1618.       (if (and (consp fundef) (function-name-p (car fundef)) (consp (cdr fundef)))
  1619.         (list* (car fundef) nil (%expand-fundefs-1 (cdr fundefs)))
  1620.         (error-of-type 'program-error
  1621.           #L{
  1622.           DEUTSCH "Falsche Syntax in FLET/LABELS: ~S"
  1623.           ENGLISH "illegal syntax in FLET/LABELS: ~S"
  1624.           FRANCAIS "syntaxe incorrecte dans FLET/LABELS : ~S"
  1625.           }
  1626.           fundef
  1627. ) ) ) ) )
  1628. ; (%expand-fundefs-2 fundefs) expandiert eine Funktionsdefinitionenliste,
  1629. ; wie in FLET, LABELS. 2 Werte.
  1630. (defun %expand-fundefs-2 (fundefs)
  1631.   (if (atom fundefs)
  1632.     (values fundefs nil)
  1633.     (let ((fundef (car fundefs)))
  1634.       (multiple-value-call #'%expand-cons fundefs
  1635.              (multiple-value-call #'%expand-cons fundef
  1636.                      (car fundef) nil
  1637.                      (%expand-lambdabody (cdr fundef))
  1638.              )
  1639.              (%expand-fundefs-2 (rest fundefs))
  1640. ) ) ) )
  1641. ; (%expand-handlers handlers) expandiert eine Typ/Handler-Liste
  1642. ; wie in %HANDLER-BIND. 2 Werte.
  1643. (defun %expand-handlers (handlers)
  1644.   (if (atom handlers)
  1645.     (values handlers nil)
  1646.     (let ((handler (car handlers)))
  1647.       (multiple-value-call #'%expand-cons handlers
  1648.         (multiple-value-call #'%expand-cons handler
  1649.           (car handler) nil
  1650.           (%expand-list (cdr handler))
  1651.         )
  1652.         (%expand-handlers (cdr handlers))
  1653. ) ) ) )
  1654.  
  1655. #|
  1656. ; expandiert eine Form in einem gegebenen Function-Environment
  1657. ; Kann bei Bedarf von EVAL aufgerufen werden.
  1658. (defun %expand-form-main (form *fenv*)
  1659.   (%expand-form form)
  1660. )
  1661. |#
  1662.  
  1663. ; expandiert (lambdalist . body) in einem gegebenen Function-Environment.
  1664. ; Wird von GET_CLOSURE aufgerufen.
  1665. (defun %expand-lambdabody-main (lambdabody *venv* *fenv*)
  1666.   (%expand-lambdabody lambdabody)
  1667. )
  1668.  
  1669. (VALUES) )
  1670.  
  1671. ;; ab hier ist FUNCTION funktionsfähig, soweit kein MACROLET darin vorkommt.
  1672.  
  1673. (PROGN
  1674.  
  1675. (proclaim '(special *load-paths*))
  1676. (setq *load-paths* nil)
  1677. (proclaim '(special *source-file-types*))
  1678. (setq *source-file-types* '(#".lsp"))
  1679. (proclaim '(special *compiled-file-types*))
  1680. (setq *compiled-file-types* '(#".fas"))
  1681.  
  1682. ; vorläufig brauchen die Files nicht gesucht zu werden:
  1683. (defun search-file (filename extensions)
  1684.   (mapcan #'(lambda (extension)
  1685.               (let ((filename (merge-pathnames filename extension)))
  1686.                 (if (probe-file filename) (list filename) '())
  1687.             ) )
  1688.           (reverse extensions)
  1689. ) )
  1690.  
  1691. (proclaim '(special *load-verbose*))
  1692. (setq *load-verbose* t)
  1693. (proclaim '(special *load-print*))
  1694. (setq *load-print* nil)
  1695. (proclaim '(special *load-echo*))
  1696. (setq *load-echo* nil)
  1697. (proclaim '(special *load-pathname*))
  1698. (setq *load-pathname* nil)
  1699. (proclaim '(special *load-truename*))
  1700. (setq *load-truename* nil)
  1701. (proclaim '(special sys::*load-input-stream*))
  1702. (setq sys::*load-input-stream* nil)
  1703.  
  1704. ; (LOAD filename [:verbose] [:print] [:if-does-not-exist] [:echo] [:compiling]),
  1705. ; CLTL S. 426
  1706. (fmakunbound 'load)
  1707. (defun load (filename
  1708.              &key (verbose *load-verbose*) (print *load-print*) (if-does-not-exist t)
  1709.                   (echo *load-echo*) (compiling nil))
  1710.   (let ((stream
  1711.           (if (streamp filename)
  1712.             filename
  1713.             (or (open (setq filename (pathname filename))
  1714.                   :direction :input-immutable
  1715.                   :element-type 'string-char
  1716.                   :if-does-not-exist nil
  1717.                 )
  1718.                 ; Datei mit genau diesem Namen nicht vorhanden.
  1719.                 ; Suche unter den Dateien mit demselben Namen und den
  1720.                 ; Extensions "LSP", "FAS" die neueste:
  1721.                 (let ((present-files
  1722.                         (search-file filename
  1723.                           (append *source-file-types* *compiled-file-types*)
  1724.                      )) )
  1725.                   (if (endp present-files)
  1726.                     nil
  1727.                     (open (setq filename (first present-files))
  1728.                           :direction :input-immutable
  1729.                           :element-type 'string-char
  1730.        )) ) )   ) ) )
  1731.     (if stream
  1732.       (let ((input-stream
  1733.               (if echo
  1734.                 (make-echo-stream stream *standard-output*)
  1735.                 stream
  1736.             ) )
  1737.             ; :verbose, :print und :echo wirken nicht rekursiv - dazu
  1738.             ; hat man ja gerade die Special-Variablen *load-verbose* etc.
  1739.             ;(*load-verbose* verbose)
  1740.             ;(*load-print* print)
  1741.             ;(*load-echo* echo)
  1742.             (*load-pathname* (if (pathnamep filename) filename nil))
  1743.             (*load-truename* (if (pathnamep filename) (truename filename) nil))
  1744.             (*package* *package*) ; *PACKAGE* binden
  1745.             (*readtable* *readtable*) ; *READTABLE* binden
  1746.             (end-of-file "EOF")) ; einmaliges Objekt
  1747.         (setq sys::*load-input-stream* input-stream)
  1748.         (when verbose
  1749.           (fresh-line)
  1750.           (write-string
  1751.            #L{
  1752.            DEUTSCH ";; Datei "
  1753.            ENGLISH ";; Loading file "
  1754.            FRANCAIS ";; Chargement du fichier "
  1755.            }
  1756.           )
  1757.           (princ filename)
  1758.           (write-string 
  1759.            #L{
  1760.            DEUTSCH " wird geladen..."
  1761.            ENGLISH " ..."
  1762.            FRANCAIS " ..."
  1763.            }
  1764.         ) )
  1765.         (block nil
  1766.           (unwind-protect
  1767.             (tagbody weiter
  1768.               (when echo (fresh-line))
  1769.               (let ((obj (read input-stream nil end-of-file)))
  1770.                 (when (eql obj end-of-file) (return-from nil))
  1771.                 (setq obj
  1772.                   (multiple-value-list
  1773.                     (cond ((compiled-function-p obj) (funcall obj))
  1774.                           (compiling (funcall (compile-form obj nil nil nil nil nil)))
  1775.                           (t (eval obj))
  1776.                 ) ) )
  1777.                 (when print (when obj (print (first obj))))
  1778.               )
  1779.               (go weiter)
  1780.             )
  1781.             (close stream) (close input-stream)
  1782.         ) )
  1783.         (when verbose
  1784.           (fresh-line)
  1785.           (write-string 
  1786.            #L{
  1787.            DEUTSCH ";; Datei "
  1788.            ENGLISH ";; Loading of file "
  1789.            FRANCAIS ";; Le fichier "
  1790.            }
  1791.           )
  1792.           (princ filename)
  1793.           (write-string 
  1794.            #L{
  1795.            DEUTSCH " ist geladen."
  1796.            ENGLISH " is finished."
  1797.            FRANCAIS " est chargé."
  1798.            }
  1799.         ) )
  1800.         t
  1801.       )
  1802.       (if if-does-not-exist
  1803.         (error-of-type 'file-error
  1804.           :pathname filename
  1805.           #L{
  1806.           DEUTSCH "Eine Datei mit Namen ~A gibt es nicht."
  1807.           ENGLISH "A file with name ~A does not exist"
  1808.           FRANCAIS "Il n'existe pas de fichier de nom ~A."
  1809.           }
  1810.           filename
  1811.         )
  1812.         nil
  1813.       )
  1814. ) ) )
  1815.  
  1816. ; vorläufig:
  1817. (sys::%putd 'defun
  1818.   (cons 'sys::macro
  1819.     (function defun
  1820.       (lambda (form env)
  1821.         (unless (and (consp (cdr form)) (consp (cddr form)))
  1822.           (error-of-type 'program-error
  1823.             #L{
  1824.             DEUTSCH "~S: Funktionsname und/oder Parameterliste fehlt"
  1825.             ENGLISH "~S: missing function name and/or parameter list"
  1826.             FRANCAIS "~S : Le nom de fonction et/ou la liste de paramètre manque"
  1827.             }
  1828.             'defun
  1829.         ) )
  1830.         (let ((name (cadr form))
  1831.               (lambdalist (caddr form))
  1832.               (body (cdddr form)))
  1833.           (unless (symbolp name)
  1834.             (error-of-type 'program-error
  1835.               #L{
  1836.               DEUTSCH "~S: ~S ist kein Symbol."
  1837.               ENGLISH "~S: ~S is not a symbol."
  1838.               FRANCAIS "~S : ~S n'est pas un symbole."
  1839.               }
  1840.               'defun name
  1841.           ) )
  1842.           (when (special-form-p name)
  1843.             (error-of-type 'program-error
  1844.               #L{
  1845.               DEUTSCH "~S: Spezialform ~S kann nicht umdefiniert werden."
  1846.               ENGLISH "~S: special form ~S cannot be redefined."
  1847.               FRANCAIS "~S : La forme spéciale ~S ne peut pas être redéfinie."
  1848.               }
  1849.               'defun name
  1850.           ) )
  1851.           (multiple-value-bind (body-rest declarations docstring)
  1852.                                (sys::parse-body body t env)
  1853.             (declare (ignore docstring))
  1854.             #|
  1855.             `(PROGN
  1856.                (SYS::%PUT ',name 'SYS::DEFINITION
  1857.                  (CONS ',form (THE-ENVIRONMENT))
  1858.                )
  1859.                (SYS::%PUTD ',name
  1860.                  (FUNCTION ,name
  1861.                    (LAMBDA ,lambdalist
  1862.                      (DECLARE (SYS::IN-DEFUN ,name) ,@declarations)
  1863.                      (BLOCK ,name ,@body-rest)
  1864.                ) ) )
  1865.                ',name
  1866.              )
  1867.             |#
  1868.             (list 'progn
  1869.               (list 'sys::%put (list 'quote name) ''sys::definition
  1870.                     (list 'cons (list 'quote form) '(the-environment))
  1871.               )
  1872.               (list 'sys::%putd (list 'quote name)
  1873.                 (list 'FUNCTION name
  1874.                   (list 'LAMBDA lambdalist
  1875.                         (list* 'DECLARE (list 'SYS::IN-DEFUN name) declarations)
  1876.                         (list* 'BLOCK name body-rest)
  1877.               ) ) )
  1878.               (list 'quote name)
  1879.             )
  1880.     ) ) ) )
  1881. ) )
  1882.  
  1883. ; vorläufige Definition des Macros DO :
  1884. (sys::%putd 'do
  1885.   (cons 'sys::macro
  1886.     (function do
  1887.       (lambda (form env)
  1888.         (let ((varclauselist (second form))
  1889.               (exitclause (third form))
  1890.               (body (cdddr form)))
  1891.           (when (atom exitclause)
  1892.             (error-of-type 'program-error
  1893.               #L{
  1894.               DEUTSCH "Exitclause in ~S muß Liste sein."
  1895.               ENGLISH "exit clause in ~S must be a list"
  1896.               FRANCAIS "La clause de sortie dans ~S doit être une liste."
  1897.               }
  1898.               'do
  1899.           ) )
  1900.           (let ((bindlist nil)
  1901.                 (reinitlist nil)
  1902.                 (bodytag (gensym))
  1903.                 (exittag (gensym)))
  1904.             (multiple-value-bind (body-rest declarations)
  1905.                                  (sys::parse-body body nil env)
  1906.               (block do
  1907.                 (tagbody 1
  1908.                   (when (atom varclauselist)
  1909.                     (return-from do
  1910.                       #|
  1911.                       `(block nil
  1912.                          (let ,(nreverse bindlist)
  1913.                            (declare ,@declarations)
  1914.                            (tagbody
  1915.                              (go ,exittag)
  1916.                              ,bodytag
  1917.                              ,@body-rest
  1918.                              (psetq ,@(nreverse reinitlist))
  1919.                              ,exittag
  1920.                              (or ,(first exitclause) (go ,bodytag))
  1921.                              (return-from nil (progn ,@(rest exitclause)))
  1922.                        ) ) )
  1923.                       |#
  1924.                       (list 'block 'nil
  1925.                         (list 'let (nreverse bindlist)
  1926.                           (cons 'declare declarations)
  1927.                           (list* 'tagbody
  1928.                             (list 'go exittag)
  1929.                             bodytag
  1930.                             (append body-rest
  1931.                               (list
  1932.                                 (cons 'psetq (nreverse reinitlist))
  1933.                                 exittag
  1934.                                 (list 'or (first exitclause) (list 'go bodytag))
  1935.                                 (list 'return-from 'nil
  1936.                                   (cons 'progn (rest exitclause))
  1937.                       ) ) ) ) ) )
  1938.                   ) )
  1939.                   (let ( (varclause (first varclauselist)) )
  1940.                        (setq varclauselist (rest varclauselist))
  1941.                        (cond ( (atom varclause)
  1942.                                   (setq bindlist
  1943.                                         (cons varclause bindlist)) )
  1944.                              ( (atom (cdr varclause))
  1945.                                   (setq bindlist
  1946.                                         (cons (first varclause) bindlist)) )
  1947.                              ( (atom (cddr varclause))
  1948.                                   (setq bindlist
  1949.                                         (cons varclause bindlist)) )
  1950.                              ( t (setq bindlist
  1951.                                        (cons (list (first varclause)
  1952.                                                    (second varclause))
  1953.                                              bindlist))
  1954.                                  (setq reinitlist
  1955.                                        (list* (third varclause)
  1956.                                               (first varclause)
  1957.                                               reinitlist)) )))
  1958.                   (go 1)
  1959.     ) ) ) ) ) ) )
  1960. ) )
  1961.  
  1962. ; vorläufige Definition des Macros DOTIMES :
  1963. (sys::%putd 'dotimes
  1964.   (cons 'sys::macro
  1965.     (function dotimes
  1966.       (lambda (form env)
  1967.         (let ((var (first (second form)))
  1968.               (countform (second (second form)))
  1969.               (resultform (third (second form)))
  1970.               (body (cddr form)))
  1971.           (multiple-value-bind (body-rest declarations)
  1972.                                (sys::parse-body body nil env)
  1973.             (let ((g (gensym)))
  1974.               #|
  1975.               `(DO ((,var 0 (1+ ,var))
  1976.                     (,g ,countform))
  1977.                    ((>= ,var ,g) ,resultform)
  1978.                  (declare ,@declarations)
  1979.                  ,@body-rest
  1980.                )
  1981.               |#
  1982.               (list* 'do (list (list var '0 (list '1+ var)) (list g countform))
  1983.                          (list (list '>= var g) resultform)
  1984.                      (cons 'declare declarations)
  1985.                      body-rest
  1986.               )
  1987.     ) ) ) ) )
  1988. ) )
  1989.  
  1990. (VALUES) )
  1991.  
  1992. ;; ab hier sind LOAD, DEFUN, DO, DOTIMES (eingeschränkt) funktionsfähig.
  1993.  
  1994. (LOAD "defseq")   ;; Definitionen von Standard-Sequences
  1995.  
  1996. (LOAD "backquot") ;; Backquote-Readmacro
  1997.  
  1998. (PROGN
  1999.  
  2000. (sys::%putd 'sys::backquote
  2001.   (cons 'sys::macro
  2002.     (function sys::backquote
  2003.       (lambda (form &optional env) (declare (ignore env)) (third form))
  2004. ) ) )
  2005.  
  2006. (VALUES) )
  2007.  
  2008. ;; ab hier ist Backquote funktionsfähig
  2009.  
  2010. (LOAD "defmacro")
  2011.  
  2012. ;; ab hier ist FUNCTION (uneingeschränkt) funktionsfähig.
  2013.  
  2014. (PROGN
  2015.  
  2016. (sys::%putd 'defmacro
  2017.   (cons 'sys::macro
  2018.     (function defmacro
  2019.       (lambda (form &optional env)
  2020.         (declare (ignore env))
  2021.         (multiple-value-bind (expansion name lambdalist docstring)
  2022.                              (sys::make-macro-expansion (cdr form))
  2023.           (declare (ignore lambdalist))
  2024.           `(LET ()
  2025.              (EVAL-WHEN (COMPILE LOAD EVAL)
  2026.                (SYSTEM::REMOVE-OLD-DEFINITIONS ',name)
  2027.                ,@(if docstring
  2028.                    `((SYSTEM::%SET-DOCUMENTATION ',name 'FUNCTION ',docstring))
  2029.                    '()
  2030.                  )
  2031.                (SYSTEM::%PUTD ',name (CONS 'SYSTEM::MACRO ,expansion))
  2032.              )
  2033.              (EVAL-WHEN (EVAL)
  2034.                (SYSTEM::%PUT ',name 'SYSTEM::DEFINITION
  2035.                  (CONS ',form (THE-ENVIRONMENT))
  2036.              ) )
  2037.              ',name
  2038.            )
  2039.     ) ) )
  2040. ) )
  2041.  
  2042. (sys::%putd 'defun
  2043.   (cons 'sys::macro
  2044.     (function defun
  2045.       (lambda (form env)
  2046.         (if (atom (cdr form))
  2047.           (error-of-type 'program-error
  2048.             #L{
  2049.             DEUTSCH "~S: Daraus kann keine Funktion definiert werden: ~S"
  2050.             ENGLISH "~S: cannot define a function from that: ~S"
  2051.             FRANCAIS "~S : Pas de définition de fonction possible à partir de: ~S"
  2052.             }
  2053.             'defun (cdr form)
  2054.         ) )
  2055.         (unless (function-name-p (cadr form))
  2056.           (error-of-type 'program-error
  2057.             #L{
  2058.             DEUTSCH "~S: Der Name einer Funktion muß ein Symbol sein, nicht: ~S"
  2059.             ENGLISH "~S: the name of a function must be a symbol, not ~S"
  2060.             FRANCAIS "~S : Le nom d'une fonction doit être un symbole et non ~S"
  2061.             }
  2062.             'defun (cadr form)
  2063.         ) )
  2064.         (if (atom (cddr form))
  2065.           (error-of-type 'program-error
  2066.             #L{
  2067.             DEUTSCH "~S: Die Funktion ~S hat keine Lambdaliste."
  2068.             ENGLISH "~S: function ~S is missing a lambda list"
  2069.             FRANCAIS "~S : Il manque une liste lambda à la fonction ~S."
  2070.             }
  2071.             'defun (cadr form)
  2072.         ) )
  2073.         (let ((name (cadr form))
  2074.               (lambdalist (caddr form))
  2075.               (body (cdddr form)))
  2076.           (multiple-value-bind (body-rest declarations docstring)
  2077.                                (sys::parse-body body t env)
  2078.             (let ((symbolform
  2079.                     (if (atom name)
  2080.                       `',name
  2081.                       `(LOAD-TIME-VALUE (GET-SETF-SYMBOL ',(second name)))
  2082.                   ) )
  2083.                   (lambdabody
  2084.                     `(,lambdalist (DECLARE (SYS::IN-DEFUN ,name) ,@declarations)
  2085.                        (BLOCK ,(block-name name) ,@body-rest)
  2086.                      )
  2087.                  ))
  2088.               `(LET ()
  2089.                  (SYSTEM::REMOVE-OLD-DEFINITIONS ,symbolform)
  2090.                  ,@(if (and compiler::*compiling*
  2091.                             compiler::*compiling-from-file*
  2092.                             (member name compiler::*inline-functions* :test #'eq)
  2093.                             (null compiler::*venv*)
  2094.                             (null compiler::*fenv*)
  2095.                             (null compiler::*benv*)
  2096.                             (null compiler::*genv*)
  2097.                             (eql compiler::*denv* *toplevel-denv*)
  2098.                        )
  2099.                      ; Lambdabody für Inline-Compilation aufheben:
  2100.                      `((EVAL-WHEN (COMPILE)
  2101.                          (COMPILER::C-DEFUN ',name ',lambdabody)
  2102.                        )
  2103.                        (EVAL-WHEN (LOAD)
  2104.                          (SYSTEM::%PUT ,symbolform 'SYSTEM::INLINE-EXPANSION ',lambdabody)
  2105.                       ))
  2106.                      `((EVAL-WHEN (COMPILE) (COMPILER::C-DEFUN ',name)))
  2107.                    )
  2108.                  ,@(if docstring
  2109.                      `((SYSTEM::%SET-DOCUMENTATION ,symbolform 'FUNCTION ',docstring))
  2110.                      '()
  2111.                    )
  2112.                  (SYSTEM::%PUTD ,symbolform
  2113.                    (FUNCTION ,name (LAMBDA ,@lambdabody))
  2114.                  )
  2115.                  (EVAL-WHEN (EVAL)
  2116.                    (SYSTEM::%PUT ,symbolform 'SYSTEM::DEFINITION
  2117.                      (CONS ',form (THE-ENVIRONMENT))
  2118.                  ) )
  2119.                  ',name
  2120.                )
  2121.     ) ) ) ) )
  2122. ) )
  2123.  
  2124. (VALUES) )
  2125.  
  2126. ;; ab hier sind DEFMACRO und DEFUN funktionsfähig.
  2127.  
  2128. ; (MACRO-EXPANDER . macrodef)                                         [Macro]
  2129. ; expandiert zum Macro-Expander als Programmtext (FUNCTION ... (LAMBDA ...)).
  2130. (defmacro MACRO-EXPANDER (&body macrodef)
  2131.   (make-macro-expansion macrodef)
  2132. )
  2133.  
  2134. (LOAD "macros1")  ;; Kontrollstrukturen - Macros
  2135. (LOAD "macros2")  ;; weitere Macros
  2136.  
  2137. (LOAD "defs1")    ;; Definitionen zu Symbolen, Zahlen, Characters, Zeit
  2138. #-(or UNIX WIN32-UNIX) (LOAD "timezone") ;; Definition der Zeitzone
  2139.  
  2140. (LOAD "places")   ;; SETF-Places: Definitionen und Macros
  2141.  
  2142. ;; ab hier ist SETF u.ä. funktionsfähig.
  2143.  
  2144. (LOAD "floatpri") ;; Ausgabe von Floating-Points
  2145.  
  2146. (LOAD "type")     ;; TYPEP
  2147.  
  2148. (LOAD "defstruc") ;; DEFSTRUCT-Macro
  2149.  
  2150. (LOAD "format")   ;; FORMAT
  2151.  
  2152. ; Ein Stückchen "DO-WHAT-I-MEAN":
  2153. ; Sucht ein Programm-File.
  2154. ; Gesucht wird im aktuellen Directory und dann in den Directories
  2155. ; aus *load-paths*.
  2156. ; Ist eine Extension angegeben, so wird nur nach Files mit genau dieser
  2157. ; Extension gesucht. Ist keine Extension angegeben, so wird nur nach Files
  2158. ; mit einer Extension aus der gegebenen Liste gesucht.
  2159. ; Man erhält alle Files aus dem ersten passenden Directory, als Pathnames,
  2160. ; in einer Liste, nach fallendem FILE-WRITE-DATE sortiert, oder NIL.
  2161. (defun search-file (filename extensions
  2162.                     &aux (use-extensions (null (pathname-type filename))) )
  2163.   (when use-extensions
  2164.     (setq extensions ; Case-Konversionen auf den Extensions durchführen
  2165.       (mapcar #'pathname-type extensions)
  2166.   ) )
  2167.   ; Defaults einmergen:
  2168.   (setq filename (merge-pathnames filename '#".*"))
  2169.   ; Suchen:
  2170.   (let ((already-searched nil))
  2171.     (dolist (dir (cons '#""
  2172.                        ; Wenn filename ".." enthält, zählt *load-paths* nicht
  2173.                        ; (um Errors wegen ".../../foo" z.B. auf DOS zu vermeiden):
  2174.                        (if (member #+(or DOS AMIGA ACORN-RISCOS) :PARENT
  2175.                                    #+(or UNIX OS/2 WIN32-UNIX WIN32-DOS) ".."
  2176.                                    (pathname-directory filename)
  2177.                                    :test #'equal
  2178.                            )
  2179.                          '()
  2180.                          (mapcar #'pathname *load-paths*)
  2181.             )    )     )
  2182.       (let ((search-filename
  2183.               (merge-pathnames (merge-pathnames filename dir))
  2184.            ))
  2185.         (unless (member search-filename already-searched :test #'equal)
  2186.           (let ((xpathnames (directory search-filename :full t :circle t)))
  2187.             (when use-extensions
  2188.               ; nach passenden Extensions filtern:
  2189.               (setq xpathnames
  2190.                 (delete-if-not ; hat xpathname eine der gegebenen Extensions?
  2191.                   #'(lambda (xpathname)
  2192.                       (member (pathname-type (first xpathname)) extensions
  2193.                               :test #-(or AMIGA OS/2 WIN32-UNIX WIN32-DOS) #'string=
  2194.                                     #+(or AMIGA OS/2 WIN32-UNIX WIN32-DOS) #'string-equal
  2195.                     ) )
  2196.                   xpathnames
  2197.             ) ) )
  2198.             (when xpathnames
  2199.               ; nach Datum sortiert, zurückgeben:
  2200.               (dolist (xpathname xpathnames)
  2201.                 (setf (rest xpathname)
  2202.                       (apply #'encode-universal-time (third xpathname))
  2203.               ) )
  2204.               (return (mapcar #'first (sort xpathnames #'> :key #'rest)))
  2205.           ) )
  2206.           (push search-filename already-searched)
  2207.     ) ) )
  2208. ) )
  2209.  
  2210. (LOAD "user1")    ;; User-Interface, Teil 1: Break-Loop, Stepper
  2211.  
  2212. (LOAD "user2")    ;; User-Interface, Teil 2: Apropos, Describe, Dribble, Ed
  2213.  
  2214. (LOAD "trace")    ;; User-Interface, Teil 3: TRACE
  2215.  
  2216. ;(LOAD "macros3")  ;; weitere Macros, optional
  2217.  
  2218. (LOAD "config")   ;; Konfigurations-Parameter
  2219.  
  2220. (LOAD "compiler") ;; Compiler
  2221.  
  2222. (LOAD "disassem") ;; Disassembler
  2223.  
  2224. (LOAD "defs2")    ;; CLtL2-Definitionen, optional
  2225.  
  2226. (LOAD "loop")     ;; CLtL2/dpANS-LOOP, optional
  2227.  
  2228. (LOAD "clos")     ;; CLOS, optional
  2229.  
  2230. (LOAD "conditio") ;; Conditions, optional
  2231.  
  2232. (LOAD "defs3")    ;; CLtL2-Definitionen, optional
  2233.  
  2234. (LOAD "gstream")  ;; generic streams, optional
  2235.  
  2236. #+FFI ; when (find-package "FFI")
  2237. (LOAD "foreign1") ;; foreign function interface, optional
  2238.  
  2239. #+AMIGA
  2240. (when (find-symbol "%LIBCALL" "SYS")
  2241.   (LOAD "affi1") ;; einfaches FFI, optional
  2242. )
  2243.  
  2244. (when (or #+AMIGA t (find-package "SCREEN"))
  2245.   (LOAD "screen") ;; Screen-Paket, optional
  2246. )
  2247.  
  2248. (when (find-package "STDWIN")
  2249.   (LOAD "stdwin2") ;; STDWIN-Schnittstelle, optional
  2250. )
  2251.  
  2252. #+AMIGA (LOAD "rexx1") ;; Rexx-Schnittstelle, optional
  2253.  
  2254. (in-package "USER") ;; Default-Package aktuell machen
  2255.  
  2256.