home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / compiler.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-12-16  |  537.2 KB  |  12,601 lines
  1. ; CLISP - Compiler
  2. ; Bruno Haible 20.-30.09.1988, 05.-07.10.1988, 10.10.1988, 16.12.1988
  3. ;   Version fⁿr KCL 27.06.1989, 05.-07.07.1989
  4. ;   c-VALUES erweitert am 14.07.1989
  5. ;   label-operand in assemble-LAP korrigiert am 14.07.1989
  6. ;   ANODE-Komponenten SOURCE, STACKZ eliminiert am 14.07.1989
  7. ;     (konditionell von #+COMPILER-DEBUG abhΣngig)
  8. ;   Peephole-Optimierung-Protokoll konditionell von #+PEEPHOLE-DEBUG abhΣngig
  9. ;   Version fⁿr CLISP 28.07.1989-11.08.1989
  10. ;   Variablen-Optimierungen 10.03.1991
  11. ; Michael Stoll, September-Dezember 1991:
  12. ;   - Bytecode ⁿberarbeitet
  13. ;   - Code-Optimierung bzgl. Labels/Sprⁿngen verbessert
  14. ;   - kleine Verbesserung bei c-plus/c-minus,
  15. ;     Compilation von CxxxR in Folge von (CAR) und (CDR)
  16. ;   - SUBR-Aufrufe ohne Argument-Check zur Laufzeit,
  17. ;     SUBRs als Konstanten (via #.#'name)
  18. ;   - Aufrufe lokaler Funktionen ohne Argument-Check zur Laufzeit
  19. ;   - Rekursive Aufrufe durch Unterprogrammaufruf JSR, bei Endrekursion
  20. ;     JMPTAIL (entspricht PSETQ mit anschlie▀endem Sprung)
  21. ;   - Verbesserung bei Aufruf einer Funktion mit Rest-Parametern via APPLY
  22. ; Bruno Haible, Februar-MΣrz 1992:
  23. ;   - detailliertere seclass, besseres PSETQ
  24. ;   - besseres Constant Folding
  25. ;   - Cross-Compilation
  26. ; Bruno Haible, 03.06.1992:
  27. ;   - Inline-Compilation von Aufrufen globaler Funktionen
  28. ; Bruno Haible, August 1993:
  29. ;   - Unterstⁿtzung fⁿr CLOS: generische Funktionen %GENERIC-FUNCTION-LAMBDA,
  30. ;     Optimierung unbenutzter Required-Parameter %OPTIMIZE-FUNCTION-LAMBDA
  31. ;   - GENERIC-FLET, GENERIC-LABELS
  32. ;   - Inline-Compilation von (APPLY (FUNCTION ...) ...)
  33. ; Weitere Vorhaben:
  34. ;   - Variablen-Environments so verΣndern, da▀ Aufruf von lokalen Funktionen
  35. ;     mittels JSR/JMPTAIL m÷glich wird (d.h. nachtrΣgliche Entscheidung, ob
  36. ;     Aufruf durch CALLC oder JSR)
  37. ;   - evtl. bessere Optimierung durch Datenflu▀analyse
  38. ;   - Inline-Compilation von Aufrufen lokaler Funktionen
  39.  
  40. ; Zur Cross-Compilation (wahlweise mit #+CLISP oder #-CLISP):
  41. ; CROSS, die Sprache und den Maschinenbezeichner in die Liste *features*
  42. ; aufnehmen, andere Maschinenbezeichner aus *features* herausnehmen.
  43. ; Dann den Compiler laden (evtl. compilieren und laden).
  44. ; Dann CROSS wieder aus der Liste *features* herausnehmen, und
  45. ; mit (cross:compile-file ...) Files compilieren.
  46.  
  47. ; #-CROSS impliziert #+CLISP.
  48.  
  49. #-CROSS (in-package "LISP")
  50. #-CROSS (export '(compiler compile compile-file disassemble))
  51. #-CROSS (pushnew 'compiler *features*)
  52.  
  53. #-CROSS (in-package "COMPILER")
  54. #+CROSS (in-package "CROSS" :nicknames '("CLISP"))
  55. #-CLISP (defmacro DEUTSCH (x ENGLISH y FRANCAIS z) y)
  56. ;; Konvention: Schreibe SYSTEM::PNAME fⁿr ein Symbol, das "zufΣllig" in
  57. ;; #<PACKAGE SYSTEM> sitzt, wir das Symbol aber nicht weiter benutzen.
  58. ;; Schreibe SYS::PNAME, wenn wir von dem Symbol irgendwelche Eigenschaften
  59. ;; voraussetzen. Schreibe COMPILER::PNAME, wenn der Compiler das Symbol
  60. ;; deklariert und es von anderen Programmteilen benutzt wird.
  61. #+CLISP (import '(sys::function-name-p sys::parse-body sys::make-load-time-eval
  62.                   sys::closure-name sys::closure-codevec sys::closure-consts
  63.                   sys::fixnump sys::short-float-p sys::single-float-p
  64.                   sys::double-float-p sys::long-float-p
  65.                   sys::search-file sys::date-format sys::line-number
  66.                   sys::%funtabref sys::inlinable
  67.                   sys::*compiling* sys::*compiling-from-file* sys::*inline-functions*
  68.                   sys::*venv* sys::*fenv* sys::*benv* sys::*genv* sys::*denv*
  69.                   sys::*toplevel-denv*
  70.                   COMPILER::C-PROCLAIM COMPILER::C-PROCLAIM-CONSTANT
  71.                   COMPILER::C-DEFUN COMPILER::C-PROVIDE COMPILER::C-REQUIRE
  72.         )        )
  73. #-CROSS (import '(sys::version sys::subr-info))
  74.  
  75. #+CROSS (shadow '(compile-file))
  76. #+CROSS (export '(compile-file))
  77.  
  78. #-CLISP (shadow '(macroexpand-1 macroexpand))
  79. #-CLISP
  80. (progn
  81.   (defun function-name-p (form)
  82.     (or (symbolp form)
  83.         (and (consp form) (eq (car form) 'SETF)
  84.              (consp (setq form (cdr form))) (null (cdr form))
  85.              (symbolp (car form))
  86.   ) )   )
  87.   (defun macroexpand-1 (form &optional (env (vector nil nil)))
  88.     (if (and (consp form) (symbolp (car form)))
  89.       (multiple-value-bind (a b c) (fenv-search (car form) (svref env 1))
  90.         (declare (ignore c))
  91.         (cond ((eq a 'system::macro) (values (funcall b form env) t))
  92.               ((macro-function (car form))
  93.                (values (funcall (macro-function (car form)) form env) t)
  94.               )
  95.               (t (values form nil))
  96.       ) )
  97.       (if (symbolp form)
  98.         (let ((h (venv-search-macro form (svref env 0))))
  99.           (if (symbol-macro-p h)
  100.             (values (sys::%record-ref h 0) t)
  101.             (values form nil)
  102.         ) )
  103.         (values form nil)
  104.   ) ) )
  105.   (defun macroexpand (form &optional (env (vector nil nil)))
  106.     (multiple-value-bind (a b) (macroexpand-1 form env)
  107.       (if b
  108.         (loop
  109.           (multiple-value-setq (a b) (macroexpand-1 a env))
  110.           (unless b (return (values a t)))
  111.         )
  112.         (values form nil)
  113.   ) ) )
  114.   (defun parse-body (body &optional docstring-allowed env)
  115.     (do ((bodyr body (cdr bodyr))
  116.          (declarations nil)
  117.          (docstring nil)
  118.          (form nil))
  119.         ((null bodyr) (values bodyr declarations docstring))
  120.       (cond ((and (stringp (car bodyr)) (cdr bodyr) (null docstring) docstring-allowed)
  121.              (setq docstring (car bodyr))
  122.             )
  123.             ((not (listp (setq form (macroexpand (car bodyr) env))))
  124.              (return (values bodyr declarations docstring))
  125.             )
  126.             ((eq (car form) 'DECLARE)
  127.              (dolist (decl (cdr form)) (push decl declarations))
  128.             )
  129.             (t (return (values bodyr declarations docstring)))
  130.   ) ) )
  131.   (defstruct (load-time-eval
  132.               (:print-function
  133.                 (lambda (object stream depth)
  134.                   (declare (ignore depth))
  135.                   (write-string "#." stream)
  136.                   (write (load-time-eval-form object) :stream stream)
  137.               ) )
  138.               (:constructor make-load-time-eval (form))
  139.              )
  140.     form
  141.   )
  142.   (defun fixnump (object) (typep object 'FIXNUM))
  143.   (defun short-float-p (object) (typep object 'SHORT-FLOAT))
  144.   (defun single-float-p (object) (typep object 'SINGLE-FLOAT))
  145.   (defun double-float-p (object) (typep object 'DOUBLE-FLOAT))
  146.   (defun long-float-p (object) (typep object 'LONG-FLOAT))
  147.   ; Sucht ein Programm-File. Siehe INIT.LSP :
  148.   (defun search-file (filename extensions
  149.                       &aux (use-extensions (null (pathname-type filename))) )
  150.     (when use-extensions
  151.       (setq extensions ; Case-Konversionen auf den Extensions durchfⁿhren
  152.         (mapcar #'pathname-type extensions)
  153.     ) )
  154.     ; Defaults einmergen:
  155.     (setq filename (merge-pathnames filename '#".*"))
  156.     ; Suchen:
  157.     (let ((already-searched nil))
  158.       (dolist (dir (cons '#"" '()))
  159.         (let ((search-filename
  160.                 (merge-pathnames (merge-pathnames filename dir))
  161.              ))
  162.           (unless (member search-filename already-searched :test #'equal)
  163.             (let ((xpathnames (directory search-filename :full t :circle t)))
  164.               (when use-extensions
  165.                 ; nach passenden Extensions filtern:
  166.                 (setq xpathnames
  167.                   (delete-if-not ; hat xpathname eine der gegebenen Extensions?
  168.                     #'(lambda (xpathname)
  169.                         (member (pathname-type (first xpathname)) extensions
  170.                                 :test #'string=
  171.                       ) )
  172.                     xpathnames
  173.               ) ) )
  174.               (when xpathnames
  175.                 ; nach Datum sortiert, zurⁿckgeben:
  176.                 (dolist (xpathname xpathnames)
  177.                   (setf (rest xpathname)
  178.                         (apply #'encode-universal-time (third xpathname))
  179.                 ) )
  180.                 (return (mapcar #'first (sort xpathnames #'> :key #'rest)))
  181.             ) )
  182.             (push search-filename already-searched)
  183.       ) ) )
  184.   ) )
  185.   (defun make-macro-expander (macrodef)
  186.     (let ((dummysym (make-symbol (symbol-name (car macrodef)))))
  187.       (eval `(DEFMACRO ,dummysym ,@(cdr macrodef)))
  188.       #'(lambda (form &rest env)
  189.           (apply #'lisp:macroexpand-1 (cons dummysym (cdr form)) env)
  190.         )
  191.   ) )
  192.   ; siehe DEFS1.LSP :
  193.   (defun date-format ()
  194.     (DEUTSCH "~1{~3@*~D.~4@*~D.~5@*~D ~2@*~2,'0D:~1@*~2,'0D:~0@*~2,'0D~:}"
  195.      ENGLISH "~1{~5@*~D/~4@*~D/~3@*~D ~2@*~2,'0D.~1@*~2,'0D.~0@*~2,'0D~:}"
  196.      FRANCAIS "~1{~3@*~D/~4@*~D/~5@*~D ~2@*~2,'0D:~1@*~2,'0D:~0@*~2,'0D~:}")
  197.   )
  198.   (defun sys::line-number (stream) nil)
  199. )
  200.  
  201.  
  202. ; Version des Evaluators:
  203. ; CLISP2 : C-Version mit SP-Manipulierbarkeit
  204. ; CLISP3 : C-Version ohne SP-Manipulierbarkeit
  205. #+(and CROSS (not (or CLISP2 CLISP3)))
  206. (eval-when (eval load compile)
  207.   (pushnew
  208.     (if (y-or-n-p (DEUTSCH "Kann man von C aus den SP verΣndern?"
  209.                    ENGLISH "Can C manipulate the SP stack pointer?"
  210.                    FRANCAIS "Peut-on modifier le pointeur de pile en C?")
  211.         )
  212.       'CLISP2
  213.       'CLISP3
  214.     )
  215.     *features*
  216. ) )
  217. #+CROSS
  218. (defconstant *jmpbuf-size*
  219.   (progn
  220.     (format *query-io* (DEUTSCH "~%Bitte *jmpbuf-size* eingeben: "
  221.                         ENGLISH "~%Please input *jmpbuf-size*: "
  222.                         FRANCAIS "~%Veuillez entrer *jmpbuf-size* :")
  223.     )
  224.     (read *query-io*)
  225. ) )
  226. #+CROSS
  227. (defconstant *big-endian*
  228.   #+(or ATARI AMIGA SUN3 SUN4) t ; BIG-ENDIAN-Prozessor
  229.   #+(or SUN386 PC386) nil ; LITTLE-ENDIAN-Prozessor
  230.   #-(or ATARI AMIGA SUN3 SUN4 SUN386 PC386)
  231.     (y-or-n-p (DEUTSCH "Prozessor BIG-ENDIAN?"
  232.                ENGLISH "processor big endian?"
  233.                FRANCAIS "Processeur BIG-ENDIAN?")
  234.     )
  235. )
  236. #+CROSS
  237. (defun version ()
  238.   (list ' #+CLISP2 SYSTEM::CLISP2 #+CLISP3 SYSTEM::CLISP3
  239.         *jmpbuf-size*
  240.         *big-endian*
  241.         '210292
  242. ) )
  243.  
  244. (defconstant *keyword-package* (find-package "KEYWORD"))
  245. (defconstant *lisp-package* (find-package "LISP"))
  246.  
  247. ; Variablen fⁿr Top-Level-Aufruf:
  248. (defvar *compiling* nil) ; gibt an, ob gerade beim Compilieren
  249. ; (defvar *error-count*) ; Anzahl der aufgetretenen Errors
  250. ; (defvar *warning-count*) ; Anzahl der aufgetretenen Warnungen
  251. (defvar *compile-warnings* t) ; ob Compiler-Warnungen ausgegeben werden
  252. (defvar *compile-verbose* t) ; ob Compiler-Kommentare ausgegeben werden
  253. (defvar *compile-print* nil) ; ob der Compiler ausgibt, wo er gerade ist
  254. (defvar *compiling-from-file*) ; NIL oder T wenn von COMPILE-FILE aufgerufen
  255. (defvar *compile-file-pathname* nil) ; CLtL2 S. 680
  256. (defvar *compile-file-truename* nil) ; CLtL2 S. 680
  257. (defvar *compile-file-lineno1* nil)
  258. (defvar *compile-file-lineno2* nil)
  259. (defvar *c-listing-output*) ; Compiler-Listing-Stream oder nil
  260. (defvar *c-error-output*) ; Compiler-Error-Stream
  261. ; Es ist im wesentlichen
  262. ; *c-error-output* = (make-broadcast-stream *error-output* *c-listing-output*)
  263. (defvar *known-special-vars*) ; Namen von deklarierten dynamischen Variablen
  264. (defvar *constant-special-vars*) ; Namen und Werte von konstanten Variablen
  265.  
  266. ; Variablen fⁿr COMPILE-FILE:
  267. (defvar *fasoutput-stream* nil) ; Compiler-Output-Stream oder nil
  268. (defvar *liboutput-stream* nil) ; Compiler-Library-Stream oder nil
  269. (defvar *functions-with-errors* nil) ; Namen der Funktionen, wo es Fehler gab
  270. (defvar *known-functions*) ; Namen der bisher bekannten Funktionen,
  271.                            ; wird vom Macroexpander von DEFUN verΣndert
  272. (defvar *unknown-functions*) ; Namen der bisher unbekannten Funktionen
  273. (defvar *unknown-free-vars*) ; Namen von undeklarierten dynamischen Variablen
  274. (defvar *inline-functions*) ; global inline-deklarierte Funktionssymbole
  275. (defvar *notinline-functions*) ; global notinline-deklarierte Funktionssymbole
  276. (defvar *inline-definitions*) ; Aliste globaler inlinebarer Funktionsdefinitionen
  277. (defvar *user-declaration-types*) ; global definierte zusΣtzliche Deklarationen
  278. (defvar *compiled-modules*) ; bereits "geladene" (compilierte) Modulnamen
  279. (defvar *package-tasks*) ; noch durchzufⁿhrende Package-Anforderungen
  280.  
  281. #|
  282. Basis fⁿr den Zielcode ist eine Stackmaschine mit zwei Stacks:
  283. STACK (Stack fⁿr LISP-Objekte und Frames) und SP (Stack fⁿr sonstiges).
  284. Mehrfache Werte werden kurzfristig in A0/A1/A2/MV_SPACE (D7.W Werte, bei D7.W=0
  285. ist A0=NIL) gehalten, lΣngerfristig auf dem STACK abgelegt.
  286.  
  287. 1. Pass des Compilers:
  288. Macro-Expansion, Codegenerierung (symbolisch), Allokation von Variablen auf
  289. dem STACK oder in Closures, Optimierung auf LISP-Ebene.
  290. Danach steht fⁿr jede beteiligte Funktion das Stack-Layout fest.
  291. Die Information steckt in einem Netz von ANODEs.
  292. 2. Pass des Compilers:
  293. Aufl÷sung der Variablenbezⁿge, Optimierung auf Code-Ebene
  294. (Peephole-Optimierung), Kreation compilierter funktionaler Objekte.
  295. 3. Pass des Compilers:
  296. Aufl÷sung von Bezⁿgen zwischen den einzelnen funktionalen Objekten.
  297.  
  298. Zielsprache:
  299. ============
  300.  
  301. ein Bytecode-Interpreter.
  302.  
  303. Ein compiliertes funktionales Objekt (Closure) hat folgenden Aufbau:
  304. FUNC = #Closure( Name
  305.                  CODEVEC
  306.                  [VenvConst] {BlockConst}* {TagbodyConst}*
  307.                  {Keyword}* {sonstige Const}*
  308.                )
  309.  
  310. VenvConst, BlockConst, TagbodyConst : diese LISP-Objekte werden innerhalb der
  311. Funktion als Konstanten betrachtet. Sie werden beim Aufbau der Funktion zur
  312. Laufzeit mitgegeben. Sollten diese drei Teile fehlen (d.h. diese Funktion ist
  313. von der Inkarnation unabhΣngig, weil sie auf keine lexikalischen Variablen,
  314. Blocks oder Tags zugreift, die im compilierten Code au▀erhalb von ihr definiert
  315. werden), so hei▀t die Funktion autonom.
  316.  
  317. Keyword : die Keywords in der richtigen Reihenfolge. Werden vom Interpreter bei
  318. der Parameterⁿbergabe gebraucht.
  319.  
  320. sonstige Const: sonstige Konstanten, auf die vom Innern der Funktion aus Bezug
  321. genommen wird. Sie sind untereinander und zu allen Keywords paarweise nicht EQL.
  322.  
  323. CODEVEC = Code-Vektor, ein SIMPLE-BIT-VECTOR,
  324.                  Falls nicht FAST_SP:
  325.                    2 Bytes : maximale SP-Tiefe
  326.                  2 Bytes : Anzahl der required parameter
  327.                  2 Bytes : Anzahl der optionalen Parameter
  328.                  1 Byte : Flags. Bit 0: ob &REST - Parameter angegeben
  329.                                  Bit 7: ob Keyword-Parameter angegeben
  330.                                  Bit 6: &ALLOW-OTHER-KEYS-Flag
  331.                                  Bit 4: ob generische Funktion
  332.                  1 Byte : Kⁿrzel fⁿr den Argumenttyp, fⁿr schnelleres FUNCALL
  333.                  Falls Keyword-Parameter angegeben:
  334.                    4 Bytes : 2 Bytes : Anzahl der Keyword-Parameter
  335.                              2 Bytes : Offset in FUNC der Keywords
  336.                  dann
  337.                  eine Folge von Byte-Instruktionen.
  338.  
  339. |#
  340. ; externe ReprΣsentation einer Closure:
  341. ; #Y(name
  342. ;    #LΣngeY(Byte in Hex ... Byte in Hex)
  343. ;    weitere Konstanten
  344. ;   )
  345.  
  346. #-CLISP
  347. (progn
  348.   (defstruct (closure (:print-function print-closure))
  349.     name    ; der Name der Closure
  350.     codevec ; Liste der Bytes des Codevektor
  351.     consts  ; Liste der Konstanten
  352.   )
  353.   (defun print-closure (closure stream depth)
  354.     (declare (ignore depth))
  355.     (write-string "#Y(" stream)
  356.     (write (closure-name closure) :stream stream)
  357.     (write-char #\space stream)
  358.     (write-char #\# stream)
  359.     (write (length (closure-codevec closure)) :stream stream :base 10. :radix nil :readably nil)
  360.     (write-char #\Y stream)
  361.     ;(write (closure-codevec closure) :stream stream :base 16.) ; stattdessen:
  362.     (write-char #\( stream)
  363.     (do ((i 0 (1- i))
  364.          (L (closure-codevec closure) (cdr L)))
  365.         ((endp L))
  366.       (when (zerop i) (write-char #\newline stream) (setq i 25))
  367.       (write-char #\space stream)
  368.       (write (car L) :stream stream :base 16. :radix nil :readably nil)
  369.     )
  370.     (write-char #\) stream)
  371.     (write-char #\newline stream)
  372.     (dolist (x (closure-consts closure))
  373.       (write-char #\space stream)
  374.       (write x :stream stream)
  375.     )
  376.     (write-char #\) stream)
  377.   )
  378. )
  379.  
  380. #+CLISP
  381. (progn
  382.   (defsetf sys::%record-ref sys::%record-store)
  383.   (defsetf closure-name (closure) (new-name)
  384.     `(sys::%record-store ,closure 0 ,new-name)
  385.   )
  386.   (defun make-closure (&key name codevec consts)
  387.     (sys::%make-closure name (sys::make-code-vector codevec) consts)
  388.   )
  389. )
  390.  
  391. #-CLISP
  392. (set-dispatch-macro-character #\# #\Y
  393.   #'(lambda (stream subchar arg)
  394.       (declare (ignore subchar))
  395.       (if arg
  396.         ; Codevector lesen
  397.         (let ((obj (let ((*read-base* 16.)) (read stream t nil t))))
  398.           (unless (= (length obj) arg)
  399.             (error (DEUTSCH "Falsche LΣnge eines Closure-Vektors: ~S"
  400.                     ENGLISH "Bad length of closure vector: ~S"
  401.                     FRANCAIS "Mauvaise longueur pour un vecteur de fermeture : ~S")
  402.                    arg
  403.           ) )
  404.           obj
  405.         )
  406.         ; Closure lesen
  407.         (let ((obj (read stream t nil t)))
  408.           (make-closure :name (first obj) :codevec (second obj) :consts (cddr obj))
  409.     ) ) )
  410. )
  411.  
  412. #|
  413. Instruktionen:
  414. Instruktionen k÷nnen Operanden haben.
  415. Operanden, die Sprungziele (labels) darstellen, sind (um CodelΣnge zu sparen)
  416. relativ angegeben:
  417.     PC := PC(in der Instruktion) + Operand(signed)
  418. Operanden, die Zahlen darstellen, sind Integers >=0.
  419. Format der Operanden:
  420. bei LOAD, ... mit kleinem Operanden: implizit im Code.
  421. bei allen anderen Instruktionen:
  422.   nΣchstes Byte:
  423.     Bit 7 = 0 --> Bits 6..0 sind der Operand (7 Bits).
  424.     Bit 7 = 1 --> Bits 6..0 und nΣchstes Byte bilden den Operanden (15 Bits).
  425.                   Bei Sprungdistanzen: Sollte dieser =0 sein, so bilden
  426.                   die nΣchsten 4 Bytes den Operanden (32 Bits).
  427.  
  428.  
  429. (1) Instruktionen fⁿr Konstanten:
  430.  
  431. Mnemonic                      Bedeutung
  432.  
  433. (NIL)                         A0 := NIL, 1 Wert
  434.  
  435. (PUSH-NIL n)                  n-mal: -(STACK) := NIL, undefinierte Werte
  436.  
  437. (T)                           A0 := T, 1 Wert
  438.  
  439. (CONST n)                     A0 := Konstante Nr. n aus FUNC, 1 Wert
  440.  
  441.  
  442. (2) Instruktionen fⁿr statische Variablen
  443.  
  444. Mnemonic                      Bedeutung
  445.  
  446. (LOAD n)                      A0 := (STACK+4*n), 1 Wert
  447.  
  448. (LOADI k n)                   A0 := ((SP+4*k)+4*n), 1 Wert
  449.  
  450. (LOADC n m)                   A0 := (svref (STACK+4*n) 1+m), 1 Wert
  451.  
  452. (LOADV k m)                   A0 := (svref ... m)
  453.                                     (svref ... 0) ; k mal wiederholt
  454.                                     VenvConst,
  455.                               1 Wert
  456.  
  457. (LOADIC k n m)                A0 := (svref ((SP+4*k)+4*n) 1+m), 1 Wert
  458.  
  459. (STORE n)                     (STACK+4*n) := A0, 1 Wert
  460.  
  461. (STOREI k n)                  ((SP+4*k)+4*n) := A0, 1 Wert
  462.  
  463. (STOREC n m)                  (svref (STACK+4*n) 1+m) := A0, 1 Wert
  464.  
  465. (STOREV k m)                  (svref ... m)
  466.                               (svref ... 0) ; k mal wiederholt
  467.                               VenvConst
  468.                               := A0, 1 Wert
  469.  
  470. (STOREIC k n m)               (svref ((SP+4*k)+4*n) 1+m) := A0, 1 Wert
  471.  
  472.  
  473. (3) Instruktionen fⁿr dynamische Variablen
  474.  
  475. Mnemonic                      Bedeutung
  476.  
  477. (GETVALUE n)                  A0 := (symbol-value (CONST n)), 1 Wert
  478.  
  479. (SETVALUE n)                  (setf (symbol-value (CONST n)) A0), 1 Wert
  480.  
  481. (BIND n)                      bindet (CONST n), ein Symbol, dynamisch an A0.
  482.                               Undefinierte Werte.
  483.  
  484. (UNBIND1)                     l÷st einen Bindungsframe auf
  485. (UNBIND n)                    l÷st n Bindungsframes auf
  486.  
  487. (PROGV)                       bindet dynamisch die Symbole in der Liste
  488.                               (STACK)+ an die Werte in der Liste A0 und baut
  489.                               dabei genau einen Bindungsframe auf,
  490.                               undefinierte Werte
  491.  
  492.  
  493. (4) Instruktionen fⁿr Stackoperationen
  494.  
  495. Mnemonic                      Bedeutung
  496.  
  497. (PUSH)                        -(STACK) := A0, undefinierte Werte
  498.  
  499. (POP)                         A0 := (STACK)+, 1 Wert
  500.  
  501. (SKIP n)                      STACK := STACK+4*n
  502.  
  503. (SKIPI k n)                   STACK := (SP+4*k)+4*n, SP:=SP+4*(k+1)
  504.  
  505. (SKIPSP k)                    SP := SP+4*k
  506.  
  507.  
  508. (5) Instruktionen fⁿr Programmflu▀ und Sprⁿnge
  509.  
  510. Mnemonic                      Bedeutung
  511.  
  512. (SKIP&RET n)                  STACK := STACK+4*n, beendet die Funktion
  513.                               mit den Werten A0/...
  514.  
  515. (JMP label)                   Sprung zu label
  516.  
  517. (JMPIF label)                 falls A0 /= NIL : Sprung zu label.
  518.  
  519. (JMPIFNOT label)              falls A0 = NIL : Sprung zu label.
  520.  
  521. (JMPIF1 label)                falls A0 /= NIL : 1 Wert, Sprung zu label.
  522.  
  523. (JMPIFNOT1 label)             falls A0 = NIL : 1 Wert, Sprung zu label.
  524.  
  525. (JMPIFATOM label)             falls A0 kein Cons : Sprung zu label.
  526.                               Undefinierte Werte.
  527.  
  528. (JMPIFCONSP label)            falls A0 ein Cons : Sprung zu label.
  529.                               Undefinierte Werte.
  530.  
  531. (JMPIFEQ label)               falls A0 EQ zu (STACK)+ : Sprung zu label.
  532.                               Undefinierte Werte.
  533.  
  534. (JMPIFNOTEQ label)            falls A0 nicht EQ zu (STACK)+ : Sprung zu label.
  535.                               Undefinierte Werte.
  536.  
  537. (JMPIFEQTO n label)           falls (STACK)+ EQ zu (CONST n) : Sprung zu label.
  538.                               Undefinierte Werte.
  539.  
  540. (JMPIFNOTEQTO n label)        falls (STACK)+ nicht EQ zu (CONST n) : Sprung zu label.
  541.                               Undefinierte Werte.
  542.  
  543. (JMPHASH n label)             Sucht A0 in der EQ- oder EQL-Hash-Tabelle
  544.                               (CONST n). Gefunden: Sprung ans von GETHASH
  545.                               gelieferte Label. Nicht gefunden: Sprung zu
  546.                               label. Undefinierte Werte.
  547.  
  548. (JMPHASHV n label)            Sucht A0 in der EQ- oder EQL-Hash-Tabelle
  549.                               (svref (CONST 0) n). Gefunden: Sprung ans von
  550.                               GETHASH gelieferte Label. Nicht gefunden: Sprung
  551.                               zu label. Undefinierte Werte.
  552.  
  553. (JSR label)                   Unterprogrammaufruf: lege Closure auf den STACK und
  554.                               springe zu label (mit undefinierten Werten),
  555.                               (RET) setzt das Programm an der Stelle nach
  556.                               dem (JSR label) fort.
  557.  
  558. (JMPTAIL m n label)           Wiederverwendung eines Stack-Frames: n>=m.
  559.                               Der Stack-Frame der Gr÷▀e n wird auf Gr÷▀e m
  560.                               verkleinert, indem die unteren m EintrΣge um
  561.                               n-m nach oben kopiert werden:
  562.                               (STACK+4*(n-m)...STACK+4*(n-1)) := (STACK+4*0...STACK+4*(m-1)),
  563.                               STACK := STACK + 4*(n-m),
  564.                               dann -(STACK) := Closure,
  565.                               Sprung zu label mit undefinierten Werten.
  566.  
  567.  
  568. (6) Instruktionen fⁿr Environments und Closures
  569.  
  570. Mnemonic                      Bedeutung
  571.  
  572. (VENV)                        A0 := VenvConst aus FUNC, 1 Wert
  573.  
  574. (MAKE-VECTOR1&PUSH n)         kreiert einen simple-vector mit n+1 (n>=0) Kom-
  575.                               ponenten und steckt A0 als Komponente 0 hinein.
  576.                               -(STACK) := der neue Vektor. Undefinierte Werte.
  577.  
  578. (COPY-CLOSURE m n)            kopiert die Closure (CONST m) aus FUNC und
  579.                               ersetzt in der Kopie fⁿr i=0,...,n-1 (n>0) die
  580.                               Komponente (CONST i) durch (STACK+4*(n-1-i)).
  581.                               STACK := STACK+4*n.
  582.                               A0 := Closure-Kopie, 1 Wert
  583.  
  584.  
  585. (7) Instruktionen fⁿr Funktionsaufrufe
  586.  
  587. Mnemonic                      Bedeutung
  588.  
  589. (CALL k n)                    ruft die Funktion (CONST n) mit k Argumenten
  590.                               (STACK+4*(k-1)),...,(STACK+4*0) auf,
  591.                               STACK:=STACK+4*k,
  592.                               Ergebnis kommt nach A0/...
  593.  
  594. (CALL0 n)                     ruft die Funktion (CONST n) mit 0 Argumenten
  595.                               auf, Ergebnis kommt nach A0/...
  596.  
  597. (CALL1 n)                     ruft die Funktion (CONST n) mit einem Argument
  598.                               (STACK)+ auf, Ergebnis kommt nach A0/...
  599.  
  600. (CALL2 n)                     ruft die Funktion (CONST n) mit zwei Argumenten
  601.                               4(STACK),(STACK) auf, STACK:=STACK+8,
  602.                               Ergebnis kommt nach A0/...
  603.  
  604. (CALLS1 n)                    ruft die Funktion (FUNTAB n)
  605. (CALLS2 n)                    bzw. (FUNTAB 256+n)
  606.                               (ein SUBR ohne Rest-Parameter) auf,
  607.                               mit der korrekten Argumentezahl auf dem STACK.
  608.                               STACK wird bereinigt, Ergebnis kommt nach A0/...
  609.  
  610. (CALLSR m n)                  ruft die Funktion (FUNTABR n)
  611.                               (ein SUBR mit Rest-Parameter) auf,
  612.                               mit der korrekten Argumentezahl und zusΣtzlich
  613.                               m restlichen Argumenten auf dem STACK.
  614.                               STACK wird bereinigt, Ergebnis kommt nach A0/...
  615.  
  616. (CALLC)                       ruft die Funktion A0 (eine compilierte Closure
  617.                               ohne Keyword-Parameter) auf. Argumente
  618.                               sind schon im richtigen Format auf dem STACK,
  619.                               STACK wird bereinigt, Ergebnis kommt nach A0/...
  620.  
  621. (CALLCKEY)                    ruft die Funktion A0 (eine compilierte Closure
  622.                               mit Keyword-Parameter) auf. Argumente
  623.                               sind schon im richtigen Format auf dem STACK,
  624.                               STACK wird bereinigt, Ergebnis kommt nach A0/...
  625.  
  626. (FUNCALL n)                   ruft die Funktion (STACK+4*n) mit n (n>=0)
  627.                               Argumenten (alle auf dem Stack) auf,
  628.                               STACK:=STACK+4*(n+1)
  629.                               Ergebnis kommt nach A0/...
  630.  
  631. (APPLY n)                     ruft die Funktion (STACK+4*n) mit n (n>=0)
  632.                               Argumenten (alle auf dem Stack) und weiteren
  633.                               Argumenten (Liste in A0) auf,
  634.                               STACK:=STACK+4*(n+1),
  635.                               Ergebnis kommt nach A0/...
  636.  
  637.  
  638. (8) Instruktionen fⁿr optionale und Keyword-Argumente
  639.  
  640. Mnemonic                      Bedeutung
  641.  
  642. (PUSH-UNBOUND n)              n-mal: -(STACK) := #<UNBOUND>, undefinierte Werte
  643.  
  644. (UNLIST n m)                  Liste A0 n mal verkⁿrzen: -(STACK) := (car A0),
  645.                               A0 := (cdr A0). Bei den letzten m Mal darf A0
  646.                               schon zu Ende sein, dann -(STACK) := #<UNBOUND>
  647.                               stattdessen. Am Schlu▀ mu▀ A0 = NIL sein,
  648.                               undefinierte Werte. 0 <= m <= n.
  649.  
  650. (UNLIST* n m)                 Liste A0 n mal verkⁿrzen: -(STACK) := (car A0),
  651.                               A0 := (cdr A0). Bei den letzten m Mal darf A0
  652.                               schon zu Ende sein, dann -(STACK) := #<UNBOUND>.
  653.                               stattdessen. Dann -(STACK) := (nthcdr n A0),
  654.                               undefinierte Werte. 0 <= m <= n, n > 0.
  655.  
  656. (JMPIFBOUNDP n label)         falls (STACK+4*n) /= #<UNBOUND> :
  657.                                 Sprung zu label, A0 := (STACK+4*n), 1 Wert.
  658.                               Sonst undefinierte Werte.
  659.  
  660. (BOUNDP n)                    A0 := (NIL falls (STACK+4*n)=#<UNBOUND>, T sonst), 1 Wert
  661.  
  662. (UNBOUND->NIL n)              Falls (STACK+4*n) = #<UNBOUND>: (STACK+4*n) := NIL
  663.  
  664.  
  665. (9) Instruktionen zur Behandlung mehrerer Werte
  666.  
  667. Mnemonic                      Bedeutung
  668.  
  669. (VALUES0)                     A0 := NIL, 0 Werte
  670.  
  671. (VALUES1)                     A0 := A0, 1 Wert
  672.  
  673. (STACK-TO-MV n)               holt n Werte von (STACK)+ herab,
  674.                               STACK:=STACK+4*n
  675.  
  676. (MV-TO-STACK)                 Multiple Values A0/A1/... auf -(STACK), 1. Wert
  677.                               zuoberst, STACK:=STACK-4*D7.W,
  678.                               danach undefinierte Werte
  679.  
  680. (NV-TO-STACK n)               die ersten n Werte (n>=0) auf -(STACK), 1. Wert
  681.                               zuoberst, STACK:=STACK-4*n, undefinierte Werte
  682.  
  683. (MV-TO-LIST)                  Multiple Values A0/... als Liste nach A0, 1 Wert
  684.  
  685. (LIST-TO-MV)                  A0/... := (values-list A0)
  686.  
  687. (MVCALLP)                     rette STACK auf -(SP), rette A0 auf -(STACK)
  688.  
  689. (MVCALL)                      fⁿhre einen Funktionsaufruf aus, wobei zwischen
  690.                               STACK und STACK:=(SP)+ die Funktion (ganz oben)
  691.                               und die Argumente stehen,
  692.                               Ergebnis kommt nach A0/...
  693.  
  694.  
  695. (10) Instruktionen fⁿr BLOCK
  696.  
  697. Mnemonic                      Bedeutung
  698.  
  699. (BLOCK-OPEN n label)          Legt einen Block-Cons (mit CAR=(CONST n) und
  700.                               CDR=Framepointer) auf -(STACK) ab, baut einen
  701.                               Block-Frame auf. Bei einem RETURN auf diesen
  702.                               Frame wird zu label gesprungen.
  703.  
  704. (BLOCK-CLOSE)                 Verlasse den Block und baue dabei einen Block-
  705.                               Frame ab (inklusive der Block-Cons-Variablen)
  706.  
  707. (RETURN-FROM n)               Verlasse den Block, dessen Block-Cons
  708.                               (CONST n) ist, mit den Werten A0/...
  709.  
  710. (RETURN-FROM-I k n)           Verlasse den Block, dessen Block-Cons
  711.                               ((SP+4*k)+4*n) ist, mit den Werten A0/...
  712.  
  713.  
  714. (11) Instruktionen fⁿr TAGBODY
  715.  
  716. Mnemonic                      Bedeutung
  717.  
  718. (TAGBODY-OPEN n label1 ... labelm)
  719.                               Legt einen Tagbody-Cons (mit CAR = (CONST n),
  720.                               einem Simple-Vector der LΣnge m, und
  721.                               CDR=Framepointer) auf -(STACK) ab, baut einen
  722.                               Tagbody-Frame auf. Bei einem GO mit Nummer l
  723.                               wird zu labell gesprungen. Undefinierte Werte.
  724.  
  725. (TAGBODY-CLOSE-NIL)           Verlasse den Tagbody und baue dabei einen
  726.                               Tagbody-Frame ab (inklusive der Tagbody-Cons-
  727.                               Variablen).
  728.                               A0 := NIL, 1 Wert
  729.  
  730. (TAGBODY-CLOSE)               Verlasse den Tagbody und baue dabei
  731.                               einen Tagbody-Frame ab (inklusive der
  732.                               Tagbody-Cons-Variablen).
  733.  
  734. (GO n l)                      Springe im Tagbody, dessen Tagbody-Cons
  735.                               (CONST n) ist, an Tag Nummer l
  736.  
  737. (GO-I k n l)                  Springe im Tagbody, dessen Tagbody-Cons
  738.                               ((SP+4*k)+4*n) ist, an Tag Nummer l
  739.  
  740.  
  741. (12) Instruktionen fⁿr CATCH und THROW
  742.  
  743. Mnemonic                      Bedeutung
  744.  
  745. (CATCH-OPEN label)            baut einen CATCH-Frame auf mit A0 als Tag;
  746.                               bei einem THROW auf dieses Tag wird zu label
  747.                               gesprungen
  748.  
  749. (CATCH-CLOSE)                 l÷st einen CATCH-Frame auf
  750.  
  751. (THROW)                       fⁿhrt ein THROW auf den Catch-Tag (STACK)+ aus,
  752.                               mit den Werten A0/...
  753.  
  754.  
  755. (13) Instruktionen fⁿr UNWIND-PROTECT
  756.  
  757. Mnemonic                      Bedeutung
  758.  
  759. (UNWIND-PROTECT-OPEN label)   baut einen UNWIND-PROTECT-Frame auf;
  760.                               bei einem Unwind wird unter Rettung
  761.                               der Werte zu label gesprungen
  762.  
  763. (UNWIND-PROTECT-NORMAL-EXIT)  l÷st einen Unwind-Protect-Frame auf, schreibt
  764.                               eine Weitermach-Adresse auf SP, rettet die
  765.                               Werte und fΣngt an, den folgenden Cleanup-Code
  766.                               auszufⁿhren
  767.  
  768. (UNWIND-PROTECT-CLOSE)        beendet den Cleanup-Code: schreibt die
  769.                               geretteten Werte zurⁿck, fⁿhrt ein RTS aus
  770.  
  771. (UNWIND-PROTECT-CLEANUP)      l÷st einen Unwind-Protect-Frame auf,
  772.                               schreibt eine Weitermach-Adresse und
  773.                               den PC auf SP, rettet die Werte und
  774.                               fΣngt an, den Cleanup-Code auszufⁿhren
  775.  
  776.  
  777. (14) Instruktionen fⁿr HANDLER-BIND
  778.  
  779. Mnemonic                      Bedeutung
  780.  
  781. (HANDLER-OPEN n)              baut einen HANDLER-Frame auf; (CONST n) enthΣlt
  782.                               die Condition-Typen, die entsprechenden Labels
  783.                               und die aktuelle SP-Tiefe
  784.  
  785. (HANDLER-BEGIN&PUSH)          beginnt einen Handler: stellt den SP-Zustand
  786.                               wie beim HANDLER-OPEN her,
  787.                               A0 := dem Handler ⁿbergebene Condition, 1 Wert,
  788.                               -(STACK) := A0
  789.  
  790.  
  791. (15) Kurz-Instruktionen fⁿr einige Funktionen
  792.  
  793. Mnemonic                      Bedeutung
  794.  
  795. (NOT)                         A0 := (not A0), 1 Wert
  796.  
  797. (EQ)                          A0 := (eq (STACK)+ A0), 1 Wert
  798.  
  799. (CAR)                         A0 := (car A0), 1 Wert
  800.  
  801. (CDR)                         A0 := (cdr A0), 1 Wert
  802.  
  803. (CONS)                        A0 := (cons (STACK)+ A0), 1 Wert
  804.  
  805. (SYMBOL-FUNCTION)             A0 := (symbol-function A0), 1 Wert
  806.  
  807. (SVREF)                       A0 := (svref (STACK)+ A0), 1 Wert
  808.  
  809. (SVSET)                       (setf (svref (STACK) A0) (STACK+4)),
  810.                               A0 := (STACK+4), 1 Wert, STACK:=STACK+8
  811.  
  812. (LIST n)                      Bildet eine Liste aus den untersten n auf dem STACK
  813.                               liegenden Objekten, STACK := STACK + 4*n,
  814.                               Liste nach A0, 1 Wert
  815.  
  816. (LIST* n)                     Bildet eine Liste aus den untersten n auf dem STACK
  817.                               liegenden Objekten und A0, STACK := STACK + 4*n,
  818.                               Liste nach A0, 1 Wert
  819.  
  820.  
  821. (16)
  822. ZusΣtzlich gibt es kombinierte Operationen im Format
  823. (<OP1>&<OP2>&...&<OPn> <Operanden_1> <Operanden_2> ... <Operanden_n>) .
  824.  
  825. Mnemonic                           Bedeutung
  826.  
  827. (NIL&PUSH)                         (NIL) (PUSH)
  828. (T&PUSH)                           (T) (PUSH)
  829. (CONST&PUSH n)                     (CONST n) (PUSH)
  830. (LOAD&PUSH n)                      (LOAD n) (PUSH)
  831. (LOADI&PUSH k n)                   (LOADI k n) (PUSH)
  832. (LOADC&PUSH n m)                   (LOADC n m) (PUSH)
  833. (LOADV&PUSH k m)                   (LOADV k m) (PUSH)
  834. (POP&STORE n)                      (POP) (STORE n)
  835. (GETVALUE&PUSH n)                  (GETVALUE n) (PUSH)
  836. (JSR&PUSH label)                   (JSR label) (PUSH)
  837. (COPY-CLOSURE&PUSH m n)            (COPY-CLOSURE m n) (PUSH)
  838. (CALL&PUSH k n)                    (CALL k n) (PUSH)
  839. (CALL1&PUSH n)                     (CALL1 n) (PUSH)
  840. (CALL2&PUSH n)                     (CALL2 n) (PUSH)
  841. (CALLS1&PUSH n)                    (CALLS1 n) (PUSH)
  842. (CALLS2&PUSH n)                    (CALLS2 n) (PUSH)
  843. (CALLSR&PUSH m n)                  (CALLSR m n) (PUSH)
  844. (CALLC&PUSH)                       (CALLC) (PUSH)
  845. (CALLCKEY&PUSH)                    (CALLCKEY) (PUSH)
  846. (FUNCALL&PUSH n)                   (FUNCALL n) (PUSH)
  847. (APPLY&PUSH n)                     (APPLY n) (PUSH)
  848. (CAR&PUSH)                         (CAR) (PUSH)
  849. (CDR&PUSH)                         (CDR) (PUSH)
  850. (CONS&PUSH)                        (CONS) (PUSH)
  851. (LIST&PUSH n)                      (LIST n) (PUSH)
  852. (LIST*&PUSH n)                     (LIST* n) (PUSH)
  853. (NIL&STORE n)                      (NIL) (STORE n)
  854. (T&STORE n)                        (T) (STORE n)
  855. (LOAD&STOREC k n m)                (LOAD k) (STOREC n m)
  856. (CALLS1&STORE n k)                 (CALLS1 n) (STORE k)
  857. (CALLS2&STORE n k)                 (CALLS2 n) (STORE k)
  858. (CALLSR&STORE m n k)               (CALLSR m n) (STORE k)
  859. (LOAD&CDR&STORE n)                 (LOAD n) (CDR) (STORE n)
  860. (LOAD&CONS&STORE n)                (LOAD n+1) (CONS) (STORE n)
  861. (LOAD&INC&STORE n)                 (LOAD n) (CALL1 #'1+) (STORE n)
  862. (LOAD&DEC&STORE n)                 (LOAD n) (CALL1 #'1-) (STORE n)
  863. (LOAD&CAR&STORE m n)               (LOAD m) (CAR) (STORE n)
  864. (CALL1&JMPIF n label)              (CALL1 n) (JMPIF label)
  865. (CALL1&JMPIFNOT n label)           (CALL1 n) (JMPIFNOT label)
  866. (CALL2&JMPIF n label)              (CALL2 n) (JMPIF label)
  867. (CALL2&JMPIFNOT n label)           (CALL2 n) (JMPIFNOT label)
  868. (CALLS1&JMPIF n label)             (CALLS1 n) (JMPIF label)
  869. (CALLS1&JMPIFNOT n label)          (CALLS1 n) (JMPIFNOT label)
  870. (CALLS2&JMPIF n label)             (CALLS2 n) (JMPIF label)
  871. (CALLS2&JMPIFNOT n label)          (CALLS2 n) (JMPIFNOT label)
  872. (CALLSR&JMPIF m n label)           (CALLSR m n) (JMPIF label)
  873. (CALLSR&JMPIFNOT m n label)        (CALLSR m n) (JMPIFNOT label)
  874. (LOAD&JMPIF n label)               (LOAD n) (JMPIF label)
  875. (LOAD&JMPIFNOT n label)            (LOAD n) (JMPIFNOT label)
  876. (LOAD&CAR&PUSH n)                  (LOAD n) (CAR) (PUSH)
  877. (LOAD&CDR&PUSH n)                  (LOAD n) (CDR) (PUSH)
  878. (LOAD&INC&PUSH n)                  (LOAD n) (CALL1 #'1+) (PUSH)
  879. (LOAD&DEC&PUSH n)                  (LOAD n) (CALL1 #'1-) (PUSH)
  880. (CONST&SYMBOL-FUNCTION n)          (CONST n) (SYMBOL-FUNCTION)
  881. (CONST&SYMBOL-FUNCTION&PUSH n)     (CONST n) (SYMBOL-FUNCTION) (PUSH)
  882. (CONST&SYMBOL-FUNCTION&STORE n k)  (CONST n) (SYMBOL-FUNCTION) (STORE k)
  883.  
  884.  
  885. |#
  886.  
  887. ; Instruktionen-Klassifikation:
  888. ; O = Instruktion ohne Operand
  889. ; K = numerischer Operand oder
  890. ;     Kurz-Operand (dann ist das Byte = short-code-ops[x] + Operand)
  891. ; N = numerischer Operand
  892. ; B = Byte-Operand
  893. ; L = Label-Operand
  894. ; NH = numerischer Operand, der eine Hashtable referenziert
  895. ; NC = numerischer Operand, der ein Handler-Cons referenziert
  896. ; LX = so viele Label-Operanden, wie der vorangehende Operand angibt
  897.  
  898. ; Die Position in der Instruction-Table liefert den eigentlichen Code der
  899. ; Instruktion (>= 0, < short-code-base), Codes >= short-code-base werden
  900. ; von den K-Instruktionen belegt.
  901. (defconstant instruction-table
  902.   '#(; (1) Konstanten
  903.      (NIL O) (PUSH-NIL N) (T O) (CONST K)
  904.      ; (2) statische Variablen
  905.      (LOAD K) (LOADI NN) (LOADC NN) (LOADV NN) (LOADIC NNN)
  906.      (STORE K) (STOREI NN) (STOREC NN) (STOREV NN) (STOREIC NNN)
  907.      ; (3) dynamische Variablen
  908.      (GETVALUE N) (SETVALUE N) (BIND N) (UNBIND1 O) (UNBIND N) (PROGV O)
  909.      ; (4) Stackoperationen
  910.      (PUSH O) (POP O) (SKIP N) (SKIPI NN) (SKIPSP N)
  911.      ; (5) Programmflu▀ und Sprⁿnge
  912.      (SKIP&RET N) (JMP L) (JMPIF L) (JMPIFNOT L) (JMPIF1 L) (JMPIFNOT1 L)
  913.      (JMPIFATOM L) (JMPIFCONSP L) (JMPIFEQ L) (JMPIFNOTEQ L)
  914.      (JMPIFEQTO NL) (JMPIFNOTEQTO NL) (JMPHASH NHL) (JMPHASHV NHL) (JSR L)
  915.      (JMPTAIL NNL)
  916.      ; (6) Environments und Closures
  917.      (VENV O) (MAKE-VECTOR1&PUSH N) (COPY-CLOSURE NN)
  918.      ; (7) Funktionsaufrufe
  919.      (CALL NN) (CALL0 N) (CALL1 N) (CALL2 N)
  920.      (CALLS1 B) (CALLS2 B) (CALLSR NB) (CALLC O) (CALLCKEY O)
  921.      (FUNCALL N) (APPLY N)
  922.      ; (8) optionale und Keyword-Argumente
  923.      (PUSH-UNBOUND N) (UNLIST NN) (UNLIST* NN) (JMPIFBOUNDP NL) (BOUNDP N)
  924.      (UNBOUND->NIL N)
  925.      ; (9) Behandlung mehrerer Werte
  926.      (VALUES0 O) (VALUES1 O) (STACK-TO-MV N) (MV-TO-STACK O) (NV-TO-STACK N)
  927.      (MV-TO-LIST O) (LIST-TO-MV O) (MVCALLP O) (MVCALL O)
  928.      ; (10) BLOCK
  929.      (BLOCK-OPEN NL) (BLOCK-CLOSE O) (RETURN-FROM N) (RETURN-FROM-I NN)
  930.      ; (11) TAGBODY
  931.      (TAGBODY-OPEN NLX) (TAGBODY-CLOSE-NIL O) (TAGBODY-CLOSE O) (GO NN)
  932.      (GO-I NNN)
  933.      ; (12) CATCH und THROW
  934.      (CATCH-OPEN L) (CATCH-CLOSE O) (THROW O)
  935.      ; (13) UNWIND-PROTECT
  936.      (UNWIND-PROTECT-OPEN L) (UNWIND-PROTECT-NORMAL-EXIT O)
  937.      (UNWIND-PROTECT-CLOSE O) (UNWIND-PROTECT-CLEANUP O)
  938.      ; (14) HANDLER
  939.      (HANDLER-OPEN NC) (HANDLER-BEGIN&PUSH O)
  940.      ; (15) einige Funktionen
  941.      (NOT O) (EQ O) (CAR O) (CDR O) (CONS O) (SYMBOL-FUNCTION O) (SVREF O)
  942.      (SVSET O) (LIST N) (LIST* N)
  943.      ; (16) kombinierte Operationen
  944.      (NIL&PUSH O) (T&PUSH O) (CONST&PUSH K)
  945.      (LOAD&PUSH K) (LOADI&PUSH NN) (LOADC&PUSH NN) (LOADV&PUSH NN) (POP&STORE N)
  946.      (GETVALUE&PUSH N)
  947.      (JSR&PUSH L)
  948.      (COPY-CLOSURE&PUSH NN)
  949.      (CALL&PUSH NN) (CALL1&PUSH N) (CALL2&PUSH N)
  950.      (CALLS1&PUSH B) (CALLS2&PUSH B) (CALLSR&PUSH NB)
  951.      (CALLC&PUSH O) (CALLCKEY&PUSH O)
  952.      (FUNCALL&PUSH N) (APPLY&PUSH N)
  953.      (CAR&PUSH O) (CDR&PUSH O) (CONS&PUSH O)
  954.      (LIST&PUSH N) (LIST*&PUSH N)
  955.      (NIL&STORE N) (T&STORE N) (LOAD&STOREC NNN)
  956.      (CALLS1&STORE BN) (CALLS2&STORE BN) (CALLSR&STORE NBN)
  957.      (LOAD&CDR&STORE N) (LOAD&CONS&STORE N) (LOAD&INC&STORE N) (LOAD&DEC&STORE N)
  958.      (LOAD&CAR&STORE NN)
  959.      (CALL1&JMPIF NL) (CALL1&JMPIFNOT NL)
  960.      (CALL2&JMPIF NL) (CALL2&JMPIFNOT NL)
  961.      (CALLS1&JMPIF BL) (CALLS1&JMPIFNOT BL)
  962.      (CALLS2&JMPIF BL) (CALLS2&JMPIFNOT BL)
  963.      (CALLSR&JMPIF NBL) (CALLSR&JMPIFNOT NBL)
  964.      (LOAD&JMPIF NL) (LOAD&JMPIFNOT NL)
  965.      (LOAD&CAR&PUSH N) (LOAD&CDR&PUSH N) (LOAD&INC&PUSH N) (LOAD&DEC&PUSH N)
  966.      (CONST&SYMBOL-FUNCTION N) (CONST&SYMBOL-FUNCTION&PUSH N)
  967.      (CONST&SYMBOL-FUNCTION&STORE NN)
  968.      (APPLY&SKIP&RET NN)
  969. )   )
  970. (dotimes (i (length instruction-table))
  971.   (setf (get (first (svref instruction-table i)) 'INSTRUCTION) i)
  972. )
  973. (defconstant instruction-codes
  974.   (let ((hashtable (make-hash-table :test #'eq)))
  975.     (dotimes (i (length instruction-table))
  976.       (setf (gethash (first (svref instruction-table i)) hashtable) i)
  977.     )
  978.     hashtable
  979. ) )
  980.  
  981. ; K-Instruktionen:
  982. (defconstant instruction-table-K
  983.   '#(LOAD LOAD&PUSH CONST CONST&PUSH STORE)
  984. )
  985. (defconstant short-code-base 155)
  986. (defconstant short-code-opsize '#(15   25   21   30   10))
  987. (defconstant short-code-ops '#(155  170  195  216  246));256
  988.  
  989.  
  990. #|
  991.  
  992. Zwischensprache nach dem 1. Pass:
  993. =================================
  994.  
  995. 1. Konstanten:
  996.  
  997. (NIL)                            A0 := NIL, 1 Wert
  998.  
  999. (PUSH-NIL n)                     n-mal: -(STACK) := NIL, undefinierte Werte
  1000.  
  1001. (T)                              A0 := T, 1 Wert
  1002.  
  1003. (CONST const)                    A0 := 'const, 1 Wert
  1004.  
  1005. (FCONST fnode)                   A0 := das Compilat des fnode, 1 Wert
  1006.  
  1007. (BCONST block)                   A0 := das Block-Cons dieses Blockes (eine
  1008.                                  Konstante aus FUNC), 1 Wert
  1009.  
  1010. (GCONST tagbody)                 A0 := das Tagbody-Cons dieses Tagbody (eine
  1011.                                  Konstante aus FUNC), 1 Wert
  1012.  
  1013. 2.,3. Variablen:
  1014.  
  1015. (GET var venvc stackz)           A0 := var, 1 Wert
  1016.                                  (venvc ist das aktuelle Closure-Venv,
  1017.                                   stackz der aktuelle Stackzustand)
  1018.  
  1019. (SET var venvc stackz)           var := A0, 1 Wert
  1020.                                  (venvc ist das aktuelle Closure-Venv,
  1021.                                   stackz der aktuelle Stackzustand)
  1022.  
  1023. (STORE n)                        (STACK+4*n) := A0, 1 Wert
  1024.  
  1025. (GETVALUE symbol)                A0 := (symbol-value 'symbol), 1 Wert
  1026.  
  1027. (SETVALUE symbol)                (setf (symbol-value 'symbol) A0), 1 Wert
  1028.  
  1029. (BIND const)                     bindet const (ein Symbol) dynamisch an A0.
  1030.                                  Undefinierte Werte.
  1031.  
  1032. (UNBIND1)                        l÷st einen Bindungsframe auf
  1033.  
  1034. (PROGV)                          bindet dynamisch die Symbole in der Liste
  1035.                                  (STACK)+ an die Werte in der Liste A0 und
  1036.                                  baut dabei genau einen Bindungsframe auf,
  1037.                                  undefinierte Werte
  1038.  
  1039. 4. Stackoperationen:
  1040.  
  1041. (PUSH)                           -(STACK) := A0, undefinierte Werte
  1042.  
  1043. (POP)                            A0 := (STACK)+, 1 Wert
  1044.  
  1045. (UNWIND stackz1 stackz2 for-value) Fⁿhrt ein Unwind binnen einer Funktion aus:
  1046.                                  Bereinigt den Stack, um vom Stackzustand
  1047.                                  stackz1 zum Stackzustand stackz2 zu kommen.
  1048.                                  L÷st dazwischen liegende Frames auf. for-value
  1049.                                  gibt an, ob dabei die Werte A0/... gerettet
  1050.                                  werden mⁿssen.
  1051.  
  1052. (UNWINDSP stackz1 stackz2)       modifiziert den SP, um vom Stackzustand
  1053.                                  stackz1 zum Stackzustand stackz2 zu kommen.
  1054.                                  STACK und die Werte A0/... bleiben unverΣndert.
  1055.  
  1056. 5. Programmflu▀ und Sprⁿnge:
  1057.  
  1058. (RET)                            beendet die Funktion mit den Werten A0/...
  1059.  
  1060. (JMP label)                      Sprung zu label
  1061.  
  1062. (JMPIF label)                    falls A0 /= NIL : Sprung zu label.
  1063.  
  1064. (JMPIFNOT label)                 falls A0 = NIL : Sprung zu label.
  1065.  
  1066. (JMPIF1 label)                   falls A0 /= NIL : 1 Wert, Sprung zu label.
  1067.  
  1068. (JMPIFNOT1 label)                falls A0 = NIL : 1 Wert, Sprung zu label.
  1069.  
  1070. (JMPHASH test ((obj1 . label1) ... (objm . labelm)) label . labels)
  1071.                                  Sprung zu labeli, falls A0 = obji (im Sinne
  1072.                                  des angegebenen Vergleichs), sonst zu label.
  1073.                                  Undefinierte Werte.
  1074.  
  1075. (JSR m label)                    ruft den Code ab label als Unterprogramm auf,
  1076.                                  mit m Argumenten auf dem Stack
  1077.  
  1078. (BARRIER)                        wird nie erreicht, zΣhlt als Wegsprung
  1079.  
  1080. 6. Environments und Closures:
  1081.  
  1082. (VENV venvc stackz)              A0 := das Venv, das venvc entspricht
  1083.                                  (aus dem Stack, als Konstante aus
  1084.                                  FUNC, oder NIL, falls in FUNC nicht vorhanden),
  1085.                                  1 Wert
  1086.                                  (stackz ist der aktuelle Stackzustand)
  1087.  
  1088. (MAKE-VECTOR1&PUSH n)            kreiert einen simple-vector mit n+1 (n>=0)
  1089.                                  Komponenten und steckt A0 als Komponente 0
  1090.                                  hinein. -(STACK) := der neue Vektor.
  1091.                                  Undefinierte Werte.
  1092.  
  1093. (COPY-CLOSURE fnode n)           kopiert die Closure, die dem fnode entspricht
  1094.                                  und ersetzt in der Kopie fⁿr i=0,...,n-1 (n>0)
  1095.                                  die Komponente (CONST i) durch (STACK+4*(n-1-i)).
  1096.                                  STACK := STACK+4*n. A0 := Closure-Kopie, 1 Wert
  1097.  
  1098. 7. Funktionsaufrufe:
  1099.  
  1100. (CALLP)                          beginnt den Aufbau eines Funktionsaufruf-Frames
  1101.                                  (wird im 2. Pass ersatzlos gestrichen)
  1102.  
  1103. (CALL k const)                   ruft die Funktion const mit k Argumenten
  1104.                                  (STACK+4*(k-1)),...,(STACK+4*0) auf,
  1105.                                  STACK:=STACK+4*k, Ergebnis kommt nach A0/...
  1106.  
  1107. (CALL0 const)                    ruft die Funktion const mit 0 Argumenten auf,
  1108.                                  Ergebnis kommt nach A0/...
  1109.  
  1110. (CALL1 const)                    ruft die Funktion const mit 1 Argument A0 auf,
  1111.                                  Ergebnis kommt nach A0/...
  1112.  
  1113. (CALL2 const)                    ruft die Funktion const mit 2 Argumenten (STACK)
  1114.                                  und A0 auf, STACK:=STACK+4,
  1115.                                  Ergebnis kommt nach A0/...
  1116.  
  1117. (CALLS1 n)                       ruft die Funktion (FUNTAB n)
  1118. (CALLS2 n)                       bzw. (FUNTAB 256+n)
  1119.                                  (ein SUBR ohne Rest-Parameter) auf,
  1120.                                  mit der korrekten Argumentezahl auf dem STACK.
  1121.                                  STACK wird bereinigt, Ergebnis kommt nach A0/...
  1122.  
  1123. (CALLSR m n)                     ruft die Funktion (FUNTABR n)
  1124.                                  (ein SUBR mit Rest-Parameter) auf,
  1125.                                  mit der korrekten Argumentezahl und zusΣtzlich
  1126.                                  m restlichen Argumenten auf dem STACK.
  1127.                                  STACK wird bereinigt, Ergebnis kommt nach A0/...
  1128.  
  1129. (CALLC)                          ruft die Funktion A0 (eine compilierte Closure
  1130.                                  ohne Keyword-Parameter) auf. Argumente
  1131.                                  sind schon im richtigen Format auf dem STACK,
  1132.                                  STACK wird bereinigt, Ergebnis kommt nach A0/...
  1133.  
  1134. (CALLCKEY)                       ruft die Funktion A0 (eine compilierte Closure
  1135.                                  mit Keyword-Parameter) auf. Argumente
  1136.                                  sind schon im richtigen Format auf dem STACK,
  1137.                                  STACK wird bereinigt, Ergebnis kommt nach A0/...
  1138.  
  1139. (FUNCALLP)                       fΣngt den Aufbau eines FUNCALL-Frames an,
  1140.                                  auszufⁿhrende Funktion ist in A0
  1141.  
  1142. (FUNCALL n)                      ruft die angegebene Funktion mit n (n>=0)
  1143.                                  Argumenten (alle auf dem Stack) auf,
  1144.                                  beseitigt den FUNCALL-Frame,
  1145.                                  Ergebnis kommt nach A0/...
  1146.  
  1147. (APPLYP)                         fΣngt den Aufbau eines APPLY-Frames an,
  1148.                                  auszufⁿhrende Funktion ist in A0
  1149.  
  1150. (APPLY n)                        ruft die angegebene Funktion mit n (n>=0)
  1151.                                  Argumenten (alle auf dem Stack) und weiteren
  1152.                                  Argumenten (Liste in A0) auf,
  1153.                                  beseitigt den APPLY-Frame,
  1154.                                  Ergebnis kommt nach A0/...
  1155.  
  1156. 8. optionale und Keyword-Argumente:
  1157.  
  1158. (PUSH-UNBOUND n)                 n-mal: -(STACK) := #<UNBOUND>, undefinierte Werte
  1159.  
  1160. (UNLIST n m)                     Liste A0 n mal verkⁿrzen: -(STACK) := (car A0),
  1161.                                  A0 := (cdr A0). Bei den letzten m Mal darf A0
  1162.                                  schon zu Ende sein, dann -(STACK) := #<UNBOUND>
  1163.                                  stattdessen. Am Schlu▀ mu▀ A0 = NIL sein,
  1164.                                  undefinierte Werte. 0 <= m <= n.
  1165.  
  1166. (UNLIST* n m)                    Liste A0 n mal verkⁿrzen: -(STACK) := (car A0),
  1167.                                  A0 := (cdr A0). Bei den letzten m Mal darf A0
  1168.                                  schon zu Ende sein, dann -(STACK) := #<UNBOUND>.
  1169.                                  stattdessen. Dann -(STACK) := (nthcdr n A0),
  1170.                                  undefinierte Werte. 0 <= m <= n, n > 0.
  1171.  
  1172. (JMPIFBOUNDP var venvc stackz label)
  1173.                                  falls Variable /= #<UNBOUND> :
  1174.                                    Sprung zu label, A0 := Variable, 1 Wert.
  1175.                                  Sonst undefinierte Werte.
  1176.                                  (stackz ist der aktuelle Stackzustand)
  1177.  
  1178. (BOUNDP var venvc stackz)        A0 := (NIL falls Variable=#<UNBOUND>, T sonst),
  1179.                                  1 Wert
  1180.                                  (stackz ist der aktuelle Stackzustand)
  1181.  
  1182. 9. Behandlung mehrerer Werte:
  1183.  
  1184. (VALUES0)                        A0 := NIL, 0 Werte
  1185.  
  1186. (VALUES1)                        A0 := A0, 1 Wert
  1187.  
  1188. (STACK-TO-MV n)                  holt n Werte von (STACK)+ herab,
  1189.                                  STACK:=STACK+4*n, n>1
  1190.  
  1191. (MV-TO-STACK)                    Multiple Values A0/A1/... auf -(STACK),
  1192.                                  1. Wert zuoberst, STACK:=STACK-4*D7.W,
  1193.                                  danach undefinierte Werte
  1194.  
  1195. (NV-TO-STACK n)                  die ersten n Werte (n>=0) auf -(STACK),
  1196.                                  1. Wert zuoberst, STACK:=STACK-4*n,
  1197.                                  undefinierte Werte
  1198.  
  1199. (MV-TO-LIST)                     Multiple Values A0/... als Liste nach A0,
  1200.                                  1 Wert
  1201.  
  1202. (LIST-TO-MV)                     A0/... := (values-list A0)
  1203.  
  1204. (MVCALLP)                        bereitet einen MULTIPLE-VALUE-CALL auf die
  1205.                                  Funktion in A0 vor
  1206.  
  1207. (MVCALL)                         fⁿhrt einen MULTIPLE-VALUE-CALL mit den im
  1208.                                  Stack liegenden Argumenten aus
  1209.  
  1210. 10. BLOCK:
  1211.  
  1212. (BLOCK-OPEN const label)         Legt einen Block-Cons (mit CAR=const und CDR=
  1213.                                  Framepointer) auf -(STACK) ab, baut einen
  1214.                                  Block-Frame auf. Bei einem RETURN auf diesen
  1215.                                  Frame wird zu label gesprungen.
  1216.  
  1217. (BLOCK-CLOSE)                    Verlasse den Block und baue dabei einen Block-
  1218.                                  Frame ab (inklusive der Block-Cons-Variablen)
  1219.  
  1220. (RETURN-FROM const)              Verlasse den Block, dessen Block-Cons angegeben
  1221.                                  ist, mit den Werten A0/...
  1222. (RETURN-FROM block)              Verlasse den angegebenen Block (sein Block-Cons
  1223.                                  kommt unter den BlockConsts von FUNC vor) mit
  1224.                                  den Werten A0/...
  1225. (RETURN-FROM block stackz)       Verlasse den angegebenen Block (sein Block-Cons
  1226.                                  kommt im Stack vor) mit den Werten A0/...
  1227.  
  1228. 11. TAGBODY:
  1229.  
  1230. (TAGBODY-OPEN const label1 ... labelm)
  1231.                                  Legt einen Tagbody-Cons (mit CAR=const
  1232.                                  und CDR=Framepointer) auf -(STACK) ab, baut einen
  1233.                                  Tagbody-Frame auf. Bei einem GO mit Nummer l
  1234.                                  wird zu labell gesprungen.
  1235.  
  1236. (TAGBODY-CLOSE-NIL)              Verlasse den Tagbody und baue dabei einen
  1237.                                  Tagbody-Frame ab (inklusive der Tagbody-Cons-
  1238.                                  Variablen). A0 := NIL, 1 Wert
  1239.  
  1240. (TAGBODY-CLOSE)                  Verlasse den Tagbody und baue dabei einen
  1241.                                  Tagbody-Frame ab (inklusive der Tagbody-Cons-
  1242.                                  Variablen).
  1243.  
  1244. (GO const l)                     Springe im Tagbody, dessen Tagbody-Cons
  1245.                                  angegeben ist, an Tag (svref (car const) l)
  1246. (GO tagbody l)                   Springe im angegebenen Tagbody an Tag Nummer l
  1247.                                  in (tagbody-used-far tagbody)
  1248. (GO tagbody l stackz)            Springe im angegebenen Tagbody an Tag Nummer l
  1249.                                  in (tagbody-used-far tagbody), sein Tagbody-
  1250.                                  Cons liegt im Stack
  1251.  
  1252. 12. CATCH und THROW:
  1253.  
  1254. (CATCH-OPEN label)               baut einen CATCH-Frame auf mit A0 als Tag;
  1255.                                  bei einem THROW auf dieses Tag wird zu label
  1256.                                  gesprungen
  1257.  
  1258. (CATCH-CLOSE)                    l÷st einen CATCH-Frame auf
  1259.  
  1260. (THROW)                          fⁿhrt ein THROW auf den Catch-Tag (STACK)+
  1261.                                  aus, mit den Werten A0/...
  1262.  
  1263. 13. UNWIND-PROTECT:
  1264.  
  1265. (UNWIND-PROTECT-OPEN label)      baut einen UNWIND-PROTECT-Frame auf; bei einem
  1266.                                  Unwind wird unter Rettung der Werte zu label
  1267.                                  gesprungen
  1268.  
  1269. (UNWIND-PROTECT-NORMAL-EXIT)     l÷st einen Unwind-Protect-Frame auf, schreibt
  1270.                                  eine Weitermach-Adresse auf SP, rettet die
  1271.                                  Werte und fΣngt an, den folgenden Cleanup-Code
  1272.                                  auszufⁿhren
  1273.  
  1274. (UNWIND-PROTECT-CLOSE label)     beendet den Cleanup-Code: schreibt die
  1275.                                  geretteten Werte zurⁿck, fⁿhrt ein RTS aus.
  1276.                                  Der Cleanup-Code fΣngt bei label an.
  1277.  
  1278. (UNWIND-PROTECT-CLEANUP)         l÷st einen Unwind-Protect-Frame auf, schreibt
  1279.                                  eine Weitermach-Adresse und den PC auf SP,
  1280.                                  rettet die Werte und fΣngt an, den Cleanup-
  1281.                                  Code auszufⁿhren
  1282.  
  1283. 14. HANDLER:
  1284.  
  1285. (HANDLER-OPEN const stackz label1 ... labelm)
  1286.                                  baut einen HANDLER-Frame auf; const enthΣlt
  1287.                                  die Condition-Typen; die entsprechenden
  1288.                                  Handler beginnen bei labeli
  1289.  
  1290. (HANDLER-BEGIN)                  beginnt einen Handler: stellt den SP-Zustand
  1291.                                  wie beim HANDLER-OPEN her,
  1292.                                  A0 := dem Handler ⁿbergebene Condition, 1 Wert
  1293.  
  1294. 15. einige Funktionen:
  1295.  
  1296. (NOT)                            = (CALL1 #'NOT)
  1297.  
  1298. (EQ)                             = (CALL2 #'EQ)
  1299.  
  1300. (CAR)                            = (CALL1 #'CAR)
  1301.  
  1302. (CDR)                            = (CALL1 #'CDR)
  1303.  
  1304. (CONS)                           = (CALL2 #'CONS)
  1305.  
  1306. (ATOM)                           = (CALL1 #'ATOM)
  1307.  
  1308. (CONSP)                          = (CALL1 #'CONSP)
  1309.  
  1310. (SYMBOL-FUNCTION)                = (CALL1 #'SYMBOL-FUNCTION)
  1311.  
  1312. (SVREF)                          = (CALL2 #'SVREF)
  1313.  
  1314. (SVSET)                          (setf (svref (STACK) A0) (STACK+4)),
  1315.                                  A0 := (STACK+4), 1 Wert, STACK:=STACK+8
  1316.  
  1317. (LIST n)                         = (CALL n #'LIST), n>0
  1318.  
  1319. (LIST* n)                        = (CALL n+1 #'LIST*), n>0
  1320.  
  1321.  
  1322. Dabei bedeuten jeweils:
  1323.  
  1324. n, m, k     eine ganze Zahl >=0
  1325.  
  1326. stackz      einen Stackzustand (siehe STACK-VERWALTUNG).
  1327.             Das Stack-Layout steht nach dem 1. Pass fest.
  1328.  
  1329. venvc       das Environment der Closure-Variablen (siehe VARIABLEN-VERWALTUNG).
  1330.             Dies steht nach dem 1. Pass auch fest.
  1331.  
  1332. var         eine Variable (siehe VARIABLEN-VERWALTUNG). Ob sie
  1333.             special/konstant/lexikalisch ist, steht nach dem 1. Pass fest.
  1334.  
  1335. const       eine Konstante
  1336.  
  1337. symbol      ein Symbol
  1338.  
  1339. fun         entweder (CONST const) eine Konstante, die ein Symbol ist,
  1340.             oder (FUNTAB index) eine Indizierung in die feste Funktionentabelle.
  1341.  
  1342. fnode       ein fnode (siehe FUNKTIONEN-VERWALTUNG)
  1343.  
  1344. label       ein Label (uninterniertes Symbol)
  1345.  
  1346. block       ein Block-Descriptor (siehe BLOCK-VERWALTUNG)
  1347.  
  1348. test        EQ oder EQL oder EQUAL
  1349.  
  1350. for-value   NIL oder T
  1351.  
  1352. |#
  1353.  
  1354. #-CLISP ; Die Funktionentabelle steckt in EVAL.
  1355. (eval-when (compile load eval)
  1356.   ; die Funktionstabelle mit max. 3*256 Funktionen (spart Konstanten in FUNC) :
  1357.   (defconstant funtab
  1358.     '#(system::%funtabref system::subr-info
  1359.        #| svref system::%svstore |# array-element-type array-rank array-dimension
  1360.        array-dimensions array-total-size adjustable-array-p bit-and bit-ior
  1361.        bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2 bit-orc1 bit-orc2
  1362.        bit-not array-has-fill-pointer-p fill-pointer system::set-fill-pointer
  1363.        vector-push vector-pop vector-push-extend make-array adjust-array
  1364.        standard-char-p graphic-char-p string-char-p alpha-char-p upper-case-p
  1365.        lower-case-p both-case-p digit-char-p alphanumericp char-code char-bits
  1366.        char-font code-char make-char character char-upcase char-downcase
  1367.        digit-char char-int int-char char-name char-bit set-char-bit char schar
  1368.        system::store-char system::store-schar string= string/= string< string>
  1369.        string<= string>= string-equal string-not-equal string-lessp
  1370.        string-greaterp string-not-greaterp string-not-lessp
  1371.        system::search-string= system::search-string-equal make-string
  1372.        system::string-both-trim nstring-upcase string-upcase nstring-downcase
  1373.        string-downcase nstring-capitalize string-capitalize string name-char
  1374.        substring
  1375.        symbol-value #| symbol-function |# boundp fboundp special-form-p set makunbound
  1376.        fmakunbound #| values-list |# system::driver system::unwind-to-driver
  1377.        macro-function macroexpand macroexpand-1 proclaim eval evalhook applyhook
  1378.        constantp system::parse-body system::keyword-test
  1379.        room
  1380.        invoke-debugger
  1381.        make-hash-table gethash system::puthash remhash maphash clrhash
  1382.        hash-table-count system::hash-table-iterator system::hash-table-iterate
  1383.        clos::class-gethash sxhash
  1384.        copy-readtable set-syntax-from-char set-macro-character
  1385.        get-macro-character make-dispatch-macro-character
  1386.        set-dispatch-macro-character get-dispatch-macro-character read
  1387.        read-preserving-whitespace read-delimited-list read-line read-char
  1388.        unread-char peek-char listen read-char-no-hang clear-input
  1389.        read-from-string parse-integer write prin1 print pprint princ
  1390.        write-to-string prin1-to-string princ-to-string write-char write-string
  1391.        write-line terpri fresh-line finish-output force-output clear-output
  1392.        system::line-position
  1393.        #| car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar
  1394.        cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
  1395.        cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr cons |# tree-equal endp
  1396.        list-length nth #| first second third fourth |# fifth sixth seventh eighth
  1397.        ninth tenth #| rest |# nthcdr last make-list copy-list copy-alist copy-tree
  1398.        revappend nreconc system::list-nreverse butlast nbutlast ldiff rplaca
  1399.        system::%rplaca rplacd system::%rplacd subst subst-if subst-if-not nsubst
  1400.        nsubst-if nsubst-if-not sublis nsublis member member-if member-if-not
  1401.        tailp adjoin acons pairlis assoc assoc-if assoc-if-not rassoc rassoc-if
  1402.        rassoc-if-not
  1403.        lisp-implementation-type lisp-implementation-version software-type
  1404.        software-version identity get-universal-time get-internal-run-time
  1405.        get-internal-real-time system::%sleep system::%%time
  1406.        make-symbol find-package package-name package-nicknames rename-package
  1407.        package-use-list package-used-by-list package-shadowing-symbols
  1408.        list-all-packages intern find-symbol unintern export unexport import
  1409.        shadowing-import shadow use-package unuse-package make-package
  1410.        system::%in-package in-package find-all-symbols system::map-symbols
  1411.        system::map-external-symbols system::map-all-symbols
  1412.        parse-namestring pathname pathname-host pathname-device
  1413.        pathname-directory pathname-name pathname-type pathname-version
  1414.        file-namestring directory-namestring host-namestring merge-pathnames
  1415.        enough-namestring make-pathname namestring truename probe-file
  1416.        delete-file rename-file open directory cd make-dir delete-dir
  1417.        file-write-date file-author savemem
  1418.        #| eq |# eql equal equalp consp atom symbolp stringp numberp
  1419.        compiled-function-p #| null not |# system::closurep listp integerp
  1420.        system::fixnump rationalp floatp system::short-float-p
  1421.        system::single-float-p system::double-float-p system::long-float-p
  1422.        realp complexp streamp random-state-p readtablep hash-table-p pathnamep
  1423.        system::logical-pathname-p characterp functionp clos::generic-function-p
  1424.        packagep arrayp system::simple-array-p bit-vector-p vectorp
  1425.        simple-vector-p simple-string-p simple-bit-vector-p commonp type-of
  1426.        clos:class-of clos:find-class coerce
  1427.        system::%record-ref system::%record-store system::%record-length
  1428.        system::%structure-ref system::%structure-store system::%make-structure
  1429.        system::%copy-structure system::%structure-type-p system::closure-name
  1430.        system::closure-codevec system::closure-consts system::make-code-vector
  1431.        system::%make-closure system::make-load-time-eval clos::std-instance-p
  1432.        clos::allocate-std-instance clos:slot-value clos::set-slot-value
  1433.        clos:slot-boundp clos:slot-makunbound clos:slot-exists-p
  1434.        system::sequencep elt system::%setelt subseq copy-seq length reverse
  1435.        nreverse make-sequence reduce fill replace remove remove-if remove-if-not
  1436.        delete delete-if delete-if-not remove-duplicates delete-duplicates
  1437.        substitute substitute-if substitute-if-not nsubstitute nsubstitute-if
  1438.        nsubstitute-if-not find find-if find-if-not position position-if
  1439.        position-if-not count count-if count-if-not mismatch search sort
  1440.        stable-sort merge
  1441.        make-synonym-stream make-two-way-stream make-echo-stream
  1442.        make-string-input-stream system::string-input-stream-index
  1443.        make-string-output-stream get-output-stream-string
  1444.        system::make-string-push-stream input-stream-p output-stream-p
  1445.        stream-element-type close read-byte write-byte file-position file-length
  1446.        system::%putd system::%proclaim-constant get getf get-properties
  1447.        system::%putplist system::%put remprop symbol-package symbol-plist
  1448.        symbol-name keywordp gensym system::special-variable-p gensym
  1449.        system::decimal-string zerop plusp minusp oddp evenp 1+ 1- conjugate exp
  1450.        expt log sqrt isqrt abs phase signum sin cos tan cis asin acos atan sinh
  1451.        cosh tanh asinh acosh atanh float rational rationalize numerator
  1452.        denominator floor ceiling truncate round mod rem ffloor fceiling
  1453.        ftruncate fround decode-float scale-float float-radix float-sign
  1454.        float-digits float-precision integer-decode-float complex realpart
  1455.        imagpart lognand lognor logandc1 logandc2 logorc1 logorc2 boole lognot
  1456.        logtest logbitp ash logcount integer-length byte byte-size byte-position
  1457.        ldb ldb-test mask-field dpb deposit-field random make-random-state !
  1458.        exquo long-float-digits system::%set-long-float-digits system::log2
  1459.        system::log10
  1460.        vector aref system::store array-in-bounds-p array-row-major-index bit
  1461.        sbit char= char/= char< char> char<= char>= char-equal char-not-equal
  1462.        char-lessp char-greaterp char-not-greaterp char-not-lessp string-concat
  1463.        apply system::%funcall funcall mapcar maplist mapc mapl mapcan mapcon
  1464.        values error system::error-of-type clos::class-tuple-gethash list list*
  1465.        append nconc concatenate map some every notany notevery
  1466.        make-broadcast-stream make-concatenated-stream = /= < > <= >= max min
  1467.        + - * / gcd lcm logior logxor logand logeqv
  1468.   )   )
  1469.   (defun %funtabref (index)
  1470.     (if (and (<= 0 index) (< index (length funtab))) (svref funtab index) nil)
  1471.   )
  1472. )
  1473. #+CROSS
  1474. (eval-when (compile load eval)
  1475.   (defun subr-info (sym)
  1476.     (values-list
  1477.       (assoc sym
  1478.         '(; Das ist die Tabelle aller SUBRs, wie in SUBR.D.
  1479.           ; SUBRs, die in verschiedenen Implementationen verschiedene
  1480.           ; Signaturen haben und/oder deren Spezifikation sich noch Σndern
  1481.           ; k÷nnte, sind dabei allerdings auskommentiert.
  1482.           (! 1 0 nil nil nil)
  1483.           (system::%%time 0 0 nil nil nil)
  1484.           (system::%copy-structure 1 0 nil nil nil)
  1485.           (system::%defseq 1 0 nil nil nil)
  1486.           (system::%exit 0 1 nil nil nil)
  1487.           (system::%funcall 1 0 t nil nil)
  1488.           (system::%funtabref 1 0 nil nil nil)
  1489.           (system::%in-package 1 0 nil (:nicknames :use) nil)
  1490.           (system::%make-closure 3 0 nil nil nil)
  1491.           (system::%make-structure 2 0 nil nil nil)
  1492.           (system::%proclaim-constant 2 0 nil nil nil)
  1493.           (system::%put 3 0 nil nil nil)
  1494.           (system::%putd 2 0 nil nil nil)
  1495.           (system::%putplist 2 0 nil nil nil)
  1496.           (system::%record-length 1 0 nil nil nil)
  1497.           (system::%record-ref 2 0 nil nil nil)
  1498.           (system::%record-store 3 0 nil nil nil)
  1499.           (system::%rplaca 2 0 nil nil nil)
  1500.           (system::%rplacd 2 0 nil nil nil)
  1501.           (system::%set-long-float-digits 1 0 nil nil nil)
  1502.           (system::%setelt 3 0 nil nil nil)
  1503.           ;(system::%sleep 1 0 nil nil nil)
  1504.           ;(system::%sleep 2 0 nil nil nil)
  1505.           (system::%structure-ref 3 0 nil nil nil)
  1506.           (system::%structure-store 4 0 nil nil nil)
  1507.           (system::%structure-type-p 2 0 nil nil nil)
  1508.           (system::%svstore 3 0 nil nil nil)
  1509.           (* 0 0 t nil nil)
  1510.           (+ 0 0 t nil nil)
  1511.           (- 1 0 t nil nil)
  1512.           (/ 1 0 t nil nil)
  1513.           (/= 1 0 t nil nil)
  1514.           (1+ 1 0 nil nil nil)
  1515.           (1- 1 0 nil nil nil)
  1516.           (< 1 0 t nil nil)
  1517.           (<= 1 0 t nil nil)
  1518.           (= 1 0 t nil nil)
  1519.           (> 1 0 t nil nil)
  1520.           (>= 1 0 t nil nil)
  1521.           (abs 1 0 nil nil nil)
  1522.           (acons 3 0 nil nil nil)
  1523.           (acos 1 0 nil nil nil)
  1524.           (acosh 1 0 nil nil nil)
  1525.           (adjoin 2 0 nil (:test :test-not :key) nil)
  1526.           (adjust-array 2 0 nil (:element-type :initial-element :initial-contents :fill-pointer :displaced-to :displaced-index-offset) nil)
  1527.           (adjustable-array-p 1 0 nil nil nil)
  1528.           (alpha-char-p 1 0 nil nil nil)
  1529.           (alphanumericp 1 0 nil nil nil)
  1530.           (append 0 0 t nil nil)
  1531.           (apply 2 0 t nil nil)
  1532.           (applyhook 4 1 nil nil nil)
  1533.           (aref 1 0 t nil nil)
  1534.           (array-dimension 2 0 nil nil nil)
  1535.           (array-dimensions 1 0 nil nil nil)
  1536.           (array-element-type 1 0 nil nil nil)
  1537.           (array-has-fill-pointer-p 1 0 nil nil nil)
  1538.           (array-in-bounds-p 1 0 t nil nil)
  1539.           (array-rank 1 0 nil nil nil)
  1540.           (system::array-reader 3 0 nil nil nil)
  1541.           (array-row-major-index 1 0 t nil nil)
  1542.           (array-total-size 1 0 nil nil nil)
  1543.           (arrayp 1 0 nil nil nil)
  1544.           (ash 2 0 nil nil nil)
  1545.           (asin 1 0 nil nil nil)
  1546.           (asinh 1 0 nil nil nil)
  1547.           (assoc 2 0 nil (:test :test-not :key) nil)
  1548.           (assoc-if 2 0 nil (:key) nil)
  1549.           (assoc-if-not 2 0 nil (:key) nil)
  1550.           (atan 1 1 nil nil nil)
  1551.           (atanh 1 0 nil nil nil)
  1552.           (atom 1 0 nil nil nil)
  1553.           (system::binary-reader 3 0 nil nil nil)
  1554.           (bit 1 0 t nil nil)
  1555.           (bit-and 2 1 nil nil nil)
  1556.           (bit-andc1 2 1 nil nil nil)
  1557.           (bit-andc2 2 1 nil nil nil)
  1558.           (bit-eqv 2 1 nil nil nil)
  1559.           (bit-ior 2 1 nil nil nil)
  1560.           (bit-nand 2 1 nil nil nil)
  1561.           (bit-nor 2 1 nil nil nil)
  1562.           (bit-not 1 1 nil nil nil)
  1563.           (bit-orc1 2 1 nil nil nil)
  1564.           (bit-orc2 2 1 nil nil nil)
  1565.           (bit-vector-p 1 0 nil nil nil)
  1566.           (system::bit-vector-reader 3 0 nil nil nil)
  1567.           (bit-xor 2 1 nil nil nil)
  1568.           (boole 3 0 nil nil nil)
  1569.           (both-case-p 1 0 nil nil nil)
  1570.           (boundp 1 0 nil nil nil)
  1571.           (butlast 1 1 nil nil nil)
  1572.           (byte 2 0 nil nil nil)
  1573.           (byte-position 1 0 nil nil nil)
  1574.           (byte-size 1 0 nil nil nil)
  1575.           (caaaar 1 0 nil nil nil)
  1576.           (caaadr 1 0 nil nil nil)
  1577.           (caaar 1 0 nil nil nil)
  1578.           (caadar 1 0 nil nil nil)
  1579.           (caaddr 1 0 nil nil nil)
  1580.           (caadr 1 0 nil nil nil)
  1581.           (caar 1 0 nil nil nil)
  1582.           (cadaar 1 0 nil nil nil)
  1583.           (cadadr 1 0 nil nil nil)
  1584.           (cadar 1 0 nil nil nil)
  1585.           (caddar 1 0 nil nil nil)
  1586.           (cadddr 1 0 nil nil nil)
  1587.           (caddr 1 0 nil nil nil)
  1588.           (cadr 1 0 nil nil nil)
  1589.           (car 1 0 nil nil nil)
  1590.           (cd 0 1 nil nil nil)
  1591.           (cdaaar 1 0 nil nil nil)
  1592.           (cdaadr 1 0 nil nil nil)
  1593.           (cdaar 1 0 nil nil nil)
  1594.           (cdadar 1 0 nil nil nil)
  1595.           (cdaddr 1 0 nil nil nil)
  1596.           (cdadr 1 0 nil nil nil)
  1597.           (cdar 1 0 nil nil nil)
  1598.           (cddaar 1 0 nil nil nil)
  1599.           (cddadr 1 0 nil nil nil)
  1600.           (cddar 1 0 nil nil nil)
  1601.           (cdddar 1 0 nil nil nil)
  1602.           (cddddr 1 0 nil nil nil)
  1603.           (cdddr 1 0 nil nil nil)
  1604.           (cddr 1 0 nil nil nil)
  1605.           (cdr 1 0 nil nil nil)
  1606.           (ceiling 1 1 nil nil nil)
  1607.           (char 2 0 nil nil nil)
  1608.           (char-bit 2 0 nil nil nil)
  1609.           (char-bits 1 0 nil nil nil)
  1610.           (char-code 1 0 nil nil nil)
  1611.           (char-downcase 1 0 nil nil nil)
  1612.           (char-equal 1 0 t nil nil)
  1613.           (char-font 1 0 nil nil nil)
  1614.           (char-greaterp 1 0 t nil nil)
  1615.           (char-int 1 0 nil nil nil)
  1616.           (char-lessp 1 0 t nil nil)
  1617.           (char-name 1 0 nil nil nil)
  1618.           (char-not-equal 1 0 t nil nil)
  1619.           (char-not-greaterp 1 0 t nil nil)
  1620.           (char-not-lessp 1 0 t nil nil)
  1621.           (system::char-reader 3 0 nil nil nil)
  1622.           (char-upcase 1 0 nil nil nil)
  1623.           (char/= 1 0 t nil nil)
  1624.           (char< 1 0 t nil nil)
  1625.           (char<= 1 0 t nil nil)
  1626.           (char= 1 0 t nil nil)
  1627.           (char> 1 0 t nil nil)
  1628.           (char>= 1 0 t nil nil)
  1629.           (character 1 0 nil nil nil)
  1630.           (characterp 1 0 nil nil nil)
  1631.           (cis 1 0 nil nil nil)
  1632.           (clos::class-gethash 2 0 nil nil nil)
  1633.           (clos:class-of 1 0 nil nil nil)
  1634.           (clos::class-p 1 0 nil nil nil)
  1635.           (clos::class-tuple-gethash 2 0 t nil nil)
  1636.           (clear-input 0 1 nil nil nil)
  1637.           (clear-output 0 1 nil nil nil)
  1638.           (close 1 0 nil (:abort) nil)
  1639.           (system::closure-codevec 1 0 nil nil nil)
  1640.           (system::closure-consts 1 0 nil nil nil)
  1641.           (system::closure-name 1 0 nil nil nil)
  1642.           (system::closure-reader 3 0 nil nil nil)
  1643.           (system::closurep 1 0 nil nil nil)
  1644.           (clrhash 1 0 nil nil nil)
  1645.           (code-char 1 2 nil nil nil)
  1646.           (coerce 2 0 nil nil nil)
  1647.           (system::comment-reader 3 0 nil nil nil)
  1648.           (commonp 1 0 nil nil nil)
  1649.           (compiled-function-p 1 0 nil nil nil)
  1650.           (complex 1 1 nil nil nil)
  1651.           (system::complex-reader 3 0 nil nil nil)
  1652.           (complexp 1 0 nil nil nil)
  1653.           (concatenate 1 0 t nil nil)
  1654.           (conjugate 1 0 nil nil nil)
  1655.           (cons 2 0 nil nil nil)
  1656.           (consp 1 0 nil nil nil)
  1657.           (constantp 1 0 nil nil nil)
  1658.           (copy-alist 1 0 nil nil nil)
  1659.           (copy-list 1 0 nil nil nil)
  1660.           (copy-readtable 0 2 nil nil nil)
  1661.           (copy-seq 1 0 nil nil nil)
  1662.           (copy-tree 1 0 nil nil nil)
  1663.           (cos 1 0 nil nil nil)
  1664.           (cosh 1 0 nil nil nil)
  1665.           (count 2 0 nil (:from-end :start :end :key :test :test-not) nil)
  1666.           (count-if 2 0 nil (:from-end :start :end :key) nil)
  1667.           (count-if-not 2 0 nil (:from-end :start :end :key) nil)
  1668.           (system::debug 0 0 nil nil nil)
  1669.           (system::decimal-string 1 0 nil nil nil)
  1670.           (decode-float 1 0 nil nil nil)
  1671.           (delete 2 0 nil (:from-end :start :end :key :test :test-not :count) nil)
  1672.           (delete-dir 1 0 nil nil nil)
  1673.           (delete-duplicates 1 0 nil (:from-end :start :end :key :test :test-not) nil)
  1674.           (delete-file 1 0 nil nil nil)
  1675.           (delete-if 2 0 nil (:from-end :start :end :key :count) nil)
  1676.           (delete-if-not 2 0 nil (:from-end :start :end :key :count) nil)
  1677.           (denominator 1 0 nil nil nil)
  1678.           (deposit-field 3 0 nil nil nil)
  1679.           (system::describe-frame 2 0 nil nil nil)
  1680.           (digit-char 1 2 nil nil nil)
  1681.           (digit-char-p 1 1 nil nil nil)
  1682.           (directory 0 1 nil (:circle :full) nil)
  1683.           (directory-namestring 1 0 nil nil nil)
  1684.           (system::double-float-p 1 0 nil nil nil)
  1685.           (dpb 3 0 nil nil nil)
  1686.           (system::driver 1 0 nil nil nil)
  1687.           (eighth 1 0 nil nil nil)
  1688.           (elt 2 0 nil nil nil)
  1689.           (endp 1 0 nil nil nil)
  1690.           (enough-namestring 1 1 nil nil nil)
  1691.           (eq 2 0 nil nil nil)
  1692.           (eql 2 0 nil nil nil)
  1693.           (equal 2 0 nil nil nil)
  1694.           (equalp 2 0 nil nil nil)
  1695.           (error 1 0 t nil nil)
  1696.           (system::error-of-type 2 0 t nil nil)
  1697.           (eval 1 0 nil nil nil)
  1698.           (system::eval-at 2 0 nil nil nil)
  1699.           (system::eval-frame-p 1 0 nil nil nil)
  1700.           (evalhook 3 1 nil nil nil)
  1701.           (evenp 1 0 nil nil nil)
  1702.           (every 2 0 t nil nil)
  1703.           ;(execute 1 2 nil nil nil)
  1704.           ;(execute 1 0 t nil nil)
  1705.           (exp 1 0 nil nil nil)
  1706.           (export 1 1 nil nil nil)
  1707.           (expt 2 0 nil nil nil)
  1708.           (exquo 2 0 nil nil nil)
  1709.           (fboundp 1 0 nil nil nil)
  1710.           (fceiling 1 1 nil nil nil)
  1711.           (system::feature-reader 3 0 nil nil nil)
  1712.           (ffloor 1 1 nil nil nil)
  1713.           (fifth 1 0 nil nil nil)
  1714.           (file-author 1 0 nil nil nil)
  1715.           (file-length 1 0 nil nil nil)
  1716.           (file-namestring 1 0 nil nil nil)
  1717.           (file-position 1 1 nil nil nil)
  1718.           (file-write-date 1 0 nil nil nil)
  1719.           (fill 2 0 nil (:start :end) nil)
  1720.           (fill-pointer 1 0 nil nil nil)
  1721.           (find 2 0 nil (:from-end :start :end :key :test :test-not) nil)
  1722.           (find-all-symbols 1 0 nil nil nil)
  1723.           (clos:find-class 1 2 nil nil nil)
  1724.           (find-if 2 0 nil (:from-end :start :end :key) nil)
  1725.           (find-if-not 2 0 nil (:from-end :start :end :key) nil)
  1726.           (find-package 1 0 nil nil nil)
  1727.           (find-symbol 1 1 nil nil nil)
  1728.           (finish-output 0 1 nil nil nil)
  1729.           (first 1 0 nil nil nil)
  1730.           (system::fixnump 1 0 nil nil nil)
  1731.           (float 1 1 nil nil nil)
  1732.           (float-digits 1 1 nil nil nil)
  1733.           (float-precision 1 0 nil nil nil)
  1734.           (float-radix 1 0 nil nil nil)
  1735.           (float-sign 1 1 nil nil nil)
  1736.           (floatp 1 0 nil nil nil)
  1737.           (floor 1 1 nil nil nil)
  1738.           (fmakunbound 1 0 nil nil nil)
  1739.           (force-output 0 1 nil nil nil)
  1740.           (fourth 1 0 nil nil nil)
  1741.           (system::frame-down 2 0 nil nil nil)
  1742.           (system::frame-down-1 2 0 nil nil nil)
  1743.           (system::frame-up 2 0 nil nil nil)
  1744.           (system::frame-up-1 2 0 nil nil nil)
  1745.           (fresh-line 0 1 nil nil nil)
  1746.           (fround 1 1 nil nil nil)
  1747.           (ftruncate 1 1 nil nil nil)
  1748.           (funcall 1 0 t nil nil)
  1749.           (system::function-reader 3 0 nil nil nil)
  1750.           (functionp 1 0 nil nil nil)
  1751.           (gc 0 0 nil nil nil)
  1752.           (gcd 0 0 t nil nil)
  1753.           (clos::generic-function-p 1 0 nil nil nil)
  1754.           (gensym 0 1 nil nil nil)
  1755.           (get 2 1 nil nil nil)
  1756.           (get-dispatch-macro-character 2 1 nil nil nil)
  1757.           (get-internal-real-time 0 0 nil nil nil)
  1758.           (get-internal-run-time 0 0 nil nil nil)
  1759.           (get-macro-character 1 1 nil nil nil)
  1760.           (get-output-stream-string 1 0 nil nil nil)
  1761.           (get-properties 2 0 nil nil nil)
  1762.           (get-universal-time 0 0 nil nil nil)
  1763.           (getf 2 1 nil nil nil)
  1764.           (gethash 2 1 nil nil nil)
  1765.           (graphic-char-p 1 0 nil nil nil)
  1766.           (hash-table-count 1 0 nil nil nil)
  1767.           (system::hash-table-iterate 1 0 nil nil nil)
  1768.           (system::hash-table-iterator 1 0 nil nil nil)
  1769.           (hash-table-p 1 0 nil nil nil)
  1770.           (system::hexadecimal-reader 3 0 nil nil nil)
  1771.           (host-namestring 1 0 nil nil nil)
  1772.           (identity 1 0 nil nil nil)
  1773.           (imagpart 1 0 nil nil nil)
  1774.           (import 1 1 nil nil nil)
  1775.           (in-package 1 0 nil (:nicknames :use) nil)
  1776.           (system::initial-contents-aux 1 0 nil nil nil)
  1777.           (input-stream-p 1 0 nil nil nil)
  1778.           (int-char 1 0 nil nil nil)
  1779.           (integer-decode-float 1 0 nil nil nil)
  1780.           (integer-length 1 0 nil nil nil)
  1781.           (integerp 1 0 nil nil nil)
  1782.           (intern 1 1 nil nil nil)
  1783.           (invoke-debugger 1 0 nil nil nil)
  1784.           (isqrt 1 0 nil nil nil)
  1785.           (system::keyword-test 2 0 nil nil nil)
  1786.           (keywordp 1 0 nil nil nil)
  1787.           (system::label-definiion-reader 3 0 nil nil nil)
  1788.           (system::label-reference-reader 3 0 nil nil nil)
  1789.           (last 1 0 nil nil nil)
  1790.           (lcm 0 0 t nil nil)
  1791.           (ldb 2 0 nil nil nil)
  1792.           (ldb-test 2 0 nil nil nil)
  1793.           (ldiff 2 0 nil nil nil)
  1794.           (length 1 0 nil nil nil)
  1795.           (system::line-comment-reader 2 0 nil nil nil)
  1796.           (system::line-number 1 0 nil nil nil)
  1797.           (system::line-position 0 1 nil nil nil)
  1798.           (lisp-implementation-type 0 0 nil nil nil)
  1799.           (lisp-implementation-version 0 0 nil nil nil)
  1800.           (list 0 0 t nil nil)
  1801.           (list* 1 0 t nil nil)
  1802.           (system::list-access 2 0 nil nil nil)
  1803.           (system::list-access-set 3 0 nil nil nil)
  1804.           (list-all-packages 0 0 nil nil nil)
  1805.           (system::list-elt 2 0 nil nil nil)
  1806.           (system::list-endtest 2 0 nil nil nil)
  1807.           (system::list-fe-init 1 0 nil nil nil)
  1808.           (system::list-fe-init-end 2 0 nil nil nil)
  1809.           (system::list-init-start 2 0 nil nil nil)
  1810.           (list-length 1 0 nil nil nil)
  1811.           (system::list-llength 1 0 nil nil nil)
  1812.           (system::list-nreverse 1 0 nil nil nil)
  1813.           (system::list-set-elt 3 0 nil nil nil)
  1814.           (system::list-upd 2 0 nil nil nil)
  1815.           (listen 0 1 nil nil nil)
  1816.           (listp 1 0 nil nil nil)
  1817.           (system::load-eval-reader 3 0 nil nil nil)
  1818.           (log 1 1 nil nil nil)
  1819.           (system::log10 1 0 nil nil nil)
  1820.           (system::log2 1 0 nil nil nil)
  1821.           (logand 0 0 t nil nil)
  1822.           (logandc1 2 0 nil nil nil)
  1823.           (logandc2 2 0 nil nil nil)
  1824.           (logbitp 2 0 nil nil nil)
  1825.           (logcount 1 0 nil nil nil)
  1826.           (logeqv 0 0 t nil nil)
  1827.           (system::logical-pathname-p 1 0 nil nil nil)
  1828.           (logior 0 0 t nil nil)
  1829.           (lognand 2 0 nil nil nil)
  1830.           (lognor 2 0 nil nil nil)
  1831.           (lognot 1 0 nil nil nil)
  1832.           (logorc1 2 0 nil nil nil)
  1833.           (logorc2 2 0 nil nil nil)
  1834.           (logtest 2 0 nil nil nil)
  1835.           (logxor 0 0 t nil nil)
  1836.           (long-float-digits 0 0 nil nil nil)
  1837.           (system::long-float-p 1 0 nil nil nil)
  1838.           (lower-case-p 1 0 nil nil nil)
  1839.           (system::lpar-reader 2 0 nil nil nil)
  1840.           ;(machine-instance 0 0 nil nil nil)
  1841.           ;(machine-type 0 0 nil nil nil)
  1842.           ;(machine-version 0 0 nil nil nil)
  1843.           (macro-function 1 0 nil nil nil)
  1844.           (macroexpand 1 1 nil nil nil)
  1845.           (macroexpand-1 1 1 nil nil nil)
  1846.           (make-array 1 0 nil (:adjustable :element-type :initial-element :initial-contents :fill-pointer :displaced-to :displaced-index-offset) nil)
  1847.           (system::make-bit-vector 1 0 nil nil nil)
  1848.           (make-broadcast-stream 0 0 t nil nil)
  1849.           (make-buffered-input-stream 2 0 nil nil nil)
  1850.           (make-buffered-output-stream 1 0 nil nil nil)
  1851.           (make-char 1 2 nil nil nil)
  1852.           (system::make-code-vector 1 0 nil nil nil)
  1853.           (make-concatenated-stream 0 0 t nil nil)
  1854.           (make-dir 1 0 nil nil nil)
  1855.           (make-dispatch-macro-character 1 2 nil nil nil)
  1856.           (make-echo-stream 2 0 nil nil nil)
  1857.           (make-hash-table 0 0 nil (:initial-contents :test :size :rehash-size :rehash-threshold) nil)
  1858.           (make-list 1 0 nil (:initial-element) nil)
  1859.           (system::make-load-time-eval 1 0 nil nil nil)
  1860.           (make-package 1 0 nil (:nicknames :use) nil)
  1861.           (make-pathname 0 0 nil (:defaults :case :host :device :directory :name :type :version) nil)
  1862.           #+(or UNIX OS/2) (make-pipe-input-stream 1 0 nil nil nil)
  1863.           #+(or UNIX OS/2) (make-pipe-output-stream 1 0 nil nil nil)
  1864.           (make-random-state 0 1 nil nil nil)
  1865.           (make-sequence 2 0 nil (:initial-element :update) nil)
  1866.           (make-string 1 0 nil (:initial-element) nil)
  1867.           (make-string-input-stream 1 2 nil nil nil)
  1868.           (make-string-output-stream 0 1 nil nil nil)
  1869.           (system::make-string-push-stream 1 0 nil nil nil)
  1870.           (make-symbol 1 0 nil nil nil)
  1871.           (make-synonym-stream 1 0 nil nil nil)
  1872.           (make-two-way-stream 2 0 nil nil nil)
  1873.           (makunbound 1 0 nil nil nil)
  1874.           (map 3 0 t nil nil)
  1875.           (system::map-all-symbols 1 0 nil nil nil)
  1876.           (system::map-external-symbols 2 0 nil nil nil)
  1877.           (system::map-symbols 2 0 nil nil nil)
  1878.           (mapc 2 0 t nil nil)
  1879.           (mapcan 2 0 t nil nil)
  1880.           (mapcar 2 0 t nil nil)
  1881.           (mapcon 2 0 t nil nil)
  1882.           (maphash 2 0 nil nil nil)
  1883.           (mapl 2 0 t nil nil)
  1884.           (maplist 2 0 t nil nil)
  1885.           (mask-field 2 0 nil nil nil)
  1886.           (max 1 0 t nil nil)
  1887.           (member 2 0 nil (:test :test-not :key) nil)
  1888.           (member-if 2 0 nil (:key) nil)
  1889.           (member-if-not 2 0 nil (:key) nil)
  1890.           (merge 4 0 nil (:key) nil)
  1891.           (merge-pathnames 1 2 nil (:wild) nil)
  1892.           (min 1 0 t nil nil)
  1893.           (minusp 1 0 nil nil nil)
  1894.           (mismatch 2 0 nil (:from-end :start1 :end1 :start2 :end2 :key :test :test-not) nil)
  1895.           (mod 2 0 nil nil nil)
  1896.           (name-char 1 0 nil nil nil)
  1897.           (namestring 1 1 nil nil nil)
  1898.           (nbutlast 1 1 nil nil nil)
  1899.           (nconc 0 0 t nil nil)
  1900.           (ninth 1 0 nil nil nil)
  1901.           (not 1 0 nil nil nil)
  1902.           (system::not-feature-reader 3 0 nil nil nil)
  1903.           (system::not-readable-reader 3 0 nil nil nil)
  1904.           (notany 2 0 t nil nil)
  1905.           (notevery 2 0 t nil nil)
  1906.           (nreconc 2 0 nil nil nil)
  1907.           (nreverse 1 0 nil nil nil)
  1908.           (nstring-capitalize 1 0 nil (:start :end) nil)
  1909.           (nstring-downcase 1 0 nil (:start :end) nil)
  1910.           (nstring-upcase 1 0 nil (:start :end) nil)
  1911.           (nsublis 2 0 nil (:test :test-not :key) nil)
  1912.           (nsubst 3 0 nil (:test :test-not :key) nil)
  1913.           (nsubst-if 3 0 nil (:key) nil)
  1914.           (nsubst-if-not 3 0 nil (:key) nil)
  1915.           (nsubstitute 3 0 nil (:from-end :start :end :key :test :test-not :count) nil)
  1916.           (nsubstitute-if 3 0 nil (:from-end :start :end :key :count) nil)
  1917.           (nsubstitute-if-not 3 0 nil (:from-end :start :end :key :count) nil)
  1918.           (nth 2 0 nil nil nil)
  1919.           (nthcdr 2 0 nil nil nil)
  1920.           (null 1 0 nil nil nil)
  1921.           (numberp 1 0 nil nil nil)
  1922.           (numerator 1 0 nil nil nil)
  1923.           (system::octal-reader 3 0 nil nil nil)
  1924.           (oddp 1 0 nil nil nil)
  1925.           (open 1 0 nil (:direction :element-type :if-exists :if-does-not-exist) nil)
  1926.           (output-stream-p 1 0 nil nil nil)
  1927.           (package-name 1 0 nil nil nil)
  1928.           (package-nicknames 1 0 nil nil nil)
  1929.           (package-shadowing-symbols 1 0 nil nil nil)
  1930.           (package-use-list 1 0 nil nil nil)
  1931.           (package-used-by-list 1 0 nil nil nil)
  1932.           (packagep 1 0 nil nil nil)
  1933.           (pairlis 2 1 nil nil nil)
  1934.           (system::parse-body 1 2 nil nil nil)
  1935.           (parse-integer 1 0 nil (:start :end :radix :junk-allowed) nil)
  1936.           (parse-namestring 1 2 nil (:start :end :junk-allowed) nil)
  1937.           (pathname 1 0 nil nil nil)
  1938.           (pathname-device 1 0 nil (:case) nil)
  1939.           (pathname-directory 1 0 nil (:case) nil)
  1940.           (pathname-host 1 0 nil (:case) nil)
  1941.           (pathname-match-p 2 0 nil nil nil)
  1942.           (pathname-name 1 0 nil (:case) nil)
  1943.           (system::pathname-reader 3 0 nil nil nil)
  1944.           (pathname-type 1 0 nil (:case) nil)
  1945.           (pathname-version 1 0 nil nil nil)
  1946.           (pathnamep 1 0 nil nil nil)
  1947.           (peek-char 0 5 nil nil nil)
  1948.           (phase 1 0 nil nil nil)
  1949.           (plusp 1 0 nil nil nil)
  1950.           (position 2 0 nil (:from-end :start :end :key :test :test-not) nil)
  1951.           (position-if 2 0 nil (:from-end :start :end :key) nil)
  1952.           (position-if-not 2 0 nil (:from-end :start :end :key) nil)
  1953.           (pprint 1 1 nil nil nil)
  1954.           (prin1 1 1 nil nil nil)
  1955.           (prin1-to-string 1 0 nil nil nil)
  1956.           (princ 1 1 nil nil nil)
  1957.           (princ-to-string 1 0 nil nil nil)
  1958.           (print 1 1 nil nil nil)
  1959.           (probe-file 1 0 nil nil nil)
  1960.           (proclaim 1 0 nil nil nil)
  1961.           (system::puthash 3 0 nil nil nil)
  1962.           (system::quote-reader 2 0 nil nil nil)
  1963.           (system::radix-reader 3 0 nil nil nil)
  1964.           (random 1 1 nil nil nil)
  1965.           (random-state-p 1 0 nil nil nil)
  1966.           (rassoc 2 0 nil (:test :test-not :key) nil)
  1967.           (rassoc-if 2 0 nil (:key) nil)
  1968.           (rassoc-if-not 2 0 nil (:key) nil)
  1969.           (rational 1 0 nil nil nil)
  1970.           (rationalize 1 0 nil nil nil)
  1971.           (rationalp 1 0 nil nil nil)
  1972.           (read 0 4 nil nil nil)
  1973.           (read-byte 1 2 nil nil nil)
  1974.           (read-char 0 4 nil nil nil)
  1975.           (read-char-no-hang 0 4 nil nil nil)
  1976.           (read-delimited-list 1 2 nil nil nil)
  1977.           (system::read-eval-print 1 1 nil nil nil)
  1978.           (system::read-eval-reader 3 0 nil nil nil)
  1979.           (system::read-form 1 1 nil nil nil)
  1980.           (read-from-string 1 2 nil (:preserve-whitespace :start :end) nil)
  1981.           (read-line 0 4 nil nil nil)
  1982.           (read-preserving-whitespace 0 4 nil nil nil)
  1983.           (readtablep 1 0 nil nil nil)
  1984.           (realp 1 0 nil nil nil)
  1985.           (realpart 1 0 nil nil nil)
  1986.           (system::redo-eval-frame 1 0 nil nil nil)
  1987.           (reduce 2 0 nil (:from-end :start :end :key :initial-value) nil)
  1988.           (rem 2 0 nil nil nil)
  1989.           (remhash 2 0 nil nil nil)
  1990.           (remove 2 0 nil (:from-end :start :end :key :test :test-not :count) nil)
  1991.           (remove-duplicates 1 0 nil (:from-end :start :end :key :test :test-not) nil)
  1992.           (remove-if 2 0 nil (:from-end :start :end :key :count) nil)
  1993.           (remove-if-not 2 0 nil (:from-end :start :end :key :count) nil)
  1994.           (remprop 2 0 nil nil nil)
  1995.           (rename-file 2 0 nil nil nil)
  1996.           (rename-package 2 1 nil nil nil)
  1997.           (replace 2 0 nil (:start1 :end1 :start2 :end2) nil)
  1998.           (rest 1 0 nil nil nil)
  1999.           (system::return-from-eval-frame 2 0 nil nil nil)
  2000.           (revappend 2 0 nil nil nil)
  2001.           (reverse 1 0 nil nil nil)
  2002.           (room 0 0 nil nil nil)
  2003.           (round 1 1 nil nil nil)
  2004.           (system::rpar-reader 2 0 nil nil nil)
  2005.           (rplaca 2 0 nil nil nil)
  2006.           (rplacd 2 0 nil nil nil)
  2007.           (system::same-env-as 2 0 nil nil nil)
  2008.           (savemem 1 0 nil nil nil)
  2009.           (sbit 1 0 t nil nil)
  2010.           (scale-float 2 0 nil nil nil)
  2011.           (schar 2 0 nil nil nil)
  2012.           (search 2 0 nil (:from-end :start1 :end1 :start2 :end2 :key :test :test-not) nil)
  2013.           (system::search-string-equal 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2014.           (system::search-string= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2015.           (second 1 0 nil nil nil)
  2016.           (system::sequencep 1 0 nil nil nil)
  2017.           (set 2 0 nil nil nil)
  2018.           (set-char-bit 3 0 nil nil nil)
  2019.           (set-dispatch-macro-character 3 1 nil nil nil)
  2020.           (system::set-fill-pointer 2 0 nil nil nil)
  2021.           (set-macro-character 2 2 nil nil nil)
  2022.           (set-syntax-from-char 2 2 nil nil nil)
  2023.           (seventh 1 0 nil nil nil)
  2024.           (shadow 1 1 nil nil nil)
  2025.           (shadowing-import 1 1 nil nil nil)
  2026.           ;(shell 0 1 nil nil nil)
  2027.           (system::short-float-p 1 0 nil nil nil)
  2028.           (show-stack 0 0 nil nil nil)
  2029.           (signum 1 0 nil nil nil)
  2030.           (system::simple-array-p 1 0 nil nil nil)
  2031.           (simple-bit-vector-p 1 0 nil nil nil)
  2032.           (simple-string-p 1 0 nil nil nil)
  2033.           (simple-vector-p 1 0 nil nil nil)
  2034.           (sin 1 0 nil nil nil)
  2035.           (system::single-float-p 1 0 nil nil nil)
  2036.           (sinh 1 0 nil nil nil)
  2037.           (sixth 1 0 nil nil nil)
  2038.           (clos:slot-value 2 0 nil nil nil)
  2039.           (clos::set-slot-value 3 0 nil nil nil)
  2040.           (clos:slot-boundp 2 0 nil nil nil)
  2041.           (clos:slot-makunbound 2 0 nil nil nil)
  2042.           (clos:slot-exists-p 2 0 nil nil nil)
  2043.           (software-type 0 0 nil nil nil)
  2044.           (software-version 0 0 nil nil nil)
  2045.           (some 2 0 t nil nil)
  2046.           (sort 2 0 nil (:key :start :end) nil)
  2047.           (special-form-p 1 0 nil nil nil)
  2048.           (system::special-variable-p 1 0 nil nil nil)
  2049.           (sqrt 1 0 nil nil nil)
  2050.           (stable-sort 2 0 nil (:key :start :end) nil)
  2051.           (standard-char-p 1 0 nil nil nil)
  2052.           (system::store 2 0 t nil nil)
  2053.           (system::store-char 3 0 nil nil nil)
  2054.           (system::store-schar 3 0 nil nil nil)
  2055.           (stream-element-type 1 0 nil nil nil)
  2056.           (streamp 1 0 nil nil nil)
  2057.           (string 1 0 nil nil nil)
  2058.           (system::string-both-trim 3 0 nil nil nil)
  2059.           (string-capitalize 1 0 nil (:start :end) nil)
  2060.           (string-char-p 1 0 nil nil nil)
  2061.           (string-concat 0 0 t nil nil)
  2062.           (string-downcase 1 0 nil (:start :end) nil)
  2063.           (string-equal 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2064.           (string-greaterp 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2065.           (system::string-input-stream-index 1 0 nil nil nil)
  2066.           (string-lessp 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2067.           (string-not-equal 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2068.           (string-not-greaterp 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2069.           (string-not-lessp 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2070.           (system::string-reader 2 0 nil nil nil)
  2071.           (string-upcase 1 0 nil (:start :end) nil)
  2072.           (string/= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2073.           (string< 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2074.           (string<= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2075.           (string= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2076.           (string> 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2077.           (string>= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2078.           (stringp 1 0 nil nil nil)
  2079.           (system::structure-reader 3 0 nil nil nil)
  2080.           (sublis 2 0 nil (:test :test-not :key) nil)
  2081.           (system::subr-info 1 0 nil nil nil)
  2082.           (subseq 2 1 nil nil nil)
  2083.           (subst 3 0 nil (:test :test-not :key) nil)
  2084.           (subst-if 3 0 nil (:key) nil)
  2085.           (subst-if-not 3 0 nil (:key) nil)
  2086.           (substitute 3 0 nil (:from-end :start :end :key :test :test-not :count) nil)
  2087.           (substitute-if 3 0 nil (:from-end :start :end :key :count) nil)
  2088.           (substitute-if-not 3 0 nil (:from-end :start :end :key :count) nil)
  2089.           (substring 2 1 nil nil nil)
  2090.           (svref 2 0 nil nil nil)
  2091.           (system::svstore 3 0 nil nil nil)
  2092.           (sxhash 1 0 nil nil nil)
  2093.           (symbol-function 1 0 nil nil nil)
  2094.           (symbol-name 1 0 nil nil nil)
  2095.           (symbol-package 1 0 nil nil nil)
  2096.           (symbol-plist 1 0 nil nil nil)
  2097.           (symbol-value 1 0 nil nil nil)
  2098.           (symbolp 1 0 nil nil nil)
  2099.           (system::syntax-error-reader 3 0 nil nil nil)
  2100.           (tailp 2 0 nil nil nil)
  2101.           (tan 1 0 nil nil nil)
  2102.           (tanh 1 0 nil nil nil)
  2103.           (tenth 1 0 nil nil nil)
  2104.           (terpri 0 1 nil nil nil)
  2105.           (system::the-frame 0 0 nil nil nil)
  2106.           (third 1 0 nil nil nil)
  2107.           (translate-pathname 3 0 nil (:all :merge) nil)
  2108.           (tree-equal 2 0 nil (:test :test-not) nil)
  2109.           (truename 1 0 nil nil nil)
  2110.           (truncate 1 1 nil nil nil)
  2111.           (type-of 1 0 nil nil nil)
  2112.           (unexport 1 1 nil nil nil)
  2113.           (unintern 1 1 nil nil nil)
  2114.           (system::uninterned-reader 3 0 nil nil nil)
  2115.           (unread-char 1 1 nil nil nil)
  2116.           (unuse-package 1 1 nil nil nil)
  2117.           (system::unwind-to-driver 0 0 nil nil nil)
  2118.           (upper-case-p 1 0 nil nil nil)
  2119.           (use-package 1 1 nil nil nil)
  2120.           (system::use-package-aux 1 0 nil nil nil)
  2121.           #+UNIX (user-homedir-pathname 0 1 nil nil nil)
  2122.           (values 0 0 t nil nil)
  2123.           (values-list 1 0 nil nil nil)
  2124.           (vector 0 0 t nil nil)
  2125.           (system::vector-endtest 2 0 nil nil nil)
  2126.           (system::vector-fe-endtest 2 0 nil nil nil)
  2127.           (system::vector-fe-init 1 0 nil nil nil)
  2128.           (system::vector-fe-init-end 2 0 nil nil nil)
  2129.           (system::vector-fe-upd 2 0 nil nil nil)
  2130.           (system::vector-init 1 0 nil nil nil)
  2131.           (system::vector-init-start 2 0 nil nil nil)
  2132.           (system::vector-length 1 0 nil nil nil)
  2133.           (vector-pop 1 0 nil nil nil)
  2134.           (vector-push 2 0 nil nil nil)
  2135.           (vector-push-extend 2 1 nil nil nil)
  2136.           (system::vector-reader 3 0 nil nil nil)
  2137.           (system::vector-upd 2 0 nil nil nil)
  2138.           (vectorp 1 0 nil nil nil)
  2139.           (system::version 0 1 nil nil nil)
  2140.           (wild-pathname-p 1 1 nil nil nil)
  2141.           (write 1 0 nil (:case :level :length :gensym :escape :radix :base :array :circle :pretty :closure :readably :stream) nil)
  2142.           (write-byte 2 0 nil nil nil)
  2143.           (write-char 1 1 nil nil nil)
  2144.           (write-line 1 1 nil (:start :end) nil)
  2145.           (write-string 1 1 nil (:start :end) nil)
  2146.           (write-to-string 1 0 nil (:case :level :length :gensym :escape :radix :base :array :circle :pretty :closure :readably) nil)
  2147.           (xgcd 0 0 t nil nil)
  2148.           (zerop 1 0 nil nil nil)
  2149. ) ) ) )  )
  2150. (defconstant function-codes
  2151.   (let ((hashtable (make-hash-table :test #'eq)))
  2152.     (dotimes (i (* 3 256))
  2153.       (let ((sym (%funtabref i))) ; Name der Funktion FUNTAB[i]
  2154.         (when sym (setf (gethash sym hashtable) i))
  2155.     ) )
  2156.     hashtable
  2157. ) )
  2158. (defconstant funtabR-index ; Startindex der FUNTABR bzgl. FUNTAB
  2159.   (dotimes (i (* 3 256))
  2160.     (let ((sym (%funtabref i)))
  2161.       (multiple-value-bind (name req opt rest-p) (subr-info sym)
  2162.         (declare (ignore name req opt))
  2163.         (when rest-p (return i))
  2164. ) ) ) )
  2165. (defun CALLS-code (funtab-index)
  2166.   (if (< funtab-index 256)
  2167.     `(CALLS1 ,funtab-index)
  2168.     `(CALLS2 ,(- funtab-index 256))
  2169. ) )
  2170.  
  2171. ; Hilfsfunktion: mapcan, aber mit append statt nconc:
  2172. #|
  2173. #-CLISP
  2174. (defun mapcap (fun &rest lists &aux (L nil))
  2175.   (loop
  2176.     (setq L
  2177.       (nconc
  2178.         (reverse
  2179.           (apply fun
  2180.             (maplist #'(lambda (listsr)
  2181.                          (if (atom (car listsr))
  2182.                            (return)
  2183.                            (pop (car listsr))
  2184.                        ) )
  2185.                      lists
  2186.         ) ) )
  2187.         L
  2188.       )
  2189.   ) )
  2190.   (nreverse L)
  2191. )
  2192. |#
  2193. #-CLISP
  2194. (defun mapcap (fun &rest lists)
  2195.   (apply #'append (apply #'mapcar fun lists))
  2196. )
  2197.  
  2198. ; Hilfsfunktion: mapcon, aber mit append statt nconc:
  2199. #|
  2200. #-CLISP
  2201. (defun maplap (fun &rest lists &aux (L nil))
  2202.   (loop
  2203.     (setq L
  2204.       (nconc
  2205.         (reverse
  2206.           (apply fun
  2207.             (maplist #'(lambda (listsr)
  2208.                          (if (atom (car listsr))
  2209.                            (return)
  2210.                            (prog1
  2211.                              (car listsr)
  2212.                              (setf (car listsr) (cdr (car listsr)))
  2213.                        ) ) )
  2214.                      lists
  2215.         ) ) )
  2216.         L
  2217.       )
  2218.   ) )
  2219.   (nreverse L)
  2220. )
  2221. |#
  2222. #-CLISP
  2223. (defun maplap (fun &rest lists)
  2224.   (apply #'append (apply #'maplist fun lists))
  2225. )
  2226.  
  2227. ; (memq item const-symbollist) == (member item const-symbollist :test #'eq),
  2228. ; nur der boolesche Wert.
  2229. (defmacro memq (item list)
  2230.   (if (and (constantp list) (listp (eval list)))
  2231.     `(case ,item (,(eval list) t) (t nil))
  2232.     `(member ,item ,list :test #'eq)
  2233. ) )
  2234.  
  2235. ; Fehlermeldungsfunktion
  2236. (defun compiler-error (caller &optional where)
  2237.   (error (DEUTSCH "Fehler im Compiler!! Aufgetreten in ~A~@[ bei ~A~]."
  2238.           ENGLISH "Compiler bug!! Occurred in ~A~@[ at ~A~]."
  2239.           FRANCAIS "Erreur dans le compilateur!! ArrivΘ dans ~A~@[ au point ~A~].")
  2240.          caller where
  2241. ) )
  2242.  
  2243.  
  2244.  
  2245. ;                      S T A C K - V E R W A L T U N G
  2246.  
  2247. ; Ein Stackzustand beschreibt, was sich zur Laufzeit alles auf den beiden
  2248. ; Stacks befinden wird.
  2249. ; Genaue Struktur:
  2250. ; (item1 ... itemk . fun)
  2251. ; Das ist im Speicher in Wirklichkeit eine Baumstruktur!
  2252. ; Es bedeuten hierbei:
  2253. ;  fun = FNODE der Funktion, in der gezΣhlt wird.
  2254. ;  item = eines der folgenden:
  2255. ;    n (Integer >=0) : n Lisp-Objekte auf dem STACK
  2256. ;                      belegt n STACK-EintrΣge
  2257. ;    (BIND n)        : einen Bindungsframe fⁿr n Variablen,
  2258. ;                      belegt 1+2*n STACK-EintrΣge und 0 SP-EintrΣge
  2259. ;                      Mu▀ bei Unwind explizit aufgel÷st werden
  2260. ;    PROGV           : ein Bindungsframe fⁿr beliebig viele Variablen,
  2261. ;                      belegt ? STACK-EintrΣge und 1 SP-Eintrag (Pointer ⁿber
  2262. ;                      den Frame = alter STACK)
  2263. ;                      Mu▀ bei Unwind explizit aufgel÷st werden
  2264. ;    CATCH           : ein CATCH-Frame
  2265. ;                      belegt 3 STACK-EintrΣge und 2+*jmpbuf-size* SP-EintrΣge
  2266. ;    UNWIND-PROTECT  : ein Unwind-Protect-Frame
  2267. ;                      belegt 2 STACK-EintrΣge und 2+*jmpbuf-size* SP-EintrΣge
  2268. ;                      Mu▀ bei Unwind aufgel÷st und der Cleanup ausgefⁿhrt
  2269. ;                      werden
  2270. ;    CLEANUP         : wΣhrend der Cleanup-Phase eines UNWIND-PROTECT
  2271. ;                      belegt ? STACK-EintrΣge und 3 SP-EintrΣge
  2272. ;                      (der untere ist Pointer ⁿber den Frame = alter STACK)
  2273. ;    BLOCK           : ein BLOCK-Frame
  2274. ;                      belegt 3 STACK-EintrΣge und 2+*jmpbuf-size* SP-EintrΣge
  2275. ;                      Mu▀ bei Unwind explizit aufgel÷st werden
  2276. ;    (TAGBODY n)     : ein TAGBODY-Frame, der n Tags aufhebt
  2277. ;                      belegt 3+n STACK-EintrΣge und 1+*jmpbuf-size* SP-EintrΣge
  2278. ;                      Mu▀ bei Unwind explizit aufgel÷st werden
  2279. ;    MVCALLP         : Vorbereitung fⁿr MVCALL
  2280. ;                      belegt 1 STACK-Eintrag und 1 SP-Eintrag (Pointer ⁿber
  2281. ;                      FRAME = STACK)
  2282. ;    MVCALL          : viele Lisp-Objekte
  2283. ;                      belegt ? STACK-EintrΣge und 1 SP-Eintrag (Pointer ⁿber
  2284. ;                      Frame = alter STACK)
  2285. ;    ANYTHING        : viele Lisp-Objekte und Frames
  2286. ;                      belegt ? STACK-EintrΣge und 1 SP-Eintrag (Pointer ⁿber
  2287. ;                      Frame = alter STACK)
  2288.  
  2289. (defvar *stackz*)    ; der aktuelle Stackzustand
  2290.  
  2291. ; (stackz-fun stackz) extrahiert aus einem Stackzustand die Funktion, in der
  2292. ; gerade gearbeitet wird.
  2293. #|
  2294. (defun stackz-fun (stackz)
  2295.   (loop (when (atom stackz) (return)) (setq stackz (cdr stackz)))
  2296.   stackz
  2297. )
  2298. |#
  2299. ; Σquivalent, aber schneller:
  2300. (defun stackz-fun (stackz)
  2301.   (if (atom stackz) stackz (cdr (last stackz)))
  2302. )
  2303.  
  2304. ; (in-same-function-p stackz1 stackz2) stellt fest, ob in beiden StackzustΣnden
  2305. ; in derselben Funktion gearbeitet wird.
  2306. (defun in-same-function-p (stackz1 stackz2)
  2307.   (eq (stackz-fun stackz1) (stackz-fun stackz2))
  2308. )
  2309.  
  2310. ; (zugriff-in-stack stackz1 stackz2)
  2311. ; Fⁿr den Zugriff auf lokale Variablen im Stack:
  2312. ; ergibt zu zwei StackzustΣnden stackz1 und stackz2, die beide innerhalb
  2313. ; derselben Funktion liegen und wo stackz1 "tiefer" ist als stackz2:
  2314. ; 2 Werte: NIL und n, falls (stackz2) = (STACK+4*n) von stackz1 aus,
  2315. ;          k und n, falls (stackz2) = ((SP+4*k)+4*n) von stackz1 aus.
  2316. ; (Falls stackz2 mit BLOCK oder TAGBODY beginnt, ist immer der Zugriff auf die
  2317. ;  consvar eines Block- bzw. Tagbody-Frames gemeint.)
  2318. (defun zugriff-in-stack (stackz1 stackz2 &aux (k nil) (n 0) (kd 0))
  2319.   (loop ; beim Durchlaufen der Stacks nach oben:
  2320.     ; momentanes STACK ist STACK+4*n (bei k=NIL) bzw. (SP+4*k)+4*n,
  2321.     ; momentanes SP ist SP+4*kd (bei k=NIL) bzw. SP+4*(k+kd).
  2322.     (when (eq stackz1 stackz2) (return))
  2323.     (when (atom stackz1) (compiler-error 'zugriff-in-stack "STACKZ-END"))
  2324.     (let ((item (car stackz1)))
  2325.       (cond ((integerp item) (setq n (+ n item)))
  2326.             ((consp item)
  2327.              (case (first item)
  2328.                (BIND    (setq n (+ n (+ 1 (* 2 (second item))))))
  2329.                (TAGBODY (setq kd (+ kd (+ 1 *jmpbuf-size*))
  2330.                               n (+ n (+ 3 (second item)))
  2331.                )        )
  2332.                (t (compiler-error 'zugriff-in-stack "STACKZ-LISTITEM"))
  2333.             ))
  2334.             (t
  2335.              (case item
  2336.                (PROGV          (setq k (if k (+ k kd) kd) kd 1 n 0))
  2337.                (CATCH          (setq kd (+ kd (+ 2 *jmpbuf-size*)) n (+ n 3)))
  2338.                (UNWIND-PROTECT (setq kd (+ kd (+ 2 *jmpbuf-size*)) n (+ n 2)))
  2339.                (CLEANUP        (setq k (if k (+ k kd) kd) kd 3 n 0))
  2340.                (BLOCK          (setq kd (+ kd (+ 2 *jmpbuf-size*)) n (+ n 3)))
  2341.                (MVCALLP        (setq kd (+ kd 1) n (+ n 1)))
  2342.                ((MVCALL ANYTHING)
  2343.                                (setq k (if k (+ k kd) kd) kd 1 n 0))
  2344.                (t (compiler-error 'zugriff-in-stack "STACKZ-ITEM"))
  2345.     ) )     ))
  2346.     (setq stackz1 (cdr stackz1))
  2347.   )
  2348.   (when (and (consp stackz2) ; beim Zugriff auf BLOCK- bzw. TAGBODY-consvar:
  2349.              (or (eq (car stackz2) 'BLOCK)
  2350.                  (and (consp (car stackz2)) (eq (first (car stackz2)) 'TAGBODY))
  2351.         )    )
  2352.     (setq n (+ n 2)) ; consvar liegt genau 2 EintrΣge h÷her als Frameanfang
  2353.   )
  2354.   (values k n)
  2355. )
  2356.  
  2357. ; (may-UNWIND stackz1 stackz2)
  2358. ; stellt fest, ob (UNWIND stackz1 stackz2 for-value) legal ist. Dazu ist
  2359. ; notwendig, da▀ der Compiler ⁿber die Frames zwischen stackz1 und stackz2
  2360. ; genau Bescheid wei▀.
  2361. (defun may-UNWIND (stackz1 stackz2)
  2362.   (loop
  2363.     (when (eq stackz1 stackz2) (return t))
  2364.     (when (atom stackz1) (compiler-error 'may-UNWIND "STACKZ-END"))
  2365.     (when (eq (car stackz1) 'ANYTHING) (return nil))
  2366.     (setq stackz1 (cdr stackz1))
  2367. ) )
  2368.  
  2369. ; (expand-UNWIND stackz1 stackz2 for-value)
  2370. ; liefert ein zu (UNWIND stackz1 stackz2 for-value) Σquivalentes Codestⁿck,
  2371. ; bestehend aus
  2372. ; (SKIP n), (SKIPI k n), (SKIPSP k), (VALUES0), (UNWIND-PROTECT-CLEANUP),
  2373. ; (UNBIND1), (BLOCK-CLOSE), (TAGBODY-CLOSE).
  2374. ; Es mu▀ - ausgehend von stackz1 - den Stack so bereinigen, da▀ danach der
  2375. ; Stackzustand stackz2 vorliegt. Bei for-value=NIL k÷nnen die Werte dabei
  2376. ; weggeworfen werden.
  2377. (defun expand-UNWIND (stackz1 stackz2 for-value
  2378.                       &aux (k nil) (n 0) (kd 0) (codelist nil))
  2379.   (flet ((here () ; bis hierher erst einmal die Stacks hochsetzen
  2380.            (if k
  2381.              (progn
  2382.                (push `(SKIPI ,k ,n) codelist)
  2383.                (when (<= kd 0) (compiler-error 'expand-UNWIND "SP-depth"))
  2384.                (when (> kd 1) (push `(SKIPSP ,(- kd 1)) codelist))
  2385.              )
  2386.              (progn
  2387.                (when (> n 0) (push `(SKIP ,n) codelist))
  2388.                (when (> kd 0) (push `(SKIPSP ,kd) codelist))
  2389.            ) )
  2390.            (setq k nil n 0 kd 0)
  2391.         ))
  2392.     (loop ; beim Durchlaufen der Stacks nach oben:
  2393.       ; momentanes STACK ist STACK+4*n (bei k=NIL) bzw. (SP+4*k)+4*n,
  2394.       ; momentanes SP ist SP+4*kd (bei k=NIL) bzw. SP+4*(k+kd).
  2395.       (when (eq stackz1 stackz2) (here) (return))
  2396.       (when (atom stackz1) (compiler-error 'expand-UNWIND "STACKZ-END"))
  2397.       (let ((item (car stackz1)))
  2398.         (cond ((integerp item) (setq n (+ n item)))
  2399.               ((consp item)
  2400.                (case (first item)
  2401.                  (BIND    (here) (push '(UNBIND1) codelist))
  2402.                  (TAGBODY (here) (push '(TAGBODY-CLOSE) codelist))
  2403.                  (t (compiler-error 'expand-UNWIND "STACKZ-LISTITEM"))
  2404.               ))
  2405.               (t
  2406.                (case item
  2407.                  (PROGV (here) (push '(UNBIND1) codelist) (setq kd 1))
  2408.                  (CATCH (setq kd (+ kd (+ 2 *jmpbuf-size*)) n (+ n 3)))
  2409.                  (UNWIND-PROTECT
  2410.                    (here)
  2411.                    (unless for-value
  2412.                       ; bei for-value=NIL wird beim ersten auftretenden
  2413.                       ; UNWIND-PROTECT-Frame ein '(VALUES0) eingefⁿgt.
  2414.                      (setq for-value t)
  2415.                      (push '(VALUES0) codelist)
  2416.                    )
  2417.                    (push '(UNWIND-PROTECT-CLEANUP) codelist)
  2418.                  )
  2419.                  (CLEANUP (setq k (if k (+ k kd) kd) kd 3 n 0))
  2420.                  (BLOCK (here) (push '(BLOCK-CLOSE) codelist))
  2421.                  (MVCALLP (setq kd (+ kd 1) n (+ n 1)))
  2422.                  (MVCALL (setq k (if k (+ k kd) kd) kd 1 n 0))
  2423.                  (t (compiler-error 'expand-UNWIND "STACKZ-ITEM"))
  2424.       ) )     ))
  2425.       (setq stackz1 (cdr stackz1))
  2426.     )
  2427.     (nreverse codelist)
  2428. ) )
  2429.  
  2430. ; (spdepth-difference stackz1 stackz2)
  2431. ; liefert den Unterschied k von SP bei stackz1 und SP bei stackz2.
  2432. ; Um den SP von stackz1 zu stackz2 hochzusetzen, reicht also ein (SKIPSP k).
  2433. (defun spdepth-difference (stackz1 stackz2 &aux (k 0))
  2434.   (loop
  2435.     (when (eq stackz1 stackz2) (return))
  2436.     (when (atom stackz1) (compiler-error 'spdepth-difference "STACKZ-END"))
  2437.     (let ((item (car stackz1)))
  2438.       (if (consp item)
  2439.         (case (first item)
  2440.           (TAGBODY (incf k (+ 1 *jmpbuf-size*)))
  2441.         )
  2442.         (case item
  2443.           ((PROGV MVCALLP MVCALL ANYTHING) (incf k 1))
  2444.           ((CATCH UNWIND-PROTECT BLOCK) (incf k (+ 2 *jmpbuf-size*)))
  2445.           (CLEANUP (incf k 3))
  2446.     ) ) )
  2447.     (setq stackz1 (cdr stackz1))
  2448.   )
  2449.   k
  2450. )
  2451.  
  2452.  
  2453.  
  2454. ;        F U N C T I O N - E N V I R O N M E N T - V E R W A L T U N G
  2455.  
  2456. ; mitgegeben vom Interpreter: %fenv%
  2457.  
  2458. ; Interpreter-Funktions-Environment hat die Gestalt
  2459. ; %fenv% = NIL oder #(f1 def1 ... fn defn NEXT-ENV), NEXT-ENV von derselben
  2460. ; Gestalt.
  2461. ; Damit ist eine Abbildung fi --> defi realisiert.
  2462. ; defi = (SYSTEM::MACRO . expander)  bedeutet einen lokalen Macro.
  2463. ; defi = Closure                     bedeutet, da▀ defi die lokale
  2464. ;                                    Funktionsdefinition von fi ist
  2465. ; defi = NIL                         bedeutet, da▀ eine lokale Funktions-
  2466. ;                                    definition noch hineinkommt (vgl. LABELS)
  2467.  
  2468. ; neu konstruiert:
  2469. (defvar *fenv*)
  2470. ; enthΣlt die neuen lexikalischen Funktionsbindungen.
  2471. ; *fenv* hat dieselbe Gestalt wie %fenv% und endet mit %fenv%:
  2472. ; #(f1 def1 ... fn defn NEXT-ENV), was eine Abbildung fi --> defi
  2473. ; realisiert.
  2474. ; defi = (SYSTEM::MACRO expander)  bedeutet einen lokalen Makro.
  2475. ; defi = (fdescr . var)            bedeutet, da▀ die lokale Funktionsdefinition
  2476. ;           von fi zur Laufzeit in der lexikalischen Variablen var steckt.
  2477. ;           fnode ist der zu fi geh÷rige fnode, anfangs noch NIL.
  2478. ; defi = (fdescr . const)          bedeutet, da▀ die lokale Funktionsdefinition
  2479. ;           von fi autonom ist und in der Konstanten const steckt.
  2480. ;           fnode ist der zu fi geh÷rige fnode, anfangs noch NIL.
  2481. ; Dabei ist fdescr ein Cons (fnode . lambdadescr),
  2482. ;           fnode der zu fi geh÷rige fnode oder NIL,
  2483. ;           lambdadescr = (LABELS . Liste der Werte von analyze-lambdalist)
  2484. ;           oder lambdadescr = (GENERIC . Signature) oder NIL.
  2485.  
  2486. ; Suche die lokale Funktionsdefinition des Symbols f in fenv :
  2487. ; Ergebnis ist:
  2488. ; SYSTEM::MACRO, expander           bei einem lokalen Macro,
  2489. ; GLOBAL, Vektor, Index             wenn defi = (svref Vektor Index)
  2490. ;                                   (also in %fenv% gefunden)
  2491. ; LOCAL, def, fdescr                wenn defi = def eine Variable oder Konstante
  2492. ;                                   (also in *fenv* ohne %fenv% gefunden)
  2493. ; NIL                               falls nicht lokal definiert.
  2494. (defun fenv-search (f &optional (fenv *fenv*))
  2495.   (loop
  2496.     (when (null fenv) (return-from fenv-search 'NIL))
  2497.     (unless (simple-vector-p fenv) (compiler-error 'fenv-search))
  2498.     (do ((l (1- (length fenv)))
  2499.          (i 0 (+ i 2)))
  2500.         ((= i l) (setq fenv (svref fenv i)))
  2501.       (if (equal f (svref fenv i))
  2502.         (let ((def (svref fenv (1+ i))))
  2503.           (return-from fenv-search
  2504.             (if (consp def)
  2505.               (if (eq (car def) 'SYSTEM::MACRO)
  2506.                 (values 'SYSTEM::MACRO (cdr def))
  2507.                 (values 'LOCAL (cdr def) (car def))
  2508.               )
  2509.               (values 'GLOBAL fenv (1+ i))
  2510.   ) ) ) ) ) )
  2511. )
  2512. ; Stellt fest, ob ein Funktionsname im Function-Environment fenv nicht
  2513. ; definiert ist und daher auf die globale Funktion verweist.
  2514. (defun global-in-fenv-p (s fenv)
  2515.   (eq (fenv-search s fenv) 'NIL)
  2516. )
  2517.  
  2518. ; Mit einem Vektor aus
  2519. ; - einem solchen Variablen-Environment (verkettete Vektoren, mit
  2520. ;   defi = #<SYMBOL-MACRO expansion> fⁿr Symbol-Macro-Definitionen),
  2521. ; - einem solchen Funktions-Environment (verkettete Vektoren, mit
  2522. ;   defi = (SYSTEM::MACRO . expander) fⁿr Macro-Definitionen zu fi)
  2523. ; arbeiten die Funktionen
  2524. ; MACROEXPAND-1, MACROEXPAND, PARSE-BODY:
  2525. #|
  2526. (MACROEXPAND-1 form env) expandiert die gegebene Form im Macroexpansions-
  2527. Environment env und liefert die 1 mal expandierte Form und T
  2528. (oder form und NIL, falls nicht expandierbar).
  2529.  
  2530. (MACROEXPAND form env) expandiert die gegebene Form im Macroexpansions-
  2531. Environment env und liefert die sooft wie m÷glich expandierte Form und T
  2532. (oder form und NIL, falls nicht expandierbar).
  2533.  
  2534. (PARSE-BODY body docstring-allowed env) analysiert den body und spaltet von
  2535. ihm die Deklarationen und den Docstring (falls erlaubt und vorhanden) ab.
  2536. 3 Werte: der ⁿbrige body-rest, eine Liste der vorgekommenen declspecs,
  2537. der Docstring (oder NIL).
  2538. |#
  2539.  
  2540.  
  2541. ;           B L O C K - E N V I R O N M E N T - V E R W A L T U N G
  2542.  
  2543. ; mitgegeben vom Interpreter: %benv%
  2544.  
  2545. ; Interpreter-Block-Environment hat die Gestalt
  2546. ; %benv% = ((name1 . status1) ... (namen . statusn))
  2547. ; wobei namei ein Symbol und statusi der Status dieses lexikalisch umfassenden
  2548. ; Blocks ist: #<DISABLED> falls der Block bereits verlassen wurde, sonst ein
  2549. ; Pointer in den Stack auf den zugeh÷rigen Block-Frame.
  2550.  
  2551. ; neu konstruiert:
  2552. (defvar *benv*)
  2553.  
  2554. ; *benv* hat die Gestalt
  2555. ; ((name1 . block1) ... (namen . blockn) . %benv%)
  2556. ; wobei blocki der Descriptor des Blocks mit Namen namei ist:
  2557. (defstruct (block (:copier nil))
  2558.   fnode                 ; Funktion, in der dieser Block definiert ist, ein FNODE
  2559.   label                 ; label, an dem dieser Block zu Ende ist
  2560.   stackz                ; Stackzustand nach dem Aufbau des Block-Frames
  2561.   consvar               ; Variable, die im Stack im Block-Frame liegt und den
  2562.                         ; Block-Cons enthΣlt (dessen CDR beim Verlassen des
  2563.                         ; Blockes auf #<DISABLED> gesetzt wird)
  2564.   used-far              ; Flag, gibt an, ob dieser Block aus einer anderen
  2565.                         ; Funktion heraus mit RETURN-FROM verlassen wird.
  2566.   for-value             ; gibt an, ob das gesamte Block-Konstrukt Werte
  2567.                         ; zurⁿckliefern soll.
  2568. )
  2569. #+CLISP (remprop 'block 'sys::defstruct-description)
  2570.  
  2571. ; Sucht nach einem Block mit dem Namen name und liefert:
  2572. ; NIL                          falls nicht gefunden,
  2573. ; Block-Descriptor             falls in *benv* gefunden,
  2574. ; Block-Cons (name . status)   falls in %benv% gefunden.
  2575. (defun benv-search (name &optional (benv *benv*))
  2576.   (loop
  2577.     (when (atom benv) (return nil))
  2578.     (when (eq (caar benv) name)
  2579.       (if (block-p (cdar benv))
  2580.         (return (cdar benv))
  2581.         (return (car benv))
  2582.     ) )
  2583.     (setq benv (cdr benv))
  2584. ) )
  2585.  
  2586.  
  2587. ;         T A G B O D Y - E N V I R O N M E N T - V E R W A L T U N G
  2588.  
  2589. ; mitgegeben vom Interpreter: %genv%
  2590.  
  2591. ; Interpreter-Tagbody-Environment hat die Gestalt
  2592. ; %genv% = ((Tagvektor1 . status1) ... (Tagvektorn . statusn))
  2593. ; wobei Tagvektori ein simple-vector ist, der die anspringbaren Tags enthΣlt,
  2594. ; statusi der Status dieses lexikalisch umfassenden Tagbodys
  2595. ; ist: #<DISABLED> falls der Tagbody bereits verlassen wurde, sonst ein
  2596. ; Pointer in den Stack auf den zugeh÷rigen Tagbody-Frame.
  2597.  
  2598. ; neu konstruiert:
  2599. (defvar *genv*)
  2600.  
  2601. ; *genv* hat die Gestalt
  2602. ; ((Tagvektor1 . tagbody1) ... (Tagvektorn . tagbodyn) . %genv%)
  2603. ; wobei tagbodyi der Descriptor des Tagbodys i ist:
  2604. (defstruct (tagbody (:copier nil))
  2605.   fnode               ; Funktion, in der dieser Tagbody definiert ist, ein FNODE
  2606.   labellist           ; Liste der Labels, parallel zum Tagvektor
  2607.   stackz              ; Stackzustand nach dem Aufbau des Tagbody-Frames
  2608.   consvar             ; Variable, die im Stack im Tagbody-Frame liegt und den
  2609.                       ; Tagbody-Cons enthΣlt (dessen CDR beim Verlassen des
  2610.                       ; Tagbodys auf #<DISABLED> gesetzt wird)
  2611.   used-far            ; Vektor mit Fill-Pointer, enthΣlt all die Tags, die
  2612.                       ; aus einer anderen Funktion heraus mit GO angesprungen
  2613.                       ; werden.
  2614. )
  2615. #+CLISP (remprop 'tagbody 'sys::defstruct-description)
  2616.  
  2617. ; Sucht nach einem Tag mit dem Namen name und liefert:
  2618. ; NIL                                         falls nicht gefunden,
  2619. ; Tagbody-Descriptor, Index                   falls in *genv* gefunden,
  2620. ; Tagbody-Cons (Tagvektor . status), Index    falls in %genv% gefunden.
  2621. (defun genv-search (name &optional (genv *genv*))
  2622.   (loop
  2623.     (when (atom genv) (return nil))
  2624.     (do* ((v (caar genv))
  2625.           (l (length v))
  2626.           (i 0 (1+ i)))
  2627.          ((= i l))
  2628.       (when (eql (svref v i) name)
  2629.         (return-from genv-search
  2630.           (values (if (tagbody-p (cdar genv)) (cdar genv) (car genv)) i)
  2631.     ) ) )
  2632.     (setq genv (cdr genv))
  2633. ) )
  2634.  
  2635.  
  2636. ;       V A R I A B L E N - E N V I R O N M E N T - V E R W A L T U N G
  2637.  
  2638. ; mitgegeben vom Interpreter: %venv%
  2639.  
  2640. ; Interpreter-Variablen-Environment hat die Gestalt
  2641. ; %venv% = NIL oder #(v1 val1 ... vn valn NEXT-ENV), NEXT-ENV von derselben
  2642. ; Gestalt.
  2643. (defparameter specdecl
  2644.   #+CLISP (eval
  2645.             '(let ((*evalhook*
  2646.                      #'(lambda (form env) (declare (ignore form))
  2647.                          (svref (svref env 0) 1)
  2648.                          ; Der Evalhook-Mechanismus ⁿbergibt das Environment.
  2649.                          ; (svref...0) davon ist das Variablen-Environment,
  2650.                          ; (svref...1) davon ist von der *evalhook*-Bindung
  2651.                          ; der assoziierte "Wert" #<SPECIAL REFERENCE>.
  2652.                   ))   )
  2653.                0
  2654.           )  )
  2655.   #-CLISP (cons nil nil)
  2656. )
  2657. ; stellt fest, ob das Symbol var eine Special-Variable darstellt
  2658. #+CLISP
  2659. (defun proclaimed-special-p (var)
  2660.   (or (sys::special-variable-p var)
  2661.       (not (null (member var *known-special-vars* :test #'eq)))
  2662. ) )
  2663. #-CLISP
  2664. (defun proclaimed-special-p (var)
  2665.   (or
  2666.     (eq var '*evalhook*)
  2667.     (eq var '*applyhook*)
  2668.     (eq var '*macroexpand-hook*)
  2669.     (let ((obj (cons nil nil)))
  2670.       (eval
  2671.         `(let ((,var ',obj))
  2672.            (and (boundp ',var) (eq (symbol-value ',var) ',obj))
  2673.     ) )  )
  2674.     (not (null (member var *known-special-vars* :test #'eq)))
  2675. ) )
  2676.  
  2677. ; neu konstruiert:
  2678. (defvar *venv*)                  ; Variablen-Environment, Feinstruktur
  2679. (defvar *venvc*)                 ; Variablen-Environment, Grobstruktur
  2680.  
  2681. ; *venv* hat dieselbe Gestalt wie %venv% und endet mit %venv%:
  2682. ; #(v1 var1 ... vn varn NEXT_ENV), wo vari Variablen-Konstrukte oder
  2683. ; Symbolmacros oder Interpreter-Werte sind und NEXT-ENV von derselben Gestalt.
  2684.  
  2685. ; *venvc* simuliert das Laufzeit-Variablen-Environment zur Laufzeit, soweit
  2686. ; es sich um Closure-Variablen handelt.
  2687. ; *venvc* hat die Gestalt
  2688. ; (item1 ... itemn)
  2689. ; jedes item ist
  2690. ;   NIL :            ein LET/LET*/MULTIPLE-VALUE-BIND/Funktionseintritt/
  2691. ;                    FLET/LABELS, der keine Closure aufmacht
  2692. ;   fnode :          eine neue Funktion
  2693. ;   ((var1 ... vark) . stackz) : durch ein LET/LET*/MULTIPLE-VALUE-BIND/
  2694. ;                    Funktionseintritt/FLET/LABELS kommen die Variablen
  2695. ;                    Var1, ..., Vark in eine Closure.
  2696. ;                    Diese Closure liegt im Stack; angegeben der
  2697. ;                    Stackzustand, an der sie erreichbar ist.
  2698.  
  2699. ; Eine Variable wird beschrieben dadurch, da▀ sie entweder special ist oder
  2700. ; - falls lexikalisch - der Stackaufbau nach dem Anlegen der Variablen im Stack
  2701. ; bzw. der Ort in der Closure festliegt.
  2702. (defstruct (var (:copier nil))
  2703.   (name nil :read-only t)     ; Symbol
  2704.   (specialp nil :read-only t) ; special deklariert (oder lexikalisch gebunden) ?
  2705.   constantp                   ; Konstante ?
  2706.   constant                    ; wenn Konstante: Wert und Herkunft der Konstanten
  2707.   usedp                       ; falls lexikalisch:
  2708.                               ;   wurde die Variable jemals abgefragt ?
  2709.                               ;   (Eine durch NIL oder T beendete Liste der
  2710.                               ;    Referenzen auf die Variable)
  2711.   really-usedp                ; falls lexikalisch:
  2712.                               ;   wurde die Variable jemals wirklich
  2713.                               ;   (um den Wert zu wissen) abgefragt ?
  2714.   (modified-list '())         ; falls lexikalisch: zu jedem SET auf die Variable
  2715.                               ;   eine Liste (value-anode set-anode . for-value)
  2716.   (replaceable-list '())      ; falls lexikalisch:
  2717.                               ;   zu jeder movable-Variablen, die wΣhrend ihrer
  2718.                               ;   gesamten Existenz denselben Wert wie diese
  2719.                               ;   hat und deswegen ersetzbar ist, jeweils eine
  2720.                               ;   Liste (var init-anode . bind-anode)
  2721.   closurep                    ; falls lexikalisch:
  2722.                               ;   NIL falls im Stack, T falls in der Closure
  2723.   (stackz nil :read-only t)   ; falls lexikalisch:
  2724.                               ;   Stackzustand nach dem Anlegen der Variablen
  2725.                               ;   (falls Variable im Stack: ihr Ort im Stack)
  2726.   (venvc nil :read-only t)    ; falls lexikalisch und in der Closure:
  2727.                               ;   das *venvc*, in dessen erstem Item diese
  2728.                               ;   Variable vorkommt.
  2729. )
  2730. #+CLISP (remprop 'var 'sys::defstruct-description)
  2731.  
  2732. ; (venv-search v) sucht in *venv* nach einer Variablen mit dem Symbol v.
  2733. ; Ergebnis ist:
  2734. ; NIL                   falls nicht gefunden
  2735. ; SPECIAL               falls als Special-deklarierte Variable gefunden
  2736. ; LOCAL, vector, index  falls interpretativ lexikalisch gebunden, Wert im Vektor
  2737. ; T, var                falls lexikalisch gebunden, im Stack oder in der Closure
  2738. (defun venv-search (v &optional (venv *venv*))
  2739.   (when (or (constantp v) (proclaimed-special-p v))
  2740.     (return-from venv-search 'SPECIAL)
  2741.   )
  2742.   (loop
  2743.     (cond ((null venv) (return-from venv-search 'NIL))
  2744.           ((simple-vector-p venv)
  2745.            (do ((l (1- (length venv)))
  2746.                 (i 0 (+ i 2)))
  2747.                ((= i l) (setq venv (svref venv i)))
  2748.              (if (eq v (svref venv i))
  2749.                (let ((val (svref venv (1+ i))))
  2750.                  (return-from venv-search
  2751.                    (if (and (var-p val) #| (eq (var-name val) v) |# )
  2752.                      (if (var-specialp val) 'SPECIAL (values T val))
  2753.                      (if (eq val specdecl) 'SPECIAL (values 'LOCAL venv (1+ i)))
  2754.           )) ) ) ) )
  2755.           (t (compiler-error 'venv-search))
  2756.   ) )
  2757. )
  2758.  
  2759. ; (venv-search-macro v) sucht in *venv* nach einer Variablen mit dem Symbol v.
  2760. ; Ergebnis ist ein Symbol-Macro-Objekt genau dann, wenn v ein Symbol-Macro
  2761. ; darstellt.
  2762. (defun venv-search-macro (v &optional (venv *venv*))
  2763.   (multiple-value-bind (a b c) (venv-search v venv)
  2764.     (case a
  2765.       ((NIL) (and (boundp v) (symbol-value v)))
  2766.       ((LOCAL) (svref b c))
  2767.       (t nil)
  2768. ) ) )
  2769.  
  2770. ; (push-*venv* var1 ... varn) erweitert *venv* um var1, ..., varn,
  2771. ; sozusagen wie durch  (dolist (v (list var1 ... varn)) (push v *venv*)).
  2772. (defun push-*venv* (&rest varlist)
  2773.   (when varlist
  2774.     (let ((l (list *venv*)))
  2775.       (dolist (var varlist) (setq l (list* (var-name var) var l)))
  2776.       (setq *venv* (apply #'vector l))
  2777. ) ) )
  2778.  
  2779. ; (zugriff-in-closure var venvc stackz)
  2780. ; liefert zu einer Closure-Variablen var, wie man auf sie zugreifen kann
  2781. ; (von einem Ort aus, an der Stack und das Closure-Environment durch stackz und
  2782. ;  venvc beschrieben werden):
  2783. ; 3 Werte k, n, m; die Variable sitzt in (svref ... 1+m) von
  2784. ;     nil, n, m  : (STACK+4*n)
  2785. ;     k, nil, m  : (svref ... 0)^k VenvConst
  2786. ;     k, n,   m  : ((SP+4*k)+4*n)
  2787. (defun zugriff-in-closure (var venvc stackz &aux (k nil) n)
  2788.   ; Grobschleife, stellt die Closure-Tiefe k ab VenvConst fest:
  2789.   (loop
  2790.     (when (eq venvc (var-venvc var)) (return))
  2791.     (let ((item (car venvc)))
  2792.       (if (null k)
  2793.         (when (not (listp item)) (setq k 0)) ; ZΣhlanfang, (not (listp item)) == (fnode-p item)
  2794.         (when (consp item) (incf k)) ; zΣhlen
  2795.     ) )
  2796.     (setq venvc (cdr venvc))
  2797.   )
  2798.   (if k
  2799.     (setq n nil)
  2800.     (multiple-value-setq (k n) (zugriff-in-stack stackz (cdr (first venvc))))
  2801.   )
  2802.   (let ((m (do ((L (car (first venvc)) (cdr L))
  2803.                 (i 0 (1+ i)))
  2804.                ((eq (car L) var) i)
  2805.        ))  )
  2806.     (values k n m)
  2807. ) )
  2808.  
  2809.  
  2810. ;             K O N S T A N T E N - V E R W A L T U N G
  2811.  
  2812. ; Eine Konstante ist eine Box mit dem Wert der Konstanten:
  2813. (defstruct (const (:copier nil))
  2814.   value               ; Wert der Konstanten
  2815.   (form nil)          ; falls /= NIL: Symbol, das konstant ist,
  2816.     ; bzw. allgemeiner: Form, die bei Auswertung value ergibt.
  2817. )
  2818. #+CLISP (remprop 'const 'sys::defstruct-description)
  2819. ; Im 2. Pass werden auch Variablen mit constantp=T als Konstanten behandelt.
  2820.  
  2821.  
  2822. ;           D E K L A R A T I O N E N - V E R W A L T U N G
  2823.  
  2824. (defparameter *declaration-types*
  2825.   '(special ; Bindungen
  2826.     type ftype function ; Typen
  2827.     inline notinline ; Funktionen-Compilation
  2828.     ignore optimize ; Compiler-Hinweise
  2829.     declaration ; Zusatzdeklarationen
  2830.     ; Typen nach Tabelle 4-1 :
  2831.     array atom bignum bit bit-vector character common compiled-function
  2832.     complex cons double-float fixnum float function hash-table integer keyword
  2833.     list long-float nil null number package pathname random-state ratio rational
  2834.     readtable sequence short-float simple-array simple-bit-vector simple-string
  2835.     simple-vector single-float standard-char stream string string-char symbol t
  2836.     vector
  2837.     ; zusΣtzliche Deklarationen:
  2838.     compile ; Anweisung, da▀ die Form bzw. Funktion zu compilieren ist
  2839.     sys::source ; der Source-Lambdabody (unexpandiert) innerhalb eines Lambdabody
  2840.     sys::in-defun ; zeigt an, zu welcher globalen Funktion der Code geh÷rt
  2841.     sys::ignorable ; markiert Variablen als vielleicht ignorierbar
  2842.                    ; (NB: Gensym-Variablen sind immer automatisch ignorable.)
  2843. )  )
  2844.  
  2845. ; mitgegeben vom Interpreter: %denv%
  2846.  
  2847. ; neu konstruiert:
  2848. (defvar *denv*)
  2849. ; *denv* hat dieselbe Gestalt wie %denv% und endet mit %denv%.
  2850. ; *denv* hat die Gestalt (item1 ... itemn), wo jedes item die Bauart
  2851. ; (declaration-type argument ...) hat.
  2852. ; Sonderbehandlung von
  2853. ;   SPECIAL : wird weggelassen, stattdessen in *venv* notiert.
  2854. ;   IGNORE, SYSTEM::IGNORABLE : wird weggelassen, stattdessen bei der
  2855. ;                               verarbeitenden Form selber verarbeitet.
  2856. ; ZusΣtzliche Deklaration (INLINING symbol) gegen rekursives Inlining.
  2857.  
  2858. ; (process-declarations declspeclist) pusht die Deklarationen (wie sie von
  2859. ; PARSE-BODY kommen) auf *denv* und liefert:
  2860. ; eine Liste der Special-deklarierten Symbole,
  2861. ; eine Liste der Ignore-deklarierten Symbole,
  2862. ; eine Liste der Ignorable-deklarierten Symbole.
  2863. (defun process-declarations (declspeclist &aux (specials nil) (ignores nil) (ignorables nil))
  2864.   (setq declspeclist (nreverse declspeclist))
  2865.   (dolist (declspec declspeclist)
  2866.     (if (or (atom declspec) (cdr (last declspec)))
  2867.       (c-warn (DEUTSCH "Falsche Deklarationen-Syntax: ~S~%Wird ignoriert."
  2868.                ENGLISH "Bad declaration syntax: ~S~%Will be ignored."
  2869.                FRANCAIS "Mauvaise syntaxe pour une dΘclaration : ~S~%IgnorΘe.")
  2870.               declspec
  2871.       )
  2872.       (let ((declspectype (car declspec)))
  2873.         (if (and (symbolp declspectype)
  2874.                  (or (member declspectype *declaration-types* :test #'eq)
  2875.                      (do ((L *denv* (cdr L)))
  2876.                          ((null L) nil)
  2877.                        (if (and (eq (first (car L)) 'DECLARATION)
  2878.                                 (member declspectype (rest (car L)) :test #'eq)
  2879.                            )
  2880.                          (return t)
  2881.                      ) )
  2882.                      (and *compiling-from-file*
  2883.                        (member declspectype *user-declaration-types* :test #'eq)
  2884.             )    )   )
  2885.           (cond ((eq declspectype 'SPECIAL)
  2886.                  (dolist (x (cdr declspec))
  2887.                    (if (symbolp x)
  2888.                      (push x specials)
  2889.                      (c-warn (DEUTSCH "Nur Symbole k÷nnen SPECIAL-deklariert werden, nicht ~S."
  2890.                               ENGLISH "Non-symbol ~S may not be declared SPECIAL."
  2891.                               FRANCAIS "Seuls les symboles peuvent Ωtre dΘclarΘs SPECIAL, pas ~S.")
  2892.                              x
  2893.                 )) ) )
  2894.                 ((eq declspectype 'IGNORE)
  2895.                  (dolist (x (cdr declspec))
  2896.                    (if (symbolp x)
  2897.                      (push x ignores)
  2898.                      (c-warn (DEUTSCH "Nur Symbole k÷nnen IGNORE-deklariert werden, nicht ~S."
  2899.                               ENGLISH "Non-symbol ~S may not be declared IGNORE."
  2900.                               FRANCAIS "Seuls les symboles peuvent Ωtre dΘclarΘs IGNORE, pas ~S.")
  2901.                              x
  2902.                 )) ) )
  2903.                 ((eq declspectype 'SYS::IGNORABLE)
  2904.                  (dolist (x (cdr declspec))
  2905.                    (if (symbolp x)
  2906.                      (push x ignorables)
  2907.                      (c-warn (DEUTSCH "Nur Symbole k÷nnen IGNORABLE-deklariert werden, nicht ~S."
  2908.                               ENGLISH "Non-symbol ~S may not be declared IGNORABLE."
  2909.                               FRANCAIS "Seuls les symboles peuvent Ωtre dΘclarΘs IGNORABLE.")
  2910.                              x
  2911.                 )) ) )
  2912.                 (t (push declspec *denv*))
  2913.           )
  2914.           (c-warn (DEUTSCH "Unbekannte Deklaration ~S.~%Die ganze Deklaration ~S wird ignoriert."
  2915.                    ENGLISH "Unknown declaration ~S.~%The whole declaration will be ignored."
  2916.                    FRANCAIS "DΘclaration inconnue ~S.~%Toute la dΘclaration ~S est ignorΘe.")
  2917.                   declspectype declspec
  2918.   ) ) ) ) )
  2919.   (values specials ignores ignorables)
  2920. )
  2921.  
  2922. ; (declared-notinline fun denv) stellt fest, ob fun - ein Symbol, das eine
  2923. ; globale Funktion, die nicht durch eine lokale Funktionsdefinition verdeckt
  2924. ; ist, benennt - in denv als NOTINLINE deklariert ist.
  2925. ; Was ist mit lokalen Funktionen ??
  2926. (defun declared-notinline (fun &optional (denv *denv*))
  2927.   (when (member `(INLINING ,fun) *denv* :test #'equal)
  2928.     (return-from declared-notinline t) ; keine Funktion rekursiv inline expandieren!
  2929.   )
  2930.   (loop
  2931.     (when (atom denv)
  2932.       (when *compiling-from-file*
  2933.         (when (member fun *notinline-functions* :test #'equal) (return t))
  2934.         (when (member fun *inline-functions* :test #'equal) (return nil))
  2935.       )
  2936.       (return (eq (get (get-funname-symbol fun) 'inlinable) 'notinline))
  2937.     )
  2938.     (let ((declspec (car denv)))
  2939.       (when (and (eq (car declspec) 'INLINE) (member fun (cdr declspec) :test #'equal))
  2940.         (return nil)
  2941.       )
  2942.       (when (and (eq (car declspec) 'NOTINLINE) (member fun (cdr declspec) :test #'equal))
  2943.         (return t)
  2944.     ) )
  2945.     (setq denv (cdr denv))
  2946. ) )
  2947.  
  2948.  
  2949. ;             F U N K T I O N E N - V E R W A L T U N G
  2950.  
  2951. ; Ein FNODE enthΣlt die n÷tige Information fⁿr eine Funktion:
  2952. (defstruct (fnode (:copier nil))
  2953.   name            ; Name, ein Symbol oder (SETF symbol)
  2954.   code            ; Code dieser Funktion (zuerst nichts, dann ein ANODE,
  2955.                   ; dann eine Closure)
  2956.   ; Ab hier Beschreibungen fⁿr die kommende Closure:
  2957.   venvconst       ; Flag, ob das Venv dieser Funktion explizit beim Aufbau
  2958.                   ; mitgegeben werden mu▀ (oder immer NIL ist)
  2959.   venvc           ; Aussehen des Venv, das dieser Funktion beim Aufbau
  2960.                   ; mitgegeben werden mu▀ (wenn ⁿberhaupt)
  2961.   Blocks-Offset   ; Anzahl der Konstanten bis hierher
  2962.   (Blocks nil)    ; Liste der Block-Konstrukte, die dieser Funktion beim Aufbau
  2963.                   ; mitgegeben werden mⁿssen
  2964.   Tagbodys-Offset ; Anzahl der Konstanten bis hierher
  2965.   (Tagbodys nil)  ; Liste der Tagbody-Konstrukte, die dieser Funktion beim
  2966.                   ; Aufbau mitgegeben werden mⁿssen
  2967.   Keyword-Offset  ; Anzahl der lokalen Konstanten bis hierher
  2968.                   ; = Anfangsoffset der Keywords in FUNC
  2969.                   ; (also =0 genau dann, wenn die Funktion autonom ist)
  2970.   (req-anz 0)     ; Anzahl der required parameter
  2971.   (opt-anz 0)     ; Anzahl der optionalen Parameter
  2972.   (rest-flag nil) ; Flag, ob &REST - Parameter angegeben.
  2973.   (keyword-flag nil) ; Flag, ob &KEY - Parameter angegeben.
  2974.   (keywords nil)  ; Liste der Keyword-Konstanten (in der richtigen Reihenfolge)
  2975.   allow-other-keys-flag ; &ALLOW-OTHER-KEYS-Flag
  2976.   Consts-Offset   ; Anzahl der lokalen Konstanten bis hierher
  2977.   (consts nil)    ; Liste der sonstigen Konstanten dieser Funktion
  2978.                   ; Diese Liste wird erst im 2. Pass aufgebaut.
  2979.   (consts-forms nil) ; Liste der evtl. Formen, die diese Konstanten ergeben
  2980.   enclosing       ; lexikalisch nΣchste darⁿberliegende Funktion (oder NIL)
  2981.   gf-p            ; Flag, ob eine generische Funktion produziert wird
  2982.                   ; (impliziert Blocks-Offset = Tagbodys-Offset = Keyword-Offset = 0 oder 1)
  2983. )
  2984. #+CLISP (remprop 'fnode 'sys::defstruct-description)
  2985.  
  2986. ; die aktuelle Funktion, ein FNODE:
  2987. (defvar *func*)
  2988. ; das Label am Beginn des Codes der aktuellen Funktion:
  2989. (defvar *func-start-label*)
  2990.  
  2991. ; Anzahl der bisher in der aktuellen Funktion aufgetretenen anonymen
  2992. ; Funktionen (Lambda-Ausdrⁿcke):
  2993. (defvar *anonymous-count*)
  2994.  
  2995. ; *no-code* = T besagt, da▀ kein Code produziert werden soll:
  2996. (defvar *no-code*)
  2997. ; Dies verhindert, da▀ Variablen unn÷tigerweise in die Closure gesteckt oder
  2998. ; Optimierungen unn÷tigerweise unterlassen werden.
  2999.  
  3000.  
  3001. ;                 F O R M E N - V E R W A L T U N G
  3002.  
  3003. ; Bei jeder Rekursion werden folgende Variablen dynamisch gebunden:
  3004. (defvar *form*)      ; die aktuelle Form
  3005. (defvar *for-value*) ; ob und welche Werte der Form von Belang sind:
  3006.                      ; NIL : Werte sind irrelevant
  3007.                      ; ONE : nur der erste Wert ist relevant
  3008.                      ; ALL : alle Werte sind relevant
  3009.  
  3010. ; Ein ANODE ist die Codierung der Information, die beim Compilieren einer Form
  3011. ; gebraucht wird.
  3012. (defstruct (anode
  3013.             (:constructor mk-anode (#+COMPILER-DEBUG source
  3014.                                     type
  3015.                                     #+COMPILER-DEBUG sub-anodes
  3016.                                     seclass
  3017.                                     code
  3018.                                     #+COMPILER-DEBUG stackz
  3019.             )                      )
  3020.             (:copier nil)
  3021.            )
  3022.   #+COMPILER-DEBUG
  3023.   source              ; die zu dieser Form geh÷rige Source, meist eine Form
  3024.                       ; (nur zu Debugzwecken erforderlich)
  3025.   type                ; Typ des ANODE (CALL, PRIMOP, VAR, LET, SETQ, ...)
  3026.   #+COMPILER-DEBUG
  3027.   sub-anodes          ; alle ANODEs der Unterformen
  3028.   seclass             ; Seiteneffekt-Klassifikation
  3029.   code                ; erzeuger LAP-Code, eine Liste aus LAP-Anweisungen
  3030.                       ; und ANODEs
  3031.   #+COMPILER-DEBUG
  3032.   stackz              ; Zustand der Stacks beim Eintritt in den zugeh÷rigen
  3033.                       ; LAP-Code
  3034. )
  3035. #+CLISP (remprop 'anode 'sys::defstruct-description)
  3036. ; (make-anode ...) ist dasselbe wie mk-anode, nur da▀ dabei die Argumente
  3037. ; mit Keywords markiert werden und wegen #+COMPILER-DEBUG unn÷tige
  3038. ; Komponenten trotzdem dastehen dⁿrfen.
  3039. (eval-when (compile eval)
  3040.   (defmacro make-anode (&key
  3041.                         (source `*form*)
  3042.                         type
  3043.                         (sub-anodes `'())
  3044.                         seclass
  3045.                         code
  3046.                         (stackz `*stackz*)
  3047.                        )
  3048.     `(mk-anode #+COMPILER-DEBUG ,source
  3049.                ,type
  3050.                #+COMPILER-DEBUG ,sub-anodes
  3051.                ,seclass
  3052.                ,code
  3053.                #+COMPILER-DEBUG ,stackz
  3054.      )
  3055. ) )
  3056.  
  3057. #|
  3058. ; Eine Seiteneffekt-Klasse (SECLASS) ist ein Indikator:
  3059. ; NIL : dieses ANODE produziert keine Seiteneffekte,
  3060. ;       sein Wert ist nicht von Seiteneffekten beeinflu▀bar.
  3061. ; VAL : dieses ANODE produziert keine Seiteneffekte,
  3062. ;       sein Wert ist aber von Seiteneffekten beeinflu▀bar.
  3063. ; T   : dieses ANODE kann Seiteneffekte produzieren.
  3064. ; Somit:
  3065. ;   Falls der Wert uninteressant ist, kann ein ANODE mit SECLASS = NIL/VAL
  3066. ;   weggelassen werden.
  3067. ;   In der Reihenfolge der Auswertung dⁿrfen vertauscht werden ANODEs mit
  3068. ;   SECLASS     NIL-NIL, NIL-VAL, NIL-T, VAL-VAL.
  3069.  
  3070. ; (seclass-or class1 ... classk) bestimmt die Gesamtklasse der Ausfⁿhrung
  3071. ; aller Klassen.
  3072. (defun seclass-or (&rest args)
  3073.   (cond ((member 'T args :test #'eq) 'T)
  3074.         ((member 'VAL args :test #'eq) 'VAL)
  3075.         (t 'NIL)
  3076. ) )
  3077. ; Dito, mit nur 2 Argumenten
  3078. (defun seclass-or-2 (seclass1 seclass2)
  3079.   (or (eq seclass1 'T) seclass2 seclass1)
  3080. )
  3081. ; Damit die Liste der sub-anodes nicht gebildet werden mu▀, aber dennoch
  3082. ; der zu dieser Liste geh÷rige Seiteneffektklasse berechnet werden kann:
  3083. (eval-when (compile eval)
  3084.   (defmacro anodes-seclass-or (&rest anodeforms)
  3085.     (reduce #'(lambda (form1 form2) `(SECLASS-OR-2 ,form1 ,form2))
  3086.             (mapcar #'(lambda (anodeform) `(ANODE-SECLASS ,anodeform))
  3087.                     anodeforms
  3088.   ) )       )
  3089.   (define-modify-macro seclass-or-f (anode) seclass-or-anode)
  3090.   (defmacro seclass-or-anode (seclass anode)
  3091.     `(SECLASS-OR-2 ,seclass (ANODE-SECLASS ,anode))
  3092.   )
  3093. )
  3094. (defun anodelist-seclass-or (anodelist)
  3095.   (apply #'seclass-or (mapcar #'anode-seclass anodelist))
  3096. )
  3097.  
  3098. ; Stellt fest, ob zwei Anodes in der Reihenfolge ihrer Auswertung vertauscht
  3099. ; werden k÷nnen - vorausgesetzt, die StackzustΣnde lassen das zu.
  3100. (defun anodes-commute (anode1 anode2)
  3101.   (let ((seclass1 (anode-seclass anode1))
  3102.         (seclass2 (anode-seclass anode2)))
  3103.     (or (eq seclass1 'NIL) (eq seclass2 'NIL)
  3104.         (and (eq seclass1 'VAL) (eq seclass2 'VAL))
  3105. ) ) )
  3106. |#
  3107.  
  3108. ; Eine Seiteneffekt-Klasse (SECLASS) ist ein Indikator (uses . modifies):
  3109. ; uses = NIL : dieses Anode ist nicht von Seiteneffekten beeinflu▀bar,
  3110. ;        Liste : dieses Anode ist vom Wert der Variablen in der Liste abhΣngig,
  3111. ;        T : dieses Anode ist m÷glicherweise von jedem Seiteneffekt beeinflu▀bar.
  3112. ; modifies = NIL : dieses Anode produziert keine Seiteneffekte
  3113. ;            Liste : ... produziert Seiteneffekte nur auf die Werte der
  3114. ;                    Variablen in der Liste
  3115. ;            T : ... produziert Seiteneffekte unbekannten Ausma▀es.
  3116. ; (Variablen sind hier VAR-Structures fⁿr lexikalische und Symbole fⁿr
  3117. ; dynamische Variablen.)
  3118. ; Somit:
  3119. ;   Falls der Wert uninteressant ist, kann ein ANODE mit SECLASS-modifies=NIL
  3120. ;   weggelassen werden.
  3121. ;   In der Reihenfolge der Auswertung dⁿrfen vertauscht werden ANODEs mit
  3122. ;   SECLASS, deren uses- und modifies-Teil ⁿber Kreuz disjunkt sind.
  3123.  
  3124. ; (seclass-or class1 ... classk) bestimmt die Gesamtklasse der Ausfⁿhrung
  3125. ; aller Klassen.
  3126. (defun seclass-or (&rest args)
  3127.   (if (null args) '(NIL . NIL) (reduce #'seclass-or-2 args))
  3128. )
  3129. ; Dito, mit nur 2 Argumenten
  3130. (defun seclass-or-2 (seclass1 seclass2)
  3131.   (cons (if (or (eq (car seclass1) 'T) (eq (car seclass2) 'T))
  3132.           'T
  3133.           (union (car seclass1) (car seclass2))
  3134.         )
  3135.         (if (or (eq (cdr seclass1) 'T) (eq (cdr seclass2) 'T))
  3136.           'T
  3137.           (union (cdr seclass1) (cdr seclass2))
  3138. ) )     )
  3139.  
  3140. ; Damit die Liste der sub-anodes nicht gebildet werden mu▀, aber dennoch
  3141. ; der zu dieser Liste geh÷rige Seiteneffektklasse berechnet werden kann:
  3142. (eval-when (compile eval)
  3143.   (defmacro anodes-seclass-or (&rest anodeforms)
  3144.     (reduce #'(lambda (form1 form2) `(SECLASS-OR-2 ,form1 ,form2))
  3145.             (mapcar #'(lambda (anodeform) `(ANODE-SECLASS ,anodeform))
  3146.                     anodeforms
  3147.   ) )       )
  3148.   (define-modify-macro seclass-or-f (anode) seclass-or-anode)
  3149.   (defmacro seclass-or-anode (seclass anode)
  3150.     `(SECLASS-OR-2 ,seclass (ANODE-SECLASS ,anode))
  3151.   )
  3152. )
  3153. (defun anodelist-seclass-or (anodelist)
  3154.   (apply #'seclass-or (mapcar #'anode-seclass anodelist))
  3155. )
  3156.  
  3157. ; Seiteneffekte auf weiter innen gebundene lexikalische Variablen zΣhlen
  3158. ; nicht und werden deshalb eliminiert:
  3159. (defun seclass-without (seclass varlist)
  3160.   (flet ((bound (var) (member var varlist))) ; testet, ob var gebunden wird
  3161.     ; (Dynamische Variablen werden nicht eliminiert; sie sind in varlist
  3162.     ; als VAR-Structures und in seclass als Symbole enthalten.)
  3163.     (cons (if (eq (car seclass) 'T) 'T (remove-if #'bound (car seclass)))
  3164.           (if (eq (cdr seclass) 'T) 'T (remove-if #'bound (cdr seclass)))
  3165. ) ) )
  3166.  
  3167. ; Stellt fest, ob zwei Anodes in der Reihenfolge ihrer Auswertung vertauscht
  3168. ; werden k÷nnen - vorausgesetzt, die StackzustΣnde lassen das zu.
  3169. (defun anodes-commute (anode1 anode2)
  3170.   (seclasses-commute (anode-seclass anode1) (anode-seclass anode2))
  3171. )
  3172. (defun seclasses-commute (seclass1 seclass2)
  3173.   (flet ((disjoint-p (uses modifies)
  3174.            (or (null uses) (null modifies)
  3175.                (and (not (eq uses 'T)) (not (eq modifies 'T))
  3176.                     (null (intersection uses modifies))
  3177.         )) )   )
  3178.     (and (disjoint-p (car seclass1) (cdr seclass2))
  3179.          (disjoint-p (car seclass2) (cdr seclass1))
  3180. ) ) )
  3181.  
  3182.  
  3183. ;            H I L F S F U N K T I O N E N
  3184.  
  3185. ; Zerlegt einen Funktionsnamen in Package und String.
  3186. (defun get-funname-string+pack (funname)
  3187.   (if (atom funname)
  3188.     (values (symbol-name funname) (symbol-package funname))
  3189.     (values (concatenate 'string "(" (symbol-name (first funname)) " "
  3190.                                      (symbol-name (second funname)) ")"
  3191.             )
  3192.             (symbol-package (second funname))
  3193. ) ) )
  3194.  
  3195. ; Liefert einen Funktionsnamen, der sich aus der Package und dem Printname eines
  3196. ; gegebenen Funktionsnamen, einem Bindestrich und einem Suffix zusammensetzt.
  3197. (defun symbol-suffix (funname suffix)
  3198.   (if (and (symbolp funname) (null (symbol-package funname))
  3199.            (function-name-p suffix)
  3200.       )
  3201.     suffix
  3202.     (multiple-value-bind (name pack) (get-funname-string+pack funname)
  3203.       ; suffix in einen String umwandeln:
  3204.       (cond ((symbolp suffix) (setq suffix (symbol-name suffix)))
  3205.             ((not (stringp suffix))
  3206.              (setq suffix (write-to-string suffix :escape nil :base 10 :radix nil :readably nil))
  3207.       )     )
  3208.       ; neues Symbol bilden:
  3209.       (let ((new-name (concatenate 'string name "-" suffix)))
  3210.         (if pack (intern new-name pack) (make-symbol new-name))
  3211. ) ) ) )
  3212.  
  3213. ; (C-COMMENT controlstring . args)
  3214. ; gibt eine Zusatzinformation des Compilers aus (mittels FORMAT).
  3215. (defun c-comment (cstring &rest args)
  3216.   (let ((dest (if *compile-verbose* *c-error-output* *c-listing-output*)))
  3217.     (when dest (apply #'format dest cstring args))
  3218. ) )
  3219.  
  3220. ; (C-SOURCE-LOCATION)
  3221. ; liefert eine Beschreibung, an welcher Source-Stelle man sich befindet.
  3222. (defun c-source-location ()
  3223.   (if (and *compiling-from-file* *compile-file-lineno1* *compile-file-lineno2*)
  3224.     (format nil
  3225.             (if (= *compile-file-lineno1* *compile-file-lineno2*)
  3226.               (DEUTSCH " in Zeile ~D"
  3227.                ENGLISH " in line ~D"
  3228.                FRANCAIS " dans la ligne ~D")
  3229.               (DEUTSCH " in Zeilen ~D..~D"
  3230.                ENGLISH " in lines ~D..~D"
  3231.                FRANCAIS " dans les lignes ~D..~D")
  3232.             )
  3233.             *compile-file-lineno1* *compile-file-lineno2*
  3234.     )
  3235.     ""
  3236. ) )
  3237.  
  3238. (defvar *warning-count*)
  3239. ; (C-WARN controlstring . args)
  3240. ; gibt eine Compiler-Warnung aus (mittels FORMAT).
  3241. (defun c-warn (cstring &rest args)
  3242.   (setq cstring
  3243.     (concatenate 'string (DEUTSCH "~%WARNUNG~@[ in Funktion ~S~]~A :~%"
  3244.                           ENGLISH "~%WARNING~@[ in function ~S~]~A :~%"
  3245.                           FRANCAIS "~%AVERTISSEMENT~@[ dans la fonction ~S~]~A :~%")
  3246.                          cstring
  3247.   ) )
  3248.   (incf *warning-count*)
  3249.   (let ((dest (if *compile-warnings* *c-error-output* *c-listing-output*)))
  3250.     (when dest
  3251.       (apply #'format dest cstring
  3252.              (and (boundp '*func*) (fnode-p *func*) (fnode-name *func*))
  3253.              (c-source-location)
  3254.              args
  3255. ) ) ) )
  3256.  
  3257. (defvar *error-count*)
  3258. ; (C-ERROR controlstring . args)
  3259. ; gibt einen Compiler-Error aus (mittels FORMAT) und beendet das laufende C-FORM.
  3260. (defun c-error (cstring &rest args)
  3261.   (setq cstring
  3262.     (concatenate 'string (DEUTSCH "~%ERROR~@[ in Funktion ~S~]~A :~%"
  3263.                           ENGLISH "~%ERROR~@[ in function ~S~]~A :~%"
  3264.                           FRANCAIS "~%ERREUR~@[ dans la fonction ~S~]~A :~%")
  3265.                          cstring
  3266.   ) )
  3267.   (incf *error-count*)
  3268.   (let ((in-function
  3269.           (and (boundp '*func*) (fnode-p *func*) (fnode-name *func*))
  3270.        ))
  3271.     (when in-function
  3272.       (when *compiling-from-file* (pushnew in-function *functions-with-errors*))
  3273.     )
  3274.     (apply #'format *c-error-output* cstring in-function (c-source-location) args)
  3275.   )
  3276.   (throw 'c-error
  3277.     (make-anode :source NIL
  3278.                 :type 'ERROR
  3279.                 :sub-anodes '()
  3280.                 :seclass '(NIL . NIL)
  3281.                 :code '((NIL))
  3282. ) ) )
  3283.  
  3284. ; (c-eval-when-compile form) fⁿhrt eine Form zur Compile-Zeit aus.
  3285. (defun c-eval-when-compile (form)
  3286.   (when (and *compiling-from-file* *liboutput-stream*)
  3287.     ; Form auf den Liboutput-Stream schreiben:
  3288.     (terpri *liboutput-stream*)
  3289.     (write form :stream *liboutput-stream* :pretty t
  3290.                 :readably t
  3291.                 ; :closure t :circle t :array t :gensym t
  3292.                 ; :escape t :level nil :length nil :radix t
  3293.   ) )
  3294.   ; Form evaluieren:
  3295.   (eval form)
  3296. )
  3297.  
  3298. ; (c-constantp form) stellt fest, ob form im Compiler als Konstante gehandhabt
  3299. ; wird.
  3300. (defun c-constantp (form)
  3301.   (if (atom form)
  3302.     (or (numberp form) (characterp form) (stringp form) (bit-vector-p form)
  3303.         (and (symbolp form)
  3304.              (cond ((keywordp form) t)
  3305.                    ((eq (symbol-package form) *lisp-package*)
  3306.                     (constantp form)
  3307.                    )
  3308.                    (t (not (null (assoc form *constant-special-vars*))))
  3309.     )   )    )
  3310.     (and (eq (first form) 'QUOTE) (consp (cdr form)) (null (cddr form)))
  3311. ) )
  3312.  
  3313. ; (c-constant-value form) liefert den Wert einer Konstanten
  3314. (defun c-constant-value (form)
  3315.   (if (atom form)
  3316.     (cond ((numberp form) form)
  3317.           ((characterp form) form)
  3318.           ((stringp form) form)
  3319.           ((bit-vector-p form) form)
  3320.           ((symbolp form)
  3321.            (cond ((keywordp form) form)
  3322.                  ((eq (symbol-package form) *lisp-package*)
  3323.                   (symbol-value form)
  3324.                  )
  3325.                  (t (cdr (assoc form *constant-special-vars*)))
  3326.     )     ))
  3327.     (second form)
  3328. ) )
  3329.  
  3330. ; (anode-constantp anode) stellt fest, ob der Anode einen konstanten Wert
  3331. ; liefert.
  3332. (defun anode-constantp (anode)
  3333.   ; Anode liefert konstanten Wert jedenfalls dann, wenn sein Code
  3334.   ; (nach TRAVERSE-ANODE) genau aus ((CONST ...)) bestehen wⁿrde.
  3335.   (let ((code (anode-code anode)))
  3336.     (and (consp code) (null (cdr code)) ; Liste der LΣnge 1
  3337.          (let ((item (car code)))
  3338.             (cond ((consp item) (eq (first item) 'CONST))
  3339.                   ((anode-p item) (anode-constantp item))
  3340. ) ) )    )  )
  3341.  
  3342. ; (anode-constant-value anode) liefert den Wert eines konstanten Anode.
  3343. (defun anode-constant (anode)
  3344.   (let ((item (car (anode-code anode))))
  3345.     (cond ((consp item) (second item))
  3346.           (t #|(anode-p item)|# (anode-constant item))
  3347. ) ) )
  3348. (defun anode-constant-value (anode)
  3349.   (const-value (anode-constant anode))
  3350. )
  3351.  
  3352. ; (new-const value) liefert eine Konstante in *func* mit dem Wert value
  3353. ; im 1. Pass
  3354. (defun new-const (value)
  3355.   (make-const :value value)
  3356. )
  3357.  
  3358. ; (make-label for-value) liefert ein neues Label. for-value (NIL/ONE/ALL)
  3359. ; gibt an, welche der Werte nach dem Label gebraucht werden.
  3360. (defun make-label (for-value)
  3361.   (let ((label (gensym)))
  3362.     (setf (symbol-value label) '()) ; Referenzliste fⁿr 2. Pass := leer
  3363.     (setf (get label 'for-value) for-value)
  3364.     label
  3365. ) )
  3366.  
  3367. ; liefert eine Special-Variable
  3368. (defun make-special-var (symbol)
  3369.   (make-var :name symbol :specialp t
  3370.             :constantp (c-constantp symbol)
  3371.             :constant (if (c-constantp symbol)
  3372.                         (make-const :value (c-constant-value symbol)
  3373.                                     :form symbol
  3374. ) )                   ) )
  3375.  
  3376.  
  3377. ;                     E R S T E R   P A S S
  3378.  
  3379. ; (test-list L) stellt fest, ob L eine echte Liste ist, die mit NIL endet
  3380. ; und mindestens l1, h÷chstens aber l2 Elemente hat. Sonst Error.
  3381. (defun test-list (L &optional (l1 0) (l2 nil))
  3382.   (unless (and (listp L) (null (cdr (last L))))
  3383.     (c-error (DEUTSCH "Dotted list im Code: ~S"
  3384.               ENGLISH "Code contains dotted list ~S"
  3385.               FRANCAIS "Paire pointΘe dans le code en ~S")
  3386.              L
  3387.   ) )
  3388.   (unless (>= (length L) l1)
  3389.     (c-error (DEUTSCH "Form zu kurz (zu wenig Argumente): ~S"
  3390.               ENGLISH "Form too short, too few arguments: ~S"
  3391.               FRANCAIS "Forme trop courte (trop peu d'arguments) : ~S")
  3392.              L
  3393.   ) )
  3394.   (when l2
  3395.     (unless (<= (length L) l2)
  3396.       (c-error (DEUTSCH "Form zu lang (zu viele Argumente): ~S"
  3397.                 ENGLISH "Form too long, too many arguments: ~S"
  3398.                 FRANCAIS "Forme trop longue (trop d'arguments) : ~S")
  3399.                L
  3400.   ) ) )
  3401. )
  3402.  
  3403. ; c-form-table enthΣlt zu allen Funktionen/Specialforms/Macros, die speziell
  3404. ; behandelt werden mⁿssen, die Behandlungsfunktion (ohne Argumente aufzurufen).
  3405. (defconstant c-form-table
  3406.   (let ((hashtable (make-hash-table :test #'eq)))
  3407.     (mapc
  3408.       #'(lambda (acons) (setf (gethash (car acons) hashtable) (cdr acons)))
  3409.       `(; Special forms:
  3410.           (QUOTE . c-QUOTE)
  3411.           (PROGN . c-PROGN)
  3412.           (LET . ,#'(lambda () (c-LET/LET* nil)))
  3413.           (LET* . ,#'(lambda () (c-LET/LET* t)))
  3414.           (IF . c-IF)
  3415.           (SETQ . c-SETQ)
  3416.           (BLOCK . c-BLOCK)
  3417.           (RETURN-FROM . c-RETURN-FROM)
  3418.           (TAGBODY . c-TAGBODY)
  3419.           (GO . c-GO)
  3420.           (FUNCTION . c-FUNCTION)
  3421.           (MULTIPLE-VALUE-BIND . c-MULTIPLE-VALUE-BIND)
  3422.           (MULTIPLE-VALUE-SETQ . c-MULTIPLE-VALUE-SETQ)
  3423.           (AND . c-AND)
  3424.           (OR . c-OR)
  3425.           (WHEN . c-WHEN)
  3426.           (UNLESS . c-UNLESS)
  3427.           (COND . c-COND)
  3428.           (PSETQ . c-PSETQ)
  3429.           (MULTIPLE-VALUE-CALL . c-MULTIPLE-VALUE-CALL)
  3430.           (PROG1 . c-PROG1)
  3431.           (PROG2 . c-PROG2)
  3432.           (THE . c-THE)
  3433.           (CATCH . c-CATCH)
  3434.           (THROW . c-THROW)
  3435.           (UNWIND-PROTECT . c-UNWIND-PROTECT)
  3436.           (PROGV . c-PROGV)
  3437.           (MULTIPLE-VALUE-LIST . c-MULTIPLE-VALUE-LIST)
  3438.           (MULTIPLE-VALUE-PROG1 . c-MULTIPLE-VALUE-PROG1)
  3439.           (FLET . c-FLET)
  3440.           (LABELS . c-LABELS)
  3441.           (MACROLET . c-MACROLET)
  3442.           (SYMBOL-MACROLET . c-SYMBOL-MACROLET)
  3443.           (COMPILER-LET . c-COMPILER-LET)
  3444.           (EVAL-WHEN . c-EVAL-WHEN)
  3445.           (DECLARE . c-DECLARE)
  3446.           (LOAD-TIME-VALUE . c-LOAD-TIME-VALUE)
  3447.           (LOCALLY . c-LOCALLY)
  3448.         ; Macros:
  3449.           (CASE . c-CASE)
  3450.           (%GENERIC-FUNCTION-LAMBDA . c-%GENERIC-FUNCTION-LAMBDA)
  3451.           (%OPTIMIZE-FUNCTION-LAMBDA . c-%OPTIMIZE-FUNCTION-LAMBDA)
  3452.           (CLOS:GENERIC-FLET . c-GENERIC-FLET)
  3453.           (CLOS:GENERIC-LABELS . c-GENERIC-LABELS)
  3454.           (HANDLER-BIND . c-HANDLER-BIND)
  3455.           (SYS::%HANDLER-BIND . c-HANDLER-BIND)
  3456.           (SYS::CONSTANT-EQL . c-CONSTANT-EQL)
  3457.         ; Inline-compilierte Funktionen:
  3458.           (FUNCALL . c-FUNCALL)
  3459.           (SYS::%FUNCALL . c-FUNCALL)
  3460.           (APPLY . c-APPLY)
  3461.           (+ . c-PLUS)
  3462.           (- . c-MINUS)
  3463.           (SYS::SVSTORE . c-SVSTORE)
  3464.           (EQ . c-EQ)
  3465.           (EQL . c-EQL)
  3466.           (EQUAL . c-EQUAL)
  3467.           (MAPCAR . c-MAPCAR)
  3468.           (MAPLIST . c-MAPLIST)
  3469.           (MAPC . c-MAPC)
  3470.           (MAPL . c-MAPL)
  3471.           (MAPCAN . c-MAPCAN)
  3472.           (MAPCON . c-MAPCON)
  3473.           (MAPCAP . c-MAPCAP)
  3474.           (MAPLAP . c-MAPLAP)
  3475.           (TYPEP . c-TYPEP)
  3476.     )  )
  3477.     hashtable
  3478. ) )
  3479. ; Diese Tabelle mu▀ alle Special-Forms enthalten:
  3480. (do-all-symbols (sym)
  3481.   (when (and (special-form-p sym) (not (gethash sym c-form-table)))
  3482.     (compiler-error 'c-form-table)
  3483. ) )
  3484.  
  3485. ; compiliert eine Form.
  3486. ; Dabei ergibt sich kein Code, falls keine Werte gebraucht werden und die Form
  3487. ; keine Seiteneffekte produziert.
  3488. (defun c-form (*form* &optional (*for-value* *for-value*))
  3489.  (let
  3490.   ((anode
  3491.     (catch 'c-error
  3492.       (if (atom *form*)
  3493.         (cond ((symbolp *form*)
  3494.                (let ((h (venv-search-macro *form* *venv*)))
  3495.                  (if (symbol-macro-p h) ; Symbol-Macro ?
  3496.                    (c-form (sys::%record-ref h 0)) ; -> expandieren
  3497.                    (c-VAR *form*)
  3498.               )) )
  3499.               ((or (numberp *form*) (characterp *form*) (stringp *form*)
  3500.                    (bit-vector-p *form*)
  3501.                )
  3502.                (c-CONST)
  3503.               )
  3504.               (t (c-error (DEUTSCH "Das ist keine gⁿltige Form: ~S"
  3505.                            ENGLISH "Invalid form: ~S"
  3506.                            FRANCAIS "Forme invalide : ~S")
  3507.                           *form*
  3508.         )     )  )
  3509.         (let ((fun (first *form*)))
  3510.           (if (function-name-p fun)
  3511.             (multiple-value-bind (a b c) (fenv-search fun)
  3512.               (declare (ignore b))
  3513.               (if (null a)
  3514.                 ; nicht lokal definiert
  3515.                 (let ((handler (gethash fun c-form-table)))
  3516.                   (if handler ; Behandlungsfunktion gefunden?
  3517.                     (funcall handler) ; ja -> aufrufen
  3518.                     ; nein -> jedenfalls keine Special-Form (die sind ja
  3519.                     ; alle in der Tabelle).
  3520.                     (if (and (symbolp fun) (macro-function fun)) ; globaler Macro ?
  3521.                       (c-form (macroexpand-1 *form* (vector *venv* *fenv*))) ; -> expandieren
  3522.                       ; globale Funktion
  3523.                       (if (and (equal fun (fnode-name *func*))
  3524.                                (not (declared-notinline fun))
  3525.                                (member `(SYS::IN-DEFUN ,fun) *denv* :test #'equal)
  3526.                           )
  3527.                         ; rekursiver Aufruf der aktuellen globalen Funktion
  3528.                         (c-LOCAL-FUNCTION-CALL fun (cons *func* nil) (cdr *form*))
  3529.                         ; normaler Aufruf globaler Funktion
  3530.                         (c-GLOBAL-FUNCTION-CALL fun)
  3531.                 ) ) ) )
  3532.                 (case a
  3533.                   (SYSTEM::MACRO ; lokaler Macro
  3534.                     (c-form (macroexpand-1 *form* (vector *venv* *fenv*))) ; -> expandieren
  3535.                   )
  3536.                   (GLOBAL ; Funktion im Interpreter-Environment %fenv% gefunden
  3537.                     ; (c-form `(SYS::%FUNCALL (FUNCTION ,fun) ,@(cdr *form*)))
  3538.                     (c-FUNCALL-NOTINLINE `(FUNCTION ,fun) (cdr *form*))
  3539.                   )
  3540.                   (LOCAL ; lokale Funktion (in *fenv* gefunden)
  3541.                     ; (c-form `(SYS::%FUNCALL (FUNCTION ,fun) ,@(cdr *form*)))
  3542.                     (c-LOCAL-FUNCTION-CALL fun c (cdr *form*))
  3543.                   )
  3544.                   (t (compiler-error 'c-form))
  3545.             ) ) )
  3546.             (if (and (consp fun) (eq (car fun) 'LAMBDA))
  3547.               (c-form `(SYS::%FUNCALL (FUNCTION ,fun) ,@(cdr *form*)))
  3548.               #| nicht: (c-LAMBDA-FUNCTION-CALL fun (cdr *form*)) |#
  3549.               (c-error (DEUTSCH "Das ist nicht der Name einer Funktion: ~S"
  3550.                         ENGLISH "Not the name of a function: ~S"
  3551.                         FRANCAIS "Ceci n'est pas le nom d'une fonction : ~S")
  3552.                        fun
  3553.     ) ) ) ) ) )
  3554.   ))
  3555.   #+COMPILER-DEBUG (setf (anode-source anode) *form*)
  3556.   ; Falls keine Werte gebraucht werden und keine Seiteneffekte produziert
  3557.   ; werden, kann der dazugeh÷rige Code ganz gestrichen werden:
  3558.   (when (and (null *for-value*) (null (cdr (anode-seclass anode))))
  3559.     (setf (anode-code anode) '())
  3560.     (setf (anode-seclass anode) '(NIL . NIL))
  3561.   )
  3562.   anode
  3563. ))
  3564.  
  3565. ; compiliere NIL (eine Art Notausgang)
  3566. (defun c-NIL ()
  3567.   (make-anode :type 'NIL
  3568.               :sub-anodes '()
  3569.               :seclass '(NIL . NIL)
  3570.               :code '((NIL)) )
  3571. )
  3572.  
  3573. ; Konstante als Form:
  3574. (defun c-CONST ()
  3575.   (make-anode :type 'const
  3576.               :sub-anodes '()
  3577.               :seclass '(NIL . NIL)
  3578.               :code `((CONST ,(new-const *form*)))
  3579. ) )
  3580.  
  3581. ; Variable als Form:
  3582. (defun c-VAR (symbol)
  3583.   ; Suche die Variable in *venv* :
  3584.   (multiple-value-bind (a b c) (venv-search symbol)
  3585.     (when (eq a 'NIL)
  3586.       (c-warn (DEUTSCH "~S ist weder deklariert noch gebunden,~@
  3587.                         behandle es als SPECIAL-deklarierte Variable."
  3588.                ENGLISH "~S is neither declared nor bound,~@
  3589.                         it will be treated as if it were declared SPECIAL."
  3590.                FRANCAIS "~S n'est ni dΘclarΘ ni liΘ,~@
  3591.                          et va Ωtre traitΘ comme Θtant dΘclarΘ SPECIAL.")
  3592.               symbol
  3593.       )
  3594.       (when *compiling-from-file*
  3595.         (pushnew symbol *unknown-free-vars* :test #'eq)
  3596.       )
  3597.       (setq a 'SPECIAL)
  3598.     )
  3599.     (case a
  3600.       (SPECIAL ; Special-Variable
  3601.         (let ((var (make-special-var symbol)))
  3602.           (make-anode
  3603.             :type 'VAR
  3604.             :sub-anodes '()
  3605.             :seclass (cons
  3606.                        (if (and *for-value* (not (var-constantp var))) (list symbol) 'NIL)
  3607.                        'NIL
  3608.                      )
  3609.             :code (if *for-value*
  3610.                     (if (var-constantp var)
  3611.                       `((CONST ,(make-const
  3612.                                   :value (c-constant-value symbol)
  3613.                                   :form (if (keywordp symbol) nil symbol)
  3614.                        ))       )
  3615.                       `((GETVALUE ,symbol))
  3616.                     )
  3617.                     '()
  3618.       ) ) )       )
  3619.       (LOCAL ; interpretativ lexikalisch
  3620.         (make-anode
  3621.           :type 'VAR
  3622.           :sub-anodes '()
  3623.           :seclass (cons (if *for-value* 'T 'NIL) 'NIL)
  3624.           :code (if *for-value*
  3625.                   `((CONST ,(new-const b)) ; Vektor
  3626.                     (PUSH)
  3627.                     (CONST ,(new-const c)) ; Index
  3628.                     (SVREF)
  3629.                    )
  3630.                   '()
  3631.       ) )       )
  3632.       ((T) ; lexikalisch in Stack oder Closure
  3633.         (let* ((var b)
  3634.                (get-anode
  3635.                  (make-anode
  3636.                    :type 'VAR
  3637.                    :sub-anodes '()
  3638.                    :seclass (cons (if *for-value* (list var) 'NIL) 'NIL)
  3639.                    :code (if *for-value*
  3640.                            `((GET ,var ,*venvc* ,*stackz*))
  3641.                            '()
  3642.               )) )       )
  3643.           (push get-anode (var-usedp var))
  3644.           (when (and *for-value* (not *no-code*))
  3645.             (setf (var-really-usedp var) t)
  3646.             (unless (eq (stackz-fun (var-stackz var)) *func*)
  3647.               (setf (var-closurep var) t)
  3648.             )
  3649.             (when (var-closurep var)
  3650.               ; aktiviere Venvconst in allen dazwischenliegenden Funktionen
  3651.               (do ((venvc *venvc* (cdr venvc)))
  3652.                   ((null venvc) (compiler-error 'c-VAR "INVISIBLE"))
  3653.                 (when (eq venvc (var-venvc var)) (return))
  3654.                 (when (fnode-p (car venvc))
  3655.                   (setf (fnode-Venvconst (car venvc)) t)
  3656.           ) ) ) )
  3657.           get-anode
  3658.       ) )
  3659.       (t (compiler-error 'c-VAR 'venv-search))
  3660. ) ) )
  3661.  
  3662. ; Variablenzuweisung:
  3663. (defun c-VARSET (symbol value-anode for-value)
  3664.   ; Suche die Variable in *venv* :
  3665.   (multiple-value-bind (a b c) (venv-search symbol)
  3666.     (when (eq a 'NIL)
  3667.       (c-warn (DEUTSCH "~S ist weder deklariert noch gebunden,~@
  3668.                         behandle es als SPECIAL-deklarierte Variable."
  3669.                ENGLISH "~S is neither declared nor bound,~@
  3670.                         it will be treated as if it were declared SPECIAL."
  3671.                FRANCAIS "~S n'est ni dΘclarΘ ni liΘ,~@
  3672.                          et va Ωtre traitΘ comme Θtant dΘclarΘ SPECIAL.")
  3673.               symbol
  3674.       )
  3675.       (setq a 'SPECIAL)
  3676.     )
  3677.     (case a
  3678.       (SPECIAL ; Special-Variable
  3679.         (let ((var (make-special-var symbol)))
  3680.           (make-anode :type 'VARSET
  3681.                       :sub-anodes '()
  3682.                       :seclass (cons
  3683.                                  'NIL
  3684.                                  (if (var-constantp var) 'NIL (list symbol))
  3685.                                )
  3686.                       :code (if (var-constantp var)
  3687.                               (progn
  3688.                                 (c-warn (DEUTSCH "Der Konstante ~S kann nicht zugewiesen werden.~@
  3689.                                                   Die Zuweisung wird ignoriert."
  3690.                                          ENGLISH "The constant ~S may not be assigned to.~@
  3691.                                                   The assignment will be ignored."
  3692.                                          FRANCAIS "Rien ne peut Ωtre assignΘ α la constante ~S.~@
  3693.                                                    L'assignation est ignorΘe.")
  3694.                                         symbol
  3695.                                 )
  3696.                                 '((VALUES1))
  3697.                               )
  3698.                               `((SETVALUE , symbol))
  3699.       ) ) )                 )
  3700.       (LOCAL ; interpretativ lexikalisch
  3701.         (make-anode :type 'VARSET
  3702.                     :sub-anodes '()
  3703.                     :seclass (cons 'NIL 'T)
  3704.                     :code `((PUSH)
  3705.                             (CONST ,(new-const b)) ; Vektor
  3706.                             (PUSH)
  3707.                             (CONST ,(new-const c)) ; Index
  3708.                             (SVSET)
  3709.       ) )                  )
  3710.       ((T) ; lexikalisch in Stack oder Closure
  3711.         (let* ((var b)
  3712.                (set-anode
  3713.                  (make-anode :type 'VARSET
  3714.                              :sub-anodes '()
  3715.                              :seclass (cons 'NIL (list var))
  3716.                              :code `((SET ,var ,*venvc* ,*stackz*))
  3717.               )) )
  3718.           (unless (var-usedp var) (setf (var-usedp var) t)) ; Zuweisung "benutzt" die Variable
  3719.           (unless *no-code*
  3720.             (setf (var-constantp var) nil) ; nicht mehr konstant wegen Zuweisung
  3721.             (push (list* value-anode set-anode for-value) (var-modified-list var))
  3722.             (unless (eq (stackz-fun (var-stackz var)) *func*)
  3723.               (setf (var-closurep var) t)
  3724.               ; aktiviere Venvconst in allen dazwischenliegenden Funktionen
  3725.               (do ((venvc *venvc* (cdr venvc)))
  3726.                   ((null venvc) (compiler-error 'c-VARSET "INVISIBLE"))
  3727.                 (when (eq venvc (var-venvc var)) (return))
  3728.                 (when (fnode-p (car venvc))
  3729.                   (setf (fnode-Venvconst (car venvc)) t)
  3730.             ) ) )
  3731.             ; Das Ersetzen einer Variablen innervar durch var ist dann
  3732.             ; nicht erlaubt, wenn wΣhrend der Existenzdauer von innervar
  3733.             ; an var ein Wert zugewiesen wird.
  3734.             (setf (var-replaceable-list var)
  3735.               (delete-if #'(lambda (innervar-info) ; innervar gerade aktiv?
  3736.                              (let ((innervar (first innervar-info)))
  3737.                                (tailp (var-stackz innervar) *stackz*)
  3738.                            ) )
  3739.                          (var-replaceable-list var)
  3740.             ) )
  3741.           )
  3742.           set-anode
  3743.       ) )
  3744.       (t (compiler-error 'c-VARSET 'venv-search))
  3745. ) ) )
  3746.  
  3747. ;; Funktionsaufrufe, bei denen die Funktion ein Symbol oder (SETF symbol) ist:
  3748.  
  3749. (defun make-funname-const (name)
  3750.   (if (atom name)
  3751.     (new-const name)
  3752.     (let ((symbol (second name)))
  3753.       (make-const :value (system::get-setf-symbol symbol)
  3754.                   :form `(SYSTEM::GET-SETF-SYMBOL ',symbol)
  3755. ) ) ) )
  3756.  
  3757. ; Global function call, normal (notinline): (fun {form}*)
  3758. (defun c-NORMAL-FUNCTION-CALL (fun) ; fun ist ein Symbol oder (SETF symbol)
  3759.   (test-list *form* 1)
  3760.   (let* ((n (length (cdr *form*)))
  3761.          #+COMPILER-DEBUG (oldstackz *stackz*)
  3762.          (*stackz* *stackz*))
  3763.     (do ((formlist (cdr *form*))
  3764.          #+COMPILER-DEBUG (anodelist '())
  3765.          (codelist (list '(CALLP))))
  3766.         ((null formlist)
  3767.          (push
  3768.            `(,@(case n
  3769.                  (0 `(CALL0)) (1 `(CALL1)) (2 `(CALL2)) (t `(CALL ,n))
  3770.                )
  3771.              ,(make-funname-const fun)
  3772.             )
  3773.            codelist
  3774.          )
  3775.          (make-anode
  3776.            :type 'CALL
  3777.            :sub-anodes (nreverse anodelist)
  3778.            :seclass '(T . T)
  3779.            :code (nreverse codelist)
  3780.            :stackz oldstackz
  3781.         ))
  3782.       (let* ((formi (pop formlist))
  3783.              (anodei (c-form formi 'ONE)))
  3784.         #+COMPILER-DEBUG (push anodei anodelist)
  3785.         (push anodei codelist)
  3786.         (push '(PUSH) codelist)
  3787.         (push 1 *stackz*)
  3788. ) ) ) )
  3789.  
  3790. ; Liefert die Signatur einer Funktion aus dem fdescr
  3791. (defun fdescr-signature (fdescr)
  3792.   (if (cdr fdescr)
  3793.     (if (eq (cadr fdescr) 'LABELS)
  3794.       ; bei LABELS: aus der Lambdalisten-Information
  3795.       (multiple-value-bind (reqvar  optvar optinit optsvar  restvar
  3796.                             keyflag keyword keyvar keyinit keysvar allow-other-keys
  3797.                             auxvar auxinit)
  3798.           (values-list (cddr fdescr))
  3799.         (declare (ignore optinit optsvar keyvar keyinit keysvar auxvar auxinit))
  3800.         (values (length reqvar) (length optvar)
  3801.                 (not (eql restvar 0)) keyflag
  3802.                 keyword allow-other-keys
  3803.       ) )
  3804.       ; bei GENERIC-FLET oder GENERIC-LABELS: aus der Signatur
  3805.       (values-list (cddr fdescr))
  3806.     )
  3807.     ; bei FLET oder IN-DEFUN: aus dem fnode
  3808.     (let ((fnode (car fdescr)))
  3809.       (values (fnode-req-anz fnode) (fnode-opt-anz fnode)
  3810.               (fnode-rest-flag fnode) (fnode-keyword-flag fnode)
  3811.               (fnode-keywords fnode) (fnode-allow-other-keys-flag fnode)
  3812. ) ) ) )
  3813.  
  3814. ; (test-argument-syntax args applyargs fun req opt rest-p key-p keylist allow-p)
  3815. ; ⁿberprⁿft, ob die Argumentliste args (und evtl. weitere Argumente applyargs)
  3816. ; als Argumentliste zu fun (Symbol) geeignet ist, d.h. ob sie der gegebenen
  3817. ; Spezifikation, gegeben durch req,opt,rest-p,keylist,allow-p, genⁿgt.
  3818. ; Gegebenenfalls wird eine Warnung ausgegeben.
  3819. ; Liefert:
  3820. ;   NO-KEYS           bei korrekter Syntax, ohne Keywords,
  3821. ;   STATIC-KEYS       bei korrekter Syntax mit konstanten Keywords,
  3822. ;   DYNAMIC-KEYS      bei (vermutlich) korrekter Syntax,
  3823. ;                       mit nicht-konstanten Keywords.
  3824. ;   NIL               bei fehlerhafter Syntax,
  3825. ; In den ersten beiden FΣllen ist
  3826. ; falls (not applyargs):
  3827. ;   req <= (length args) <= (req+opt oder, falls rest-p oder key-p, unendlich)
  3828. ; bzw. falls applyargs:
  3829. ;   (length args) <= (req+opt oder, falls rest-p oder key-p, unendlich).
  3830. (defun test-argument-syntax (args applyargs fun req opt rest-p key-p keylist allow-p)
  3831.   (unless (and (listp args) (null (cdr (last args))))
  3832.     (c-error (DEUTSCH "Argumentliste zu Funktion ~S ist dotted: ~S"
  3833.               ENGLISH "argument list to function ~S is dotted: ~S"
  3834.               FRANCAIS "Liste pointΘe d'arguments pour la fonction ~S : ~S")
  3835.              fun args
  3836.   ) )
  3837.   (let ((n (length args))
  3838.         (reqopt (+ req opt)))
  3839.     (unless (and (or applyargs (<= req n)) (or rest-p key-p (<= n reqopt)))
  3840.       (c-warn (DEUTSCH "~S mit ~S~:[~; oder mehr~] Argumenten aufgerufen, braucht aber ~
  3841.                         ~:[~:[~S bis ~S~;~S~]~;mindestens ~*~S~] Argumente."
  3842.                ENGLISH "~S called with ~S~:[~; or more~] arguments, but it requires ~
  3843.                         ~:[~:[from ~S to ~S~;~S~]~;at least ~*~S~] arguments."
  3844.                FRANCAIS "~S est appelΘ avec ~S~[; ou plus~] d'arguments mais a besoin ~
  3845.                          ~:[de ~:[~S α ~S~;~S~]~;d'au moins ~*~S~] arguments.")
  3846.               fun n applyargs
  3847.               (or rest-p key-p)  (eql req reqopt) req reqopt
  3848.       )
  3849.       (return-from test-argument-syntax 'NIL)
  3850.     )
  3851.     (unless key-p (return-from test-argument-syntax 'NO-KEYS))
  3852.     ; Mit Keywords.
  3853.     (when (<= n reqopt) (return-from test-argument-syntax 'STATIC-KEYS))
  3854.     (when rest-p (return-from test-argument-syntax 'DYNAMIC-KEYS))
  3855.     (setq n (- n reqopt) args (nthcdr reqopt args))
  3856.     (unless (evenp n)
  3857.       (c-warn (DEUTSCH "Keyword-Argumente zu Funktion ~S sind nicht paarig: ~S"
  3858.                ENGLISH "keyword arguments to function ~S should occur pairwise: ~S"
  3859.                FRANCAIS "Les arguments de genre mot-clΘ pour la fonction ~S ne sont pas par paires : ~S")
  3860.               fun args
  3861.       )
  3862.       (return-from test-argument-syntax 'NIL)
  3863.     )
  3864.     (do ((keyargs args (cddr keyargs))
  3865.          (allow-flag allow-p)
  3866.          (wrong-key nil)
  3867.         )
  3868.         ((null keyargs)
  3869.          (if wrong-key
  3870.            (c-error (DEUTSCH "Keyword ~S ist bei Funktion ~S nicht erlaubt.~
  3871.                               ~%Erlaubt ~:[sind nur ~{~S~#[~; und ~S~:;, ~]~}~;ist nur ~{~S~}~]."
  3872.                      ENGLISH "keyword ~S is not allowed for function ~S.~
  3873.                               ~%The only allowed keyword~:[s are ~{~S~#[~; and ~S~:;, ~]~}~; is ~{~S~}~]."
  3874.                      FRANCAIS "L'argument mot-clΘ ~S n'est pas permis pour la fonction ~S.~
  3875.                                ~%Seul~:[s sont permis ~{~S~#[~; et ~S~:;, ~]~}~; est permis ~{~S~}~].")
  3876.                     wrong-key fun (eql (length keylist) 1) keylist
  3877.            )
  3878.            'STATIC-KEYS
  3879.         ))
  3880.       (let ((key (first keyargs)))
  3881.         (unless (c-constantp key)
  3882.           (return-from test-argument-syntax 'DYNAMIC-KEYS)
  3883.         )
  3884.         (setq key (c-constant-value key))
  3885.         (unless (keywordp key)
  3886.           (c-warn (DEUTSCH "Das Argument ~S zu Funktion ~S ist kein Keyword."
  3887.                    ENGLISH "argument ~S to function ~S is not a keyword"
  3888.                    FRANCAIS "L'argument ~S pour la fonction ~S n'est pas un mot-clΘ.")
  3889.                   (first keyargs) fun
  3890.           )
  3891.           (return-from test-argument-syntax 'DYNAMIC-KEYS)
  3892.         )
  3893.         (when (eq key ':ALLOW-OTHER-KEYS)
  3894.           (unless (c-constantp (second keyargs))
  3895.             (return-from test-argument-syntax 'DYNAMIC-KEYS)
  3896.           )
  3897.           (when (c-constant-value (second keyargs)) (setq allow-flag t))
  3898.         )
  3899.         (unless (or allow-flag (member key keylist :test #'eq))
  3900.           (setq wrong-key key)
  3901.     ) ) )
  3902. ) )
  3903.  
  3904. ; (c-DIRECT-FUNCTION-CALL args applyargs fun req opt rest-p key-p keylist
  3905. ;                         subr-flag call-code-producer)
  3906. ; compiliert die Abarbeitung der Argumente fⁿr den Direktaufruf einer
  3907. ; Funktion (d.h. ohne Argument-Check zur Laufzeit).
  3908. ; (test-argument-syntax ...) mu▀ die Argumente bereits erfolgreich (d.h.
  3909. ; mit Ergebnis NO-KEYS oder STATIC-KEYS) ⁿberprⁿft haben.
  3910. ; args : Liste der Argumentformen,
  3911. ; applyargs : falls angegeben, Liste einer Form fⁿr die weiteren Argumente,
  3912. ; fun : Name der aufzurufenden Funktion (Symbol),
  3913. ; req,opt,rest-p,key-p,keylist,allow-p : Information ⁿber die Lambdaliste von fun
  3914. ; subr-flag : Flag, ob fun ein SUBR oder aber eine compilierte Closure ist,
  3915. ;             (Obacht: applyargs nur bei compilierten Closures verwenden!),
  3916. ; call-code-producer : Funktion, die den Code liefert, der am Ende anzufⁿgen
  3917. ;                      ist und den Aufruf ausfⁿhrt.
  3918. (defun c-DIRECT-FUNCTION-CALL (args applyargs fun req opt rest-p key-p keylist
  3919.                                subr-flag call-code-producer)
  3920.   (let* ((foldable nil)
  3921.          (sideeffects ; Seiteneffektklasse des Funktionsaufrufs selbst
  3922.            (if (not subr-flag)
  3923.              '(T . T) ; kein SUBR -> kann nichts aussagen
  3924.              (case fun ; fun ein SUBR
  3925.                (; Seiteneffektklasse (NIL . NIL) haben diejenigen Funktionen,
  3926.                 ; die ihre Argumente nur anschauen (Pointer, Inhalt nur bei
  3927.                 ; Zahlen oder Σhnlichen unmodifizierbaren Datenstrukturen)
  3928.                 ; und auf keine globalen Variablen zugreifen.
  3929.                 ; Eine Funktion, die, zweimal mit denselben Argumenten auf-
  3930.                 ; gerufen, stets dasselbe Ergebnis liefert (im EQL-Sinne),
  3931.                 ; erlaubt Constant-Folding: Sind alle Argumente Konstanten
  3932.                 ; und der Funktionsaufruf durchfⁿhrbar, so darf der Funktions-
  3933.                 ; aufruf durch das konstante Funktionsergebnis ersetzt werden.
  3934.                 (SYSTEM::%FUNTABREF
  3935.                  ARRAY-ELEMENT-TYPE ARRAY-RANK ADJUSTABLE-ARRAY-P
  3936.                  STANDARD-CHAR-P GRAPHIC-CHAR-P STRING-CHAR-P ALPHA-CHAR-P UPPER-CASE-P
  3937.                  LOWER-CASE-P BOTH-CASE-P DIGIT-CHAR-P ALPHANUMERICP CHAR= CHAR/= CHAR< CHAR>
  3938.                  CHAR<= CHAR>= CHAR-EQUAL CHAR-NOT-EQUAL CHAR-LESSP CHAR-GREATERP
  3939.                  CHAR-NOT-GREATERP CHAR-NOT-LESSP CHAR-CODE CHAR-BITS CHAR-FONT CODE-CHAR
  3940.                  MAKE-CHAR CHAR-UPCASE CHAR-DOWNCASE DIGIT-CHAR CHAR-INT INT-CHAR
  3941.                  CHAR-NAME CHAR-BIT
  3942.                  SPECIAL-FORM-P
  3943.                  ENDP
  3944.                  IDENTITY
  3945.                  EQ EQL CONSP ATOM SYMBOLP STRINGP NUMBERP
  3946.                  NULL NOT SYSTEM::CLOSUREP LISTP INTEGERP SYSTEM::FIXNUMP RATIONALP FLOATP
  3947.                  SYSTEM::SHORT-FLOAT-P SYSTEM::SINGLE-FLOAT-P SYSTEM::DOUBLE-FLOAT-P SYSTEM::LONG-FLOAT-P
  3948.                  REALP COMPLEXP STREAMP RANDOM-STATE-P READTABLEP HASH-TABLE-P PATHNAMEP
  3949.                  SYSTEM::LOGICAL-PATHNAME-P CHARACTERP FUNCTIONP PACKAGEP ARRAYP SIMPLE-ARRAY-P
  3950.                  BIT-VECTOR-P VECTORP SIMPLE-VECTOR-P SIMPLE-STRING-P SIMPLE-BIT-VECTOR-P
  3951.                  SYSTEM::SYMBOL-MACRO-P CLOS::STD-INSTANCE-P
  3952.                  ZEROP PLUSP MINUSP ODDP EVENP = /= < > <= >= MAX MIN
  3953.                  + - * / 1+ 1- CONJUGATE GCD LCM ISQRT
  3954.                  RATIONAL RATIONALIZE NUMERATOR DENOMINATOR FLOOR CEILING TRUNCATE
  3955.                  ROUND MOD REM DECODE-FLOAT SCALE-FLOAT
  3956.                  FLOAT-RADIX FLOAT-SIGN FLOAT-DIGITS FLOAT-PRECISION INTEGER-DECODE-FLOAT
  3957.                  COMPLEX REALPART IMAGPART LOGIOR LOGXOR LOGAND LOGEQV LOGNAND LOGNOR
  3958.                  LOGANDC1 LOGANDC2 LOGORC1 LOGORC2 BOOLE LOGNOT LOGTEST LOGBITP ASH LOGCOUNT
  3959.                  INTEGER-LENGTH LDB LDB-TEST MASK-FIELD DPB DEPOSIT-FIELD ! EXQUO
  3960.                 ) ; alle diese sind SUBRs ohne Keyword-Parameter
  3961.                 (setq foldable t)
  3962.                 '(NIL . NIL)
  3963.                )
  3964.                ((VECTOR MAKE-STRING
  3965.                  VALUES ; nicht foldable, um Endlosschleife zu verhindern!
  3966.                  CONS LIST LIST* MAKE-LIST ACONS
  3967.                  LISP-IMPLEMENTATION-TYPE LISP-IMPLEMENTATION-VERSION SOFTWARE-TYPE
  3968.                  SOFTWARE-VERSION
  3969.                  SYSTEM::MAKE-LOAD-TIME-EVAL
  3970.                  SYMBOL-NAME
  3971.                  SYSTEM::DECIMAL-STRING
  3972.                 )
  3973.                 '(NIL . NIL)
  3974.                )
  3975.                ((SYSTEM::SUBR-INFO
  3976.                  AREF SVREF ARRAY-DIMENSION ARRAY-DIMENSIONS ARRAY-TOTAL-SIZE
  3977.                  ARRAY-IN-BOUNDS-P ARRAY-ROW-MAJOR-INDEX BIT SBIT
  3978.                  ARRAY-HAS-FILL-POINTER-P FILL-POINTER MAKE-ARRAY
  3979.                  CHARACTER CHAR SCHAR STRING= STRING/= STRING< STRING> STRING<=
  3980.                  STRING>= STRING-EQUAL STRING-NOT-EQUAL STRING-LESSP STRING-GREATERP
  3981.                  STRING-NOT-GREATERP STRING-NOT-LESSP SYSTEM::SEARCH-STRING=
  3982.                  SYSTEM::SEARCH-STRING-EQUAL SYSTEM::STRING-BOTH-TRIM STRING-UPCASE
  3983.                  STRING-DOWNCASE STRING-CAPITALIZE STRING NAME-CHAR SUBSTRING STRING-CONCAT
  3984.                  MAKE-SYMBOL SYMBOL-VALUE SYMBOL-FUNCTION BOUNDP FBOUNDP
  3985.                  VALUES-LIST MACRO-FUNCTION CONSTANTP
  3986.                  MAKE-HASH-TABLE GETHASH HASH-TABLE-COUNT SYSTEM::HASH-TABLE-ITERATOR SXHASH
  3987.                  GET-MACRO-CHARACTER GET-DISPATCH-MACRO-CHARACTER SYSTEM::LINE-POSITION
  3988.                  CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR
  3989.                  CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR
  3990.                  CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR
  3991.                  LIST-LENGTH NTH FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH
  3992.                  EIGHTH NINTH TENTH REST NTHCDR LAST APPEND COPY-LIST
  3993.                  COPY-ALIST COPY-TREE REVAPPEND BUTLAST LDIFF TAILP PAIRLIS
  3994.                  GET-UNIVERSAL-TIME GET-INTERNAL-RUN-TIME
  3995.                  GET-INTERNAL-REAL-TIME SYSTEM::%%TIME
  3996.                  FIND-PACKAGE PACKAGE-NAME PACKAGE-NICKNAMES PACKAGE-USE-LIST
  3997.                  PACKAGE-USED-BY-LIST PACKAGE-SHADOWING-SYMBOLS LIST-ALL-PACKAGES FIND-SYMBOL
  3998.                  FIND-ALL-SYMBOLS
  3999.                  PARSE-NAMESTRING PATHNAME PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY
  4000.                  PATHNAME-NAME PATHNAME-TYPE PATHNAME-VERSION FILE-NAMESTRING
  4001.                  DIRECTORY-NAMESTRING HOST-NAMESTRING MERGE-PATHNAMES ENOUGH-NAMESTRING
  4002.                  MAKE-PATHNAME NAMESTRING TRUENAME PROBE-FILE DIRECTORY FILE-WRITE-DATE
  4003.                  FILE-AUTHOR
  4004.                  EQUAL EQUALP COMPILED-FUNCTION-P CLOS::GENERIC-FUNCTION-P COMMONP
  4005.                  TYPE-OF CLOS::CLASS-P CLOS:CLASS-OF COERCE
  4006.                  SYSTEM::%RECORD-REF SYSTEM::%RECORD-LENGTH SYSTEM::%STRUCTURE-REF SYSTEM::%MAKE-STRUCTURE
  4007.                  SYSTEM::%COPY-STRUCTURE SYSTEM::%STRUCTURE-TYPE-P SYSTEM::CLOSURE-NAME
  4008.                  SYSTEM::CLOSURE-CODEVEC SYSTEM::CLOSURE-CONSTS SYSTEM::MAKE-CODE-VECTOR
  4009.                  SYSTEM::%MAKE-CLOSURE SYSTEM::MAKE-LOAD-TIME-EVAL SYSTEM::MAKE-SYMBOL-MACRO
  4010.                  CLOS::ALLOCATE-STD-INSTANCE CLOS:SLOT-EXISTS-P
  4011.                  SYSTEM::SEQUENCEP ELT SUBSEQ COPY-SEQ LENGTH REVERSE CONCATENATE
  4012.                  MAKE-SYNONYM-STREAM MAKE-BROADCAST-STREAM MAKE-CONCATENATED-STREAM
  4013.                  MAKE-TWO-WAY-STREAM MAKE-ECHO-STREAM MAKE-STRING-INPUT-STREAM
  4014.                  SYSTEM::STRING-INPUT-STREAM-INDEX MAKE-STRING-OUTPUT-STREAM
  4015.                  SYSTEM::MAKE-STRING-PUSH-STREAM MAKE-BUFFERED-INPUT-STREAM
  4016.                  MAKE-BUFFERED-OUTPUT-STREAM INPUT-STREAM-P OUTPUT-STREAM-P
  4017.                  STREAM-ELEMENT-TYPE FILE-LENGTH
  4018.                  GET GETF GET-PROPERTIES SYMBOL-PACKAGE SYMBOL-PLIST KEYWORDP
  4019.                  SYSTEM::SPECIAL-VARIABLE-P GENSYM
  4020.                  FFLOOR FCEILING FTRUNCATE FROUND
  4021.                  EXP EXPT LOG SQRT ABS PHASE SIGNUM SIN COS TAN CIS ASIN ACOS ATAN
  4022.                  SINH COSH TANH ASINH ACOSH ATANH FLOAT BYTE BYTE-SIZE BYTE-POSITION
  4023.                  SYSTEM::LOG2 SYSTEM::LOG10
  4024.                 )
  4025.                 '(T . NIL)
  4026.                )
  4027.                (t '(T . T)) ; vielleicht Seiteneffekte
  4028.         )) ) )
  4029.     (if (and (null *for-value*) (null (cdr sideeffects)))
  4030.       ; Brauche die Funktion nicht aufzurufen, nur die Argumente auswerten
  4031.       (progn
  4032.         (let ((*no-code* t) (*for-value* 'NIL))
  4033.           (funcall call-code-producer)
  4034.         )
  4035.         (c-form `(PROGN ,@args ,@applyargs))
  4036.       )
  4037.       (let ((n (length args))
  4038.             (reqopt (+ req opt))
  4039.             (seclass sideeffects)
  4040.             (codelist '()))
  4041.         (let ((*stackz* *stackz*))
  4042.           ; required und angegebene optionale Parameter:
  4043.           (dotimes (i (min n reqopt))
  4044.             (let* ((formi (pop args))
  4045.                    (anodei (c-form formi 'ONE)))
  4046.               (seclass-or-f seclass anodei)
  4047.               (push anodei codelist)
  4048.             )
  4049.             (push '(PUSH) codelist)
  4050.             (push 1 *stackz*)
  4051.           )
  4052.           (if applyargs
  4053.             (progn
  4054.               (when subr-flag (compiler-error 'c-DIRECT-FUNCTION-CALL "APPLY-SUBR"))
  4055.               (when key-p (compiler-error 'c-DIRECT-FUNCTION-CALL "APPLY-KEY"))
  4056.               (if (>= reqopt n)
  4057.                 ; fehlende optionale Parameter werden aus der Liste initialisiert:
  4058.                 (let* ((anz (- reqopt n))
  4059.                        (anode1 (c-form (first applyargs) 'ONE))
  4060.                        (anode2 (progn
  4061.                                  (push (if rest-p (+ anz 1) anz) *stackz*)
  4062.                                  (c-unlist rest-p anz (min opt anz))
  4063.                       ))       )
  4064.                   (seclass-or-f seclass anode1)
  4065.                   (push anode1 codelist)
  4066.                   (seclass-or-f seclass anode2)
  4067.                   (push anode2 codelist)
  4068.                 )
  4069.                 ; n > reqopt, impliziert rest-p.
  4070.                 ; ▄bergabe von restlichen Argumenten an eine compilierte Closure:
  4071.                 ; als Liste.
  4072.                 ; Liste aus allen weiteren Argumenten:
  4073.                 (progn
  4074.                   (let ((*stackz* *stackz*)
  4075.                         (rest-args args))
  4076.                     (loop
  4077.                       (when (null rest-args) (return))
  4078.                       (let ((anode (c-form (pop rest-args) 'ONE)))
  4079.                         (seclass-or-f seclass anode)
  4080.                         (push anode codelist)
  4081.                       )
  4082.                       (push '(PUSH) codelist)
  4083.                       (push 1 *stackz*)
  4084.                     )
  4085.                     (let ((anode (c-form (first applyargs) 'ONE)))
  4086.                       (seclass-or-f seclass anode)
  4087.                       (push anode codelist)
  4088.                     )
  4089.                     (push `(LIST* ,(- n reqopt)) codelist)
  4090.                   )
  4091.                   (push '(PUSH) codelist)
  4092.                   (push 1 *stackz*)
  4093.             ) ) )
  4094.             (progn
  4095.               ; fehlende optionale Parameter werden mit #<UNBOUND> initialisiert:
  4096.               (when (> reqopt n)
  4097.                 (let ((anz (- reqopt n)))
  4098.                   (push `(PUSH-UNBOUND ,anz) codelist)
  4099.                   (push anz *stackz*)
  4100.               ) )
  4101.               ; &rest-Parameter:
  4102.               (when rest-p
  4103.                 (if subr-flag
  4104.                   ; ▄bergabe von restlichen Argumenten an ein SUBR: einzeln
  4105.                   (loop
  4106.                     (when (null args) (return))
  4107.                     (let ((anode (c-form (pop args) 'ONE)))
  4108.                       (seclass-or-f seclass anode)
  4109.                       (push anode codelist)
  4110.                     )
  4111.                     (push '(PUSH) codelist)
  4112.                     (push 1 *stackz*)
  4113.                   )
  4114.                   ; ▄bergabe von restlichen Argumenten an eine compilierte Closure:
  4115.                   ; als Liste
  4116.                   (if (null args)
  4117.                     ; leere Liste
  4118.                     (progn
  4119.                       (push '(NIL) codelist)
  4120.                       (push '(PUSH) codelist)
  4121.                       (push 1 *stackz*)
  4122.                     )
  4123.                     ; Liste aus allen weiteren Argumenten:
  4124.                     (progn
  4125.                       (let ((*stackz* *stackz*)
  4126.                             (rest-args args))
  4127.                         (loop
  4128.                           (when (null rest-args) (return))
  4129.                           (let ((anode (c-form (pop rest-args) 'ONE)))
  4130.                             (seclass-or-f seclass anode)
  4131.                             (push anode codelist)
  4132.                           )
  4133.                           (push '(PUSH) codelist)
  4134.                           (push 1 *stackz*)
  4135.                         )
  4136.                         (push `(LIST ,(- n reqopt)) codelist)
  4137.                       )
  4138.                       (push '(PUSH) codelist)
  4139.                       (push 1 *stackz*)
  4140.             ) ) ) ) )
  4141.           )
  4142.           ; &key-Parameter:
  4143.           (when key-p
  4144.             ; Nur dann gleichzeitig rest-p und key-p, wenn n <= reqopt, da
  4145.             ; test-argument-syntax (ergab STATIC-KEYS) den anderen Fall
  4146.             ; bereits ausgeschlossen hat.
  4147.             (let ((keyanz (length keylist)))
  4148.               ; Erst alle Keys mit #<UNBOUND> vorbelegen, dann die Argumente
  4149.               ; in der angegebenen Reihenfolge auswerten und zuordnen?
  4150.               ; Das ist uns zu einfach. Wir lassen die Argumente kommutieren,
  4151.               ; damit m÷glichst viele der (STORE ...) durch (PUSH) ersetzt
  4152.               ; werden k÷nnen: Die Argumente zu den ersten Keys werden nach
  4153.               ; M÷glichkeit zuerst ausgewertet, die zu den letzten Keys
  4154.               ; zuletzt. Wir lassen es allerdings bei einem einzigen
  4155.               ; (PUSH-UNBOUND ...).
  4156.               (let* ((key-positions ; Liste von Tripeln (key stack-depth free-p),
  4157.                                     ; wobei stack-depth = keyanz-1...0 lΣuft und
  4158.                                     ; free-p angibt, ob der Slot schon gefⁿllt ist.
  4159.                        (let ((i keyanz))
  4160.                          (mapcar #'(lambda (key) (list key (decf i) t)) keylist)
  4161.                      ) )
  4162.                      (anodes ; Liste von Quadrupeln
  4163.                              ; (needed key-position anode stackz), wobei
  4164.                              ; key-position die stack-depth des Keyword-Slots
  4165.                              ; oder NIL ist, anode der Anode zu diesem Argument.
  4166.                              ; Die Liste wird in derselben Reihenfolge gehalten,
  4167.                              ; wie sie die Argumentliste vorgibt.
  4168.                              ; Ausnahme: needed = NIL bei anodes, deren
  4169.                              ; Berechnung man vorgezogen oder verschoben hat.
  4170.                        (let ((L '()))
  4171.                          (loop
  4172.                            (when (null args) (return))
  4173.                            (let* ((key (c-constant-value (pop args)))
  4174.                                   (tripel (assoc key key-positions :test #'eq)) ; kann =NIL sein!
  4175.                                   (for-value (third tripel))
  4176.                                   (arg (pop args)))
  4177.                              ; for-value /= NIL: Existentes Keyword, und der Slot ist noch leer
  4178.                              ; for-value = NIL: ALLOW-erlaubtes Keyword oder Slot schon gefⁿllt
  4179.                              (let* ((*stackz* (cons 0 *stackz*)) ; 0 wird spΣter ersetzt
  4180.                                     (anode (c-form arg (if for-value 'ONE 'NIL))))
  4181.                                (seclass-or-f seclass anode)
  4182.                                (push (list t (second tripel) anode *stackz*) L)
  4183.                              )
  4184.                              (setf (third tripel) nil)
  4185.                          ) )
  4186.                          (nreverse L)
  4187.                     )) )
  4188.                 (let ((depth1 0)
  4189.                       (depth2 0)
  4190.                       (codelist-from-end '()))
  4191.                   ; M÷glichst viel nach vorne ziehen:
  4192.                   (do ((anodesr anodes (cdr anodesr)))
  4193.                       ((null anodesr))
  4194.                     (let ((anodeetc (car anodesr))) ; nΣchstes Quadrupel
  4195.                       (when (first anodeetc) ; noch was zu tun?
  4196.                         (if (and
  4197.                               (or ; kein Keyword, d.h. kein (STORE ...) n÷tig?
  4198.                                   (null (second anodeetc))
  4199.                                   ; oberstes Keyword?
  4200.                                   (= (second anodeetc) (- keyanz depth1 1))
  4201.                               )
  4202.                               ; kommutiert anodeetc mit allen vorigen anodes?
  4203.                               (let ((anode (third anodeetc)))
  4204.                                 (do ((anodesr2 anodes (cdr anodesr2)))
  4205.                                     ((eq anodesr2 anodesr) t)
  4206.                                   (unless (anodes-commute anode (third (car anodesr2)))
  4207.                                     (return nil)
  4208.                               ) ) )
  4209.                             )
  4210.                           ; vorziehen:
  4211.                           (progn
  4212.                             (setf (first (fourth anodeetc)) depth1) ; korrekte Stacktiefe
  4213.                             (push (third anodeetc) codelist) ; in die Codeliste
  4214.                             (when (second anodeetc)
  4215.                               (push '(PUSH) codelist)
  4216.                               (incf depth1)
  4217.                             )
  4218.                             (setf (first anodeetc) nil) ; diesen brauchen wir nicht mehr
  4219.                           )
  4220.                           ; sonst machen wir nichts.
  4221.                   ) ) ) )
  4222.                   ; M÷glichst viel nach hinten ziehen:
  4223.                   (setq anodes (nreverse anodes))
  4224.                   (do ((anodesr anodes (cdr anodesr)))
  4225.                       ((null anodesr))
  4226.                     (let ((anodeetc (car anodesr))) ; nΣchstes Quadrupel
  4227.                       (when (first anodeetc) ; noch was zu tun?
  4228.                         (if (and
  4229.                               (or ; kein Keyword, d.h. kein (STORE ...) n÷tig?
  4230.                                   (null (second anodeetc))
  4231.                                   ; unterstes Keyword?
  4232.                                   (= (second anodeetc) depth2)
  4233.                               )
  4234.                               ; kommutiert anodeetc mit allen spΣteren anodes?
  4235.                               (let ((anode (third anodeetc)))
  4236.                                 (do ((anodesr2 anodes (cdr anodesr2)))
  4237.                                     ((eq anodesr2 anodesr) t)
  4238.                                   (unless (anodes-commute anode (third (car anodesr2)))
  4239.                                     (return nil)
  4240.                               ) ) )
  4241.                             )
  4242.                           ; ans Ende verschieben:
  4243.                           (progn
  4244.                             (when (second anodeetc)
  4245.                               (push '(PUSH) codelist-from-end)
  4246.                               (incf depth2)
  4247.                             )
  4248.                             (setf (first (fourth anodeetc)) (- keyanz depth2)) ; korrekte Stacktiefe
  4249.                             (push (third anodeetc) codelist-from-end) ; in die Codeliste
  4250.                             (setf (first anodeetc) nil) ; diesen brauchen wir nicht mehr
  4251.                           )
  4252.                           ; sonst machen wir nichts.
  4253.                   ) ) ) )
  4254.                   (setq anodes (nreverse anodes))
  4255.                   (let ((depth-now (- keyanz depth2))) ; codelist-from-end erniedrigt den Stack um depth2
  4256.                     (when (> depth-now depth1)
  4257.                       (push `(PUSH-UNBOUND ,(- depth-now depth1)) codelist)
  4258.                     )
  4259.                     ; In codelist herrscht jetzt Stacktiefe depth-now.
  4260.                     (dolist (anodeetc anodes)
  4261.                       (when (first anodeetc)
  4262.                         (setf (first (fourth anodeetc)) depth-now) ; korrekte Stacktiefe
  4263.                         (push (third anodeetc) codelist)
  4264.                         (when (second anodeetc)
  4265.                           (push `(STORE ,(- (second anodeetc) depth2)) codelist)
  4266.                   ) ) ) )
  4267.                   ; Nun codelist-from-end:
  4268.                   (setq codelist (nreconc codelist-from-end codelist))
  4269.               ) )
  4270.               ; Jetzt sind alle Key-Argumente auf dem Stack.
  4271.               (push keyanz *stackz*)
  4272.           ) )
  4273.           (setq codelist (nreconc codelist (funcall call-code-producer)))
  4274.         )
  4275.         ; Constant-Folding: Ist fun foldable (also subr-flag = T und
  4276.         ; key-flag = NIL) und besteht codelist au▀er den (PUSH)s und dem
  4277.         ; Call-Code am Schlu▀ nur aus Anodes mit code = ((CONST ...)) ?
  4278.         (when (and foldable
  4279.                    (every #'(lambda (code)
  4280.                               (or (not (anode-p code)) (anode-constantp code))
  4281.                             )
  4282.                           codelist
  4283.               )    )
  4284.           ; Funktion aufzurufen versuchen:
  4285.           (let ((args (let ((L '())) ; Liste der (konstanten) Argumente
  4286.                         (dolist (code codelist)
  4287.                           (when (anode-p code)
  4288.                             (push (anode-constant-value code) L)
  4289.                         ) )
  4290.                         (nreverse L)
  4291.                 )     )
  4292.                 resulting-values)
  4293.             (when (block try-eval
  4294.                     (setq resulting-values
  4295.                       (let ((*error-handler*
  4296.                               #'(lambda (&rest error-args)
  4297.                                   (declare (ignore error-args))
  4298.                                   (return-from try-eval nil)
  4299.                            ))   )
  4300.                         (multiple-value-list (apply fun args))
  4301.                     ) )
  4302.                     t
  4303.                   )
  4304.               ; Funktion erfolgreich aufgerufen, Constant-Folding durchfⁿhren:
  4305.               (return-from c-DIRECT-FUNCTION-CALL
  4306.                 (c-GLOBAL-FUNCTION-CALL-form
  4307.                   `(VALUES ,@(mapcar #'(lambda (x) `(QUOTE ,x)) resulting-values))
  4308.         ) ) ) ) )
  4309.         (make-anode
  4310.           :type `(DIRECT-CALL ,fun)
  4311.           :sub-anodes (remove-if-not #'anode-p codelist)
  4312.           :seclass seclass
  4313.           :code codelist
  4314.         )
  4315. ) ) ) )
  4316. (defun c-unlist (rest-p n m)
  4317.   (if rest-p
  4318.     (if (eql n 0)
  4319.       (make-anode :type 'UNLIST*
  4320.                   :sub-anodes '()
  4321.                   :seclass '(NIL . NIL)
  4322.                   :code '((PUSH))
  4323.       )
  4324.       (make-anode :type 'UNLIST*
  4325.                   :sub-anodes '()
  4326.                   :seclass '(T . T) ; kann Error melden
  4327.                   :code `((UNLIST* ,n ,m))
  4328.     ) )
  4329.     (make-anode :type 'UNLIST
  4330.                 :sub-anodes '()
  4331.                 :seclass '(T . T) ; kann Error melden
  4332.                 :code `((UNLIST ,n ,m))
  4333. ) ) )
  4334. (defun cclosure-call-code-producer (fun fnode req opt rest-flag key-flag keylist)
  4335.   (if (eq fnode *func*)
  4336.     ; rekursiver Aufruf der eigenen Funktion
  4337.     (let ((call-code
  4338.             `((JSR ,(+ req opt (if rest-flag 1 0) (length keylist)) ; Zahl der Stack-EintrΣge
  4339.                    ,*func-start-label*
  4340.              ))
  4341.          ))
  4342.       #'(lambda () call-code)
  4343.     )
  4344.     ; eine andere Cclosure aufrufen
  4345.     #'(lambda ()
  4346.         (list
  4347.           (c-form `(FUNCTION ,fun) 'ONE)
  4348.           (if key-flag '(CALLCKEY) '(CALLC))
  4349.       ) )
  4350. ) )
  4351.  
  4352. ; Global function call: (fun {form}*)
  4353. (defun c-GLOBAL-FUNCTION-CALL-form (*form*)
  4354.   (c-GLOBAL-FUNCTION-CALL (first *form*))
  4355. )
  4356. (defun c-GLOBAL-FUNCTION-CALL (fun) ; fun ist ein Symbol oder (SETF symbol)
  4357.   (test-list *form* 1)
  4358.   (when *compiling-from-file* ; von COMPILE-FILE aufgerufen?
  4359.     (unless (or (fboundp fun) (member fun *known-functions* :test #'equal))
  4360.       (pushnew fun *unknown-functions* :test #'equal)
  4361.     )
  4362.     ; PROCLAIM-Deklarationen zur Kenntnis nehmen:
  4363.     (when (and (eq fun 'PROCLAIM) (= (length *form*) 2))
  4364.       (let ((h (second *form*)))
  4365.         (when (c-constantp h)
  4366.           (c-form
  4367.             `(EVAL-WHEN (COMPILE) (c-PROCLAIM ',(c-constant-value h)))
  4368.     ) ) ) )
  4369.     ; Modul-Anforderungen zur Kenntnis nehmen:
  4370.     (when (and (memq fun '(PROVIDE REQUIRE))
  4371.                (every #'c-constantp (rest *form*))
  4372.           )
  4373.       (c-form
  4374.         `(EVAL-WHEN (COMPILE)
  4375.            (,(case fun
  4376.                (PROVIDE 'c-PROVIDE) ; c-PROVIDE statt PROVIDE
  4377.                (REQUIRE 'c-REQUIRE) ; c-REQUIRE statt REQUIRE
  4378.              )
  4379.             ,@(mapcar
  4380.                 #'(lambda (x) (list 'QUOTE (c-constant-value x))) ; Argumente quotieren
  4381.                 (rest *form*)
  4382.          ) )  )
  4383.     ) )
  4384.     ; Package-Anforderungen zur Kenntnis nehmen:
  4385.     (when (and (memq fun '(MAKE-PACKAGE SYSTEM::%IN-PACKAGE IN-PACKAGE
  4386.                            SHADOW SHADOWING-IMPORT EXPORT UNEXPORT
  4387.                            USE-PACKAGE UNUSE-PACKAGE IMPORT
  4388.                )          )
  4389.                (every #'c-constantp (rest *form*))
  4390.           )
  4391.       (push
  4392.         `(,fun
  4393.           ,@(mapcar
  4394.               #'(lambda (x) (list 'QUOTE (c-constant-value x))) ; Argumente quotieren
  4395.               (rest *form*)
  4396.          )  )
  4397.         *package-tasks*
  4398.   ) ) )
  4399.   (let* ((args (cdr *form*)) ; Argumente
  4400.          (n (length args))) ; Anzahl der Argumente
  4401.     (if (not (declared-notinline fun)) ; darf fun INLINE genommen werden?
  4402.       (multiple-value-bind (name req opt rest-p keylist allow-p) (subr-info fun)
  4403.         ; Ist fun ein SUBR, so sollte name = fun sein, und das SUBR hat die
  4404.         ; Spezifikation req, opt, rest-p, key-p = (not (null keylist)), allow-p.
  4405.         ; Sonst ist name = NIL.
  4406.         (if (and name (eq fun name)) ; beschreibt fun ein gⁿltiges SUBR?
  4407.           (case fun
  4408.             ((CAR CDR FIRST REST NOT NULL CONS SVREF VALUES
  4409.               CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR
  4410.               CDDAR CDDDR SECOND THIRD FOURTH CAAAAR CAAADR CAADAR CAADDR
  4411.               CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDADDR
  4412.               CDDAAR CDDADR CDDDAR CDDDDR ATOM CONSP
  4413.               VALUES-LIST SYS::%SVSTORE EQ SYMBOL-FUNCTION LIST LIST*
  4414.              )
  4415.              ; Diese hier haben keylist=NIL, allow-p=NIL und
  4416.              ; (was aber nicht verwendet wird) opt=0.
  4417.              (if (and (<= req n) (or rest-p (<= n (+ req opt))))
  4418.                ; Wir machen den Aufruf INLINE.
  4419.                (let ((sideeffects ; Seiteneffektklasse der Funktionsausfⁿhrung
  4420.                        (case fun
  4421.                          ((NOT NULL CONS VALUES ATOM CONSP EQ LIST LIST*)
  4422.                            '(NIL . NIL)
  4423.                          )
  4424.                          ((CAR CDR FIRST REST CAAR CADR
  4425.                            CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR
  4426.                            CDDDR SECOND THIRD FOURTH CAAAAR CAAADR CAADAR CAADDR
  4427.                            CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDADDR
  4428.                            CDDAAR CDDADR CDDDAR CDDDDR VALUES-LIST
  4429.                            SVREF SYMBOL-FUNCTION
  4430.                           )
  4431.                            '(T . NIL)
  4432.                          )
  4433.                          (t '(T . T))
  4434.                     )) )
  4435.                  (if (and (null *for-value*) (null (cdr sideeffects)))
  4436.                    ; Brauche die Funktion nicht aufzurufen, nur die Argumente auswerten
  4437.                    (c-form `(PROGN ,@args))
  4438.                    (if (and (eq fun 'VALUES) (eq *for-value* 'ONE))
  4439.                      (if (= n 0) (c-NIL) (c-form `(PROG1 ,@args)))
  4440.                      (let ((seclass sideeffects)
  4441.                            (codelist '()))
  4442.                        (let ((*stackz* *stackz*))
  4443.                          ; Argumente auswerten und bis auf das letzte auf den Stack
  4444.                          ; (denn das letzte Argument wird in A0 erwartet):
  4445.                          (loop
  4446.                            (when (null args) (return))
  4447.                            (let ((anode (c-form (pop args) 'ONE)))
  4448.                              (seclass-or-f seclass anode)
  4449.                              (push anode codelist)
  4450.                            )
  4451.                            (when args ; nicht am Schlu▀
  4452.                              (push '(PUSH) codelist)
  4453.                              (push 1 *stackz*)
  4454.                          ) )
  4455.                          (setq codelist
  4456.                            (nreconc codelist
  4457.                              (case fun
  4458.                                ((CAR FIRST) '((CAR)))
  4459.                                ((CDR REST) '((CDR)))
  4460.                                (CAAR '((CAR) (CAR)))
  4461.                                ((CADR SECOND) '((CDR) (CAR)))
  4462.                                (CDAR '((CAR) (CDR)))
  4463.                                (CDDR '((CDR) (CDR)))
  4464.                                (CAAAR '((CAR) (CAR) (CAR)))
  4465.                                (CAADR '((CDR) (CAR) (CAR)))
  4466.                                (CADAR '((CAR) (CDR) (CAR)))
  4467.                                ((CADDR THIRD) '((CDR) (CDR) (CAR)))
  4468.                                (CDAAR '((CAR) (CAR) (CDR)))
  4469.                                (CDADR '((CDR) (CAR) (CDR)))
  4470.                                (CDDAR '((CAR) (CDR) (CDR)))
  4471.                                (CDDDR '((CDR) (CDR) (CDR)))
  4472.                                (CAAAAR '((CAR) (CAR) (CAR) (CAR)))
  4473.                                (CAAADR '((CDR) (CAR) (CAR) (CAR)))
  4474.                                (CAADAR '((CAR) (CDR) (CAR) (CAR)))
  4475.                                (CAADDR '((CDR) (CDR) (CAR) (CAR)))
  4476.                                (CADAAR '((CAR) (CAR) (CDR) (CAR)))
  4477.                                (CADADR '((CDR) (CAR) (CDR) (CAR)))
  4478.                                (CADDAR '((CAR) (CDR) (CDR) (CAR)))
  4479.                                ((CADDDR FOURTH) '((CDR) (CDR) (CDR) (CAR)))
  4480.                                (CDAAAR '((CAR) (CAR) (CAR) (CDR)))
  4481.                                (CDAADR '((CDR) (CAR) (CAR) (CDR)))
  4482.                                (CDADAR '((CAR) (CDR) (CAR) (CDR)))
  4483.                                (CDADDR '((CDR) (CDR) (CAR) (CDR)))
  4484.                                (CDDAAR '((CAR) (CAR) (CDR) (CDR)))
  4485.                                (CDDADR '((CDR) (CAR) (CDR) (CDR)))
  4486.                                (CDDDAR '((CAR) (CDR) (CDR) (CDR)))
  4487.                                (CDDDDR '((CDR) (CDR) (CDR) (CDR)))
  4488.                                (ATOM '((ATOM)))
  4489.                                (CONSP '((CONSP)))
  4490.                                ((NOT NULL) '((NOT)))
  4491.                                (CONS '((CONS)))
  4492.                                (SVREF '((SVREF)))
  4493.                                (SYS::%SVSTORE '((SVSET)))
  4494.                                (EQ '((EQ)))
  4495.                                (VALUES (case n
  4496.                                          (0 '((VALUES0)) )
  4497.                                          (1 '((VALUES1)) )
  4498.                                          (t `((PUSH) ; letztes Argument auch noch in den Stack
  4499.                                               (STACK-TO-MV ,n)
  4500.                                              )
  4501.                                )       ) )
  4502.                                (VALUES-LIST '((LIST-TO-MV)))
  4503.                                (SYMBOL-FUNCTION '((SYMBOL-FUNCTION)))
  4504.                                (LIST (if (plusp n)
  4505.                                        `((PUSH) (LIST ,n))
  4506.                                        '((NIL))
  4507.                                )     )
  4508.                                (LIST* (case n
  4509.                                         (1 '((VALUES1)) )
  4510.                                         (t `((LIST* ,(1- n))) )
  4511.                                )      )
  4512.                                (t (compiler-error 'c-GLOBAL-FUNCTION-CALL))
  4513.                        ) ) ) )
  4514.                        (make-anode
  4515.                          :type `(PRIMOP ,fun)
  4516.                          :sub-anodes (remove-if-not #'anode-p codelist)
  4517.                          :seclass seclass
  4518.                          :code codelist
  4519.                        )
  4520.                ) ) ) )
  4521.                ; falsche Argumentezahl -> doch nicht INLINE:
  4522.                (progn
  4523.                  (c-warn (DEUTSCH "~S mit ~S Argumenten aufgerufen, braucht aber ~
  4524.                                    ~:[~:[~S bis ~S~;~S~]~;mindestens ~*~S~] Argumente."
  4525.                           ENGLISH "~S called with ~S arguments, but it requires ~
  4526.                                    ~:[~:[from ~S to ~S~;~S~]~;at least ~*~S~] arguments."
  4527.                           FRANCAIS "~S est appelΘ avec ~S arguments mais a besoin ~
  4528.                                     ~:[de ~:[~S α ~S~;~S~]~;d'au moins ~*~S~] arguments.")
  4529.                          fun n
  4530.                          rest-p  (eql opt 0) req (+ req opt)
  4531.                  )
  4532.                  (c-NORMAL-FUNCTION-CALL fun)
  4533.             )) )
  4534.             (t ; Ist das SUBR fun in der FUNTAB enthalten?
  4535.              (let ((index (gethash fun function-codes)))
  4536.                (if index
  4537.                  (case (test-argument-syntax args nil
  4538.                                     fun req opt rest-p keylist keylist allow-p
  4539.                        )
  4540.                    ((NO-KEYS STATIC-KEYS)
  4541.                     ; korrekte Syntax, Stack-Layout zur Compilezeit vorhersehbar
  4542.                     ; -> INLINE
  4543.                     (c-DIRECT-FUNCTION-CALL
  4544.                       args nil fun req opt rest-p keylist keylist
  4545.                       t ; es handelt sich um ein SUBR
  4546.                       (let ((call-code
  4547.                               ; Aufruf mit Hilfe der FUNTAB:
  4548.                               (cons
  4549.                                 (if (not rest-p)
  4550.                                   (CALLS-code index)
  4551.                                   `(CALLSR ,(max 0 (- n req opt)) ; Bei n<req+opt kommt noch ein (PUSH-UNBOUND ...)
  4552.                                            ,(- index funtabR-index)
  4553.                                    )
  4554.                                 )
  4555.                                 (case fun
  4556.                                   (; Funktionen, die nicht zurⁿckkehren:
  4557.                                    (; control.d:
  4558.                                     SYS::DRIVER SYS::UNWIND-TO-DRIVER
  4559.                                     ; debug.d:
  4560.                                     ; SYS::REDO-EVAL-FRAME SYS::RETURN-FROM-EVAL-FRAME
  4561.                                     ; error.d:
  4562.                                     ERROR SYSTEM::ERROR-OF-TYPE INVOKE-DEBUGGER
  4563.                                    )
  4564.                                    '((BARRIER))
  4565.                                   )
  4566.                                   (t '())
  4567.                            )) ) )
  4568.                         #'(lambda () call-code)
  4569.                    )) )
  4570.                    (t (c-NORMAL-FUNCTION-CALL fun))
  4571.                  )
  4572.                  (c-NORMAL-FUNCTION-CALL fun)
  4573.           ) )) )
  4574.           (let ((inline-lambdabody
  4575.                   (or (and *compiling-from-file*
  4576.                            (cdr (assoc fun *inline-definitions* :test #'equal))
  4577.                       )
  4578.                       (get (get-funname-symbol fun) 'sys::inline-expansion)
  4579.                )) )
  4580.             (if (and #| inline-lambdabody |#
  4581.                      (consp inline-lambdabody)
  4582.                      (inline-callable-function-p `(FUNCTION (LAMBDA ,@inline-lambdabody)) n)
  4583.                 )
  4584.               ; Aufruf einer globalen Funktion INLINE m÷glich
  4585.               (c-FUNCALL-INLINE fun args nil inline-lambdabody nil)
  4586.               (c-NORMAL-FUNCTION-CALL fun)
  4587.       ) ) ) )
  4588.       (c-NORMAL-FUNCTION-CALL fun)
  4589. ) ) )
  4590.  
  4591. ; Hilfsfunktion: PROCLAIM beim Compilieren vom File, vgl. Funktion PROCLAIM
  4592. (defun c-PROCLAIM (declspec)
  4593.   (when (consp declspec)
  4594.     (case (car declspec)
  4595.       (SPECIAL
  4596.         (dolist (var (cdr declspec))
  4597.           (when (symbolp var) (pushnew var *known-special-vars* :test #'eq))
  4598.       ) )
  4599.       (INLINE
  4600.         (dolist (var (cdr declspec))
  4601.           (when (function-name-p var)
  4602.             (pushnew var *inline-functions* :test #'equal)
  4603.             (setq *notinline-functions* (delete var *notinline-functions* :test #'equal))
  4604.       ) ) )
  4605.       (NOTINLINE
  4606.         (dolist (var (cdr declspec))
  4607.           (when (function-name-p var)
  4608.             (pushnew var *notinline-functions* :test #'equal)
  4609.             (setq *inline-functions* (delete var *inline-functions* :test #'equal))
  4610.       ) ) )
  4611.       (DECLARATION
  4612.         (dolist (var (cdr declspec))
  4613.           (when (symbolp var) (pushnew var *user-declaration-types* :test #'eq))
  4614.       ) )
  4615. ) ) )
  4616.  
  4617. ; Hilfsfunktion: DEFCONSTANT beim Compilieren
  4618. (defun c-PROCLAIM-CONSTANT (symbol initial-value-form)
  4619.   (when *compiling-from-file*
  4620.     (pushnew symbol *known-special-vars* :test #'eq)
  4621.     (when (c-constantp initial-value-form)
  4622.       (push (cons symbol (c-constant-value initial-value-form))
  4623.             *constant-special-vars*
  4624. ) ) ) )
  4625.  
  4626. ; Hilfsfunktion: DEFUN beim Compilieren
  4627. (defun c-DEFUN (symbol &optional lambdabody)
  4628.   (when *compiling* ; c-DEFUN kann auch vom Expander aus aufgerufen werden!
  4629.     (when *compiling-from-file*
  4630.       (pushnew symbol *known-functions* :test #'equal)
  4631.       (when lambdabody ; Lambdabody angegeben ->
  4632.         ; Funktionsdefinition erfolgt im Top-Level-Environment und ist inlinebar.
  4633.         (push (cons symbol lambdabody) *inline-definitions*)
  4634. ) ) ) )
  4635.  
  4636. ; Hilfsfunktion: PROVIDE beim Compilieren vom File, vgl. Funktion PROVIDE
  4637. (defun c-PROVIDE (module-name)
  4638.   (pushnew (string module-name) *compiled-modules* :test #'string=)
  4639. )
  4640.  
  4641. ; Hilfsfunktion: REQUIRE beim Compilieren vom File, vgl. Funktion REQUIRE
  4642. (defun c-REQUIRE (module-name &optional (pathname nil p-given))
  4643.   (unless (member (string module-name) *compiled-modules* :test #'string-equal)
  4644.     (unless p-given (setq pathname (pathname module-name)))
  4645.     (flet ((load-lib (file)
  4646.              (let* ((present-files
  4647.                       (search-file file (append *source-file-types* '(#".lib")))
  4648.                     )
  4649.                     (newest-file (first present-files)))
  4650.                ; Falls das libfile unter den gefundenen Files vorkommt
  4651.                ; und das neueste ist:
  4652.                (if (and (consp present-files)
  4653.                         (string= (pathname-type newest-file)
  4654.                                  '#,(pathname-type '#".lib")
  4655.                    )    )
  4656.                  (load newest-file :verbose nil :print nil :echo nil) ; libfile laden
  4657.                  (compile-file (or newest-file file)) ; file compilieren
  4658.           )) ) )
  4659.       (if (atom pathname) (load-lib pathname) (mapcar #'load-lib pathname))
  4660. ) ) )
  4661.  
  4662. ;;; Hilfsfunktionen fⁿr
  4663. ;;; LET/LET*/MULTIPLE-VALUE-BIND/Lambda-Ausdruck/FLET/LABELS:
  4664.  
  4665. ;; Syntaxanalyse:
  4666.  
  4667. ; analysiert eine Parameterliste von LET/LET*, liefert:
  4668. ; die Liste der Symbole,
  4669. ; die Liste der Formen.
  4670. (defun analyze-letlist (parameters)
  4671.   (do ((L parameters (cdr L))
  4672.        (symbols nil)
  4673.        (forms nil))
  4674.       ((null L) (values (nreverse symbols) (nreverse forms)))
  4675.     (cond ((symbolp (car L)) (push (car L) symbols) (push nil forms))
  4676.           ((and (consp (car L)) (symbolp (caar L))
  4677.                 (consp (cdar L)) (null (cddar L))
  4678.            )
  4679.            (push (caar L) symbols) (push (cadar L) forms)
  4680.           )
  4681.           (t (catch 'c-error
  4682.                (c-error (DEUTSCH "Falsche Syntax in LET/LET*: ~S"
  4683.                          ENGLISH "Illegal syntax in LET/LET*: ~S"
  4684.                          FRANCAIS "Mauvaise syntaxe pour LET/LET* : ~S")
  4685.                         (car L)
  4686.     )     )  ) )
  4687. ) )
  4688.  
  4689. ; analysiert eine Lambdaliste einer Funktion (CLTL S. 60), liefert 13 Werte:
  4690. ; 1. Liste der required Parameter
  4691. ; 2. Liste der optionalen Parameter
  4692. ; 3. Liste der Initformen der optionalen Parameter
  4693. ; 4. Liste der Svars zu den optionalen Parametern (0 fⁿr die fehlenden)
  4694. ; 5. Rest-Parameter oder 0
  4695. ; 6. Flag, ob Keywords erlaubt sind
  4696. ; 7. Liste der Keywords
  4697. ; 8. Liste der Keyword-Parameter
  4698. ; 9. Liste der Initformen der Keyword-Parameter
  4699. ; 10. Liste der Svars zu den Keyword-Parametern (0 fⁿr die fehlenden)
  4700. ; 11. Flag, ob andere Keywords erlaubt sind
  4701. ; 12. Liste der Aux-Variablen
  4702. ; 13. Liste der Initformen der Aux-Variablen
  4703. (defun analyze-lambdalist (lambdalist)
  4704.   (let ((L lambdalist) ; Rest der Lambdaliste
  4705.         (req nil)
  4706.         (optvar nil)
  4707.         (optinit nil)
  4708.         (optsvar nil)
  4709.         (rest 0)
  4710.         (keyflag nil)
  4711.         (keyword nil)
  4712.         (keyvar nil)
  4713.         (keyinit nil)
  4714.         (keysvar nil)
  4715.         (allow-other-keys nil)
  4716.         (auxvar nil)
  4717.         (auxinit nil))
  4718.        ; alle in umgedrehter Reihenfolge
  4719.     (macrolet ((err-illegal (item)
  4720.                  `(catch 'c-error
  4721.                     (c-error (DEUTSCH "Dieser Lambdalistenmarker ist an dieser Stelle nicht erlaubt: ~S"
  4722.                               ENGLISH "Lambda list marker ~S not allowed here."
  4723.                               FRANCAIS "Le marqueur de liste lambda ~S n'est pas permis ici.")
  4724.                              ,item
  4725.                   ) )
  4726.                )
  4727.                (err-norest ()
  4728.                  `(catch 'c-error
  4729.                     (c-error (DEUTSCH "Fehlender &REST-Parameter in der Lambdaliste: ~S"
  4730.                               ENGLISH "Missing &REST parameter in lambda list ~S"
  4731.                               FRANCAIS "Il manque le paramΦtre &REST dans la liste lambda ~S")
  4732.                              lambdalist
  4733.                   ) )
  4734.                )
  4735.                (err-superflu (item)
  4736.                  `(catch 'c-error
  4737.                     (c-error (DEUTSCH "▄berflⁿssiges Lambdalisten-Element: ~S"
  4738.                               ENGLISH "Lambda list element ~S is superfluous."
  4739.                               FRANCAIS "L'ΘlΘment de liste lambda est superflu : ~S")
  4740.                              ,item
  4741.                   ) )
  4742.               ))
  4743.       ; Required Parameter:
  4744.       (loop
  4745.         (if (atom L) (return))
  4746.         (let ((item (car L)))
  4747.           (if (symbolp item)
  4748.             (if (memq item lambda-list-keywords)
  4749.               (if (memq item '(&optional &rest &key &aux))
  4750.                 (return)
  4751.                 (err-illegal item)
  4752.               )
  4753.               (push item req)
  4754.             )
  4755.             (lambdalist-error item)
  4756.         ) )
  4757.         (setq L (cdr L))
  4758.       )
  4759.       ; Hier gilt (or (atom L) (member (car L) '(&optional &rest &key &aux))).
  4760.       ; Optionale Parameter:
  4761.       (when (and (consp L) (eq (car L) '&optional))
  4762.         (setq L (cdr L))
  4763.         (loop
  4764.           (if (atom L) (return))
  4765.           (let ((item (car L)))
  4766.             (if (symbolp item)
  4767.               (if (memq item lambda-list-keywords)
  4768.                 (if (memq item '(&rest &key &aux))
  4769.                   (return)
  4770.                   (err-illegal item)
  4771.                 )
  4772.                 (progn (push item optvar) (push nil optinit) (push 0 optsvar))
  4773.               )
  4774.               (if (and (consp item) (symbolp (car item)))
  4775.                 (if (null (cdr item))
  4776.                   (progn (push (car item) optvar) (push nil optinit) (push 0 optsvar))
  4777.                   (if (consp (cdr item))
  4778.                     (if (null (cddr item))
  4779.                       (progn (push (car item) optvar) (push (cadr item) optinit) (push 0 optsvar))
  4780.                       (if (and (consp (cddr item)) (symbolp (caddr item)) (null (cdddr item)))
  4781.                         (progn (push (car item) optvar) (push (cadr item) optinit) (push (caddr item) optsvar))
  4782.                         (lambdalist-error item)
  4783.                     ) )
  4784.                     (lambdalist-error item)
  4785.                 ) )
  4786.                 (lambdalist-error item)
  4787.           ) ) )
  4788.           (setq L (cdr L))
  4789.       ) )
  4790.       ; Hier gilt (or (atom L) (member (car L) '(&rest &key &aux))).
  4791.       ; Rest-Parameter:
  4792.       (when (and (consp L) (eq (car L) '&rest))
  4793.         (setq L (cdr L))
  4794.         (if (atom L)
  4795.           (err-norest)
  4796.           (prog ((item (car L)))
  4797.             (if (symbolp item)
  4798.               (if (memq item lambda-list-keywords)
  4799.                 (progn (err-norest) (return))
  4800.                 (setq rest item)
  4801.               )
  4802.               (lambdalist-error item)
  4803.             )
  4804.             (setq L (cdr L))
  4805.       ) ) )
  4806.       ; Vorrⁿcken bis zum nΣchsten &key oder &aux :
  4807.       (loop
  4808.         (when (atom L) (return))
  4809.         (let ((item (car L)))
  4810.           (if (memq item lambda-list-keywords)
  4811.             (if (memq item '(&key &aux))
  4812.               (return)
  4813.               (err-illegal item)
  4814.             )
  4815.             (err-superflu item)
  4816.         ) )
  4817.         (setq L (cdr L))
  4818.       )
  4819.       ; Hier gilt (or (atom L) (member (car L) '(&key &aux))).
  4820.       ; Keyword-Parameter:
  4821.       (when (and (consp L) (eq (car L) '&key))
  4822.         (setq L (cdr L))
  4823.         (setq keyflag t)
  4824.         (loop
  4825.           (if (atom L) (return))
  4826.           (let ((item (car L)))
  4827.             (if (symbolp item)
  4828.               (if (memq item lambda-list-keywords)
  4829.                 (if (memq item '(&allow-other-keys &aux))
  4830.                   (return)
  4831.                   (err-illegal item)
  4832.                 )
  4833.                 (progn
  4834.                   (push (intern (symbol-name item) *keyword-package*) keyword)
  4835.                   (push item keyvar) (push nil keyinit) (push 0 keysvar)
  4836.               ) )
  4837.               (if (and
  4838.                     (consp item)
  4839.                     (or
  4840.                       (symbolp (car item))
  4841.                       (and (consp (car item))
  4842.                            (keywordp (caar item))
  4843.                            (consp (cdar item))
  4844.                            (symbolp (cadar item))
  4845.                            (null (cddar item))
  4846.                     ) )
  4847.                     (or (null (cdr item))
  4848.                         (and (consp (cdr item))
  4849.                              (or (null (cddr item))
  4850.                                  (and (consp (cddr item)) (symbolp (caddr item)) (null (cdddr item)))
  4851.                   ) )   )    )
  4852.                 (progn
  4853.                   (if (consp (car item))
  4854.                     (progn (push (caar item) keyword) (push (cadar item) keyvar))
  4855.                     (progn (push (intern (symbol-name (car item)) *keyword-package*) keyword) (push (car item) keyvar))
  4856.                   )
  4857.                   (if (consp (cdr item))
  4858.                     (progn
  4859.                       (push (cadr item) keyinit)
  4860.                       (if (consp (cddr item))
  4861.                         (push (caddr item) keysvar)
  4862.                         (push 0 keysvar)
  4863.                     ) )
  4864.                     (progn (push nil keyinit) (push 0 keysvar))
  4865.                 ) )
  4866.                 (lambdalist-error item)
  4867.           ) ) )
  4868.           (setq L (cdr L))
  4869.         )
  4870.         ; Hier gilt (or (atom L) (member (car L) '(&allow-other-keys &aux))).
  4871.         (when (and (consp L) (eq (car L) '&allow-other-keys))
  4872.           (setq allow-other-keys t)
  4873.           (setq L (cdr L))
  4874.       ) )
  4875.       ; Vorrⁿcken bis zum nΣchsten &AUX :
  4876.       (loop
  4877.         (when (atom L) (return))
  4878.         (let ((item (car L)))
  4879.           (if (memq item lambda-list-keywords)
  4880.             (if (memq item '(&aux))
  4881.               (return)
  4882.               (err-illegal item)
  4883.             )
  4884.             (err-superflu item)
  4885.         ) )
  4886.         (setq L (cdr L))
  4887.       )
  4888.       ; Hier gilt (or (atom L) (member (car L) '(&aux))).
  4889.       ; &AUX-Variablen:
  4890.       (when (and (consp L) (eq (car L) '&aux))
  4891.         (setq L (cdr L))
  4892.         (loop
  4893.           (if (atom L) (return))
  4894.           (let ((item (car L)))
  4895.             (if (symbolp item)
  4896.               (if (memq item lambda-list-keywords)
  4897.                 (err-illegal item)
  4898.                 (progn (push item auxvar) (push nil auxinit))
  4899.               )
  4900.               (if (and (consp item) (symbolp (car item)))
  4901.                 (if (null (cdr item))
  4902.                   (progn (push (car item) auxvar) (push nil auxinit))
  4903.                   (if (and (consp (cdr item)) (null (cddr item)))
  4904.                     (progn (push (car item) auxvar) (push (cadr item) auxinit))
  4905.                     (lambdalist-error item)
  4906.                 ) )
  4907.                 (lambdalist-error item)
  4908.           ) ) )
  4909.           (setq L (cdr L))
  4910.       ) )
  4911.       ; Hier gilt (atom L).
  4912.       (if L
  4913.         (catch 'c-error
  4914.           (c-error (DEUTSCH "Eine Lambdaliste, die einen Punkt enthΣlt, ist nur bei Macros erlaubt, nicht hier: ~S"
  4915.                     ENGLISH "Lambda lists with dots are only allowed in macros, not here: ~S"
  4916.                     FRANCAIS "Les listes lambdas contenant une paire pointΘe ne sont permises qu'avec des macros et non ici : ~S")
  4917.                    lambdalist
  4918.       ) ) )
  4919.     )
  4920.     (values
  4921.       (nreverse req)
  4922.       (nreverse optvar) (nreverse optinit) (nreverse optsvar)
  4923.       rest
  4924.       keyflag
  4925.       (nreverse keyword) (nreverse keyvar) (nreverse keyinit) (nreverse keysvar)
  4926.       allow-other-keys
  4927.       (nreverse auxvar) (nreverse auxinit)
  4928. ) ) )
  4929.  
  4930. (defun lambdalist-error (item)
  4931.   (catch 'c-error
  4932.     (c-error (DEUTSCH "UnzulΣssiges Lambdalistenelement: ~S"
  4933.               ENGLISH "Illegal lambda list element ~S"
  4934.               FRANCAIS "N'est pas permis dans une liste lambda : ~S")
  4935.              item
  4936. ) ) )
  4937.  
  4938. ; (inline-callable-function-p form n) stellt fest, ob form eine Form ist, die
  4939. ; eine Funktion liefert, die mit n (und evtl. mehr) Argumenten Inline
  4940. ; aufgerufen werden kann. (vorbehaltlich Syntax-Errors in der Lambdaliste)
  4941. (defun inline-callable-function-p (form n &optional (more nil))
  4942.   ; mu▀ von der Bauart (FUNCTION funname) sein
  4943.   (and (consp form) (eq (first form) 'FUNCTION)
  4944.        (consp (cdr form)) (null (cddr form))
  4945.        (let ((funname (second form)))
  4946.          ; funname mu▀ von der Bauart (LAMBDA lambdalist ...) sein
  4947.          (and (consp funname) (eq (first funname) 'LAMBDA) (consp (cdr funname))
  4948.               (let ((lambdalist (second funname)))
  4949.                 ; lambdalist mu▀ eine Liste sein, die kein &KEY enthΣlt
  4950.                 ; (Funktionen mit &KEY werden nicht INLINE-expandiert, weil die
  4951.                 ; Zuordnung von den Argumenten zu den Variablen nur dynamisch,
  4952.                 ; mit GETF, m÷glich ist, und das kann die in Assembler
  4953.                 ; geschriebene APPLY-Routine schneller.)
  4954.                 (and (listp lambdalist)
  4955.                      (not (position '&KEY lambdalist))
  4956.                      (not (position '&ALLOW-OTHER-KEYS lambdalist))
  4957.                      (let ((&opt-pos (position '&OPTIONAL lambdalist))
  4958.                            (&rest-pos (position '&REST lambdalist))
  4959.                            (&aux-pos (or (position '&AUX lambdalist)
  4960.                                          (length lambdalist)
  4961.                           ))         )
  4962.                        (if &rest-pos
  4963.                          ; &rest angegeben
  4964.                          (or more (>= n (or &opt-pos &rest-pos)))
  4965.                          ; &rest nicht angegeben
  4966.                          (if more
  4967.                            (<= n (if &opt-pos (- &aux-pos 1) &aux-pos))
  4968.                            (if &opt-pos
  4969.                              (<= &opt-pos n (- &aux-pos 1))
  4970.                              (= n &aux-pos)
  4971.                      ) ) ) )
  4972.               ) )
  4973.        ) )
  4974. ) )
  4975.  
  4976.  
  4977. ;; Special-deklarierte Symbole:
  4978.  
  4979. (defvar *specials*) ; Liste aller zuletzt special deklarierten Symbole
  4980. (defvar *ignores*) ; Liste aller zuletzt ignore deklarierten Symbole
  4981. (defvar *ignorables*) ; Liste aller zuletzt ignorable deklarierten Symbole
  4982.  
  4983. ; pusht alle Symbole von specials als Variablen auf *venv* :
  4984. (defun push-specials ()
  4985.   (apply #'push-*venv* (mapcar #'make-special-var *specials*))
  4986. )
  4987.  
  4988. ; ▄berprⁿft eine Variable, ob sie zu Recht ignore-deklariert ist oder nicht...
  4989. (defun ignore-check (var)
  4990.   (let ((sym (var-name var)))
  4991.     (if (member sym *ignores* :test #'eq)
  4992.       ; var ignore-deklariert
  4993.       (if (var-specialp var)
  4994.         (c-warn (DEUTSCH "Binden der Variablen ~S kann trotz IGNORE-Deklaration~%Seiteneffekte haben, weil sie SPECIAL deklariert ist."
  4995.                  ENGLISH "Binding variable ~S can cause side effects despite of IGNORE declaration~%since it is declared SPECIAL."
  4996.                  FRANCAIS "Lier la variable ~S peut avoir des effets de bord malgrΘ la dΘclaration IGNORE~%car elle a ΘtΘ dΘclarΘe SPECIAL.")
  4997.                 sym
  4998.         )
  4999.         (if (var-usedp var)
  5000.           (c-warn (DEUTSCH "Variable ~S wird trotz IGNORE-Deklaration benutzt."
  5001.                    ENGLISH "variable ~S is used despite of IGNORE declaration."
  5002.                    FRANCAIS "La variable ~S est utilisΘe malgrΘ la dΘclaration IGNORE.")
  5003.                   sym
  5004.       ) ) )
  5005.       ; var nicht ignore-deklariert
  5006.       (unless (member sym *ignorables* :test #'eq)
  5007.         ; var auch nicht ignorable-deklariert
  5008.         (unless (or (var-specialp var) (var-usedp var))
  5009.           ; var lexikalisch und unbenutzt
  5010.           (unless (null (symbol-package sym)) ; sym ein (gensym) ?
  5011.             ; (Symbole ohne Home-Package kommen nicht vom Benutzer, die Warnung
  5012.             ; wⁿrde nur verwirren).
  5013.             (c-warn (DEUTSCH "Variable ~S wird nicht benutzt.~%Schreibfehler oder fehlende IGNORE-Deklaration?"
  5014.                      ENGLISH "variable ~S is not used.~%Misspelled or missing IGNORE declaration?"
  5015.                      FRANCAIS "La variable ~S n'est pas utilisΘe.~%Mauvaise orthographe ou dΘclaration IGNORE manquante?")
  5016.                     sym
  5017. ) ) ) ) ) ) )
  5018.  
  5019. ; liefert den Code, der zum neuen Aufbau einer Closure und ihrer Unterbringung
  5020. ; im Stack n÷tig ist:
  5021. ; Dieser Code erweitert das von (cdr venvc) beschriebene Venv um closurevars,
  5022. ; (cdr stackz) ist der aktuelle Stackzustand.
  5023. ; Nach Aufbau der Closure sind venvc bzw. stackz die aktuellen ZustΣnde.
  5024. (defun c-MAKE-CLOSURE (closurevars venvc stackz)
  5025.   (if closurevars
  5026.     `((VENV ,(cdr venvc) ,(cdr stackz))
  5027.       (MAKE-VECTOR1&PUSH ,(length closurevars))
  5028.      )
  5029.     '()
  5030. ) )
  5031.  
  5032. ;; Es gibt zwei Arten von Variablen-Bindungs-Vorgehensweisen:
  5033. ; 1. fixed-var: die Variable hat eine Position im Stack, darf nicht wegoptimiert
  5034. ;               werden. Ist die Variable dann doch in der Closure, so mu▀ ihr
  5035. ;               Wert dorthin ⁿbertragen werden; ist die Variable dynamisch, so
  5036. ;               mu▀ ein Bindungsframe aufgemacht werden.
  5037. ;               Auftreten: MULTIPLE-VALUE-BIND, Lambda-Ausdruck (required,
  5038. ;               optional, rest, keyword - Parameter)
  5039. ; 2. movable-var: die Variable darf wegoptimiert werden, falls sie konstant ist
  5040. ;                 (sie entweder dynamisch und konstant ist oder lexikalisch
  5041. ;                  und an eine Konstante gebunden und nie geSETQed wird). Hier
  5042. ;                 spielt also der Init-Wert eine Rolle.
  5043. ;                 Auftreten: LET, LET*, Lambda-Ausdruck (optional-svar,
  5044. ;                 keyword-svar, aux-Variablen)
  5045.  
  5046. ;; 1. fixed-var
  5047.  
  5048. ; Bindung einer fixed-var:
  5049. ; symbol --> Variable
  5050. ; LΣ▀t *stackz* unverΣndert.
  5051. (defun bind-fixed-var-1 (symbol)
  5052.   (if (or (constantp symbol)
  5053.           (proclaimed-special-p symbol)
  5054.           (member symbol *specials* :test #'eq)
  5055.       )
  5056.     ; mu▀ symbol dynamisch binden:
  5057.     (progn
  5058.       (when (c-constantp symbol)
  5059.         (catch 'c-error
  5060.           (c-error (DEUTSCH "Konstante ~S kann nicht gebunden werden."
  5061.                     ENGLISH "Constant ~S cannot be bound."
  5062.                     FRANCAIS "La constante ~S ne peut pas Ωtre liΘe.")
  5063.                    symbol
  5064.       ) ) )
  5065.       (make-special-var symbol)
  5066.     )
  5067.     ; mu▀ symbol lexikalisch binden:
  5068.     (make-var :name symbol :specialp nil :constantp nil
  5069.               :usedp nil :really-usedp nil :closurep nil
  5070.               :stackz *stackz* :venvc *venvc*
  5071.     )
  5072. ) )
  5073.  
  5074. ; registriert in *stackz*, da▀ eine fixed-var gebunden wird
  5075. (defun bind-fixed-var-2 (var)
  5076.   (when (and (var-specialp var) (not (var-constantp var)))
  5077.     (push '(BIND 1) *stackz*)
  5078. ) )
  5079.  
  5080. ; liefert den Code, der die Variable var an den Inhalt von stackdummyvar
  5081. ; bindet. stackz ist der Stackzustand vor dem Binden dieser Variablen.
  5082. (defun c-bind-fixed-var (var stackdummyvar stackz)
  5083.   (if (var-specialp var)
  5084.     (if (var-constantp var)
  5085.       '() ; Konstante kann nicht gebunden werden
  5086.       `((GET ,stackdummyvar ,*venvc* ,stackz)
  5087.         (BIND ,(new-const (var-name var)))
  5088.        )
  5089.     )
  5090.     ; var lexikalisch, nach Definition nicht konstant
  5091.     (if (var-closurep var)
  5092.       `((GET ,stackdummyvar ,*venvc* ,stackz)
  5093.         (SET ,var ,*venvc* ,stackz)
  5094.        )
  5095.       '() ; var und stackdummyvar identisch
  5096. ) ) )
  5097.  
  5098. ; Kreiert je eine Stackvariable und eine Fixed-Variable zu jedem Symbol aus der
  5099. ; Variablenliste symbols und liefert beide Listen als Werte.
  5100. (defun process-fixed-var-list (symbols &optional optimflags)
  5101.   (do ((symbolsr symbols (cdr symbolsr))
  5102.        (optimflagsr optimflags (cdr optimflagsr))
  5103.        (varlist nil) ; Liste der Variablen
  5104.        (stackvarlist nil)) ; Liste der Stackvariablen (teils Dummys)
  5105.       ((null symbolsr) (values (nreverse varlist) (nreverse stackvarlist)))
  5106.     (push 1 *stackz*)
  5107.     ; (mit constantp=nil und really-usedp=t, um eine Wegoptimierung zu vermeiden)
  5108.     (push (make-var :name (gensym) :specialp nil :constantp nil
  5109.                     :usedp nil :really-usedp (null (car optimflagsr))
  5110.                     :closurep nil :stackz *stackz* :venvc *venvc*
  5111.           )
  5112.           stackvarlist
  5113.     )
  5114.     (push (bind-fixed-var-1 (car symbolsr)) varlist)
  5115. ) )
  5116.  
  5117. ; Eliminiert alle Zuweisungen auf eine unbenutzte Variable.
  5118. (defun unmodify-unused-var (var)
  5119.   (dolist (modified (var-modified-list var))
  5120.     (if (cddr modified)
  5121.       ; Wert der Zuweisung wird gebraucht
  5122.       (let ((set-anode (second modified))) ; Anode der Zuweisung selbst
  5123.         (setf (anode-code set-anode) '((VALUES1))) ; Zuweisung entfernen
  5124.       )
  5125.       ; Wert der Zuweisung wird nicht gebraucht
  5126.       (progn
  5127.         (let ((value-anode (first modified))) ; Anode fⁿr zugewiesenen Wert
  5128.           (when (null (cdr (anode-seclass value-anode)))
  5129.             (setf (anode-code value-anode) '()) ; evtl. Wert-Form entfernen
  5130.         ) )
  5131.         (let ((set-anode (second modified))) ; Anode der Zuweisung selbst
  5132.           (setf (anode-code set-anode) '()) ; Zuweisung entfernen
  5133. ) ) ) ) )
  5134.  
  5135. ; ▄berprⁿft und optimiert die Variablen
  5136. ; und liefert die Liste der Closure-Variablen (in der richtigen Reihenfolge).
  5137. (defun checking-fixed-var-list (varlist &optional optimflaglist)
  5138.   (let ((closurevarlist '()))
  5139.     (dolist (var varlist (nreverse closurevarlist))
  5140.       ; 1. Schritt: eventuelle Warnungen ausgeben
  5141.       (ignore-check var)
  5142.       ; 2. Schritt: Variablen-Ort (Stack oder Closure) endgⁿltig bestimmen,
  5143.       ; evtl. optimieren
  5144.       (unless (var-specialp var)
  5145.         ; nur lexikalische Variablen k÷nnen in der Closure liegen,
  5146.         ; nur bei lexikalischen Variablen kann optimiert werden
  5147.         (if (not (var-really-usedp var))
  5148.           ; Variable lexikalisch und unbenutzt
  5149.           (progn ; Variable eliminieren
  5150.             (setf (var-closurep var) nil)
  5151.             (when (car optimflaglist) ; optimierbare fixed-var?
  5152.               (setf (first (var-stackz var)) 0) ; aus dem Stack entfernen
  5153.               (setf (car optimflaglist) 'GONE) ; als gestrichen vermerken
  5154.             )
  5155.             (unmodify-unused-var var) ; Zuweisungen auf var eliminieren
  5156.           )
  5157.           (when (var-closurep var)
  5158.             ; Variable mu▀ in der Closure liegen
  5159.             (push var closurevarlist)
  5160.       ) ) )
  5161.       (setq optimflaglist (cdr optimflaglist))
  5162. ) ) )
  5163.  
  5164. ;; 2. movable-var
  5165.  
  5166. ; Beim Binden einer Variablen var an einen Anode anode:
  5167. ; Wird eine lexikalische Variable an den Wert an einer lexikalischen Variablen
  5168. ; gebunden? Wenn ja, an welche Variable?
  5169. (defun bound-to-var-p (var anode)
  5170.   (if (var-specialp var)
  5171.     nil
  5172.     ; var lexikalisch
  5173.     (loop
  5174.       (unless (eql (length (anode-code anode)) 1) (return nil))
  5175.       (setq anode (first (anode-code anode)))
  5176.       (unless (anode-p anode)
  5177.         (if (and (consp anode) (eq (first anode) 'GET))
  5178.           ; Code zum Anode besteht genau aus ((GET outervar ...)).
  5179.           (return (second anode))
  5180.           (return nil)
  5181.     ) ) )
  5182. ) )
  5183.  
  5184. ; Bindung einer movable-var:
  5185. ; symbol form-anode --> Variable
  5186. ; erweitert *stackz* um genau einen Eintrag
  5187. (defun bind-movable-var (symbol form-anode)
  5188.   (if (or (constantp symbol)
  5189.           (proclaimed-special-p symbol)
  5190.           (member symbol *specials* :test #'eq)
  5191.       )
  5192.     ; mu▀ symbol dynamisch binden:
  5193.     (progn
  5194.       (if (c-constantp symbol)
  5195.         (progn
  5196.           (catch 'c-error
  5197.             (c-error (DEUTSCH "Konstante ~S kann nicht gebunden werden."
  5198.                       ENGLISH "Constant ~S cannot be bound."
  5199.                       FRANCAIS "La constante ~S ne peut pas Ωtre liΘe.")
  5200.                      symbol
  5201.           ) )
  5202.           (push 0 *stackz*)
  5203.         )
  5204.         (push '(BIND 1) *stackz*)
  5205.       )
  5206.       (make-special-var symbol)
  5207.     )
  5208.     ; mu▀ symbol lexikalisch binden:
  5209.     (let ((var
  5210.             (progn
  5211.               (push 1 *stackz*) ; vorlΣufig: 1 Platz auf dem Stack
  5212.               (make-var :name symbol :specialp nil
  5213.                 :constantp (anode-constantp form-anode) ; wird bei Zuweisungen auf NIL gesetzt
  5214.                 :constant (if (anode-constantp form-anode) (anode-constant form-anode))
  5215.                 :usedp nil :really-usedp nil :closurep nil ; wird evtl. auf T gesetzt
  5216.                 :stackz *stackz* :venvc *venvc*
  5217.          )) ) )
  5218.       (let ((outervar (bound-to-var-p var form-anode)))
  5219.         (when outervar ; Wird var an eine Variable outervar gebunden, so
  5220.                        ; darf spΣter evtl. jede Referenz zu var in eine
  5221.                        ; Referenz zu outervar umgewandelt werden.
  5222.           (push (list var form-anode) (var-replaceable-list outervar))
  5223.       ) )
  5224.       var
  5225. ) ) )
  5226.  
  5227. ; liefert den Code, der die Variable var an A0 bindet:
  5228. (defun c-bind-movable-var (var)
  5229.   (if (var-specialp var)
  5230.     (if (var-constantp var)
  5231.       '() ; dynamische Konstanten k÷nnen nicht gebunden werden
  5232.       `((BIND ,(new-const (var-name var))))
  5233.     )
  5234.     (if (var-closurep var)
  5235.       ; Closure-Variable schreiben:
  5236.       ; (var-stackz var) = (0 . ...) ist der aktuelle Stackzustand.
  5237.       `((SET ,var ,*venvc* ,(var-stackz var)))
  5238.       ; lexikalische Variable: wurde eventuell aus dem Stack eliminiert
  5239.       (if (zerop (first (var-stackz var)))
  5240.         '()
  5241.         `((PUSH)) ; im Stack: in die nΣchstuntere Stacklocation schreiben
  5242. ) ) ) )
  5243.  
  5244. ; liefert den Code, der die Variable var an das Ergebnis des ANODEs anode bindet
  5245. (defun c-bind-movable-var-anode (var anode)
  5246.   (let ((binding-anode
  5247.           (make-anode :type 'BIND-MOVABLE
  5248.                       :sub-anodes '()
  5249.                       :seclass '(NIL . NIL)
  5250.                       :code (c-bind-movable-var var)
  5251.        )) )
  5252.     (let ((outervar (bound-to-var-p var anode)))
  5253.       (when outervar ; Wird var an eine Variable outervar gebunden, so
  5254.                      ; darf spΣter evtl. jede Referenz zu var in eine
  5255.                      ; Referenz zu outervar umgewandelt werden.
  5256.         (dolist (innervar-info (var-replaceable-list outervar))
  5257.           (when (eq (first innervar-info) var)
  5258.             (setf (cddr innervar-info) binding-anode) ; binding-anode nachtragen
  5259.     ) ) ) )
  5260.     (list anode binding-anode)
  5261. ) )
  5262.  
  5263. ; (process-movable-var-list symbols initforms *-flag) compiliert die initforms
  5264. ; (wie bei LET/LET*) und assoziiert sie mit den Variablen zu symbols.
  5265. ; VerΣndert *venv* (bei *-flag : incrementell, sonst auf einmal).
  5266. ; Liefert drei Werte:
  5267. ; 1. Liste der Variablen,
  5268. ; 2. Liste der ANODEs zu den initforms,
  5269. ; 3. Liste der StackzustΣnde nach dem Binden der Variablen.
  5270. (defun process-movable-var-list (symbols initforms *-flag)
  5271.   (do ((symbolsr symbols (cdr symbolsr))
  5272.        (initformsr initforms (cdr initformsr))
  5273.        (varlist '())
  5274.        (anodelist '())
  5275.        (stackzlist '()))
  5276.       ((null symbolsr)
  5277.        (unless *-flag (apply #'push-*venv* varlist)) ; Binden bei LET
  5278.        (values (nreverse varlist) (nreverse anodelist) (nreverse stackzlist))
  5279.       )
  5280.     (let* ((initform (car initformsr))
  5281.            (anode (c-form initform 'ONE)) ; initform compilieren
  5282.            (var (bind-movable-var (car symbolsr) anode)))
  5283.       (push anode anodelist)
  5284.       (push var varlist)
  5285.       (push *stackz* stackzlist)
  5286.       (when *-flag (push-*venv* var)) ; Binden bei LET*
  5287. ) ) )
  5288.  
  5289. ; ▄berprⁿft und optimiert die Variablen (wie bei LET/LET*)
  5290. ; und liefert die Liste der Closure-Variablen (in der richtigen Reihenfolge).
  5291. (defun checking-movable-var-list (varlist anodelist)
  5292.   (do ((varlistr varlist (cdr varlistr))
  5293.        (anodelistr anodelist (cdr anodelistr))
  5294.        (closurevarlist '()))
  5295.       ((null varlistr) (nreverse closurevarlist))
  5296.     (let ((var (car varlistr)))
  5297.       (when var
  5298.         ; 1. Schritt: eventuelle Warnungen ausgeben
  5299.         (ignore-check var)
  5300.         ; 2. Schritt: Variablen-Ort (Stack oder Closure oder eliminiert)
  5301.         ; endgⁿltig bestimmen
  5302.         (unless (var-specialp var)
  5303.           ; nur bei lexikalischen Variablen kann optimiert werden
  5304.           (if (var-constantp var)
  5305.             ; Variable lexikalisch und konstant
  5306.             (progn ; Variable eliminieren
  5307.               (setf (var-closurep var) nil)
  5308.               (setf (first (var-stackz var)) 0) ; aus dem Stack entfernen
  5309.               (when (null (cdr (anode-seclass (car anodelistr))))
  5310.                 (setf (anode-code (car anodelistr)) '()) ; evtl. initform entfernen
  5311.             ) )
  5312.             (if (not (var-really-usedp var))
  5313.               ; Variable lexikalisch und unbenutzt
  5314.               (progn ; Variable eliminieren
  5315.                 (setf (var-closurep var) nil)
  5316.                 (setf (first (var-stackz var)) 0) ; aus dem Stack entfernen
  5317.                 (when (null (cdr (anode-seclass (car anodelistr))))
  5318.                   (setf (anode-code (car anodelistr)) '()) ; evtl. initform entfernen
  5319.                 )
  5320.                 (unmodify-unused-var var) ; Zuweisungen auf var eliminieren
  5321.               )
  5322.               (when (var-closurep var)
  5323.                 ; Variable mu▀ in der Closure liegen
  5324.                 (setf (first (var-stackz var)) 0) ; belegt 0 Stack-EintrΣge
  5325.                 (push var closurevarlist)
  5326.         ) ) ) )
  5327. ) ) ) )
  5328.  
  5329. ; Optimiert eine Liste von Variablen.
  5330. ; (In der Liste mⁿssen die lexikalisch inneren Variablen zuletzt kommen.)
  5331. (defun optimize-var-list (vars)
  5332.   (unless *no-code*
  5333.     (dolist (var (reverse vars))
  5334.       (when var
  5335.         ; Optimierung (innere Variablen zuerst):
  5336.         ; Wird eine Variable innervar an den Wert von var gebunden, wird
  5337.         ; wΣhrend der Lebensdauer von innervar weder innervar noch var verΣndert
  5338.         ; (um dies sicherstellen zu k÷nnen, mⁿssen beide lexikalisch und im Stack
  5339.         ; sein), so kann innervar durch var ersetzt werden.
  5340.         (unless (or (var-specialp var) (var-closurep var))
  5341.           ; var ist lexikalisch und im Stack
  5342.           (dolist (innervar-info (var-replaceable-list var))
  5343.             (let ((innervar (first innervar-info)))
  5344.               ; innervar ist eine movable-var, die mit var initialisiert wird.
  5345.               ; WΣhrend der Lebensdauer von innervar wird var nichts zugewiesen.
  5346.               (unless (or (var-specialp innervar) (var-closurep innervar))
  5347.                 ; innervar ist lexikalisch und im Stack
  5348.                 (when (null (var-modified-list innervar))
  5349.                   ; WΣhrend der Lebensdauer von innervar wird auch innervar
  5350.                   ; nichts zugewiesen.
  5351.                   (unless (eql (first (var-stackz innervar)) 0) ; innervar noch nicht wegoptimiert?
  5352.                     (when (cddr innervar-info) ; und innervar-info korrekt dreigliedrig?
  5353.                       ; Variable innervar eliminieren:
  5354.                       (setf (first (var-stackz innervar)) 0) ; aus dem Stack entfernen
  5355.                       ; Initialisierung und Binden von innervar eliminieren:
  5356.                       (setf (anode-code (second innervar-info)) '())
  5357.                       (setf (anode-code (cddr innervar-info)) '())
  5358.                       ; Die Referenzen auf die Variable innervar werden
  5359.                       ; in Referenzen auf die Variable var umgewandelt:
  5360.                       (let ((using-var (var-usedp var)))
  5361.                         (do ((using-innervar (var-usedp innervar) (cdr using-innervar)))
  5362.                             ((atom using-innervar))
  5363.                           (let* ((anode (car using-innervar)) ; ein Anode vom Typ VAR
  5364.                                  (code (anode-code anode))) ; sein Code, () oder ((GET ...))
  5365.                             (unless (null code)
  5366.                               ; (anode-code anode) ist von der Gestalt ((GET innervar ...))
  5367.                               (setf (second (car code)) var)
  5368.                               (push anode using-var)
  5369.                         ) ) )
  5370.                         (setf (var-usedp var) using-var)
  5371.                       )
  5372.         ) ) ) ) ) ) )
  5373. ) ) ) )
  5374.  
  5375. ; Bildet den Code, der eine Liste von Variablen, zusammen mit ihren svars,
  5376. ; bindet (wie bei Lambdabody- Optional/Key - Variablen).
  5377. (defun c-bind-with-svars (-vars -dummys s-vars -anodes s-anodes -stackzs)
  5378.   (do ((-varsr -vars (cdr -varsr)) ; fixed-vars
  5379.        (-dummysr -dummys (cdr -dummysr))
  5380.        (s-varsr s-vars (cdr s-varsr)) ; movable-vars
  5381.        (-anodesr -anodes (cdr -anodesr))
  5382.        (s-anodesr s-anodes (cdr s-anodesr))
  5383.        (-stackzsr -stackzs (cdr -stackzsr))
  5384.        (L '()))
  5385.       ((null -varsr) (nreverse L))
  5386.     (when (car s-varsr)
  5387.       (setq L
  5388.         (revappend
  5389.           (c-bind-movable-var-anode (car s-varsr) (car s-anodesr))
  5390.           L
  5391.     ) ) )
  5392.     (setq L
  5393.       (revappend
  5394.         (let* ((var (car -varsr))
  5395.                (stackdummyvar (car -dummysr))
  5396.                (anode (car -anodesr))
  5397.                (stackz (car -stackzsr))
  5398.                (label (make-label 'ONE)))
  5399.           (if (var-specialp var)
  5400.             `((JMPIFBOUNDP ,stackdummyvar ,*venvc* ,stackz ,label)
  5401.               ,anode
  5402.               ,label
  5403.               ,@(if (var-constantp var)
  5404.                   '() ; Konstante kann nicht gebunden werden
  5405.                   `((BIND ,(new-const (var-name var))))
  5406.                 )
  5407.              )
  5408.             ; var lexikalisch, nach Definition nicht konstant
  5409.             (if (var-closurep var)
  5410.               `((JMPIFBOUNDP ,stackdummyvar ,*venvc* ,stackz ,label)
  5411.                 ,anode
  5412.                 ,label
  5413.                 (SET ,var ,*venvc* ,stackz)
  5414.                )
  5415.               (if (not (var-really-usedp var))
  5416.                 ; Variable wurde in checking-fixed-var-list wegoptimiert
  5417.                 (if (cdr (anode-seclass anode))
  5418.                   `((JMPIFBOUNDP ,stackdummyvar ,*venvc* ,stackz ,label)
  5419.                     ,anode
  5420.                     ,label
  5421.                    )
  5422.                   '()
  5423.                 )
  5424.                 ; im Stack vorhandene Variable
  5425.                 `((JMPIFBOUNDP ,stackdummyvar ,*venvc* ,stackz ,label)
  5426.                   ,anode
  5427.                   (SET ,var ,*venvc* ,stackz)
  5428.                   ,label
  5429.                  )
  5430.         ) ) ) )
  5431.         L
  5432.     ) )
  5433. ) )
  5434.  
  5435. ; compiliere (name lambdalist {declaration|docstring}* {form}*), liefere FNODE
  5436. (defun c-LAMBDABODY (name lambdabody &optional fenv-cons gf-p reqoptimflags)
  5437.   (test-list lambdabody 1)
  5438.   (let* ((*func* (make-fnode :name name :enclosing *func* :venvc *venvc*))
  5439.          (*stackz* *func*) ; leerer Stack
  5440.          (*venvc* (cons *func* *venvc*))
  5441.          (*func-start-label* (make-label 'NIL))
  5442.          (*anonymous-count* 0)
  5443.          (anode (catch 'c-error
  5444.     ; ab hier wird's kompliziert
  5445.     (multiple-value-bind (reqvar  optvar optinit optsvar  restvar
  5446.                           keyflag keyword keyvar keyinit keysvar allow-other-keys
  5447.                           auxvar auxinit)
  5448.         (if fenv-cons
  5449.           (values-list (cddar fenv-cons)) ; Bei c-LABELS wurde analyze-lambdalist schon aufgerufen
  5450.           (analyze-lambdalist (car lambdabody))
  5451.         )
  5452.       (setf (fnode-req-anz *func*) (length reqvar)
  5453.             (fnode-opt-anz *func*) (length optvar)
  5454.             (fnode-rest-flag *func*) (not (eql restvar 0))
  5455.             (fnode-keyword-flag *func*) keyflag
  5456.             (fnode-keywords *func*) keyword
  5457.             (fnode-allow-other-keys-flag *func*) allow-other-keys
  5458.       )
  5459.       (when fenv-cons (setf (caar fenv-cons) *func*)) ; Fixup fⁿr c-LABELS
  5460.       (multiple-value-bind (body-rest declarations)
  5461.           (parse-body (cdr lambdabody) t (vector *venv* *fenv*))
  5462.         (let ((oldstackz *stackz*)
  5463.               (*stackz* *stackz*)
  5464.               (*denv* *denv*)
  5465.               (*venv* *venv*)
  5466.               (*venvc* *venvc*)
  5467.               *specials* *ignores* *ignorables*
  5468.               req-vars req-dummys req-stackzs
  5469.               opt-vars opt-dummys opt-anodes opts-vars opts-anodes opt-stackzs
  5470.               rest-vars rest-dummys rest-stackzs
  5471.               key-vars key-dummys key-anodes keys-vars keys-anodes key-stackzs
  5472.               aux-vars aux-anodes
  5473.               closuredummy-stackz closuredummy-venvc
  5474.              )
  5475.           (multiple-value-setq (*specials* *ignores* *ignorables*)
  5476.             (process-declarations declarations)
  5477.           )
  5478.           ; Special-Variable auf *venv* pushen:
  5479.           (push-specials)
  5480.           ; Sichtbarkeit von Closure-Dummyvar:
  5481.           (push nil *venvc*)
  5482.           (setq closuredummy-venvc *venvc*)
  5483.           ; Stack-Dummy-Variable fⁿr die reqvar,optvar,restvar,keyvar bilden:
  5484.           (multiple-value-setq (req-vars req-dummys)
  5485.             (process-fixed-var-list reqvar reqoptimflags)
  5486.           )
  5487.           (multiple-value-setq (opt-vars opt-dummys)
  5488.             (process-fixed-var-list optvar)
  5489.           )
  5490.           (multiple-value-setq (rest-vars rest-dummys)
  5491.             (if (eql restvar 0)
  5492.               (values '() '())
  5493.               (process-fixed-var-list (list restvar))
  5494.           ) )
  5495.           (multiple-value-setq (key-vars key-dummys)
  5496.             (process-fixed-var-list keyvar)
  5497.           )
  5498.           ; Platz fⁿr die Funktion selbst (unter den Argumenten):
  5499.           (push 1 *stackz*)
  5500.           ; Platz fⁿr Closure-Dummyvar:
  5501.           (push 0 *stackz*)
  5502.           (setq closuredummy-stackz *stackz*)
  5503.           ; Bindungen der required-Parameter aktivieren:
  5504.           (setq req-stackzs (bind-req-vars req-vars))
  5505.           ; Bindungen der optional-Parameter/svar aktivieren:
  5506.           (multiple-value-setq (opt-anodes opt-stackzs opts-vars opts-anodes)
  5507.             (bind-opt-vars opt-vars opt-dummys optinit optsvar)
  5508.           )
  5509.           ; Bindung des rest-Parameters aktivieren:
  5510.           (unless (eql restvar 0)
  5511.             (setq rest-stackzs (bind-rest-vars rest-vars))
  5512.           )
  5513.           ; Bindungen der keyword-Parameter/svar aktivieren:
  5514.           (multiple-value-setq (key-anodes key-stackzs keys-vars keys-anodes)
  5515.             (bind-opt-vars key-vars key-dummys keyinit keysvar)
  5516.           )
  5517.           ; Bindungen der Aux-Variablen aktivieren:
  5518.           (multiple-value-setq (aux-vars aux-anodes)
  5519.             (bind-aux-vars auxvar auxinit)
  5520.           )
  5521.           (let* ((body-anode (c-form `(PROGN ,@body-rest) 'ALL))
  5522.                  ; ▄berprⁿfen der Variablen:
  5523.                  (closurevars
  5524.                    (append
  5525.                      (checking-fixed-var-list req-vars reqoptimflags)
  5526.                      (checking-fixed-var-list opt-vars)
  5527.                      (checking-movable-var-list opts-vars opts-anodes)
  5528.                      (checking-fixed-var-list rest-vars)
  5529.                      (checking-fixed-var-list key-vars)
  5530.                      (checking-movable-var-list keys-vars keys-anodes)
  5531.                      (checking-movable-var-list aux-vars aux-anodes)
  5532.                  ) )
  5533.                  (codelist
  5534.                    `(,*func-start-label*
  5535.                      ,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  5536.                      ,@(mapcap #'c-bind-fixed-var req-vars req-dummys req-stackzs)
  5537.                      ,@(c-bind-with-svars opt-vars opt-dummys opts-vars opt-anodes opts-anodes opt-stackzs)
  5538.                      ,@(mapcap #'c-bind-fixed-var rest-vars rest-dummys rest-stackzs)
  5539.                      ,@(c-bind-with-svars key-vars key-dummys keys-vars key-anodes keys-anodes key-stackzs)
  5540.                      ,@(mapcap #'c-bind-movable-var-anode aux-vars aux-anodes)
  5541.                      ,body-anode
  5542.                      (UNWIND ,*stackz* ,oldstackz t)
  5543.                      (RET)
  5544.                  )  )
  5545.                  (anode
  5546.                    (make-anode
  5547.                      :type 'LAMBDABODY
  5548.                      :source lambdabody
  5549.                      :sub-anodes `(,@opt-anodes ,@(remove nil opts-anodes)
  5550.                                    ,@key-anodes ,@(remove nil keys-anodes)
  5551.                                    ,@aux-anodes ,body-anode
  5552.                                   )
  5553.                      :seclass '(T . T) ; die Seiteneffektklasse dieses Anode ist irrelevant
  5554.                      :stackz oldstackz
  5555.                      :code codelist
  5556.                 )) )
  5557.             (when closurevars
  5558.               (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  5559.               (setf (first closuredummy-venvc)
  5560.                 (cons closurevars closuredummy-stackz)
  5561.             ) )
  5562.             (optimize-var-list (append req-vars opt-vars opts-vars rest-vars key-vars keys-vars aux-vars))
  5563.             anode
  5564.     ) ) ) )
  5565.     ; das war die Produktion des Anode
  5566.         ))      )
  5567.     (setf (fnode-code *func*) anode)
  5568.     (when reqoptimflags (decf (fnode-req-anz *func*) (count 'GONE reqoptimflags)))
  5569.     (when (eq (anode-type anode) 'ERROR)
  5570.       ; korrekte, aber nichtstuende Funktion daraus machen
  5571.       (setf (fnode-req-anz *func*) 0
  5572.             (fnode-opt-anz *func*) 0
  5573.             (fnode-rest-flag *func*) t
  5574.             (fnode-keyword-flag *func*) nil
  5575.             (fnode-keywords *func*) '()
  5576.             (fnode-allow-other-keys-flag *func*) nil
  5577.             (anode-code (fnode-code *func*)) `((NIL) (SKIP 2) (RET))
  5578.     ) )
  5579.     (setf (fnode-gf-p *func*) gf-p)
  5580.     (setf (fnode-Consts-Offset *func*)
  5581.       (+ (setf (fnode-Keyword-Offset *func*)
  5582.            (+ (setf (fnode-Tagbodys-Offset *func*)
  5583.                 (+ (setf (fnode-Blocks-Offset *func*)
  5584.                      (if (fnode-venvconst *func*) 1 0)
  5585.                    )
  5586.                    (length (fnode-Blocks *func*))
  5587.               ) )
  5588.               (length (fnode-Tagbodys *func*))
  5589.          ) )
  5590.          (length (fnode-Keywords *func*))
  5591.     ) )
  5592.     (when gf-p
  5593.       ; Der Dispatch generischer Funktionen kann nicht auf externe Blocks und
  5594.       ; Tagbodys verweisen. Die Keywords allerdings werden notgedrungen verlagert.
  5595.       (when (or (fnode-Blocks *func*) (fnode-Tagbodys *func*))
  5596.         (compiler-error 'c-LAMBDABODY "GF")
  5597.       )
  5598.       ; Nun ist (fnode-Keyword-Offset *func*) = (fnode-Tagbodys-Offset *func*) =
  5599.       ;       = (fnode-Blocks-Offset *func*) = (if (fnode-venvconst *func*) 1 0)
  5600.     )
  5601.     *func*
  5602. ) )
  5603. (defun bind-req-vars (req-vars)
  5604.   (let ((req-stackzs '()))
  5605.     (dolist (var req-vars)
  5606.       (push-*venv* var)
  5607.       (push *stackz* req-stackzs)
  5608.       (bind-fixed-var-2 var)
  5609.     )
  5610.     (nreverse req-stackzs)
  5611. ) )
  5612. (defun bind-opt-vars (opt-vars opt-dummys optinit optsvar)
  5613.   (let ((opt-anodes '())
  5614.         (opt-stackzs '())
  5615.         (opts-vars '())
  5616.         (opts-anodes '()))
  5617.     (do ((opt-varsr opt-vars (cdr opt-varsr))
  5618.          (opt-dummysr opt-dummys (cdr opt-dummysr))
  5619.          (optinitr optinit (cdr optinitr))
  5620.          (optsvarr optsvar (cdr optsvarr)))
  5621.         ((null opt-varsr))
  5622.       (if (eql (car optsvarr) 0)
  5623.         (progn (push nil opts-vars) (push nil opts-anodes))
  5624.         (let* ((anode
  5625.                  (make-anode
  5626.                    :type 'OPTIONAL-SVAR
  5627.                    :sub-anodes '()
  5628.                    :seclass (cons (list (car opt-dummysr)) 'NIL)
  5629.                    :code `((BOUNDP ,(car opt-dummysr) ,*venvc* ,*stackz*))
  5630.                ) )
  5631.                (var (bind-movable-var (car optsvarr) anode))
  5632.               )
  5633.           (push anode opts-anodes)
  5634.           (push var opts-vars)
  5635.       ) )
  5636.       (push (c-form (car optinitr) 'ONE) opt-anodes)
  5637.       (push-*venv* (car opt-varsr))
  5638.       (push *stackz* opt-stackzs) (bind-fixed-var-2 (car opt-varsr))
  5639.       (unless (eql (car optsvarr) 0) (push-*venv* (car opts-vars)))
  5640.     )
  5641.     (values
  5642.       (nreverse opt-anodes) (nreverse opt-stackzs)
  5643.       (nreverse opts-vars) (nreverse opts-anodes)
  5644.     )
  5645. ) )
  5646. (defun bind-rest-vars (rest-vars)
  5647.   (let ((rest-stackzs '()))
  5648.     (push-*venv* (car rest-vars))
  5649.     (push *stackz* rest-stackzs)
  5650.     (bind-fixed-var-2 (car rest-vars))
  5651.     rest-stackzs ; (nreverse rest-stackzs) unn÷tig
  5652. ) )
  5653. (defun bind-aux-vars (auxvar auxinit)
  5654.   (let ((aux-vars '())
  5655.         (aux-anodes '()))
  5656.     (do ((auxvarr auxvar (cdr auxvarr))
  5657.          (auxinitr auxinit (cdr auxinitr)))
  5658.         ((null auxvarr))
  5659.       (let* ((initform (car auxinitr))
  5660.              (anode (c-form initform 'ONE))
  5661.              (var (bind-movable-var (car auxvarr) anode)))
  5662.         (push anode aux-anodes)
  5663.         (push var aux-vars)
  5664.         (push-*venv* var)
  5665.     ) )
  5666.     (values (nreverse aux-vars) (nreverse aux-anodes))
  5667. ) )
  5668.  
  5669. ; liefert den ANODE, der (bei gegebenem aktuellem Stackzustand)
  5670. ; die zu einem FNODE geh÷rende Funktion als Wert liefert.
  5671. (defun c-FNODE-FUNCTION (fnode &optional (*stackz* *stackz*))
  5672.   (make-anode
  5673.     :type 'FUNCTION
  5674.     :sub-anodes '()
  5675.     :seclass '(NIL . NIL)
  5676.     :code (if (zerop (fnode-keyword-offset fnode))
  5677.             `((FCONST ,fnode))
  5678.             `(,@(if (fnode-Venvconst fnode)
  5679.                   (prog1 ; beim Aufbau mitzugebendes Venv
  5680.                     `((VENV ,(fnode-venvc fnode) ,*stackz*)
  5681.                       (PUSH)
  5682.                      )
  5683.                     (setq *stackz* (cons 1 *stackz*))
  5684.                 ) )
  5685.               ,@(mapcap ; beim Aufbau mitzugebende Block-Conses
  5686.                   #'(lambda (block)
  5687.                       (prog1
  5688.                         `(,(if (member block (fnode-Blocks *func*) :test #'eq)
  5689.                              `(BCONST ,block)
  5690.                              `(GET ,(block-consvar block) ,*venvc* ,*stackz*)
  5691.                            )
  5692.                            (PUSH)
  5693.                          )
  5694.                         (setq *stackz* (cons 1 *stackz*))
  5695.                     ) )
  5696.                   (fnode-Blocks fnode)
  5697.                 )
  5698.               ,@(mapcap ; beim Aufbau mitzugebende Tagbody-Conses
  5699.                   #'(lambda (tagbody)
  5700.                       (prog1
  5701.                         `(,(if (member tagbody (fnode-Tagbodys *func*) :test #'eq)
  5702.                              `(GCONST ,tagbody)
  5703.                              `(GET ,(tagbody-consvar tagbody) ,*venvc* ,*stackz*)
  5704.                            )
  5705.                            (PUSH)
  5706.                          )
  5707.                         (setq *stackz* (cons 1 *stackz*))
  5708.                     ) )
  5709.                   (fnode-Tagbodys fnode)
  5710.                 )
  5711.               (COPY-CLOSURE ,fnode ,(fnode-keyword-offset fnode))
  5712.              )
  5713.           )
  5714. ) )
  5715.  
  5716.  
  5717. ;        ERSTER PASS :   S P E C I A L   F O R M S
  5718.  
  5719. ; compiliere (PROGN {form}*)
  5720. ; keine Formen -> NIL, genau eine Form -> diese Form,
  5721. ; mindestens zwei Formen -> alle der Reihe nach, nur bei der letzten kommt es
  5722. ; auf die Werte an.
  5723. (defun c-PROGN ()
  5724.   (test-list *form* 1)
  5725.   (let ((L (cdr *form*))) ; Liste der Formen
  5726.     (cond ((null L) (c-NIL)) ; keine Form -> NIL
  5727.           ((null (cdr L)) (c-form (car L))) ; genau eine Form
  5728.           (t (do (#+COMPILER-DEBUG (anodelist '())
  5729.                   (seclass '(NIL . NIL))
  5730.                   (codelist '())
  5731.                   (Lr L)) ; restliche Formenliste
  5732.                  ((null Lr)
  5733.                   (make-anode
  5734.                     :type 'PROGN
  5735.                     :sub-anodes (nreverse anodelist)
  5736.                     :seclass seclass
  5737.                     :code (nreverse codelist)
  5738.                  ))
  5739.                (let* ((formi (pop Lr)) ; i-te Form
  5740.                       (anodei (c-form formi (if (null Lr) *for-value* 'NIL))))
  5741.                  #+COMPILER-DEBUG (push anodei anodelist)
  5742.                  (seclass-or-f seclass anodei)
  5743.                  (push anodei codelist)
  5744. ) ) )     )  ) )
  5745.  
  5746. ; compiliere (PROG1 form1 {form}*)
  5747. ; bei *for-value* mu▀ der Wert von form1 im Stack gerettet werden
  5748. (defun c-PROG1 ()
  5749.   (test-list *form* 2)
  5750.   (if (or (null *for-value*) (and (eq *for-value* 'ONE) (null (cddr *form*))))
  5751.     (c-form `(PROGN ,@(cdr *form*)))
  5752.     (let ((anode1 (c-form (second *form*) 'ONE))
  5753.           (anode2 (let ((*stackz* (cons 1 *stackz*)))
  5754.                     (c-form `(PROGN ,@(cddr *form*)) 'NIL)
  5755.          ))       )
  5756.       (make-anode
  5757.         :type 'PROG1
  5758.         :sub-anodes (list anode1 anode2)
  5759.         :seclass (anodes-seclass-or anode1 anode2)
  5760.         :code `(,anode1 (PUSH) ,anode2 (POP))
  5761. ) ) ) )
  5762.  
  5763. ; compiliere (PROG2 form1 form2 {form}*)
  5764. (defun c-PROG2 ()
  5765.   (test-list *form* 3)
  5766.   (c-form `(PROGN ,(second *form*) (PROG1 ,(third *form*) ,@(cdddr *form*))))
  5767. )
  5768.  
  5769. ; compiliere (IF form1 form2 [form3])
  5770. ; ist form1 eine Konstante, so kann der Compiler die Fallunterscheidung treffen.
  5771. (defun c-IF ()
  5772.   (test-list *form* 3 4)
  5773.   (let ((form1 (second *form*))
  5774.         (form2 (third *form*))
  5775.         (form3 (fourth *form*))) ; = NIL, falls *form* nur 3 lang ist
  5776.     (let ((anode1 (c-form form1 'ONE)))
  5777.       (if (anode-constantp anode1)
  5778.         (if (anode-constant-value anode1)
  5779.           (prog1 (c-form form2) (let ((*no-code* t)) (c-form form3 'NIL)))
  5780.           (prog2 (let ((*no-code* t)) (c-form form2 'NIL)) (c-form form3))
  5781.         )
  5782.         (let ((anode2 (c-form form2))
  5783.               (anode3 (c-form form3))
  5784.               (label1 (make-label 'NIL))
  5785.               (label2 (make-label *for-value*)))
  5786.           (make-anode
  5787.             :type 'IF
  5788.             :sub-anodes (list anode1 anode2 anode3)
  5789.             :seclass (anodes-seclass-or anode1 anode2 anode3)
  5790.             :code
  5791.               `(,anode1
  5792.                 (JMPIFNOT ,label1)
  5793.                 ,anode2
  5794.                 (JMP ,label2)
  5795.                 ,label1
  5796.                 ,anode3
  5797.                 ,label2
  5798.                )
  5799. ) ) ) ) ) )
  5800.  
  5801. ; compiliere (WHEN form1 {form}*)
  5802. (defun c-WHEN ()
  5803.   (test-list *form* 2)
  5804.   (c-form `(IF ,(second *form*) (PROGN ,@(cddr *form*))))
  5805. )
  5806.  
  5807. ; compiliere (UNLESS form1 {form}*)
  5808. (defun c-UNLESS ()
  5809.   (test-list *form* 2)
  5810.   (c-form `(IF ,(second *form*) NIL (PROGN ,@(cddr *form*))))
  5811. )
  5812.  
  5813. ; compiliere (AND {form}*)
  5814. (defun c-AND ()
  5815.   (test-list *form* 1)
  5816.   (cond ((null (cdr *form*)) ; keine Formen
  5817.          (make-anode
  5818.            :type 'AND
  5819.            :sub-anodes '()
  5820.            :seclass '(NIL . NIL)
  5821.            :code '((T))
  5822.         ))
  5823.         ((null (cddr *form*)) (c-form (second *form*))) ; genau eine Form
  5824.         (t (do (#+COMPILER-DEBUG (anodelist '())
  5825.                 (seclass '(NIL . NIL))
  5826.                 (codelist '())
  5827.                 (Lr (cdr *form*))
  5828.                 (label (make-label *for-value*))) ; Label am Ende
  5829.                ((null Lr)
  5830.                 (push label codelist)
  5831.                 (make-anode
  5832.                   :type 'AND
  5833.                   :sub-anodes (nreverse anodelist)
  5834.                   :seclass seclass
  5835.                   :code (nreverse codelist)
  5836.                ))
  5837.              (let* ((formi (pop Lr))
  5838.                     (anodei (c-form formi (if (null Lr) *for-value* 'ONE))))
  5839.                #+COMPILER-DEBUG (push anodei anodelist)
  5840.                (seclass-or-f seclass anodei)
  5841.                (if (null Lr)
  5842.                  ; letzte Form -> direkt ⁿbernehmen
  5843.                  (push anodei codelist)
  5844.                  ; nicht letzte Form -> Test kreieren
  5845.                  (if (anode-constantp anodei)
  5846.                    ; Konstante /= NIL -> weglassen, Konstante NIL -> fertig
  5847.                    (unless (anode-constant-value anodei)
  5848.                      (if *for-value* (push '(NIL) codelist))
  5849.                      (let ((*no-code* t)) (dolist (form Lr) (c-form form 'NIL)))
  5850.                      (setq Lr nil)
  5851.                    )
  5852.                    (progn ; normaler Test
  5853.                      (push anodei codelist)
  5854.                      (push `(,(if *for-value* 'JMPIFNOT1 'JMPIFNOT) ,label)
  5855.                            codelist
  5856.              ) ) ) ) )
  5857. ) )     )  )
  5858.  
  5859. ; compiliere (OR {form}*)
  5860. (defun c-OR ()
  5861.   (test-list *form* 1)
  5862.   (cond ((null (cdr *form*)) ; keine Formen
  5863.          (make-anode
  5864.            :type 'OR
  5865.            :sub-anodes '()
  5866.            :seclass '(NIL . NIL)
  5867.            :code '((NIL))
  5868.         ))
  5869.         ((null (cddr *form*)) (c-form (second *form*))) ; genau eine Form
  5870.         (t (do (#+COMPILER-DEBUG (anodelist '())
  5871.                 (seclass '(NIL . NIL))
  5872.                 (codelist '())
  5873.                 (Lr (cdr *form*))
  5874.                 (label (make-label *for-value*))) ; Label am Ende
  5875.                ((null Lr)
  5876.                 (push label codelist)
  5877.                 (make-anode
  5878.                   :type 'OR
  5879.                   :sub-anodes (nreverse anodelist)
  5880.                   :seclass seclass
  5881.                   :code (nreverse codelist)
  5882.                ))
  5883.              (let* ((formi (pop Lr))
  5884.                     (anodei (c-form formi (if (null Lr) *for-value* 'ONE))))
  5885.                #+COMPILER-DEBUG (push anodei anodelist)
  5886.                (seclass-or-f seclass anodei)
  5887.                (if (null Lr)
  5888.                  ; letzte Form -> direkt ⁿbernehmen
  5889.                  (push anodei codelist)
  5890.                  ; nicht letzte Form -> Test kreieren
  5891.                  (if (anode-constantp anodei)
  5892.                    ; Konstante NIL -> weglassen, Konstante /= NIL -> fertig
  5893.                    (when (anode-constant-value anodei)
  5894.                      (if *for-value* (push anodei codelist))
  5895.                      (let ((*no-code* t)) (dolist (form Lr) (c-form form 'NIL)))
  5896.                      (setq Lr nil)
  5897.                    )
  5898.                    (progn ; normaler Test
  5899.                      (push anodei codelist)
  5900.                      (push `(,(if *for-value* 'JMPIF1 'JMPIF) ,label)
  5901.                            codelist
  5902.              ) ) ) ) )
  5903. ) )     )  )
  5904.  
  5905. ; compiliere (QUOTE object)
  5906. (defun c-QUOTE ()
  5907.   (test-list *form* 2 2)
  5908.   (let ((value (second *form*)))
  5909.     (make-anode :type 'QUOTE
  5910.                 :sub-anodes '()
  5911.                 :seclass '(NIL . NIL)
  5912.                 :code (if *for-value* `((CONST ,(new-const value))) '() )
  5913. ) ) )
  5914.  
  5915. ; compiliere (THE type form)
  5916. (defun c-THE ()
  5917.   (test-list *form* 3 3)
  5918.   (c-form (third *form*)) ; ignoriere einfach die Typdeklaration
  5919. )
  5920.  
  5921. ; compiliere (DECLARE {declspec}*)
  5922. (defun c-DECLARE ()
  5923.   (test-list *form* 1)
  5924.   (c-error (DEUTSCH "Deklarationen sind an dieser Stelle nicht erlaubt: ~S"
  5925.             ENGLISH "Misplaced declaration: ~S"
  5926.             FRANCAIS "Une dΘclaration n'est pas permise ici : ~S")
  5927.            *form*
  5928. ) )
  5929.  
  5930. ; compiliere (LOAD-TIME-VALUE form [read-only-p])
  5931. (defun c-LOAD-TIME-VALUE ()
  5932.   (test-list *form* 2 3)
  5933.   (let ((form (second *form*))) ; ignoriere read-only-p
  5934.     (make-anode :type 'LOAD-TIME-VALUE
  5935.                 :sub-anodes '()
  5936.                 :seclass '(NIL . NIL)
  5937.                 :code (if *for-value*
  5938.                         `((CONST ,(make-const :value (eval form) :form form)))
  5939.                         '()
  5940.                       )
  5941. ) ) )
  5942.  
  5943. ; compiliere (CATCH tag {form}*)
  5944. (defun c-CATCH ()
  5945.   (test-list *form* 2)
  5946.   (let* ((anode1 (c-form (second *form*) 'ONE))
  5947.          (anode2 (let ((*stackz* (cons 'CATCH *stackz*)))
  5948.                    (c-form `(PROGN ,@(cddr *form*)))
  5949.          )       )
  5950.          (label (make-label *for-value*)))
  5951.     (make-anode :type 'CATCH
  5952.                 :sub-anodes (list anode1 anode2)
  5953.                 :seclass (anodes-seclass-or anode1 anode2)
  5954.                 :code `(,anode1
  5955.                         (CATCH-OPEN ,label)
  5956.                         ,anode2
  5957.                         (CATCH-CLOSE)
  5958.                         ,label
  5959. ) ) )                  )
  5960.  
  5961. ; compiliere (THROW tag form)
  5962. (defun c-THROW ()
  5963.   (test-list *form* 3 3)
  5964.   (let* ((anode1 (c-form (second *form*) 'ONE))
  5965.          (anode2 (let ((*stackz* (cons 1 *stackz*)))
  5966.                    (c-form (third *form*) 'ALL)
  5967.         ))       )
  5968.     (make-anode :type 'THROW
  5969.                 :sub-anodes (list anode1 anode2)
  5970.                 :seclass (cons (car (anodes-seclass-or anode1 anode2)) 'T)
  5971.                 :code `(,anode1 (PUSH) ,anode2 (THROW))
  5972. ) ) )
  5973.  
  5974. ; compiliere (UNWIND-PROTECT form1 {form}*)
  5975. (defun c-UNWIND-PROTECT ()
  5976.   (test-list *form* 2)
  5977.   (let* ((anode1 (let ((*stackz* (cons 'UNWIND-PROTECT *stackz*)))
  5978.                    (c-form (second *form*))
  5979.          )       )
  5980.          (anode2 (let ((*stackz* (cons 'CLEANUP *stackz*)))
  5981.                    (c-form `(PROGN ,@(cddr *form*)) 'NIL)
  5982.          )       )
  5983.          (label (make-label 'NIL)))
  5984.     (make-anode :type 'UNWIND-PROTECT
  5985.                 :sub-anodes (list anode1 anode2)
  5986.                 :seclass (anodes-seclass-or anode1 anode2)
  5987.                 :code `((UNWIND-PROTECT-OPEN ,label)
  5988.                         ,anode1
  5989.                         ,@(case *for-value*
  5990.                             ((NIL) '((VALUES0)))
  5991.                             (ONE '((VALUES1)))
  5992.                             ((T) '())
  5993.                           )
  5994.                         (UNWIND-PROTECT-NORMAL-EXIT)
  5995.                         ,label
  5996.                         ,anode2
  5997.                         (UNWIND-PROTECT-CLOSE ,label)
  5998. ) ) )                  )
  5999.  
  6000. ; compiliere (PROGV form1 form2 {form}*)
  6001. (defun c-PROGV ()
  6002.   (test-list *form* 3)
  6003.   (let ((anode1 (c-form (second *form*) 'ONE)))
  6004.     ; falls form1 konstant=NIL ist, kann man sich das Binden sparen:
  6005.     (if (and (anode-constantp anode1) (null (anode-constant-value anode1)))
  6006.       (c-form `(PROGN ,(third *form*) (PROGN ,@(cdddr *form*))))
  6007.       (let* ((stackz2 (cons 1 *stackz*))
  6008.              (anode2 (let ((*stackz* stackz2))
  6009.                        (c-form (third *form*) 'ONE)
  6010.              )       )
  6011.              (stackz3 (cons 'PROGV *stackz*))
  6012.              (anode3 (let ((*stackz* stackz3))
  6013.                        (c-form `(PROGN ,@(cdddr *form*)))
  6014.              )       )
  6015.              (flag t))
  6016.         ; falls anode3 von keinen Seiteneffekten abhΣngig ist, kann man sich das
  6017.         ; Binden sparen:
  6018.         (when (null (car (anode-seclass anode3)))
  6019.           (setf (first stackz2) 0)
  6020.           (setf (first stackz3) 0)
  6021.           (setq flag nil)
  6022.         )
  6023.         (make-anode :type 'PROGV
  6024.                     :sub-anodes (list anode1 anode2 anode3)
  6025.                     :seclass (anodes-seclass-or anode1 anode2 anode3)
  6026.                     :code `(,anode1
  6027.                             ,@(if flag '((PUSH)))
  6028.                             ,anode2
  6029.                             ,@(if flag '((PROGV)))
  6030.                             ,anode3
  6031.                             ,@(if flag
  6032.                                 `((UNWIND ,stackz3 ,*stackz* ,*for-value*))
  6033.                                 ; wird expandiert zu '((UNBIND1) (SKIPSP 1))
  6034.                            )  )
  6035. ) ) ) ) )
  6036.  
  6037. ; compiliere (MULTIPLE-VALUE-PROG1 form1 {form}*)
  6038. ; falls Werte nicht gebraucht werden: einfaches PROGN. Sonst: falls {form}*
  6039. ; seiteneffektfrei, nur form1, sonst: Werte von form1 auf den Stack legen und
  6040. ; nachher mit Funktion VALUES wieder einsammeln.
  6041. (defun c-MULTIPLE-VALUE-PROG1 ()
  6042.   (test-list *form* 2)
  6043.   (case *for-value*
  6044.     (ALL
  6045.      (let* ((stackz1 (cons 'MVCALLP *stackz*))
  6046.             (anode1 (let ((*stackz* stackz1))
  6047.                       (c-form (second *form*))
  6048.             )       )
  6049.             (anode2 (let ((*stackz* (cons 'MVCALL *stackz*)))
  6050.                       (c-form `(PROGN ,@(cddr *form*)) 'NIL)
  6051.            ))       )
  6052.        (make-anode :type 'MULTIPLE-VALUE-PROG1
  6053.                    :sub-anodes (list anode1 anode2)
  6054.                    :seclass (anodes-seclass-or anode1 anode2)
  6055.                    :code
  6056.                       (if (cdr (anode-seclass anode2))
  6057.                         `((CONST , #+CLISP (make-const :value #'values
  6058.                                                        :form '(function values)
  6059.                                            )
  6060.                                    #-CLISP (new-const 'values)
  6061.                           )
  6062.                           (MVCALLP)
  6063.                           ,anode1
  6064.                           (MV-TO-STACK)
  6065.                           ,anode2
  6066.                           (MVCALL))
  6067.                         (prog2 (setf (first stackz1) 0) `(,anode1))
  6068.                       )
  6069.     )) )
  6070.     (ONE (c-form `(PROG1 ,@(cdr *form*))))
  6071.     ((NIL) (c-form `(PROGN ,@(cdr *form*))))
  6072. ) )
  6073.  
  6074. ; compiliere (MULTIPLE-VALUE-CALL form1 {form}*)
  6075. (defun c-MULTIPLE-VALUE-CALL ()
  6076.   (test-list *form* 2)
  6077.   (if (null (cddr *form*))
  6078.     ; (c-form `(SYS::%FUNCALL ,(second *form*))) ; 0 Argumente zu form1
  6079.     (c-FUNCTION-CALL (second *form*) '())
  6080.     (let* ((anode1 (c-form (second *form*) 'ONE))
  6081.            #+COMPILER-DEBUG (anodelist (list anode1))
  6082.            (codelist '()))
  6083.       (push anode1 codelist)
  6084.       (push '(MVCALLP) codelist)
  6085.       (do ((Lr (cddr *form*))
  6086.            (i 0 (1+ i)))
  6087.           ((null Lr))
  6088.         (let* ((formi (pop Lr))
  6089.                (anodei
  6090.                  (let ((*stackz* (cons (if (zerop i) 'MVCALLP 'MVCALL) *stackz*)))
  6091.                    (c-form formi 'ALL)
  6092.               )) )
  6093.           #+COMPILER-DEBUG (push anodei anodelist)
  6094.           (push anodei codelist)
  6095.           (push '(MV-TO-STACK) codelist)
  6096.       ) )
  6097.       (push '(MVCALL) codelist)
  6098.       (make-anode :type 'MULTIPLE-VALUE-CALL
  6099.                   :sub-anodes (nreverse anodelist)
  6100.                   :seclass '(T . T)
  6101.                   :code (nreverse codelist)
  6102. ) ) ) )
  6103.  
  6104. ; compiliere (MULTIPLE-VALUE-LIST form)
  6105. (defun c-MULTIPLE-VALUE-LIST ()
  6106.   (test-list *form* 2 2)
  6107.   (if *for-value*
  6108.     (let ((anode1 (c-form (second *form*) 'ALL)))
  6109.       (make-anode :type 'MULTIPLE-VALUE-LIST
  6110.                   :sub-anodes (list anode1)
  6111.                   :seclass (anodes-seclass-or anode1)
  6112.                   :code `(,anode1 (MV-TO-LIST))
  6113.     ) )
  6114.     (c-form (second *form*))
  6115. ) )
  6116.  
  6117. ; Stellt fest, ob eine SETQ-Argumentliste Symbol-Macros zuweist.
  6118. (defun setqlist-macrop (l)
  6119.   (do ((l l (cddr l)))
  6120.       ((null l) nil)
  6121.     (let ((s (car l)))
  6122.       (when (and (symbolp s) (symbol-macro-p (venv-search-macro s))) (return t))
  6123. ) ) )
  6124.  
  6125. ; compiliere (SETQ {symbol form}*)
  6126. ; alle Zuweisungen nacheinander durchfⁿhren
  6127. (defun c-SETQ ()
  6128.   (test-list *form* 1)
  6129.   (when (evenp (length *form*))
  6130.     (c-error (DEUTSCH "Ungerade viele Argumente zu SETQ: ~S"
  6131.               ENGLISH "Odd number of arguments to SETQ: ~S"
  6132.               FRANCAIS "Nombre impair d'arguments pour SETQ : ~S")
  6133.              *form*
  6134.   ) )
  6135.   (if (null (cdr *form*))
  6136.     (c-NIL) ; (SETQ) == (PROGN) == NIL
  6137.     (if (setqlist-macrop (cdr *form*))
  6138.       (c-form ; (SETF ...) statt (SETQ ...), macroexpandieren
  6139.         (funcall (macro-function 'SETF) (cons 'SETF (cdr *form*))
  6140.                  (vector *venv* *fenv*)
  6141.       ) )
  6142.       (do ((L (cdr *form*) (cddr L))
  6143.            #+COMPILER-DEBUG (anodelist '())
  6144.            (seclass '(NIL . NIL))
  6145.            (codelist '()))
  6146.           ((null L)
  6147.            (make-anode
  6148.              :type 'SETQ
  6149.              :sub-anodes (nreverse anodelist)
  6150.              :seclass seclass
  6151.              :code (nreverse codelist)
  6152.           ))
  6153.         (let* ((symboli (first L))
  6154.                (formi (second L))
  6155.                (anodei (c-form formi 'ONE)))
  6156.           #+COMPILER-DEBUG (push anodei anodelist)
  6157.           (if (symbolp symboli)
  6158.             (progn
  6159.               (push anodei codelist)
  6160.               (seclass-or-f seclass anodei)
  6161.               (let ((setteri (c-VARSET symboli anodei
  6162.                                        (and *for-value* (null (cddr L)))
  6163.                    ))        )
  6164.                 (push setteri codelist)
  6165.                 (seclass-or-f seclass setteri)
  6166.             ) )
  6167.             (progn
  6168.               (catch 'c-error
  6169.                 (c-error (DEUTSCH "Zuweisung auf ~S unm÷glich, da kein Symbol."
  6170.                           ENGLISH "Cannot assign to non-symbol ~S."
  6171.                           FRANCAIS "Rien ne peut Ωtre assignΘ α ~S car ce n'est pas un symbole.")
  6172.                          symboli
  6173.               ) )
  6174.               (push '(VALUES1) codelist)
  6175.       ) ) ) )
  6176. ) ) )
  6177.  
  6178. ; compiliere (PSETQ {symbol form}*)
  6179. ; alle Zwischenwerte auf dem Stack retten, erst dann zuweisen
  6180. (defun c-PSETQ ()
  6181.   (test-list *form* 1)
  6182.   (when (evenp (length *form*))
  6183.     (c-error (DEUTSCH "Ungerade viele Argumente zu PSETQ: ~S"
  6184.               ENGLISH "Odd number of arguments to PSETQ: ~S"
  6185.               FRANCAIS "Nombre impair d'arguments pour PSETQ : ~S")
  6186.              *form*
  6187.   ) )
  6188.   (if (null (cdr *form*))
  6189.     (c-NIL) ; (PSETQ) == (PROGN) == NIL
  6190.     (if (setqlist-macrop (cdr *form*))
  6191.       (c-form ; (PSETF ...) statt (PSETQ ...), macroexpandieren
  6192.         (funcall (macro-function 'PSETF) (cons 'PSETF (cdr *form*))
  6193.                  (vector *venv* *fenv*)
  6194.       ) )
  6195.       (let ((anodelist '())
  6196.             (setterlist '()))
  6197.         ; Formen und Zuweisungen compilieren:
  6198.         (do ((L (cdr *form*)))
  6199.             ((null L))
  6200.           (let* ((symboli (pop L))
  6201.                  (formi (pop L))
  6202.                  (anodei (c-form formi 'ONE)))
  6203.             (if (symbolp symboli)
  6204.               (progn
  6205.                 (push anodei anodelist)
  6206.                 (push (c-VARSET symboli anodei nil) setterlist)
  6207.                 (push 0 *stackz*)
  6208.               )
  6209.               (catch 'c-error
  6210.                 (c-error (DEUTSCH "Zuweisung auf ~S unm÷glich, da kein Symbol."
  6211.                           ENGLISH "Cannot assign to non-symbol ~S."
  6212.                           FRANCAIS "Rien ne peut Ωtre assignΘ α ~S car ce n'est pas un symbole.")
  6213.                          symboli
  6214.         ) ) ) ) )
  6215.         ; Versuche, sie so zu reorganisieren, da▀ m÷glichst wenige (PUSH)
  6216.         ; und (POP) n÷tig werden:
  6217.         (let ((codelist1 '())
  6218.               (codelist2 '())
  6219.               ; baue codelist = (nconc codelist1 (nreverse codelist2)) zusammen
  6220.               (seclass '(NIL . NIL))) ; Seiteneffektklasse von codelist insgesamt
  6221.           (do ((anodelistr anodelist (cdr anodelistr))
  6222.                (setterlistr setterlist (cdr setterlistr)))
  6223.               ((null anodelistr))
  6224.             (let ((anode (car anodelistr))
  6225.                   (setter (car setterlistr)))
  6226.               ; Normalerweise wΣre vor codelist der anode und ein (PUSH)
  6227.               ; und nach codelist ein (POP) und der setter anzuhΣngen.
  6228.               ; Dies versuchen wir zu vereinfachen:
  6229.               (cond ((seclasses-commute (anode-seclass setter) seclass)
  6230.                      ; Ziehe den setter nach vorne:
  6231.                      (push setter codelist1)
  6232.                      (push anode codelist1)
  6233.                     )
  6234.                     ((seclasses-commute (anode-seclass anode) seclass)
  6235.                      ; Ziehe den anode nach hinten:
  6236.                      (push anode codelist2)
  6237.                      (push setter codelist2)
  6238.                     )
  6239.                     (t ; keine Vereinfachung m÷glich
  6240.                      (push '(PUSH) codelist1)
  6241.                      (push anode codelist1)
  6242.                      (push '(POP) codelist2)
  6243.                      (push setter codelist2)
  6244.                      (setf (car *stackz*) 1) ; brauche eine Variable im Stack
  6245.               )     )
  6246.               (setq seclass
  6247.                 (seclass-or-2 seclass
  6248.                   (seclass-or-2 (anode-seclass anode) (anode-seclass setter))
  6249.               ) )
  6250.               (setf *stackz* (cdr *stackz*))
  6251.           ) )
  6252.           ; *stackz* ist nun wieder auf dem alten Niveau.
  6253.           (when *for-value* (push '(NIL) codelist2))
  6254.           (make-anode
  6255.             :type 'PSETQ
  6256.             :sub-anodes (nreverse anodelist)
  6257.             :seclass seclass
  6258.             :code (nconc codelist1 (nreverse codelist2))
  6259. ) ) ) ) ) )
  6260.  
  6261. ; compiliere (MULTIPLE-VALUE-SETQ ({symbol}*) form)
  6262. ; alle gewⁿnschten Werte auf den Stack, dann einzeln herunternehmen und
  6263. ; zuweisen.
  6264. (defun c-MULTIPLE-VALUE-SETQ ()
  6265.   (test-list *form* 3 3)
  6266.   (test-list (second *form*) 0)
  6267.   (if (dolist (s (second *form*) nil)
  6268.         (when (and (symbolp s) (symbol-macro-p (venv-search-macro s))) (return t))
  6269.       )
  6270.     (c-form `(SYSTEM::MULTIPLE-VALUE-SETF ,@(cdr *form*)))
  6271.     (let* ((n (length (second *form*)))
  6272.            (anode1 (c-form (third *form*) 'ALL))
  6273.            (*stackz* *stackz*))
  6274.       (if (zerop n)
  6275.         (make-anode :type 'MULTIPLE-VALUE-SETQ
  6276.                     :sub-anodes (list anode1)
  6277.                     :seclass (anodes-seclass-or anode1)
  6278.                     :code `(,anode1
  6279.                             ,@(if (eq *for-value* 'ALL) '((VALUES1)) '())
  6280.         )                  )
  6281.         (do ((L (second *form*) (cdr L))
  6282.              #+COMPILER-DEBUG (anodelist (list anode1))
  6283.              (seclass (anode-seclass anode1))
  6284.              (codelist '()))
  6285.             ((null L)
  6286.              (if (= n 1)
  6287.                (setq codelist (cdr codelist)) ; letztes (POP) streichen
  6288.                (setq codelist (cons `(NV-TO-STACK ,n) codelist))
  6289.              )
  6290.              (make-anode
  6291.                :type 'MULTIPLE-VALUE-SETQ
  6292.                :sub-anodes (nreverse anodelist)
  6293.                :seclass seclass
  6294.                :code (cons anode1 codelist)
  6295.             ))
  6296.           (let ((symbol (car L)))
  6297.             (if (symbolp symbol)
  6298.               (let ((setter (c-VARSET symbol
  6299.                               (make-anode :type 'NOP
  6300.                                           :sub-anodes '()
  6301.                                           :seclass '(NIL . NIL)
  6302.                                           :code '()
  6303.                               )
  6304.                               (and *for-value* (null codelist))
  6305.                    ))       )
  6306.                 (push setter codelist)
  6307.                 (seclass-or-f seclass setter)
  6308.               )
  6309.               (catch 'c-error
  6310.                 (c-error (DEUTSCH "Zuweisung auf ~S unm÷glich, da kein Symbol."
  6311.                           ENGLISH "Cannot assign to non-symbol ~S."
  6312.                           FRANCAIS "Rien ne peut Ωtre assignΘ α ~S car ce n'est pas un symbole.")
  6313.                          symbol
  6314.           ) ) ) )
  6315.           (push '(POP) codelist)
  6316.           (push 1 *stackz*)
  6317. ) ) ) ) )
  6318.  
  6319. ; Liefert den Code fⁿr das parallele Binden von Variablen.
  6320. ; (car *stackz*) sollte = 0 sein, (cdr *stackz*) wird evtl. erweitert.
  6321. (defun c-parallel-bind-movable-var-anode (varlist anodelist stackzlist
  6322.                                           &optional (other-anodes '())
  6323.                                          )
  6324.   ; Variable darf erst am Schlu▀ gebunden werden, falls sie SPECIAL ist
  6325.   ; und nachfolgende Anodes von ihrem Wert abhΣngen k÷nnen.
  6326.   (let ((bind-afterwards nil))
  6327.     (append
  6328.       (maplap
  6329.         #'(lambda (varlistr anodelistr stackzlistr)
  6330.             (let ((var (car varlistr))
  6331.                   (anode (car anodelistr)))
  6332.               (if (and (var-specialp var)
  6333.                        (let ((symbol (var-name var)))
  6334.                          (some
  6335.                            #'(lambda (other-anode)
  6336.                                ; hΣngt der Wert von other-anode m÷glicherweise
  6337.                                ; vom Wert von var ab?
  6338.                                (let ((uses (car (anode-seclass other-anode))))
  6339.                                  (or (eq uses 'T) (member symbol uses))
  6340.                              ) )
  6341.                            (cdr anodelistr)
  6342.                   )    ) )
  6343.                 (let* ((stackz (car stackzlistr))
  6344.                        (dummyvar ; Hilfsvariable im Stack
  6345.                          (make-var :name (gensym) :specialp nil
  6346.                                    :closurep nil :stackz stackz
  6347.                       )) )
  6348.                   (push (list dummyvar var (cdr *stackz*)) bind-afterwards)
  6349.                   (push (car stackz) (cdr *stackz*)) ; Platz fⁿr 1 Schlu▀-Bindung mehr
  6350.                   (setf (car stackz) 1) ; Platz fⁿr Hilfsvariable im Stack merken
  6351.                   (c-bind-movable-var-anode dummyvar anode)
  6352.                 )
  6353.                 (c-bind-movable-var-anode var anode)
  6354.           ) ) )
  6355.         varlist (append anodelist other-anodes) stackzlist
  6356.       )
  6357.       other-anodes
  6358.       (mapcap
  6359.         #'(lambda (bind)
  6360.             (let ((dummyvar (first bind)) ; Hilfsvariable im Stack
  6361.                   (var (second bind)) ; SPECIAL-Variable
  6362.                   (stackz (third bind))) ; Stackzustand vor Aufbau der Schlu▀-Bindung
  6363.               `((GET ,dummyvar ,*venvc* ,stackz)
  6364.                 ,@(c-bind-movable-var var)
  6365.                )
  6366.           ) )
  6367.         (nreverse bind-afterwards)
  6368.       )
  6369.     )
  6370. ) )
  6371.  
  6372. ; compiliere (LET/LET* ({var|(var value)}*) {declaration}* {form}*)
  6373. (defun c-LET/LET* (*-flag)
  6374.   (test-list *form* 2)
  6375.   (test-list (second *form*) 0)
  6376.   (multiple-value-bind (body-rest declarations)
  6377.       (parse-body (cddr *form*) nil (vector *venv* *fenv*))
  6378.     (let ((oldstackz *stackz*)
  6379.           (*stackz* *stackz*)
  6380.           (*denv* *denv*)
  6381.           (*venv* *venv*)
  6382.           (*venvc* *venvc*))
  6383.       (multiple-value-bind (*specials* *ignores* *ignorables*)
  6384.           (process-declarations declarations)
  6385.         ; Special-Variable auf *venv* pushen:
  6386.         (push-specials)
  6387.         ; Syntaxtest der Parameterliste:
  6388.         (multiple-value-bind (symbols initforms) (analyze-letlist (second *form*))
  6389.           (push 0 *stackz*) (push nil *venvc*) ; Platz fⁿr Closure-Dummyvar
  6390.           (let ((closuredummy-stackz *stackz*)
  6391.                 (closuredummy-venvc *venvc*))
  6392.             (multiple-value-bind (varlist anodelist stackzlist)
  6393.                 (process-movable-var-list symbols initforms *-flag)
  6394.               (unless *-flag (push 0 *stackz*)) ; Platz fⁿr Schlu▀-Bindungen
  6395.               (let ((body-anode (c-form `(PROGN ,@body-rest)))) ; Body compilieren
  6396.                 ; ▄berprⁿfen der Variablen:
  6397.                 (let* ((closurevars (checking-movable-var-list varlist anodelist))
  6398.                        (codelist
  6399.                          `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  6400.                            ,@(if *-flag
  6401.                                ; sequentielles Binden der Variablen
  6402.                                (mapcap #'c-bind-movable-var-anode varlist anodelist)
  6403.                                ; paralleles Binden der Variablen
  6404.                                (c-parallel-bind-movable-var-anode varlist anodelist stackzlist)
  6405.                              )
  6406.                            ,body-anode
  6407.                            (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  6408.                        )  )
  6409.                        (anode
  6410.                          (make-anode
  6411.                            :type (if *-flag 'LET* 'LET)
  6412.                            :sub-anodes `(,@anodelist ,body-anode)
  6413.                            :seclass (seclass-without
  6414.                                       (anodelist-seclass-or `(,@anodelist ,body-anode))
  6415.                                       varlist
  6416.                                     )
  6417.                            :stackz oldstackz
  6418.                            :code codelist
  6419.                       )) )
  6420.                   (when closurevars
  6421.                     (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  6422.                     (setf (first closuredummy-venvc)
  6423.                       (cons closurevars closuredummy-stackz)
  6424.                   ) )
  6425.                   (optimize-var-list varlist)
  6426.                   anode
  6427. ) ) ) ) ) ) ) ) )
  6428.  
  6429. ; compiliere (LOCALLY {declaration}* {form}*)
  6430. (defun c-LOCALLY (&optional (c #'c-form)) ; vgl. c-LET/LET*
  6431.   (test-list *form* 1)
  6432.   (multiple-value-bind (body-rest declarations)
  6433.       (parse-body (cdr *form*) nil (vector *venv* *fenv*))
  6434.     (let ((*venv* *venv*))
  6435.       (multiple-value-bind (*specials* ignores ignorables)
  6436.           (process-declarations declarations)
  6437.         (declare (ignore ignores ignorables))
  6438.         ; Special-Variable auf *venv* pushen:
  6439.         (push-specials)
  6440.         (funcall c `(PROGN ,@body-rest))
  6441. ) ) ) )
  6442.  
  6443. ; compiliere (MULTIPLE-VALUE-BIND ({var}*) form1 {declaration}* {form}*)
  6444. (defun c-MULTIPLE-VALUE-BIND ()
  6445.   (test-list *form* 3)
  6446.   (test-list (second *form*) 0)
  6447.   (let ((symbols (second *form*)))
  6448.     (dolist (sym symbols)
  6449.       (unless (symbolp sym)
  6450.         (c-error (DEUTSCH "Nur Symbole k÷nnen Variable sein, nicht ~S"
  6451.                   ENGLISH "Only symbols may be used as variables, not ~S"
  6452.                   FRANCAIS "Seuls les symboles peuvent servir de variable et non ~S")
  6453.                  sym
  6454.     ) ) )
  6455.     (if (= (length symbols) 1)
  6456.       (c-form `(LET ((,(first symbols) ,(third *form*))) ,@(cdddr *form*)))
  6457.       (multiple-value-bind (body-rest declarations)
  6458.           (parse-body (cdddr *form*) nil (vector *venv* *fenv*))
  6459.         (let ((oldstackz *stackz*)
  6460.               (*stackz* *stackz*)
  6461.               (*denv* *denv*)
  6462.               (*venv* *venv*)
  6463.               (*venvc* *venvc*))
  6464.           (multiple-value-bind (*specials* *ignores* *ignorables*)
  6465.               (process-declarations declarations)
  6466.             ; Special-Variable auf *venv* pushen:
  6467.             (push-specials)
  6468.             (if (null symbols) ; leere Variablenliste -> gar nichts binden
  6469.               (let* ((anode1 (c-form (third *form*) 'NIL))
  6470.                      (anode2 (c-form `(PROGN ,@(cdddr *form*)))))
  6471.                 (make-anode :type 'MULTIPLE-VALUE-BIND
  6472.                   :sub-anodes (list anode1 anode2)
  6473.                   :seclass (anodes-seclass-or anode1 anode2)
  6474.                   :code `(,anode1 ,anode2)
  6475.               ) )
  6476.               (let ((anode1 (c-form (third *form*) 'ALL)))
  6477.                 (push nil *venvc*) ; Sichtbarkeit von Closure-Dummyvar
  6478.                 (multiple-value-bind (varlist stackvarlist)
  6479.                     (process-fixed-var-list symbols)
  6480.                   (push 0 *stackz*) ; Platz fⁿr Closure-Dummyvar
  6481.                   (let* ((closuredummy-stackz *stackz*)
  6482.                          (closuredummy-venvc *venvc*)
  6483.                          (stackzlist
  6484.                            (do* ((varlistr varlist (cdr varlistr))
  6485.                                  (L '()))
  6486.                                 ((null varlistr) (nreverse L))
  6487.                              (let ((var (car varlistr)))
  6488.                                (push-*venv* var)
  6489.                                (push *stackz* L) (bind-fixed-var-2 var)
  6490.                          ) ) )
  6491.                          (body-anode ; Body compilieren
  6492.                            (c-form `(PROGN ,@body-rest))
  6493.                          )
  6494.                          ; ▄berprⁿfen der Variablen:
  6495.                          (closurevars (checking-fixed-var-list varlist))
  6496.                          (codelist ; Code generieren
  6497.                            `(,anode1
  6498.                              (NV-TO-STACK ,(length symbols))
  6499.                              ,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  6500.                              ,@ ; Binden von special- oder Closure-Variablen:
  6501.                                (do ((stackvarlistr stackvarlist (cdr stackvarlistr))
  6502.                                     (stackzlistr stackzlist (cdr stackzlistr))
  6503.                                     (varlistr varlist (cdr varlistr))
  6504.                                     (L '()))
  6505.                                    ((null varlistr) (nreverse L))
  6506.                                  (setq L
  6507.                                    (append
  6508.                                      (reverse
  6509.                                        (c-bind-fixed-var
  6510.                                          (car varlistr)
  6511.                                          (car stackvarlistr)
  6512.                                          (car stackzlistr)
  6513.                                      ) )
  6514.                                      L
  6515.                                ) ) )
  6516.                              ,body-anode
  6517.                              (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  6518.                          )  )
  6519.                          (anode
  6520.                            (make-anode
  6521.                              :type 'MULTIPLE-VALUE-BIND
  6522.                              :sub-anodes (list anode1 body-anode)
  6523.                              :seclass (seclass-without
  6524.                                         (anodes-seclass-or anode1 body-anode)
  6525.                                         varlist
  6526.                                       )
  6527.                              :stackz oldstackz
  6528.                              :code codelist
  6529.                         )) )
  6530.                     (when closurevars
  6531.                       (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  6532.                       (setf (first closuredummy-venvc)
  6533.                         (cons closurevars closuredummy-stackz)
  6534.                     ) )
  6535.                     (optimize-var-list varlist)
  6536.                     anode
  6537. ) ) ) ) ) ) ) ) ) )
  6538.  
  6539. ; compiliere (COMPILER-LET ({var|(var value)}*) {form}*)
  6540. (defun c-COMPILER-LET (&optional (c #'c-form))
  6541.   (test-list *form* 2)
  6542.   (test-list (second *form*) 0)
  6543.   (do ((L (second *form*) (cdr L))
  6544.        (varlist '())
  6545.        (valueslist '()))
  6546.       ((null L)
  6547.        (progv (nreverse varlist) (nreverse valueslist)
  6548.          (funcall c `(PROGN ,@(cddr *form*)) )
  6549.       ))
  6550.     (cond ((symbolp (car L)) (push (car L) varlist) (push nil valueslist))
  6551.           ((and (consp (car L)) (symbolp (caar L)) (consp (cdar L)) (null (cddar L)))
  6552.            (push (caar L) varlist) (push (eval (cadar L)) valueslist))
  6553.           (t (catch 'c-error
  6554.                (c-error (DEUTSCH "Falsche Syntax in COMPILER-LET: ~S"
  6555.                          ENGLISH "Illegal syntax in COMPILER-LET: ~S"
  6556.                          FRANCAIS "Mauvaise syntaxe pour COMPILER-LET : ~S")
  6557.                         (car L)
  6558.     )     )  ) )
  6559. ) )
  6560.  
  6561. (macrolet ((check-blockname (name)
  6562.              `(unless (symbolp ,name)
  6563.                 (catch 'c-error
  6564.                   (c-error (DEUTSCH "Blockname mu▀ ein Symbol sein, nicht ~S"
  6565.                             ENGLISH "Block name must be a symbol, not ~S"
  6566.                             FRANCAIS "Un nom de bloc doit Ωtre un symbole et non ~S")
  6567.                            ,name
  6568.                 ) )
  6569.                 (setq ,name NIL) ; Default-Blockname
  6570.               )
  6571.           ))
  6572.  
  6573. ; compiliere (BLOCK name {form}*)
  6574. (defun c-BLOCK ()
  6575.   (test-list *form* 2)
  6576.   (let ((name (second *form*)))
  6577.     (check-blockname name)
  6578.     (let* ((*stackz* (cons 'BLOCK *stackz*)) ; Block-Frame
  6579.            (label (make-label *for-value*))
  6580.            (block (make-block :fnode *func* :label label
  6581.                     :consvar (make-var :name (gensym) :specialp nil
  6582.                                        :closurep nil :stackz *stackz*
  6583.                              )
  6584.                     :stackz *stackz* :used-far nil :for-value *for-value*
  6585.            )      )
  6586.            (*benv* (cons (cons name block) *benv*)) ; Block aktivieren
  6587.            (anode (c-form `(PROGN ,@(cddr *form*))))
  6588.           )
  6589.       (if (block-used-far block)
  6590.         (make-anode :type 'BLOCK
  6591.                     :sub-anodes (list anode)
  6592.                     :seclass (anodes-seclass-or anode)
  6593.                     :code `((BLOCK-OPEN ,(new-const (and (symbol-package name) name)) ; (gensym) zu nil machen
  6594.                                         ,label
  6595.                             )
  6596.                             ,anode
  6597.                             (BLOCK-CLOSE)
  6598.                             ,label
  6599.         )                  )
  6600.         (progn
  6601.           (setf (first *stackz*) 0) ; brauche keinen Blockframe
  6602.           (make-anode :type 'BLOCK
  6603.                       :sub-anodes (list anode)
  6604.                       :seclass (anodes-seclass-or anode)
  6605.                       :code `(,anode ,label)
  6606. ) ) ) ) ) )
  6607.  
  6608. ; compiliere (RETURN-FROM name [form])
  6609. (defun c-RETURN-FROM ()
  6610.   (test-list *form* 2 3)
  6611.   (let ((name (second *form*)))
  6612.     (check-blockname name)
  6613.     (let ((a (benv-search name)))
  6614.       (cond ((null a) ; dieser Blockname ist unsichtbar
  6615.              (c-error (DEUTSCH "RETURN-FROM auf Block ~S an dieser Stelle nicht m÷glich."
  6616.                        ENGLISH "RETURN-FROM block ~S is impossible from here."
  6617.                        FRANCAIS "RETURN-FROM bloc ~S est impossible α partir d'ici.")
  6618.                       name
  6619.             ))
  6620.             ((block-p a) ; in *benv* ohne %benv% sichtbar
  6621.              (let ((anode (c-form (third *form*) (block-for-value a))))
  6622.                (if (and (eq (block-fnode a) *func*)
  6623.                         (may-UNWIND *stackz* (cdr (block-stackz a)))
  6624.                    )
  6625.                  ; selbe Funktionen
  6626.                  (make-anode
  6627.                    :type 'RETURN-FROM
  6628.                    :sub-anodes (list anode)
  6629.                    :seclass '(T . T)
  6630.                    :code `(,anode
  6631.                            (UNWIND ,*stackz* ,(cdr (block-stackz a)) ,(block-for-value a))
  6632.                            (JMP ,(block-label a))
  6633.                  )        )
  6634.                  ; verschiedene Funktionen oder unbekannte Frames auf dem Stack
  6635.                  (progn
  6636.                    (unless *no-code*
  6637.                      ; in alle dazwischenliegenden Funktionen diesen Block eintragen:
  6638.                      (do ((fnode *func* (fnode-enclosing fnode)))
  6639.                          ((eq fnode (block-fnode a)))
  6640.                        (pushnew a (fnode-blocks fnode))
  6641.                      )
  6642.                      (setf (block-used-far a) t)
  6643.                    )
  6644.                    (make-anode
  6645.                      :type 'RETURN-FROM
  6646.                      :sub-anodes (list anode)
  6647.                      :seclass '(T . T)
  6648.                      :code `(,anode
  6649.                              ,@(if (not (block-for-value a)) '((VALUES0)))
  6650.                              (RETURN-FROM ,a
  6651.                               ,@(if (eq (block-fnode a) *func*) `(,*stackz*) '())
  6652.                    )        ))
  6653.             )) ) )
  6654.             ((consp a) ; in %benv% sichtbar
  6655.              (let ((anode (c-form (third *form*) 'ALL)))
  6656.                (make-anode
  6657.                  :type 'RETURN-FROM
  6658.                  :sub-anodes (list anode)
  6659.                  :seclass '(T . T)
  6660.                  :code `(,anode
  6661.                          (RETURN-FROM ,(new-const a))
  6662.             )) )        )
  6663.             (t (compiler-error 'c-RETURN-FROM))
  6664. ) ) ) )
  6665.  
  6666. ) ; macrolet
  6667.  
  6668. ; compiliere (TAGBODY {tag|form}*)
  6669. (defun c-TAGBODY ()
  6670.   (test-list *form* 1)
  6671.   (multiple-value-bind (taglist labellist)
  6672.     (do ((L (cdr *form*) (cdr L))
  6673.          (taglist '())
  6674.          (labellist '()))
  6675.         ((null L) (values (nreverse taglist) (nreverse labellist)))
  6676.       (let ((item (car L)))
  6677.         (if (atom item)
  6678.           (if (or (and (symbolp item) (not (null item))) (numberp item))
  6679.             ; Symbol NIL wird ausgeschlossen, weil zweideutig (ist auch Liste!).
  6680.             ; Andere Zahlen werden zugelassen, damit - ebenso wie 3.3.2 - auch
  6681.             ; 3.3 ein zulΣssiges Sprungziel ist.
  6682.             (progn
  6683.               (push item taglist)
  6684.               (push (make-label 'NIL) labellist)
  6685.             )
  6686.             (catch 'c-error
  6687.               (c-error (DEUTSCH "Nur Zahlen und Symbole sind zulΣssige Sprungziele, nicht aber ~S"
  6688.                         ENGLISH "Only numbers and symbols are valid tags, not ~S"
  6689.                         FRANCAIS "Seuls les symboles et les nombres peuvent servir de marqueur de saut et non ~S")
  6690.                        item
  6691.     ) ) ) ) ) )
  6692.     (let* ((*stackz* (cons 0 *stackz*)) ; evtl. TAGBODY-Frame
  6693.            (tagbody (make-tagbody :fnode *func* :labellist labellist
  6694.                       :consvar (make-var :name (gensym) :specialp nil
  6695.                                          :closurep nil :stackz *stackz*
  6696.                                )
  6697.                       :stackz *stackz*
  6698.                       :used-far (make-array (length taglist) :fill-pointer 0)
  6699.            )        )
  6700.            (*genv* (cons (cons (apply #'vector taglist) tagbody) *genv*))
  6701.              ; Tagbody aktivieren
  6702.            (codelist '())
  6703.            #+COMPILER-DEBUG (anodelist '())
  6704.            (seclass '(NIL . NIL)))
  6705.       ; Inneres des Tagbody compilieren:
  6706.       (do ((formlistr (cdr *form*) (cdr formlistr))
  6707.            (taglistr taglist)
  6708.            (labellistr labellist))
  6709.           ((null formlistr)
  6710.            #+COMPILER-DEBUG (setq anodelist (nreverse anodelist))
  6711.            (setq codelist (nreverse codelist))
  6712.           )
  6713.         (let ((formi (car formlistr)))
  6714.           (if (atom formi)
  6715.             (when (and (consp taglistr) (eql formi (car taglistr)))
  6716.               ; Tag wiedergefunden
  6717.               (pop taglistr) (push (pop labellistr) codelist)
  6718.             )
  6719.             (let ((anodei (c-form formi 'NIL)))
  6720.               #+COMPILER-DEBUG (push anodei anodelist)
  6721.               (seclass-or-f seclass anodei)
  6722.               (push anodei codelist)
  6723.       ) ) ) )
  6724.       (if (> (length (tagbody-used-far tagbody)) 0)
  6725.         (let* ((used-tags (tagbody-used-far tagbody))
  6726.                (l (length used-tags))
  6727.                (used-label-list
  6728.                  (do ((i 0 (1+ i))
  6729.                       (l1 '()))
  6730.                      ((= i l) (nreverse l1))
  6731.                    (push
  6732.                      (elt labellist (position (aref used-tags i) taglist :test #'eql))
  6733.                      l1
  6734.               )) ) )
  6735.           (setf (first *stackz*) `(TAGBODY ,l))
  6736.           (setq codelist
  6737.             `((TAGBODY-OPEN
  6738.                 ,(new-const (map 'simple-vector
  6739.                                  #'(lambda (tag) (and (symbol-package tag) tag)) ; (gensym)s zu nil machen
  6740.                                  used-tags
  6741.                  )          )
  6742.                 ,@used-label-list
  6743.               )
  6744.               ,@codelist
  6745.               (TAGBODY-CLOSE-NIL)
  6746.         ) )  )
  6747.         (when *for-value* (setq codelist `(,@codelist (NIL))))
  6748.       )
  6749.       (make-anode :type 'TAGBODY
  6750.                   :sub-anodes anodelist
  6751.                   :seclass seclass
  6752.                   :code codelist
  6753. ) ) ) )
  6754.  
  6755. ; compiliere (GO tag)
  6756. (defun c-GO ()
  6757.   (test-list *form* 2 2)
  6758.   (let ((tag (second *form*)))
  6759.     (unless (or (and (symbolp tag) (not (null tag))) (numberp tag))
  6760.       (c-error (DEUTSCH "Sprungziel mu▀ ein Symbol oder eine Zahl sein, nicht ~S"
  6761.                 ENGLISH "Tag must be a symbol or a number, not ~S"
  6762.                 FRANCAIS "Le marqueur de saut doit Ωtre un symbole ou un nombre et non ~S")
  6763.                tag
  6764.     ) )
  6765.     (multiple-value-bind (a b) (genv-search tag)
  6766.       (cond ((null a) ; dieser Tag ist unsichtbar
  6767.              (c-error (DEUTSCH "GO auf Tag ~S an dieser Stelle nicht m÷glich."
  6768.                        ENGLISH "GO to tag ~S is impossible from here."
  6769.                        FRANCAIS "GO vers le marqueur ~S n'est pas possible ici.")
  6770.                       tag
  6771.             ))
  6772.             ((tagbody-p a) ; in *genv* ohne %genv% sichtbar
  6773.              (if (and (eq (tagbody-fnode a) *func*)
  6774.                       (may-UNWIND *stackz* (tagbody-stackz a))
  6775.                  )
  6776.                ; selbe Funktionen
  6777.                (make-anode
  6778.                  :type 'GO
  6779.                  :sub-anodes '()
  6780.                  :seclass '(T . T)
  6781.                  :code `((UNWIND ,*stackz* ,(tagbody-stackz a) nil)
  6782.                          (JMP ,(nth b (tagbody-labellist a)))
  6783.                )        )
  6784.                ; verschiedene Funktionen oder unbekannte Frames auf dem Stack
  6785.                (let ((index 0))
  6786.                  (unless *no-code*
  6787.                    (setq index
  6788.                      (do* ((v (tagbody-used-far a))
  6789.                            (l (length v))
  6790.                            (i 0 (1+ i)))
  6791.                           ((= i l) (vector-push tag v) l)
  6792.                        (if (eql (aref v i) tag) (return i))
  6793.                    ) )
  6794.                    ; (aref (tagbody-used-far a) index) = tag
  6795.                    ; in alle dazwischenliegenden Funktionen diesen Tagbody eintragen:
  6796.                    (do ((fnode *func* (fnode-enclosing fnode)))
  6797.                        ((eq fnode (tagbody-fnode a)))
  6798.                      (pushnew a (fnode-tagbodys fnode))
  6799.                  ) )
  6800.                  (make-anode
  6801.                    :type 'GO
  6802.                    :sub-anodes '()
  6803.                    :seclass '(T . T)
  6804.                    :code `((VALUES0)
  6805.                            (GO ,a ,index
  6806.                             ,@(if (eq (tagbody-fnode a) *func*) `(,*stackz*) '())
  6807.                           ))
  6808.                  )
  6809.             )) )
  6810.             ((consp a) ; in %genv% sichtbar
  6811.              (make-anode
  6812.                :type 'GO
  6813.                :sub-anodes '()
  6814.                :seclass '(T . T)
  6815.                :code `((GO ,(new-const a) ,b))
  6816.             ))
  6817.             (t (compiler-error 'c-GO))
  6818. ) ) ) )
  6819.  
  6820. ; compiliere (FUNCTION funname)
  6821. (defun c-FUNCTION ()
  6822.   (test-list *form* 2 3)
  6823.   (let* ((longp (cddr *form*)) ; Flag, ob Langform (FUNCTION name funname)
  6824.          (name (second *form*)))
  6825.     (if (and (not longp) (function-name-p name))
  6826.       (multiple-value-bind (a b c) (fenv-search name)
  6827.         (case a
  6828.           ((NIL)
  6829.            (when *compiling-from-file* ; von COMPILE-FILE aufgerufen?
  6830.              (unless (or (fboundp name) (member name *known-functions* :test #'equal))
  6831.                (pushnew name *unknown-functions* :test #'equal)
  6832.            ) )
  6833.            (make-anode
  6834.              :type 'FUNCTION
  6835.              :sub-anodes '()
  6836.              :seclass '(T . NIL)
  6837.              :code (if (and (subr-info name) (not (declared-notinline name)))
  6838.                      `((CONST ,(make-const :value (symbol-function name)
  6839.                                            :form `(FUNCTION ,name)
  6840.                       ))       )
  6841.                      `((CONST ,(make-funname-const name)) (SYMBOL-FUNCTION))
  6842.           ))       )
  6843.           (SYSTEM::MACRO
  6844.            (c-error (DEUTSCH "~S ist keine Funktion, sondern ein lokal definierter Macro."
  6845.                      ENGLISH "~S is not a function. It is a locally defined macro."
  6846.                      FRANCAIS "~S n'est pas une fonction mais une macro dΘfinie localement.")
  6847.                     name
  6848.           ))
  6849.           (GLOBAL ; gefunden in %fenv%
  6850.            (make-anode
  6851.              :type 'FUNCTION
  6852.              :sub-anodes '()
  6853.              :seclass '(T . NIL)
  6854.              :code `((CONST ,(new-const b))
  6855.                      (PUSH)
  6856.                      (CONST ,(new-const c))
  6857.                      (SVREF)
  6858.           ))        )
  6859.           (LOCAL ; gefunden in *fenv* ohne %fenv%
  6860.            (if (const-p b)
  6861.              (make-anode
  6862.                :type 'FUNCTION
  6863.                :sub-anodes '()
  6864.                :seclass '(NIL . NIL)
  6865.                :code `((FCONST ,(const-value b)))
  6866.              )
  6867.              (c-VAR (var-name b))
  6868.           ))
  6869.           (t (compiler-error 'c-FUNCTION))
  6870.       ) )
  6871.       (let ((funname (car (last *form*))))
  6872.         (if (and (consp funname) (eq (car funname) 'LAMBDA) (consp (cdr funname)))
  6873.           (let ((*no-code* (or *no-code* (null *for-value*))))
  6874.             (c-fnode-function
  6875.               (c-lambdabody
  6876.                 (if (and longp (function-name-p name))
  6877.                   name ; angegebener Funktionsname
  6878.                   (symbol-suffix (fnode-name *func*) (incf *anonymous-count*))
  6879.                 )
  6880.                 (cdr funname)
  6881.           ) ) )
  6882.           (c-error (DEUTSCH "Nur Symbole und Lambda-Ausdrⁿcke sind Namen von Funktionen, nicht ~S"
  6883.                     ENGLISH "Only symbols and lambda expressions are function names, not ~S"
  6884.                     FRANCAIS "Seuls les symboles et les expressions lambda sont des noms de fonction et non ~S")
  6885.                    funname
  6886. ) ) ) ) ) )
  6887.  
  6888. ; compiliere (%GENERIC-FUNCTION-LAMBDA . lambdabody)
  6889. (defun c-%GENERIC-FUNCTION-LAMBDA ()
  6890.   (test-list *form* 1)
  6891.   (let ((*no-code* (or *no-code* (null *for-value*))))
  6892.     (c-fnode-function
  6893.       (c-lambdabody
  6894.         (symbol-suffix (fnode-name *func*) (incf *anonymous-count*))
  6895.         (cdr *form*)
  6896.         nil
  6897.         t ; gf-p = T, Code fⁿr generische Funktion bauen
  6898. ) ) ) )
  6899.  
  6900. ; compiliere (%OPTIMIZE-FUNCTION-LAMBDA reqoptimflags . lambdabody)
  6901. ; reqoptimflags ist eine Liste von Flags, welche Required-Parameter des
  6902. ; lambdabody wegoptimiert werden dⁿrfen. Zu jedem Required-Parameter:
  6903. ; NIL: normal,
  6904. ; T: darf wegoptimiert werden, dann wird daraus GONE gemacht.
  6905. ; NILs am Schlu▀ der Liste dⁿrfen weggelassen werden.
  6906. ; Die Ausgabe enthΣlt zusΣtzlich zur Funktion die Liste der Wegoptimierten.
  6907. (defmacro %OPTIMIZE-FUNCTION-LAMBDA (reqoptimflags &rest lambdabody)
  6908.   (declare (ignore reqoptimflags))
  6909.   `(CONS (FUNCTION (LAMBDA ,@lambdabody)) NIL) ; ohne Compiler: nicht optimieren
  6910. )
  6911. (defun c-%OPTIMIZE-FUNCTION-LAMBDA ()
  6912.   (test-list *form* 2)
  6913.   (let ((*no-code* (or *no-code* (null *for-value*))))
  6914.     (let* ((reqoptimflags (copy-list (second *form*)))
  6915.            (anode1
  6916.              (c-fnode-function
  6917.                (c-lambdabody
  6918.                  (symbol-suffix (fnode-name *func*) (incf *anonymous-count*))
  6919.                  (cddr *form*)
  6920.                  nil nil reqoptimflags
  6921.            ) ) )
  6922.            (resultflags (mapcar #'(lambda (x) (eq x 'GONE)) reqoptimflags))
  6923.            (anode2 (let ((*stackz* (cons 1 *stackz*))
  6924.                          (*form* `(QUOTE ,resultflags)))
  6925.                      (c-QUOTE)
  6926.           ))       )
  6927.       (make-anode :type '%OPTIMIZE-FUNCTION-LAMBDA
  6928.                   :sub-anodes (list anode1 anode2)
  6929.                   :seclass (anodes-seclass-or anode1 anode2)
  6930.                   :code `(,anode1 (PUSH) ,anode2 (CONS))
  6931. ) ) ) )
  6932.  
  6933. (macrolet ((err-syntax (specform fdef)
  6934.              `(catch 'c-error
  6935.                 (c-error (DEUTSCH "Falsche Syntax einer Funktionsdefinition in ~S: ~S"
  6936.                           ENGLISH "Illegal function definition syntax in ~S: ~S"
  6937.                           FRANCAIS "Mauvaise syntaxe de dΘfinition de fonction dans ~S : ~S")
  6938.                          ,specform ,fdef
  6939.               ) )
  6940.           ))
  6941.  
  6942. ; compiliere (FLET ({fundef}*) {form}*)
  6943. (defun c-FLET ()
  6944.   (test-list *form* 2)
  6945.   (test-list (second *form*) 0)
  6946.   (multiple-value-bind (namelist fnodelist)
  6947.       (do ((fdefsr (second *form*) (cdr fdefsr))
  6948.            (L1 '())
  6949.            (L2 '()))
  6950.           ((null fdefsr) (values (nreverse L1) (nreverse L2)))
  6951.         (let ((fdef (car fdefsr)))
  6952.           (if (and (consp fdef) (function-name-p (car fdef)) (consp (cdr fdef)))
  6953.             (let ((fnode (c-lambdabody
  6954.                            (symbol-suffix (fnode-name *func*) (car fdef))
  6955.                            (cdr fdef)
  6956.                  ))      )
  6957.               (push (car fdef) L1)
  6958.               (push fnode L2)
  6959.             )
  6960.             (err-syntax 'FLET fdef)
  6961.       ) ) )
  6962.     ; namelist = Liste der Namen, fnodelist = Liste der fnodes der Funktionen
  6963.     (let ((oldstackz *stackz*)
  6964.           (*stackz* *stackz*)
  6965.           (*venvc* *venvc*)
  6966.           (*venv* *venv*))
  6967.       (push 0 *stackz*) (push nil *venvc*) ; Platz fⁿr Closure-Dummyvar
  6968.       (let ((closuredummy-stackz *stackz*)
  6969.             (closuredummy-venvc *venvc*))
  6970.         (multiple-value-bind (varlist anodelist *fenv*)
  6971.             (do ((namelistr namelist (cdr namelistr))
  6972.                  (fnodelistr fnodelist (cdr fnodelistr))
  6973.                  (varlist '())
  6974.                  (anodelist '())
  6975.                  (fenv '()))
  6976.                 ((null namelistr)
  6977.                  (values (nreverse varlist) (nreverse anodelist)
  6978.                          (apply #'vector (nreverse (cons *fenv* fenv)))
  6979.                 ))
  6980.               (push (car namelistr) fenv)
  6981.               (let ((fnode (car fnodelistr)))
  6982.                 (if (zerop (fnode-keyword-offset fnode))
  6983.                   ; Funktionsdefinition ist autonom
  6984.                   (push (cons (list fnode) (make-const :value fnode)) fenv)
  6985.                   (progn
  6986.                     (push (c-fnode-function fnode) anodelist)
  6987.                     (push 1 *stackz*)
  6988.                     (let ((var (make-var :name (gensym) :specialp nil
  6989.                                  :constantp nil :usedp t :really-usedp nil
  6990.                                  :closurep nil ; spΣter evtl. auf T gesetzt
  6991.                                  :stackz *stackz* :venvc *venvc*
  6992.                          ))    )
  6993.                       (push (cons (list fnode) var) fenv)
  6994.                       (push var varlist)
  6995.             ) ) ) ) )
  6996.           (apply #'push-*venv* varlist) ; Hilfsvariablen aktivieren
  6997.           (let* ((body-anode ; restliche Formen compilieren
  6998.                    (c-form `(PROGN ,@(cddr *form*)))
  6999.                  )
  7000.                  (closurevars (checking-movable-var-list varlist anodelist))
  7001.                  (anode
  7002.                    (make-anode
  7003.                      :type 'FLET
  7004.                      :sub-anodes `(,@anodelist ,body-anode)
  7005.                      :seclass (seclass-without
  7006.                                 (anodelist-seclass-or `(,@anodelist ,body-anode))
  7007.                                 varlist
  7008.                               )
  7009.                      :code `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7010.                              ,@(mapcap #'c-bind-movable-var-anode varlist anodelist)
  7011.                              ,body-anode
  7012.                              (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7013.                    )        )
  7014.                 ))
  7015.             (when closurevars
  7016.               (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  7017.               (setf (first closuredummy-venvc)
  7018.                 (cons closurevars closuredummy-stackz)
  7019.             ) )
  7020.             (optimize-var-list varlist)
  7021.             anode
  7022. ) ) ) ) ) )
  7023.  
  7024. ; compiliere (LABELS ({fundef}*) {form}*)
  7025. (defun c-LABELS ()
  7026.   (test-list *form* 2)
  7027.   (test-list (second *form*) 0)
  7028.   (let ((oldstackz *stackz*)
  7029.         (*stackz* *stackz*)
  7030.         (*venvc* *venvc*)
  7031.         (*venv* *venv*))
  7032.     (push 0 *stackz*) (push nil *venvc*) ; Platz fⁿr Closure-Dummyvar
  7033.     (let ((closuredummy-stackz *stackz*)
  7034.           (closuredummy-venvc *venvc*))
  7035.       (multiple-value-bind (namelist varlist lambdanamelist lambdabodylist fenvconslist)
  7036.           (do ((fdefsr (second *form*) (cdr fdefsr))
  7037.                (L1 '())
  7038.                (L2 '())
  7039.                (L3 '())
  7040.                (L4 '())
  7041.                (L5 '()))
  7042.               ((null fdefsr)
  7043.                (values (nreverse L1) (nreverse L2) (nreverse L3) (nreverse L4) (nreverse L5))
  7044.               )
  7045.             (let ((fdef (car fdefsr)))
  7046.               (if (and (consp fdef) (function-name-p (car fdef)) (consp (cdr fdef)))
  7047.                 (progn
  7048.                   (push (car fdef) L1)
  7049.                   (push 1 *stackz*)
  7050.                   (push (make-var :name (gensym) :specialp nil
  7051.                                   :constantp nil :usedp t :really-usedp nil
  7052.                                   :closurep nil ; spΣter evtl. auf T gesetzt
  7053.                                   :stackz *stackz* :venvc *venvc*
  7054.                         )
  7055.                         L2
  7056.                   )
  7057.                   (push (symbol-suffix (fnode-name *func*) (car fdef)) L3)
  7058.                   (push (cdr fdef) L4)
  7059.                   (push
  7060.                     (cons
  7061.                       ; fdescr, bestehend aus:
  7062.                       (cons nil ; Platz fⁿr den FNODE
  7063.                         (cons 'LABELS
  7064.                           (multiple-value-list ; Werten von analyze-lambdalist
  7065.                             (analyze-lambdalist (cadr fdef))
  7066.                       ) ) )
  7067.                       ; Variable
  7068.                       (car L2)
  7069.                     )
  7070.                     L5
  7071.                 ) )
  7072.                 (err-syntax 'LABELS fdef)
  7073.           ) ) )
  7074.         ; namelist = Liste der Namen, varlist = Liste der Variablen,
  7075.         ; lambdanamelist = Liste der Dummynamen der Funktionen,
  7076.         ; lambdabodylist = Liste der Lambdabodys der Funktionen,
  7077.         ; fenvconslist = Liste der Conses (fdescr . var) fⁿr *fenv*
  7078.         ; (jeweils fdescr noch ohne den fnode, der kommt erst spΣter hinein).
  7079.         (let ((*fenv* ; Funktionsnamen aktivieren
  7080.                 (do ((namelistr namelist (cdr namelistr))
  7081.                      (fenvconslistr fenvconslist (cdr fenvconslistr))
  7082.                      (L nil))
  7083.                     ((null namelistr)
  7084.                      (push *fenv* L)
  7085.                      (apply #'vector (nreverse L))
  7086.                     )
  7087.                   (push (car namelistr) L)
  7088.                   (push (car fenvconslistr) L)
  7089.              )) )
  7090.           (apply #'push-*venv* varlist) ; Hilfsvariablen aktivieren
  7091.           (let* ((fnodelist ; Funktionen compilieren
  7092.                    (mapcar #'c-lambdabody lambdanamelist lambdabodylist fenvconslist)
  7093.                  )
  7094.                  (anodelist
  7095.                    (mapcar #'(lambda (fnode var)
  7096.                                (c-fnode-function fnode (cdr (var-stackz var)))
  7097.                              )
  7098.                            fnodelist varlist
  7099.                  ) )
  7100.                  (body-anode ; restliche Formen compilieren
  7101.                    (c-form `(PROGN ,@(cddr *form*)))
  7102.                 ))
  7103.             ; die Variablen, zu denen die Funktion autonom war, werden nach-
  7104.             ; trΣglich zu Konstanten erklΣrt:
  7105.             (do ((varlistr varlist (cdr varlistr))
  7106.                  (fnodelistr fnodelist (cdr fnodelistr)))
  7107.                 ((null varlistr))
  7108.               (let ((var (car varlistr))
  7109.                     (fnode (car fnodelistr)))
  7110.                 (when (zerop (fnode-keyword-offset fnode))
  7111.                   ; Funktionsdefinition ist autonom
  7112.                   (setf (var-constantp var) t)
  7113.                   (setf (var-constant var) (new-const fnode))
  7114.             ) ) )
  7115.             (let* ((closurevars (checking-movable-var-list varlist anodelist))
  7116.                    (anode
  7117.                      (make-anode
  7118.                        :type 'LABELS
  7119.                        :sub-anodes `(,@anodelist ,body-anode)
  7120.                        :seclass (seclass-without
  7121.                                   (anodelist-seclass-or `(,@anodelist ,body-anode))
  7122.                                   varlist
  7123.                                 )
  7124.                        :code `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7125.                                ,@(mapcap #'c-bind-movable-var-anode varlist anodelist)
  7126.                                ,body-anode
  7127.                                (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7128.                      )        )
  7129.                   ))
  7130.               (when closurevars
  7131.                 (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  7132.                 (setf (first closuredummy-venvc)
  7133.                   (cons closurevars closuredummy-stackz)
  7134.               ) )
  7135.               (optimize-var-list varlist)
  7136.               anode
  7137. ) ) ) ) ) ) )
  7138.  
  7139. ; compiliere (CLOS:GENERIC-FLET ({genfundefs}*) {form}*)
  7140. (defun c-GENERIC-FLET ()
  7141.   (test-list *form* 2)
  7142.   (test-list (second *form*) 0)
  7143.   (multiple-value-bind (namelist signlist formlist)
  7144.       (do ((fdefsr (second *form*) (cdr fdefsr))
  7145.            (L1 '())
  7146.            (L2 '())
  7147.            (L3 '()))
  7148.           ((null fdefsr) (values (nreverse L1) (nreverse L2) (nreverse L3)))
  7149.         (let ((fdef (car fdefsr)))
  7150.           (if (and (consp fdef) (function-name-p (car fdef)) (consp (cdr fdef)))
  7151.             (let ((name (first fdef)))
  7152.               (push name L1)
  7153.               (push (clos::defgeneric-lambdalist-callinfo 'clos:generic-flet name (second fdef))
  7154.                     L2
  7155.               )
  7156.               (push (clos::make-generic-function-form 'clos:generic-flet
  7157.                       name (second fdef) (cddr fdef) (vector *venv* *fenv*)
  7158.                     )
  7159.                     L3
  7160.             ) )
  7161.             (err-syntax 'CLOS:GENERIC-FLET fdef)
  7162.       ) ) )
  7163.     ; namelist = Liste der Namen,
  7164.     ; signlist = Liste der Signaturen der generischen Funktionen,
  7165.     ; formlist = Liste der Konstruktor-Formen der generischen Funktionen.
  7166.     (let ((oldstackz *stackz*)
  7167.           (*stackz* *stackz*)
  7168.           (*venvc* *venvc*)
  7169.           (*venv* *venv*))
  7170.       (push 0 *stackz*) (push nil *venvc*) ; Platz fⁿr Closure-Dummyvar
  7171.       (let ((closuredummy-stackz *stackz*)
  7172.             (closuredummy-venvc *venvc*))
  7173.         (multiple-value-bind (varlist anodelist *fenv*)
  7174.             (do ((namelistr namelist (cdr namelistr))
  7175.                  (signlistr signlist (cdr signlistr))
  7176.                  (formlistr formlist (cdr formlistr))
  7177.                  (varlist '())
  7178.                  (anodelist '())
  7179.                  (fenv '()))
  7180.                 ((null namelistr)
  7181.                  (values (nreverse varlist) (nreverse anodelist)
  7182.                          (apply #'vector (nreverse (cons *fenv* fenv)))
  7183.                 ))
  7184.               (push (car namelistr) fenv)
  7185.               (push (c-form (car formlistr) 'ONE) anodelist)
  7186.               (push 1 *stackz*)
  7187.               (let ((var (make-var :name (gensym) :specialp nil
  7188.                            :constantp nil :usedp t :really-usedp nil
  7189.                            :closurep nil ; spΣter evtl. auf T gesetzt
  7190.                            :stackz *stackz* :venvc *venvc*
  7191.                    ))    )
  7192.                 (push (cons (list* nil 'GENERIC (car signlistr)) var) fenv)
  7193.                 (push var varlist)
  7194.             ) )
  7195.           (apply #'push-*venv* varlist) ; Hilfsvariablen aktivieren
  7196.           (let* ((body-anode ; restliche Formen compilieren
  7197.                    (c-form `(PROGN ,@(cddr *form*)))
  7198.                  )
  7199.                  (closurevars (checking-movable-var-list varlist anodelist))
  7200.                  (anode
  7201.                    (make-anode
  7202.                      :type 'CLOS:GENERIC-FLET
  7203.                      :sub-anodes `(,@anodelist ,body-anode)
  7204.                      :seclass (seclass-without
  7205.                                 (anodelist-seclass-or `(,@anodelist ,body-anode))
  7206.                                 varlist
  7207.                               )
  7208.                      :code `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7209.                              ,@(mapcap #'c-bind-movable-var-anode varlist anodelist)
  7210.                              ,body-anode
  7211.                              (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7212.                    )        )
  7213.                 ))
  7214.             (when closurevars
  7215.               (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  7216.               (setf (first closuredummy-venvc)
  7217.                 (cons closurevars closuredummy-stackz)
  7218.             ) )
  7219.             (optimize-var-list varlist)
  7220.             anode
  7221. ) ) ) ) ) )
  7222.  
  7223. ; compiliere (CLOS:GENERIC-LABELS ({genfundefs}*) {form}*)
  7224. (defun c-GENERIC-LABELS ()
  7225.   (test-list *form* 2)
  7226.   (test-list (second *form*) 0)
  7227.   (let ((oldstackz *stackz*)
  7228.         (*stackz* *stackz*)
  7229.         (*venvc* *venvc*)
  7230.         (*venv* *venv*))
  7231.     (push 0 *stackz*) (push nil *venvc*) ; Platz fⁿr Closure-Dummyvar
  7232.     (let ((closuredummy-stackz *stackz*)
  7233.           (closuredummy-venvc *venvc*))
  7234.       (multiple-value-bind (namelist varlist fenvconslist formlist)
  7235.           (do ((fdefsr (second *form*) (cdr fdefsr))
  7236.                (L1 '())
  7237.                (L2 '())
  7238.                (L3 '())
  7239.                (L4 '()))
  7240.               ((null fdefsr)
  7241.                (values (nreverse L1) (nreverse L2) (nreverse L3) (nreverse L4))
  7242.               )
  7243.             (let ((fdef (car fdefsr)))
  7244.               (if (and (consp fdef) (function-name-p (car fdef)) (consp (cdr fdef)))
  7245.                 (let ((name (first fdef)))
  7246.                   (push name L1)
  7247.                   (push 1 *stackz*)
  7248.                   (push (make-var :name (gensym) :specialp nil
  7249.                                   :constantp nil :usedp t :really-usedp nil
  7250.                                   :closurep nil ; spΣter evtl. auf T gesetzt
  7251.                                   :stackz *stackz* :venvc *venvc*
  7252.                         )
  7253.                         L2
  7254.                   )
  7255.                   (push (cons
  7256.                           ; fdescr
  7257.                           (list* nil 'GENERIC
  7258.                                  (clos::defgeneric-lambdalist-callinfo 'clos:generic-labels name (second fdef))
  7259.                           )
  7260.                           ; Variable
  7261.                           (car L2)
  7262.                         )
  7263.                         L3
  7264.                   )
  7265.                   (push (clos::make-generic-function-form 'clos:generic-labels
  7266.                           name (second fdef) (cddr fdef) (vector *venv* *fenv*)
  7267.                         )
  7268.                         L4
  7269.                 ) )
  7270.                 (err-syntax 'CLOS:GENERIC-LABELS fdef)
  7271.           ) ) )
  7272.         ; namelist = Liste der Namen, varlist = Liste der Variablen,
  7273.         ; fenvconslist = Liste der Conses (fdescr . var) fⁿr *fenv*,
  7274.         ; formlist = Liste der Konstruktor-Formen der generischen Funktionen.
  7275.         (let ((*fenv* ; Funktionsnamen aktivieren
  7276.                 (do ((namelistr namelist (cdr namelistr))
  7277.                      (fenvconslistr fenvconslist (cdr fenvconslistr))
  7278.                      (L nil))
  7279.                     ((null namelistr)
  7280.                      (push *fenv* L)
  7281.                      (apply #'vector (nreverse L))
  7282.                     )
  7283.                   (push (car namelistr) L)
  7284.                   (push (car fenvconslistr) L)
  7285.              )) )
  7286.           (apply #'push-*venv* varlist) ; Hilfsvariablen aktivieren
  7287.           (let* ((anodelist
  7288.                    (mapcar #'(lambda (form) (c-form form 'ONE)) formlist)
  7289.                  )
  7290.                  (body-anode ; restliche Formen compilieren
  7291.                    (c-form `(PROGN ,@(cddr *form*)))
  7292.                  )
  7293.                  (closurevars (checking-movable-var-list varlist anodelist))
  7294.                  (anode
  7295.                    (make-anode
  7296.                      :type 'CLOS:GENERIC-LABELS
  7297.                      :sub-anodes `(,@anodelist ,body-anode)
  7298.                      :seclass (seclass-without
  7299.                                 (anodelist-seclass-or `(,@anodelist ,body-anode))
  7300.                                 varlist
  7301.                               )
  7302.                      :code `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7303.                              ,@(mapcap #'c-bind-movable-var-anode varlist anodelist)
  7304.                              ,body-anode
  7305.                              (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7306.                    )        )
  7307.                 ))
  7308.             (when closurevars
  7309.               (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  7310.               (setf (first closuredummy-venvc)
  7311.                 (cons closurevars closuredummy-stackz)
  7312.             ) )
  7313.             (optimize-var-list varlist)
  7314.             anode
  7315. ) ) ) ) ) )
  7316.  
  7317. ) ; macrolet
  7318.  
  7319. ; compiliere (MACROLET ({macrodef}*) {form}*)
  7320. (defun c-MACROLET (&optional (c #'c-form))
  7321.   (test-list *form* 2)
  7322.   (test-list (second *form*) 0)
  7323.   (do ((L1 (second *form*) (cdr L1))
  7324.        (L2 '()))
  7325.       ((null L1)
  7326.        (push *fenv* L2)
  7327.        (let ((*fenv* (apply #'vector (nreverse L2)))) ; *fenv* erweitern
  7328.          (funcall c `(PROGN ,@(cddr *form*))) ; restliche Formen compilieren
  7329.       ))
  7330.     (let* ((macrodef (car L1))
  7331.            (name (car macrodef)))
  7332.       (push name L2)
  7333.       (push #+CLISP (sys::make-macro-expandercons macrodef)
  7334.             #-CLISP (cons 'SYSTEM::MACRO (make-macro-expander macrodef))
  7335.             L2
  7336.   ) ) )
  7337. )
  7338.  
  7339. ; compiliere (SYMBOL-MACROLET ({symdef}*) {declaration}* {form}*)
  7340. (defun c-SYMBOL-MACROLET (&optional (c #'c-form))
  7341.   (test-list *form* 2)
  7342.   (test-list (second *form*) 0)
  7343.   (multiple-value-bind (body-rest declarations)
  7344.       (parse-body (cddr *form*) nil (vector *venv* *fenv*))
  7345.     (let ((*denv* *denv*)
  7346.           (*venv* *venv*))
  7347.       (multiple-value-bind (*specials* *ignores* *ignorables*)
  7348.           (process-declarations declarations)
  7349.         ; Special-Variable auf *venv* pushen:
  7350.         (push-specials)
  7351.         ; Syntaxtest der Parameterliste:
  7352.         (multiple-value-bind (symbols expansions)
  7353.             (do ((L (second *form*) (cdr L))
  7354.                  (symbols nil)
  7355.                  (expansions nil))
  7356.                 ((null L) (values (nreverse symbols) (nreverse expansions)))
  7357.               (let ((symdef (car L)))
  7358.                 (if (and (consp symdef) (symbolp (car symdef))
  7359.                          (consp (cdr symdef)) (null (cddr symdef))
  7360.                     )
  7361.                   (progn (push (first symdef) symbols) (push (second symdef) expansions))
  7362.                   (catch 'c-error
  7363.                     (c-error (DEUTSCH "Falsche Syntax in SYMBOL-MACROLET: ~S"
  7364.                               ENGLISH "Illegal syntax in SYMBOL-MACROLET: ~S"
  7365.                               FRANCAIS "Mauvaise syntaxe pour SYMBOL-MACROLET : ~S")
  7366.                              symdef
  7367.             ) ) ) ) )
  7368.           (dolist (s (intersection *specials* symbols))
  7369.             (catch 'c-error
  7370.               (c-error (DEUTSCH "~S: Symbol ~S darf nicht gleichzeitig SPECIAL und Makro deklariert werden."
  7371.                         ENGLISH "~S: symbol ~S must not be declared SPECIAL and a macro at the same time"
  7372.                         FRANCAIS "~S : Le symbole ~S ne peut Ωtre dΘclarΘ SPECIAL et macro en mΩme temps.")
  7373.                        'symbol-macrolet s
  7374.           ) ) )
  7375.           (setq *venv* ; *venv* erweitern
  7376.             (apply #'vector
  7377.               (nconc (mapcan #'(lambda (sym expansion) (list sym (make-symbol-macro expansion)))
  7378.                              symbols expansions
  7379.                      )
  7380.                      (list *venv*)
  7381.           ) ) )
  7382.           (funcall c `(PROGN ,@body-rest)) ; restliche Formen compilieren
  7383. ) ) ) ) )
  7384.  
  7385. ; compiliere (EVAL-WHEN ({situation}*) {form}*)
  7386. (defun c-EVAL-WHEN (&optional (c #'c-form))
  7387.   (test-list *form* 2)
  7388.   (test-list (second *form*) 0)
  7389.   (let ((load-flag nil)
  7390.         (compile-flag nil))
  7391.     (dolist (situation (second *form*))
  7392.       (case situation
  7393.         (LOAD (setq load-flag t))
  7394.         (COMPILE (setq compile-flag t))
  7395.         (EVAL)
  7396.         (T (cond ((equal situation '(NOT EVAL)) (setq load-flag t compile-flag t))
  7397.                  ((equal situation '(NOT COMPILE)) (setq load-flag t))
  7398.                  (t (c-error (DEUTSCH "Situation bei EVAL-WHEN mu▀ EVAL, LOAD oder COMPILE sein, nicht ~S."
  7399.                               ENGLISH "EVAL-WHEN situation must be EVAL or LOAD or COMPILE, but not ~S"
  7400.                               FRANCAIS "EVAL-WHEN ne s'applique qu'aux situations EVAL, LOAD ou COMPILE et non ~S.")
  7401.                              situation
  7402.     ) ) )  )     )  )
  7403.     (let ((form `(PROGN ,@(cddr *form*))))
  7404.       (when compile-flag (c-eval-when-compile form))
  7405.       (funcall c (if load-flag form 'NIL))
  7406. ) ) )
  7407.  
  7408. ; compiliere (COND {clause}*)
  7409. (defun c-COND ()
  7410.   (test-list *form* 1)
  7411.   (c-form
  7412.     (let ((clauses (cdr *form*))) ; (COND . clauses) macroexpandieren
  7413.       (if (null clauses)
  7414.         'NIL
  7415.         (let ((clause (car clauses)))
  7416.           (if (atom clause)
  7417.             (c-error (DEUTSCH "COND-Klausel ohne Test: ~S"
  7418.                       ENGLISH "COND clause without test: ~S"
  7419.                       FRANCAIS "Clause COND sans test : ~S")
  7420.                      clause
  7421.             )
  7422.             (let ((test (car clause)))
  7423.               (if (cdr clause)
  7424.                 `(IF ,test (PROGN ,@(cdr clause)) (COND ,@(cdr clauses)))
  7425.                 `(OR ,test (COND ,@(cdr clauses)))
  7426. ) ) ) ) ) ) ) )
  7427.  
  7428.  
  7429. ;               ERSTER PASS :   M A C R O S
  7430.  
  7431. ; compiliere (CASE keyform {clause}*)
  7432. (defun c-CASE ()
  7433.   (test-list *form* 1)
  7434.   (let ((keyform (second *form*))
  7435.         (clauses (cddr *form*))
  7436.         ; clauses vereinfachen:
  7437.         (newclauses '())
  7438.         (allkeys '()))
  7439.     (let ((default-passed nil))
  7440.       (dolist (clause clauses)
  7441.         (if (atom clause)
  7442.           (c-error (DEUTSCH "CASE-Klausel ohne Objekte: ~S"
  7443.                     ENGLISH "CASE clause without objects: ~S"
  7444.                     FRANCAIS "Clause CASE sans objets LISP : ~S")
  7445.                    clause
  7446.           )
  7447.           (let ((keys (car clause)))
  7448.             (if default-passed ; war der Default schon da?
  7449.               (setq keys nil)
  7450.               (if (or (eq keys 'T) (eq keys 'OTHERWISE))
  7451.                 (setq keys 'T default-passed t)
  7452.                 (let ((newkeys '()))
  7453.                   (dolist (key (if (listp keys) keys (list keys)))
  7454.                     (unless (member key allkeys :test #'eq) ; remove-duplicates
  7455.                       (push key allkeys) (push key newkeys)
  7456.                   ) )
  7457.                   (setq keys (nreverse newkeys))
  7458.             ) ) )
  7459.             (push (cons keys (cdr clause)) newclauses)
  7460.       ) ) )
  7461.       (unless default-passed (push '(T NIL) newclauses))
  7462.       (setq newclauses (nreverse newclauses))
  7463.       (setq allkeys (nreverse allkeys))
  7464.     )
  7465.     ; newclauses enthΣlt jetzt keine doppelten keys, genau einmal T als keys,
  7466.     ; und allkeys ist die Menge aller Keys.
  7467.     (if (<= (length allkeys) 2) ; wenige Keys -> direkt EQL verwenden
  7468.       (let ((keyvar (gensym)))
  7469.         (labels ((ifify (clauses)
  7470.                    (if (null clauses)
  7471.                      'NIL
  7472.                      `(IF ,(let ((keys (caar clauses)))
  7473.                              (if (atom keys) ; keys = T, der Default-Fall?
  7474.                                'T
  7475.                                `(OR ,@(mapcar
  7476.                                         #'(lambda (key) `(EQL ,keyvar ',key))
  7477.                                         keys
  7478.                                 )     )
  7479.                            ) )
  7480.                         (PROGN ,@(cdar clauses))
  7481.                         ,(ifify (cdr clauses))
  7482.                       )
  7483.                 )) )
  7484.           (c-form
  7485.             `(LET ((,keyvar ,keyform)) (PROGN ,keyvar ,(ifify newclauses)))
  7486.       ) ) )
  7487.       (let ((keyform-anode (c-form keyform 'ONE))
  7488.             (default-anode nil)
  7489.             (cases '())) ; Liste von Tripeln (keylist label anode)
  7490.         (dolist (clause newclauses)
  7491.           (if (car clause)
  7492.             (let ((anode (c-form `(PROGN ,@(cdr clause)))))
  7493.               (if (atom (car clause))
  7494.                 (setq default-anode anode)
  7495.                 (push (list (car clause) (make-label 'NIL) anode) cases)
  7496.             ) )
  7497.             (let ((*no-code* t)) (c-form `(PROGN ,@(cdr clause)) 'NIL))
  7498.         ) )
  7499.         (setq cases (nreverse cases))
  7500.         (if (anode-constantp keyform-anode)
  7501.           (let ((value (anode-constant-value keyform-anode)))
  7502.             (dolist (case cases default-anode)
  7503.               (when (member value (first case) :test #'eql)
  7504.                 (return (third case))
  7505.           ) ) )
  7506.           (let ((default-label (make-label 'NIL))
  7507.                 (end-label (make-label *for-value*))
  7508.                 (test (if (every #'EQL=EQ allkeys) 'EQ 'EQL)))
  7509.             (make-anode
  7510.               :type 'CASE
  7511.               :sub-anodes `(,keyform-anode ,@(mapcar #'third cases) ,default-anode)
  7512.               :seclass
  7513.                 (anodelist-seclass-or
  7514.                   `(,keyform-anode ,@(mapcar #'third cases) ,default-anode)
  7515.                 )
  7516.               :code
  7517.                 `(,keyform-anode
  7518.                   (JMPHASH
  7519.                     ,test
  7520.                     ,(mapcap ; Aliste (obji -> labeli)
  7521.                        #'(lambda (case)
  7522.                            (let ((label (second case)))
  7523.                              (mapcar #'(lambda (obj) (cons obj label))
  7524.                                      (first case)
  7525.                          ) ) )
  7526.                        cases
  7527.                      )
  7528.                     ,default-label
  7529.                     ,@(mapcar #'second cases) ; alle Labels, ohne Doppelte
  7530.                   )
  7531.                   ,@(mapcap
  7532.                       #'(lambda (case)
  7533.                           `(,(second case) ; Label
  7534.                             ,(third case) ; Anode
  7535.                             (JMP ,end-label)
  7536.                            )
  7537.                         )
  7538.                       cases
  7539.                     )
  7540.                   ,default-label
  7541.                   ,default-anode
  7542.                   ,end-label
  7543.                  )
  7544.           ) )
  7545. ) ) ) ) )
  7546.  
  7547. ; compiliere (HANDLER-BIND ({(typespec handler)}*) {form}*)
  7548. ; und  (SYS::%HANDLER-BIND ({(typespec handler)}*) {form}*)
  7549. (defun c-HANDLER-BIND ()
  7550.   (test-list *form* 2)
  7551.   (test-list (second *form*) 0)
  7552.   (let ((body (cddr *form*))
  7553.         (types '())
  7554.         (handler-labels '())
  7555.         (handler-anodes '()))
  7556.     (dolist (clause (second *form*))
  7557.       (test-list clause 2 2)
  7558.       (let ((type (first clause))
  7559.             (handler (second clause)))
  7560.         (if (block try-subtypep
  7561.               (let ((*error-handler*
  7562.                       #'(lambda (&rest error-args)
  7563.                           (declare (ignore error-args))
  7564.                           (return-from try-subtypep nil)
  7565.                    ))   )
  7566.                 (subtypep type `(OR ,@types))
  7567.             ) )
  7568.           ; Brauche diesen Handler nicht zu berⁿcksichtigen
  7569.           (let ((*no-code* t) (*for-value* 'NIL)) (c-form handler))
  7570.           ; Der Handler ist eine Funktion mit dynamischem Extent.
  7571.           (let ((label (make-label 'ONE)))
  7572.             (push type types)
  7573.             (push label handler-labels)
  7574.             (push
  7575.               (let* ((*stackz* (cons 'ANYTHING *stackz*))
  7576.                      (oldstackz *stackz*)
  7577.                      (*venv* *venv*))
  7578.                 ; Platz fⁿr die Funktion selbst:
  7579.                 (push 1 *stackz*)
  7580.                 (let* ((condition-sym (gensym))
  7581.                        (condition-anode
  7582.                          (make-anode :type 'CONDITION
  7583.                                      :sub-anodes '()
  7584.                                      :seclass '(T . NIL)
  7585.                                      :code '() ; vorher kommt (HANDLER-BEGIN)
  7586.                        ) )
  7587.                        (condition-var (bind-movable-var condition-sym condition-anode)))
  7588.                   (push-*venv* condition-var)
  7589.                   (let ((body-anode
  7590.                           (c-form `(SYS::%FUNCALL ,handler ,condition-sym) 'NIL)
  7591.                        ))
  7592.                     ; ▄berprⁿfen der Variablen (mu▀ nicht in die Closure):
  7593.                     (checking-movable-var-list (list condition-var) (list condition-anode))
  7594.                     (let* ((codelist
  7595.                              `(,label
  7596.                                (HANDLER-BEGIN)
  7597.                                ,@(c-bind-movable-var-anode condition-var condition-anode)
  7598.                                ,body-anode
  7599.                                (UNWINDSP ,*stackz* ,*func*) ; ein (SKIPSP k)
  7600.                                (UNWIND ,*stackz* ,oldstackz NIL) ; ein (SKIP 2)
  7601.                                (RET)
  7602.                               )
  7603.                            )
  7604.                            (anode
  7605.                              (make-anode
  7606.                                :type 'HANDLER
  7607.                                :sub-anodes `(,body-anode)
  7608.                                :seclass '(T . T) ; eigentlich irrelevant
  7609.                                :stackz oldstackz
  7610.                                :code codelist
  7611.                           )) )
  7612.                       (optimize-var-list (list condition-var))
  7613.                       anode
  7614.               ) ) ) )
  7615.               handler-anodes
  7616.             )
  7617.     ) ) ) )
  7618.     (if (null types)
  7619.       (c-form `(PROGN ,@body))
  7620.       (progn
  7621.         (setq types (nreverse types))
  7622.         (setq handler-labels (nreverse handler-labels))
  7623.         (setq handler-anodes (nreverse handler-anodes))
  7624.         (let* ((label (make-label 'NIL))
  7625.                (oldstackz *stackz*)
  7626.                (*stackz* (cons 4 *stackz*)) ; HANDLER-Frame
  7627.                (body-anode (c-form `(PROGN ,@body))))
  7628.           (make-anode
  7629.             :type 'HANDLER-BIND
  7630.             :sub-anodes `(,body-anode ,@handler-anodes)
  7631.             :seclass (anodelist-seclass-or `(,body-anode ,@handler-anodes))
  7632.             :stackz oldstackz
  7633.             :code `((HANDLER-OPEN ,(new-const (coerce types 'vector)) ,*stackz* ,@handler-labels)
  7634.                     (JMP ,label)
  7635.                     ,@handler-anodes
  7636.                     ,label
  7637.                     ,body-anode
  7638.                     (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7639.                    )
  7640.     ) ) ) )
  7641. ) )
  7642.  
  7643. ; compiliere (SYS::CONSTANT-EQL form1 form2 form3)
  7644. (defun c-CONSTANT-EQL ()
  7645.   (test-list *form* 4 4)
  7646.   (let ((form1 (second *form*))
  7647.         (form23 (cddr *form*)))
  7648.     (if (and *compiling-from-file*
  7649.              (c-constantp form1)
  7650.              (let ((value (c-constant-value form1)))
  7651.                (or (stringp value) (bit-vector-p value))
  7652.         )    )
  7653.       (c-form `(SYS::LOOSE-CONSTANT-EQL ,@form23))
  7654.       (c-form `(EQL ,@form23))
  7655. ) ) )
  7656.  
  7657.  
  7658. ;   ERSTER PASS :   I N L I N E - F U N K T I O N E N   (PRIMOPS)
  7659.  
  7660. ; Funktionsaufrufe, die wie special forms behandelt werden:
  7661.  
  7662. ; Erst FUNCALL bzw. SYS::%FUNCALL.
  7663.  
  7664. ; (c-FUNCALL-NOTINLINE funform args) compiliert einen Funktionsaufruf
  7665. ; (SYS::%FUNCALL funform . args),
  7666. ; fⁿr den das STACK-Layout der Argumente nicht zur Compile-Zeit bestimmt
  7667. ; werden kann.
  7668. (defun c-FUNCALL-NOTINLINE (funform args)
  7669.   (test-list args 0)
  7670.   (let* ((anode1 (c-form funform 'ONE))
  7671.          (*stackz* (cons 1 *stackz*)))
  7672.     (do ((formlistr args (cdr formlistr))
  7673.          #+COMPILER-DEBUG (anodelist (list anode1))
  7674.          (codelist (list '(FUNCALLP) anode1)))
  7675.         ((null formlistr)
  7676.          (push `(FUNCALL ,(length args)) codelist)
  7677.          (make-anode
  7678.            :type 'FUNCALL
  7679.            :sub-anodes (nreverse anodelist)
  7680.            :seclass '(T . T)
  7681.            :code (nreverse codelist)
  7682.         ))
  7683.       (let ((anode (c-form (car formlistr) 'ONE)))
  7684.         #+COMPILER-DEBUG (push anode anodelist)
  7685.         (push anode codelist)
  7686.       )
  7687.       (push '(PUSH) codelist)
  7688.       (push 1 *stackz*)
  7689. ) ) )
  7690.  
  7691. ; (c-FUNCALL-INLINE funform args applyargs lambdabody sameenv) compiliert einen
  7692. ; Funktionsaufruf (SYS::%FUNCALL funform . args) bzw.
  7693. ; (APPLY funform . args applyargs) [applyargs eine Liste aus einer Form],
  7694. ; fⁿr den das STACK-Layout der Argumente zur Compile-Zeit bestimmt werden kann.
  7695. ; sameenv gibt an, ob lambdabody im selben Environment oder im
  7696. ; Top-Level-Environment zu betrachten ist.
  7697. (defun c-FUNCALL-INLINE (funform arglist applyarglist lambdabody sameenv)
  7698.   (test-list lambdabody 1)
  7699.   (multiple-value-bind (reqvar  optvar optinit optsvar  restvar
  7700.                         keyflag keyword keyvar keyinit keysvar allow-other-keys
  7701.                         auxvar auxinit)
  7702.       (analyze-lambdalist (pop lambdabody))
  7703.     (when (or keyflag keyword keyvar keyinit keysvar allow-other-keys)
  7704.       (compiler-error 'c-FUNCALL-INLINE)
  7705.     )
  7706.     (let ((r (length reqvar)) ; Anzahl der required-Argumente
  7707.           (s (length optvar)) ; Anzahl der optionalen Argumente
  7708.           (|t| (length arglist))) ; Anzahl der angegebenen Argumente
  7709.       (when (and (null restvar) (> |t| (+ r s)))
  7710.         ; zu viele Argumente angegeben. Wird beseitigt durch Einfⁿhrung
  7711.         ; mehrerer zusΣtzlicher optionaler Argumente:
  7712.         (catch 'c-error
  7713.           (c-error (DEUTSCH "Zuviele Argumente fⁿr ~S"
  7714.                     ENGLISH "Too many arguments to ~S"
  7715.                     FRANCAIS "Trop d'arguments pour ~S")
  7716.                    funform
  7717.         ) )
  7718.         (dotimes (i (- |t| (+ r s)))
  7719.           (let ((var (gensym)))
  7720.             (setq optvar (append optvar (list var)))
  7721.             (setq optinit (append optinit (list nil)))
  7722.             (setq optsvar (append optsvar (list nil)))
  7723.             (incf s)
  7724.             (push `(DECLARE (IGNORE ,var)) lambdabody)
  7725.       ) ) )
  7726.       (when (and (null applyarglist) (< |t| r))
  7727.         ; zu wenige Argumente angegeben. Wird beseitigt durch Einfⁿhrung
  7728.         ; zusΣtzlicher Argumente:
  7729.         (catch 'c-error
  7730.           (c-error (DEUTSCH "Zuwenig Argumente fⁿr ~S"
  7731.                     ENGLISH "Too few arguments to ~S"
  7732.                     FRANCAIS "Trop peu d'arguments pour ~S")
  7733.                    funform
  7734.         ) )
  7735.         (setq arglist (append arglist (make-list (- r |t|) :initial-element nil)))
  7736.         (setq |t| r)
  7737.       )
  7738.       ; Nun ist (t>=r oder apply-arg da) und (t<=r+s oder &rest-Parameter da).
  7739.       (let ((oldstackz *stackz*)
  7740.             (oldvenv *venv*)
  7741.             (oldfenv *fenv*)
  7742.             (oldbenv *benv*)
  7743.             (oldgenv *genv*)
  7744.             (olddenv *denv*)
  7745.             (*stackz* *stackz*)
  7746.             (*venv* (and sameenv *venv*))
  7747.             (*venvc* *venvc*)
  7748.             (*fenv* (and sameenv *fenv*))
  7749.             (*benv* (and sameenv *benv*))
  7750.             (*genv* (and sameenv *genv*))
  7751.             (*denv* (if sameenv
  7752.                       *denv*
  7753.                       (cons `(INLINING ,funform)
  7754.                             (remove-if-not #'(lambda (declspec)
  7755.                                                (case (car declspec)
  7756.                                                  ((DECLARATION SYS::IN-DEFUN INLINING) t)
  7757.                                                  (t nil)
  7758.                                              ) )
  7759.                                            *denv*
  7760.            ))       ) )     )
  7761.         (multiple-value-bind (body-rest declarations)
  7762.             (parse-body lambdabody t (vector *venv* *fenv*))
  7763.           (let (*specials* *ignores* *ignorables*
  7764.                 req-vars req-anodes req-stackzs
  7765.                 opt-vars opt-anodes opt-stackzs ; optionale und svar zusammen!
  7766.                 rest-vars rest-anodes rest-stackzs
  7767.                 fixed-anodes fixed-stackz
  7768.                 reqfixed-vars reqfixed-dummys reqfixed-stackzs
  7769.                 optfixed-vars optfixed-dummys optfixed-anodes
  7770.                 optsfixed-vars optsfixed-anodes optfixed-stackzs
  7771.                 restfixed-vars restfixed-dummys restfixed-stackzs
  7772.                 aux-vars aux-anodes
  7773.                 closuredummy-stackz closuredummy-venvc
  7774.                )
  7775.             (multiple-value-setq (*specials* *ignores* *ignorables*)
  7776.               (process-declarations declarations)
  7777.             )
  7778.             ; Special-Variable auf *venv* pushen:
  7779.             (push-specials)
  7780.             (push 0 *stackz*) (push nil *venvc*) ; Platz fⁿr Closure-Dummyvar
  7781.             (setq closuredummy-stackz *stackz* closuredummy-venvc *venvc*)
  7782.             (flet ((finish-using-applyarg (reqvar optvar optinit optsvar restvar)
  7783.                      ; reqvar und optvar/optinit/optsvar sowie arglist sind schon
  7784.                      ; teilweise verkⁿrzt. Zerlegen der weiteren Argumentliste
  7785.                      ; mittels UNLIST bzw. UNLIST*. Daher ein Stackaufbau mit
  7786.                      ; festem Aussehen, vgl. c-LAMBDABODY.
  7787.                      (setq fixed-anodes
  7788.                            (list
  7789.                              (let ((anode1 (let ((*venv* oldvenv)
  7790.                                                  (*fenv* oldfenv)
  7791.                                                  (*benv* oldbenv)
  7792.                                                  (*genv* oldgenv)
  7793.                                                  (*denv* olddenv))
  7794.                                              (c-form (first applyarglist) 'ONE)
  7795.                                    )       )
  7796.                                    (anode2 (c-unlist (not (eql restvar 0))
  7797.                                                      (+ (length reqvar) (length optvar))
  7798.                                                      (length optvar)
  7799.                                   ))       )
  7800.                                (make-anode
  7801.                                  :type 'APPLY-UNLIST
  7802.                                  :sub-anodes (list anode1 anode2)
  7803.                                  :seclass (anodes-seclass-or anode1 anode2)
  7804.                                  :code `(,anode1 ,anode2)
  7805.                      )     ) ) )
  7806.                      ; Stack-Dummy-Variable fⁿr die reqvar,optvar,restvar bilden:
  7807.                      (multiple-value-setq (reqfixed-vars reqfixed-dummys)
  7808.                        (process-fixed-var-list reqvar)
  7809.                      )
  7810.                      (multiple-value-setq (optfixed-vars optfixed-dummys)
  7811.                        (process-fixed-var-list optvar)
  7812.                      )
  7813.                      (multiple-value-setq (restfixed-vars restfixed-dummys)
  7814.                        (if (eql restvar 0)
  7815.                          (values '() '())
  7816.                          (process-fixed-var-list (list restvar))
  7817.                      ) )
  7818.                      (push 0 *stackz*) (setq fixed-stackz *stackz*)
  7819.                      ; Bindungen der required-Parameter aktivieren:
  7820.                      (setq reqfixed-stackzs (bind-req-vars reqfixed-vars))
  7821.                      ; Bindungen der optional-Parameter/svar aktivieren:
  7822.                      (multiple-value-setq (optfixed-anodes optfixed-stackzs optsfixed-vars optsfixed-anodes)
  7823.                        (bind-opt-vars optfixed-vars optfixed-dummys optinit optsvar)
  7824.                      )
  7825.                      ; Bindung des rest-Parameters aktivieren:
  7826.                      (unless (eql restvar 0)
  7827.                        (setq restfixed-stackzs (bind-rest-vars restfixed-vars))
  7828.                      )
  7829.                   ))
  7830.               (block main-args
  7831.                 ; required-Parameter binden:
  7832.                 (do ((reqvarr reqvar (cdr reqvarr)))
  7833.                     ((null reqvarr))
  7834.                   (if (null arglist) ; impliziert, da▀ apply-arg da
  7835.                     (return-from main-args
  7836.                       (finish-using-applyarg reqvarr optvar optinit optsvar restvar)
  7837.                     )
  7838.                     (let* ((form (pop arglist))
  7839.                            (anode (let ((*venv* oldvenv)
  7840.                                         (*fenv* oldfenv)
  7841.                                         (*benv* oldbenv)
  7842.                                         (*genv* oldgenv)
  7843.                                         (*denv* olddenv))
  7844.                                     (c-form form 'ONE)
  7845.                            )      )
  7846.                            (var (bind-movable-var (car reqvarr) anode)))
  7847.                       (push anode req-anodes)
  7848.                       (push var req-vars)
  7849.                       (push *stackz* req-stackzs)
  7850.                       (push-*venv* var)
  7851.                 ) ) )
  7852.                 ; optionale Parameter und Svars binden:
  7853.                 (do ((optvarr optvar (cdr optvarr))
  7854.                      (optinitr optinit (cdr optinitr))
  7855.                      (optsvarr optsvar (cdr optsvarr)))
  7856.                     ((null optvarr))
  7857.                   (if (and applyarglist (null arglist))
  7858.                     (return-from main-args
  7859.                       (finish-using-applyarg '() optvarr optinitr optsvarr restvar)
  7860.                     )
  7861.                     (let* ((svar-init (not (null arglist))) ; = NIL oder T
  7862.                            (anode (if svar-init
  7863.                                     (progn
  7864.                                       (let ((*no-code* t))
  7865.                                         (c-form (car optinitr) 'NIL)
  7866.                                       )
  7867.                                       (let ((*venv* oldvenv)
  7868.                                             (*fenv* oldfenv)
  7869.                                             (*benv* oldbenv)
  7870.                                             (*genv* oldgenv)
  7871.                                             (*denv* olddenv))
  7872.                                         (c-form (pop arglist) 'ONE)
  7873.                                     ) )
  7874.                                     (c-form (car optinitr) 'ONE)
  7875.                            )      )
  7876.                            (var (bind-movable-var (car optvarr) anode)))
  7877.                       (push anode opt-anodes)
  7878.                       (push var opt-vars)
  7879.                       (push *stackz* opt-stackzs)
  7880.                       (push-*venv* var)
  7881.                       (unless (eql (car optsvarr) 0)
  7882.                         (let* ((anode (c-form svar-init 'ONE))
  7883.                                (var (bind-movable-var (car optsvarr) anode)))
  7884.                           (push anode opt-anodes)
  7885.                           (push var opt-vars)
  7886.                           (push *stackz* opt-stackzs)
  7887.                           (push-*venv* var)
  7888.                       ) )
  7889.                 ) ) )
  7890.                 (if (eql restvar 0)
  7891.                   ; weitere Argumente verbrauchen:
  7892.                   (when applyarglist
  7893.                     (return-from main-args
  7894.                       (finish-using-applyarg '() '() '() '() restvar)
  7895.                   ) )
  7896.                   ; Rest-Parameter binden:
  7897.                   (let* ((form (if applyarglist
  7898.                                  (if arglist `(LIST* ,@arglist ,@applyarglist) (first applyarglist))
  7899.                                  (if arglist `(LIST ,@arglist) 'NIL)
  7900.                          )     )
  7901.                          (anode (let ((*venv* oldvenv)
  7902.                                       (*fenv* oldfenv)
  7903.                                       (*benv* oldbenv)
  7904.                                       (*genv* oldgenv)
  7905.                                       (*denv* olddenv))
  7906.                                   (c-form form 'ONE)
  7907.                          )      )
  7908.                          (var (bind-movable-var restvar anode)))
  7909.                     (push anode rest-anodes)
  7910.                     (push var rest-vars)
  7911.                     (push *stackz* rest-stackzs)
  7912.                     (push-*venv* var)
  7913.                 ) )
  7914.                 (push 0 *stackz*) (setq fixed-stackz *stackz*)
  7915.             ) )
  7916.             (setq req-vars (nreverse req-vars))
  7917.             (setq req-anodes (nreverse req-anodes))
  7918.             (setq req-stackzs (nreverse req-stackzs))
  7919.             (setq opt-vars (nreverse opt-vars))
  7920.             (setq opt-anodes (nreverse opt-anodes))
  7921.             (setq opt-stackzs (nreverse opt-stackzs))
  7922.             ; Bindungen der Aux-Variablen aktivieren:
  7923.             (multiple-value-setq (aux-vars aux-anodes)
  7924.               (bind-aux-vars auxvar auxinit)
  7925.             )
  7926.             (let* ((body-anode (c-form `(PROGN ,@body-rest)))
  7927.                    ; ▄berprⁿfen der Variablen:
  7928.                    (varlist
  7929.                      (append req-vars opt-vars rest-vars
  7930.                              reqfixed-vars optfixed-vars optsfixed-vars restfixed-vars
  7931.                              aux-vars
  7932.                    ) )
  7933.                    (closurevars
  7934.                      (append
  7935.                        (checking-movable-var-list req-vars req-anodes)
  7936.                        (checking-movable-var-list opt-vars opt-anodes)
  7937.                        (checking-movable-var-list rest-vars rest-anodes)
  7938.                        (checking-fixed-var-list reqfixed-vars)
  7939.                        (checking-fixed-var-list optfixed-vars)
  7940.                        (checking-movable-var-list optsfixed-vars optsfixed-anodes)
  7941.                        (checking-fixed-var-list restfixed-vars)
  7942.                        (checking-movable-var-list aux-vars aux-anodes)
  7943.                    ) )
  7944.                    (codelist
  7945.                      `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7946.                        ,@(let ((*stackz* fixed-stackz))
  7947.                            (c-parallel-bind-movable-var-anode
  7948.                              (append req-vars    opt-vars    rest-vars   )
  7949.                              (append req-anodes  opt-anodes  rest-anodes )
  7950.                              (append req-stackzs opt-stackzs rest-stackzs)
  7951.                              fixed-anodes
  7952.                          ) )
  7953.                        ,@(mapcap #'c-bind-fixed-var reqfixed-vars reqfixed-dummys reqfixed-stackzs)
  7954.                        ,@(c-bind-with-svars optfixed-vars optfixed-dummys optsfixed-vars optfixed-anodes optsfixed-anodes optfixed-stackzs)
  7955.                        ,@(mapcap #'c-bind-fixed-var restfixed-vars restfixed-dummys restfixed-stackzs)
  7956.                        ,@(mapcap #'c-bind-movable-var-anode aux-vars aux-anodes)
  7957.                        ,body-anode
  7958.                        (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7959.                    )  )
  7960.                    (anode
  7961.                      (make-anode
  7962.                        :type 'FUNCALL
  7963.                        :sub-anodes
  7964.                          `(,@req-anodes ,@opt-anodes ,@rest-anodes
  7965.                            ,@fixed-anodes ,@optfixed-anodes ,@(remove nil optsfixed-anodes)
  7966.                            ,@aux-anodes ,body-anode
  7967.                           )
  7968.                        :seclass
  7969.                          (seclass-without
  7970.                            (anodelist-seclass-or
  7971.                              `(,@req-anodes ,@opt-anodes ,@rest-anodes
  7972.                                ,@fixed-anodes ,@optfixed-anodes ,@(remove nil optsfixed-anodes)
  7973.                                ,@aux-anodes ,body-anode
  7974.                            )  )
  7975.                            varlist
  7976.                          )
  7977.                        :stackz oldstackz
  7978.                        :code codelist
  7979.                   )) )
  7980.               (when closurevars
  7981.                 (setf (first closuredummy-stackz) 1) ; 1 Stackplatz fⁿr Dummy
  7982.                 (setf (first closuredummy-venvc)
  7983.                   (cons closurevars closuredummy-stackz)
  7984.               ) )
  7985.               (optimize-var-list varlist)
  7986.               anode
  7987. ) ) ) ) ) ) )
  7988.  
  7989. ; compiliert (fun {form}*), wobei fun eine lokale Funktion ist.
  7990. ; fdescr die zugeh÷rige Information aus *fenv*.
  7991. (defun c-LOCAL-FUNCTION-CALL (fun fdescr args)
  7992.   ; (test-list args 0) ; das erledigt gleich (test-argument-syntax ...)
  7993.   ; Aufruf-Spezifikation holen:
  7994.   (multiple-value-bind (req opt rest-flag key-flag keylist allow-flag)
  7995.       (fdescr-signature fdescr)
  7996.     (case (test-argument-syntax
  7997.             args nil fun req opt rest-flag key-flag keylist allow-flag
  7998.           )
  7999.       ((NO-KEYS STATIC-KEYS)
  8000.        ; Aufruf INLINE
  8001.        (c-DIRECT-FUNCTION-CALL
  8002.          args nil fun req opt rest-flag key-flag keylist
  8003.          nil ; kein SUBR-, sondern Cclosure-Aufruf
  8004.          (cclosure-call-code-producer fun (car fdescr) req opt rest-flag key-flag keylist)
  8005.       ))
  8006.       (t (c-FUNCALL-NOTINLINE `(FUNCTION ,fun) args))
  8007. ) ) )
  8008.  
  8009. ; (c-FUNCTION-CALL funform arglist) compiliert einen Funktionsaufruf
  8010. ; (SYS::%FUNCALL funform . arglist).
  8011. (defun c-FUNCTION-CALL (funform arglist)
  8012.   (if (inline-callable-function-p funform (length arglist))
  8013.     ; Aufruf eines Lambda-Ausdrucks INLINE m÷glich
  8014.     (c-FUNCALL-INLINE funform arglist nil (cdr (second funform)) t)
  8015.     (if (and (consp funform) (eq (first funform) 'FUNCTION)
  8016.              ; Ausdrⁿcke der Form (FUNCTION ...) dⁿrfen zu beliebigem
  8017.              ; Zeitpunkt ausgewertet werden, also ist
  8018.              ; (SYS::%FUNCALL (FUNCTION fun) . arglist)  Σquivalent zu
  8019.              ; (fun . arglist).
  8020.              (consp (rest funform)) (function-name-p (second funform)) ; vorerst nur #'sym, sonst Endlosschleife!
  8021.         )
  8022.       (progn
  8023.         (test-list funform 2 2)
  8024.         (c-form `(,(second funform) ,@arglist)) ; genauer aufschlⁿsseln, vgl. c-FUNCTION ??
  8025.       )
  8026.       ; Aufruf NOTINLINE
  8027.       (c-FUNCALL-NOTINLINE funform arglist)
  8028. ) ) )
  8029.  
  8030. (defun c-FUNCALL ()
  8031.   (test-list *form* 2)
  8032.   (c-FUNCTION-CALL (second *form*) (cddr *form*))
  8033. )
  8034.  
  8035. (defun c-APPLY ()
  8036.   (test-list *form* 3)
  8037.   (let* ((funform (second *form*))
  8038.          (arglist (cddr *form*))
  8039.          (n (1- (length arglist)))) ; Mindestanzahl Argumente
  8040.     (if (inline-callable-function-p funform n t)
  8041.       ; Aufruf eines Lambda-Ausdrucks INLINE m÷glich
  8042.       (return-from c-APPLY
  8043.         (c-FUNCALL-INLINE funform (butlast arglist) (last arglist) (cdr (second funform)) t)
  8044.       )
  8045.       (when (and (consp funform) (eq (first funform) 'FUNCTION)
  8046.                  ; Ausdrⁿcke der Form (FUNCTION ...) dⁿrfen zu beliebigem
  8047.                  ; Zeitpunkt ausgewertet werden.
  8048.                  (consp (rest funform)) (function-name-p (second funform))
  8049.             )
  8050.         (let ((fun (second funform)))
  8051.           (test-list funform 2 2)
  8052.           (unless (declared-notinline fun) ; darf fun INLINE genommen werden?
  8053.             (flet ((c-LOCAL-APPLY (fdescr)
  8054.                      (multiple-value-bind (req opt rest-flag key-flag keylist allow-flag)
  8055.                          (fdescr-signature fdescr)
  8056.                        (unless key-flag
  8057.                          ; ohne Keyword-Argumente
  8058.                          (when (eq (test-argument-syntax (butlast arglist) (last arglist)
  8059.                                      fun req opt rest-flag key-flag keylist allow-flag
  8060.                                    )
  8061.                                  'NO-KEYS
  8062.                                )
  8063.                            ; Syntax stimmt -> Aufruf INLINE
  8064.                            (return-from c-APPLY
  8065.                              (c-DIRECT-FUNCTION-CALL (butlast arglist) (last arglist)
  8066.                                fun req opt rest-flag key-flag keylist
  8067.                                nil ; kein SUBR-, sondern Cclosure-Aufruf
  8068.                                (cclosure-call-code-producer fun (car fdescr) req opt rest-flag key-flag keylist)
  8069.                   )) ) ) ) ) )
  8070.               (multiple-value-bind (a b c) (fenv-search fun)
  8071.                 (declare (ignore b))
  8072.                 ; (APPLY #'fun . args) kann evtl. vereinfacht werden
  8073.                 (case a
  8074.                   ((NIL) ; globale Funktion
  8075.                     (unless (and (symbolp fun) (or (special-form-p fun) (macro-function fun))) ; Special-Form oder globaler Macro ?
  8076.                       (when (and (equal fun (fnode-name *func*))
  8077.                                  (member `(SYS::IN-DEFUN ,fun) *denv* :test #'equal)
  8078.                             )
  8079.                         ; rekursiver Aufruf der aktuellen globalen Funktion
  8080.                         (c-LOCAL-APPLY (cons *func* nil))
  8081.                       )
  8082.                       (let ((inline-lambdabody
  8083.                               (or (and *compiling-from-file*
  8084.                                        (cdr (assoc fun *inline-definitions* :test #'equal))
  8085.                                   )
  8086.                                   (get (get-funname-symbol fun) 'sys::inline-expansion)
  8087.                            )) )
  8088.                         (if (and #| inline-lambdabody |#
  8089.                                  (consp inline-lambdabody)
  8090.                                  (inline-callable-function-p `(FUNCTION (LAMBDA ,@inline-lambdabody)) n t)
  8091.                             )
  8092.                           ; Aufruf einer globalen Funktion INLINE m÷glich
  8093.                           (return-from c-APPLY
  8094.                             (c-FUNCALL-INLINE fun (butlast arglist) (last arglist) inline-lambdabody nil)
  8095.                   ) ) ) ) )
  8096.                   (LOCAL ; lokale Funktion
  8097.                     (c-LOCAL-APPLY c)
  8098.                 ) )
  8099.       ) ) ) ) )
  8100.     )
  8101.     ; Wenn keine der Optimierungen m÷glich war:
  8102.     (let* ((anode1 (c-form funform 'ONE))
  8103.            (*stackz* (cons 1 *stackz*)))
  8104.       (do ((formlistr arglist (cdr formlistr))
  8105.            #+COMPILER-DEBUG (anodelist (list anode1))
  8106.            (codelist (list '(APPLYP) anode1)))
  8107.           ((null formlistr)
  8108.            (push `(APPLY ,n) codelist)
  8109.            (make-anode
  8110.              :type 'APPLY
  8111.              :sub-anodes (nreverse anodelist)
  8112.              :seclass '(T . T)
  8113.              :code (nreverse codelist)
  8114.           ))
  8115.         (let ((anode (c-form (car formlistr) 'ONE)))
  8116.           #+COMPILER-DEBUG (push anode anodelist)
  8117.           (push anode codelist)
  8118.           (when (cdr formlistr)
  8119.             (push 1 *stackz*) (push '(PUSH) codelist)
  8120.     ) ) ) )
  8121. ) )
  8122.  
  8123. (defun c-PLUS ()
  8124.   (test-list *form* 1)
  8125.   ; bilde Teilsumme der konstanten Argumente, Rest dann dazu:
  8126.   (let ((const-sum 0)
  8127.         (other-parts '())
  8128.         val
  8129.        )
  8130.     (dolist (form (cdr *form*))
  8131.       (if (and (c-constantp form) (numberp (setq val (c-constant-value form))))
  8132.         (setq const-sum (+ const-sum val))
  8133.         (push form other-parts)
  8134.     ) )
  8135.     (case (length other-parts)
  8136.       (0 ; nur konstante Summanden
  8137.          (c-form const-sum) ; Zahl const-sum wertet zu sich selbst aus
  8138.       )
  8139.       (1 ; nur ein variabler Summand
  8140.          (case const-sum
  8141.            (0 (c-form (first other-parts))) ; keine Addition n÷tig
  8142.            (+1 (c-form `(1+ ,(first other-parts))))
  8143.            (-1 (c-form `(1- ,(first other-parts))))
  8144.            (t (c-GLOBAL-FUNCTION-CALL-form `(+ ,const-sum ,@other-parts)))
  8145.       )  )
  8146.       (t (setq other-parts (nreverse other-parts))
  8147.          (unless (eql const-sum 0) (push const-sum other-parts))
  8148.          (c-GLOBAL-FUNCTION-CALL-form `(+ ,@other-parts))
  8149. ) ) ) )
  8150.  
  8151. (defun c-MINUS ()
  8152.   (test-list *form* 2)
  8153.   (let ((unary-p (= (length *form*) 2)) ; unΣres Minus oder nicht?
  8154.         (const-sum 0) ; Summe der konstanten Teile
  8155.         (first-part 0) ; zu addierende Form
  8156.         (other-parts '()) ; abzuziehende Formen
  8157.         val
  8158.        )
  8159.     (unless unary-p
  8160.       (let ((form (second *form*)))
  8161.         (if (and (c-constantp form) (numberp (setq val (c-constant-value form))))
  8162.           (setq const-sum val)
  8163.           (setq first-part form)
  8164.     ) ) )
  8165.     (dolist (form (if unary-p (cdr *form*) (cddr *form*)))
  8166.       (if (and (c-constantp form) (numberp (setq val (c-constant-value form))))
  8167.         (setq const-sum (- const-sum val))
  8168.         (push form other-parts)
  8169.     ) )
  8170.     (if (null other-parts)
  8171.       ; nichts zu subtrahieren
  8172.       (let ((*form* `(+ ,const-sum ,first-part))) (c-PLUS))
  8173.       ; etwas zu subtrahieren
  8174.       (c-GLOBAL-FUNCTION-CALL-form
  8175.         `(-
  8176.           ,@(if (eql first-part 0) ; variable zu addierende Form?
  8177.               (if (and (eql const-sum 0) (null (cdr other-parts)))
  8178.                 '()
  8179.                 `(,const-sum)
  8180.               )
  8181.               (if (eql const-sum 0)
  8182.                 `(,first-part)
  8183.                 `(,first-part ,(- const-sum))
  8184.             ) )
  8185.           ,@(nreverse other-parts)
  8186.          )
  8187. ) ) ) )
  8188.  
  8189. (defun c-SVSTORE ()
  8190.   (test-list *form* 4 4)
  8191.   ; (sys::svstore arg1 arg2 arg3) -> (sys::%svstore arg3 arg1 arg2)
  8192.   (let ((arg1 (second *form*)) (arg2 (third *form*)) (arg3 (fourth *form*))
  8193.         (argvar1 (gensym)) (argvar2 (gensym)))
  8194.     (c-form
  8195.       `(LET* ((,argvar1 ,arg1) (,argvar2 ,arg2))
  8196.          (sys::%svstore ,arg3 ,argvar1 ,argvar2)
  8197.        )
  8198. ) ) )
  8199.  
  8200. (defun c-EQ ()
  8201.   (test-list *form* 3 3)
  8202.   (let ((arg1 (second *form*)) (arg2 (third *form*)))
  8203.     (if (and (c-constantp arg1) (c-constantp arg2))
  8204.       (c-form `(QUOTE ,(eq (c-constant-value arg1) (c-constant-value arg2))))
  8205.       (progn
  8206.         (when (c-constantp arg1)
  8207.           (rotatef arg1 arg2) ; Besser arg2 konstant, damit JMPIFEQTO geht
  8208.         )
  8209.         (if (and (c-constantp arg2) (eq (c-constant-value arg2) 'NIL))
  8210.           (c-GLOBAL-FUNCTION-CALL-form `(NULL ,arg1))
  8211.           (c-GLOBAL-FUNCTION-CALL-form `(EQ ,arg1 ,arg2))
  8212. ) ) ) ) )
  8213.  
  8214. ; bei Symbolen, Fixnums und Characters ist EQL mit EQ gleichbedeutend
  8215. (defun EQL=EQ (x) (or (symbolp x) (fixnump x) (characterp x)))
  8216.  
  8217. (defun c-EQL ()
  8218.   (test-list *form* 3 3)
  8219.   (let ((arg1 (second *form*)) (arg2 (third *form*)))
  8220.     (cond ((and (c-constantp arg1) (c-constantp arg2))
  8221.            (c-form `(QUOTE ,(eql (c-constant-value arg1) (c-constant-value arg2))))
  8222.           )
  8223.           ((or (and (c-constantp arg1) (EQL=EQ (c-constant-value arg1)))
  8224.                (and (c-constantp arg2) (EQL=EQ (c-constant-value arg2)))
  8225.            )
  8226.            (let ((*form* `(EQ ,arg1 ,arg2))) (c-EQ))
  8227.           )
  8228.           (t (c-GLOBAL-FUNCTION-CALL 'EQL))
  8229. ) ) )
  8230.  
  8231. ; bei Symbolen, Zahlen und Characters ist EQUAL mit EQL gleichbedeutend
  8232. (defun EQUAL=EQL (x) (or (symbolp x) (numberp x) (characterp x)))
  8233.  
  8234. (defun c-EQUAL ()
  8235.   (test-list *form* 3 3)
  8236.   (let ((arg1 (second *form*)) (arg2 (third *form*)))
  8237.     (cond ((or (and (c-constantp arg1) (EQUAL=EQL (c-constant-value arg1)))
  8238.                (and (c-constantp arg2) (EQUAL=EQL (c-constant-value arg2)))
  8239.            )
  8240.            (let ((*form* `(EQL ,arg1 ,arg2))) (c-EQL))
  8241.           )
  8242.           (t (c-GLOBAL-FUNCTION-CALL 'EQUAL))
  8243. ) ) )
  8244.  
  8245. ; Bildet den inneren Teil einer MAPCAR/MAPC/MAPCAN/MAPCAP-Expansion
  8246. (defun c-MAP-on-CARs-inner (innerst-fun blockname restvars &optional (itemvars '()))
  8247.   (if (null restvars)
  8248.     (funcall innerst-fun (nreverse itemvars))
  8249.     (let ((restvar (car restvars))
  8250.           (itemvar (gensym)))
  8251.       `(IF (CONSP ,restvar)
  8252.          (LET ((,itemvar (CAR ,restvar)))
  8253.            ,(c-MAP-on-CARs-inner innerst-fun blockname (cdr restvars) (cons itemvar itemvars))
  8254.          )
  8255.          (RETURN-FROM ,blockname)
  8256. ) ) )  )
  8257.  
  8258. ; Bildet eine MAPCAR/MAPCAN/MAPCAP-Expansion
  8259. (defun c-MAP-on-CARs (adjoin-fun funform forms)
  8260.   (let ((erg (gensym))
  8261.         (blockname (gensym))
  8262.         (restvars
  8263.           (mapcar #'(lambda (form) (declare (ignore form)) (gensym)) forms)
  8264.         )
  8265.         (tag (gensym)))
  8266.     `(LET ((,erg NIL))
  8267.        (BLOCK ,blockname
  8268.          (LET* ,(mapcar #'list restvars forms)
  8269.            (TAGBODY ,tag
  8270.              ,(c-MAP-on-CARs-inner
  8271.                 #'(lambda (itemvars)
  8272.                     `(SETQ ,erg (,adjoin-fun (SYS::%FUNCALL ,funform ,@itemvars) ,erg))
  8273.                   )
  8274.                 blockname
  8275.                 restvars
  8276.               )
  8277.              (SETQ ,@(mapcap #'(lambda (restvar)
  8278.                                  `(,restvar (CDR ,restvar))
  8279.                                )
  8280.                              restvars
  8281.              )       )
  8282.              (GO ,tag)
  8283.        ) ) )
  8284.        (SYS::LIST-NREVERSE ,erg)
  8285. ) )  )
  8286.  
  8287. ; Bildet eine MAPLIST/MAPCON/MAPLAP-Expansion
  8288. (defun c-MAP-on-LISTs (adjoin-fun funform forms)
  8289.   (let ((erg (gensym))
  8290.         (blockname (gensym))
  8291.         (restvars
  8292.           (mapcar #'(lambda (form) (declare (ignore form)) (gensym)) forms)
  8293.         )
  8294.         (tag (gensym)))
  8295.     `(LET ((,erg NIL))
  8296.        (BLOCK ,blockname
  8297.          (LET* ,(mapcar #'list restvars forms)
  8298.            (TAGBODY ,tag
  8299.              (IF (OR ,@(mapcar #'(lambda (restvar) `(ATOM ,restvar)) restvars))
  8300.                (RETURN-FROM ,blockname)
  8301.              )
  8302.              (SETQ ,erg (,adjoin-fun (SYS::%FUNCALL ,funform ,@restvars) ,erg))
  8303.              (SETQ ,@(mapcap #'(lambda (restvar)
  8304.                                  `(,restvar (CDR ,restvar))
  8305.                                )
  8306.                              restvars
  8307.              )       )
  8308.              (GO ,tag)
  8309.        ) ) )
  8310.        (SYS::LIST-NREVERSE ,erg)
  8311. ) )  )
  8312.  
  8313. (defun c-MAPC ()
  8314.   (test-list *form* 3)
  8315.   (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8316.     (c-form
  8317.       (let* ((tempvar (gensym))
  8318.              (forms (cons tempvar (cdddr *form*)))
  8319.              (blockname (gensym))
  8320.              (restvars
  8321.                (mapcar #'(lambda (form) (declare (ignore form)) (gensym)) forms)
  8322.              )
  8323.              (tag (gensym)))
  8324.         `(LET ((,tempvar ,(third *form*)))
  8325.            (BLOCK ,blockname
  8326.              (LET* ,(mapcar #'list restvars forms)
  8327.                (TAGBODY ,tag
  8328.                  ,(c-MAP-on-CARs-inner
  8329.                     #'(lambda (itemvars) `(SYS::%FUNCALL ,(second *form*) ,@itemvars))
  8330.                     blockname
  8331.                     restvars
  8332.                   )
  8333.                  (SETQ ,@(mapcap #'(lambda (restvar)
  8334.                                      `(,restvar (CDR ,restvar))
  8335.                                    )
  8336.                                  restvars
  8337.                  )       )
  8338.                  (GO ,tag)
  8339.            ) ) )
  8340.            ,tempvar
  8341.     ) )  )
  8342.     (c-GLOBAL-FUNCTION-CALL 'MAPC)
  8343. ) )
  8344.  
  8345. (defun c-MAPL ()
  8346.   (test-list *form* 3)
  8347.   (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8348.     (c-form
  8349.       (let* ((tempvar (gensym))
  8350.              (forms (cons tempvar (cdddr *form*)))
  8351.              (blockname (gensym))
  8352.              (restvars
  8353.                (mapcar #'(lambda (form) (declare (ignore form)) (gensym)) forms)
  8354.              )
  8355.              (tag (gensym)))
  8356.         `(LET ((,tempvar ,(third *form*)))
  8357.            (BLOCK ,blockname
  8358.              (LET* ,(mapcar #'list restvars forms)
  8359.                (TAGBODY ,tag
  8360.                  (IF (OR ,@(mapcar #'(lambda (restvar) `(ATOM ,restvar)) restvars))
  8361.                    (RETURN-FROM ,blockname)
  8362.                  )
  8363.                  (SYS::%FUNCALL ,(second *form*) ,@restvars)
  8364.                  (SETQ ,@(mapcap #'(lambda (restvar)
  8365.                                      `(,restvar (CDR ,restvar))
  8366.                                    )
  8367.                                  restvars
  8368.                  )       )
  8369.                  (GO ,tag)
  8370.            ) ) )
  8371.            ,tempvar
  8372.     ) )  )
  8373.     (c-GLOBAL-FUNCTION-CALL 'MAPL)
  8374. ) )
  8375.  
  8376. (defun c-MAPCAR ()
  8377.   (test-list *form* 3)
  8378.   (if (null *for-value*)
  8379.     (let ((*form* `(MAPC ,@(cdr *form*)))) (c-MAPC))
  8380.     (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8381.       (c-form (c-MAP-on-CARs 'CONS (second *form*) (cddr *form*)))
  8382.       (c-GLOBAL-FUNCTION-CALL 'MAPCAR)
  8383. ) ) )
  8384.  
  8385. (defun c-MAPLIST ()
  8386.   (test-list *form* 3)
  8387.   (if (null *for-value*)
  8388.     (let ((*form* `(MAPL ,@(cdr *form*)))) (c-MAPL))
  8389.     (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8390.       (c-form (c-MAP-on-LISTs 'CONS (second *form*) (cddr *form*)))
  8391.       (c-GLOBAL-FUNCTION-CALL 'MAPLIST)
  8392. ) ) )
  8393.  
  8394. (defun c-MAPCAN ()
  8395.   (test-list *form* 3)
  8396.   (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8397.     (c-form (c-MAP-on-CARs 'NRECONC (second *form*) (cddr *form*)))
  8398.     (c-GLOBAL-FUNCTION-CALL 'MAPCAN)
  8399. ) )
  8400.  
  8401. (defun c-MAPCON ()
  8402.   (test-list *form* 3)
  8403.   (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8404.     (c-form (c-MAP-on-LISTs 'NRECONC (second *form*) (cddr *form*)))
  8405.     (c-GLOBAL-FUNCTION-CALL 'MAPCON)
  8406. ) )
  8407.  
  8408. (defun c-MAPCAP ()
  8409.   (test-list *form* 3)
  8410.   (if (null *for-value*)
  8411.     (let ((*form* `(MAPC ,@(cdr *form*)))) (c-MAPC))
  8412.     (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8413.       (c-form (c-MAP-on-CARs 'REVAPPEND (second *form*) (cddr *form*)))
  8414.       (c-GLOBAL-FUNCTION-CALL 'MAPCAP)
  8415. ) ) )
  8416.  
  8417. (defun c-MAPLAP ()
  8418.   (test-list *form* 3)
  8419.   (if (null *for-value*)
  8420.     (let ((*form* `(MAPL ,@(cdr *form*)))) (c-MAPL))
  8421.     (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8422.       (c-form (c-MAP-on-LISTs 'REVAPPEND (second *form*) (cddr *form*)))
  8423.       (c-GLOBAL-FUNCTION-CALL 'MAPLAP)
  8424. ) ) )
  8425.  
  8426. ;; c-TYPEP vgl. TYPEP in type.lsp
  8427. ; Symbole mit Property TYPE-SYMBOL:
  8428. (defconstant c-typep-alist1
  8429.   '((ARRAY . arrayp)
  8430.     (ATOM . atom)
  8431.     (BIT-VECTOR . bit-vector-p)
  8432.     (CHARACTER . characterp)
  8433.     (COMMON . commonp)
  8434.     (COMPILED-FUNCTION . compiled-function-p)
  8435.     (COMPLEX . complexp)
  8436.     (CONS . consp)
  8437.     (DOUBLE-FLOAT . double-float-p)
  8438.     (FIXNUM . fixnump)
  8439.     (FLOAT . floatp)
  8440.     (FUNCTION . functionp)
  8441.     (HASH-TABLE . hash-table-p)
  8442.     (INTEGER . integerp)
  8443.     (KEYWORD . keywordp)
  8444.     (LIST . listp)
  8445.     #+LOGICAL-PATHNAMES
  8446.     (LOGICAL-PATHNAME . sys::logical-pathname-p)
  8447.     (LONG-FLOAT . long-float-p)
  8448.     (NULL . null)
  8449.     (NUMBER . numberp)
  8450.     (PACKAGE . packagep)
  8451.     (PATHNAME . pathnamep)
  8452.     (RANDOM-STATE . random-state-p)
  8453.     (RATIONAL . rationalp)
  8454.     (READTABLE . readtablep)
  8455.     (REAL . realp)
  8456.     (SEQUENCE . sys::sequencep)
  8457.     (SHORT-FLOAT . short-float-p)
  8458.     (SIMPLE-ARRAY . sys::simple-array-p)
  8459.     (SIMPLE-BIT-VECTOR . simple-bit-vector-p)
  8460.     (SIMPLE-STRING . simple-string-p)
  8461.     (SIMPLE-VECTOR . simple-vector-p)
  8462.     (SINGLE-FLOAT . single-float-p)
  8463.     (CLOS:STANDARD-GENERIC-FUNCTION . clos::generic-function-p)
  8464.     (CLOS:STANDARD-OBJECT . clos::std-instance-p)
  8465.     (STREAM . streamp)
  8466.     (STRING . stringp)
  8467.     (SYMBOL . symbolp)
  8468.     (VECTOR . vectorp)
  8469. )  )
  8470. (defconstant c-typep-alist2
  8471.   '((BIGNUM . ((x) (and (integerp x) (not (fixnump x)))))
  8472.     (BIT . ((x) (or (eql x 0) (eql x 1))))
  8473.     (NIL . ((x) (declare (ignore x)) nil))
  8474.     (RATIO . ((x) (and (rationalp x) (not (integerp x)))))
  8475.     (STANDARD-CHAR . ((x) (and (characterp x) (standard-char-p x))))
  8476.     (STRING-CHAR . ((x) (and (characterp x) (string-char-p x))))
  8477.     (STRUCTURE .
  8478.       ((x)
  8479.         (let ((y (type-of x)))
  8480.           (and (symbolp y) (get y 'SYS::DEFSTRUCT-DESCRIPTION)
  8481.                (SYS::%STRUCTURE-TYPE-P y x)
  8482.     ) ) ) )
  8483.     (T . ((x) (declare (ignore x)) t))
  8484. )  )
  8485. (defun c-typep-array (tester)
  8486.   #'(lambda (x &optional (el-type '*) (dims '*) &rest illegal-args)
  8487.       (declare (ignore illegal-args))
  8488.       `(AND (,tester ,x)
  8489.             ,@(if (eq el-type '*)
  8490.                 '()
  8491.                 `((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type)))
  8492.               )
  8493.             ,@(if (eq dims '*)
  8494.                 '()
  8495.                 (if (numberp dims)
  8496.                   `((EQL ,dims (ARRAY-RANK ,x)))
  8497.                   `((EQL ,(length dims) (ARRAY-RANK ,x))
  8498.                     ,@(let ((i 0))
  8499.                         (mapcap #'(lambda (dim)
  8500.                                     (prog1
  8501.                                       (if (eq dim '*)
  8502.                                         '()
  8503.                                         `((EQL ',dim (ARRAY-DIMENSION ,x ,i)))
  8504.                                       )
  8505.                                       (incf i)
  8506.                                   ) )
  8507.                                 dims
  8508.                       ) )
  8509.                    )
  8510.               ) )
  8511.        )
  8512. )   )
  8513. (defun c-typep-vector (tester)
  8514.   #'(lambda (x &optional (size '*) &rest illegal-args)
  8515.       (declare (ignore illegal-args))
  8516.       `(AND (,tester ,x)
  8517.             ,@(if (eq size '*)
  8518.                 '()
  8519.                 `((EQL (ARRAY-DIMENSION ,x 0) ',size))
  8520.               )
  8521.        )
  8522.     )
  8523. )
  8524. (defun c-typep-number (caller tester)
  8525.   #'(lambda (x &optional (low '*) (high '*) &rest illegal-args)
  8526.       (declare (ignore illegal-args))
  8527.       `(AND (,tester ,x)
  8528.             ,@(cond ((eq low '*) '())
  8529.                     ((funcall tester low) `((<= ,low ,x)))
  8530.                     ((and (consp low) (null (rest low)) (funcall tester (first low)))
  8531.                      `((< ,(first low) ,x))
  8532.                     )
  8533.                     (t (c-warn (DEUTSCH "~S: Argument zu ~S mu▀ *, ~S oder eine Liste von ~S sein: ~S"
  8534.                                 ENGLISH "~S: argument to ~S must be *, ~S or a list of ~S: ~S"
  8535.                                 FRANCAIS "~S : L'argument de ~S doit Ωtre *, ~S ou une liste de ~S: ~S")
  8536.                                'typep caller caller caller low
  8537.                        )
  8538.                        (throw 'c-TYPEP nil)
  8539.               )     )
  8540.             ,@(cond ((eq high '*) '())
  8541.                     ((funcall tester high) `((>= ,high ,x)))
  8542.                     ((and (consp high) (null (rest high)) (funcall tester (first high)))
  8543.                      `((> ,(first high) ,x))
  8544.                     )
  8545.                     (t (c-warn (DEUTSCH "~S: Argument zu ~S mu▀ *, ~S oder eine Liste von ~S sein: ~S"
  8546.                                 ENGLISH "~S: argument to ~S must be *, ~S or a list of ~S: ~S"
  8547.                                 FRANCAIS "~S : L'argument de ~S doit Ωtre *, ~S ou une liste de ~S: ~S")
  8548.                                'typep caller caller caller high
  8549.                        )
  8550.                        (throw 'c-TYPEP nil)
  8551.               )     )
  8552.        )
  8553.     )
  8554. )
  8555. (defconstant c-typep-alist3
  8556.   `((ARRAY . ,(c-typep-array 'ARRAYP))
  8557.     (SIMPLE-ARRAY . ,(c-typep-array 'SIMPLE-ARRAY-P))
  8558.     (VECTOR .
  8559.       ,#'(lambda (x &optional (el-type '*) (size '*) &rest illegal-args)
  8560.            (declare (ignore illegal-args))
  8561.            `(AND (VECTORP ,x)
  8562.                  ,@(if (eq el-type '*)
  8563.                      '()
  8564.                      `((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type)))
  8565.                    )
  8566.                  ,@(if (eq size '*)
  8567.                      '()
  8568.                      `((EQL (ARRAY-DIMENSION ,x 0) ',size))
  8569.                    )
  8570.             )
  8571.          )
  8572.     )
  8573.     (SIMPLE-VECTOR . ,(c-typep-vector 'SIMPLE-VECTOR-P))
  8574.     (COMPLEX .
  8575.       ,#'(lambda (x &optional (rtype '*) (itype rtype) &rest illegal-args)
  8576.            (declare (ignore illegal-args))
  8577.            `(AND (COMPLEXP ,x)
  8578.                  ,@(if (eq rtype '*)
  8579.                      '()
  8580.                      `((TYPEP (REALPART ,x) ',rtype))
  8581.                    )
  8582.                  ,@(if (eq itype '*)
  8583.                      '()
  8584.                      `((TYPEP (IMAGPART ,x) ',itype))
  8585.                    )
  8586.             )
  8587.          )
  8588.     )
  8589.     (INTEGER . ,(c-typep-number 'INTEGER 'INTEGERP))
  8590.     (MOD .
  8591.       ,#'(lambda (x &optional n &rest illegal-args)
  8592.            (declare (ignore illegal-args))
  8593.            (unless (integerp n)
  8594.              (c-warn (DEUTSCH "~S: Argument zu MOD mu▀ ganze Zahl sein: ~S"
  8595.                       ENGLISH "~S: argument to MOD must be an integer: ~S"
  8596.                       FRANCAIS "~S : L'argument de MOD doit Ωtre un entier: ~S")
  8597.                      'typep n
  8598.              )
  8599.              (throw 'c-TYPEP nil)
  8600.            )
  8601.            `(AND (INTEGERP ,x) (NOT (MINUSP ,x)) (< ,x ,n))
  8602.          )
  8603.     )
  8604.     (SIGNED-BYTE .
  8605.       ,#'(lambda (x &optional (n '*) &rest illegal-args)
  8606.            (declare (ignore illegal-args))
  8607.            (unless (or (eq n '*) (integerp n))
  8608.              (c-warn (DEUTSCH "~S: Argument zu SIGNED-BYTE mu▀ ganze Zahl oder * sein: ~S"
  8609.                       ENGLISH "~S: argument to SIGNED-BYTE must be an integer or * : ~S"
  8610.                       FRANCAIS "~S : L'argument de SIGNED-BYTE doit Ωtre un entier ou bien * : ~S")
  8611.                      'typep n
  8612.              )
  8613.              (throw 'c-TYPEP nil)
  8614.            )
  8615.            `(AND (INTEGERP ,x)
  8616.                  ,@(if (eq n '*) '() `((< (INTEGER-LENGTH ,x) ,n)))
  8617.             )
  8618.          )
  8619.     )
  8620.     (UNSIGNED-BYTE .
  8621.       ,#'(lambda (x &optional (n '*) &rest illegal-args)
  8622.            (declare (ignore illegal-args))
  8623.            (unless (or (eq n '*) (integerp n))
  8624.              (c-warn (DEUTSCH "~S: Argument zu UNSIGNED-BYTE mu▀ ganze Zahl oder * sein: ~S"
  8625.                       ENGLISH "~S: argument to UNSIGNED-BYTE must be an integer or * : ~S"
  8626.                       FRANCAIS "~S : L'argument de UNSIGNED-BYTE doit Ωtre un entier ou bien * : ~S")
  8627.                      'typep n
  8628.              )
  8629.              (throw 'c-TYPEP nil)
  8630.            )
  8631.            `(AND (INTEGERP ,x) (NOT (MINUSP ,x))
  8632.                  ,@(if (eq n '*) '() `((<= (INTEGER-LENGTH ,x) ,n)))
  8633.             )
  8634.          )
  8635.     )
  8636.     (REAL . ,(c-typep-number 'REAL 'REALP))
  8637.     (RATIONAL . ,(c-typep-number 'RATIONAL 'RATIONALP))
  8638.     (FLOAT . ,(c-typep-number 'FLOAT 'FLOATP))
  8639.     (SHORT-FLOAT . ,(c-typep-number 'SHORT-FLOAT 'SHORT-FLOAT-P))
  8640.     (SINGLE-FLOAT . ,(c-typep-number 'SINGLE-FLOAT 'SINGLE-FLOAT-P))
  8641.     (DOUBLE-FLOAT . ,(c-typep-number 'DOUBLE-FLOAT 'DOUBLE-FLOAT-P))
  8642.     (LONG-FLOAT . ,(c-typep-number 'LONG-FLOAT 'LONG-FLOAT-P))
  8643.     (STRING . ,(c-typep-vector 'STRINGP))
  8644.     (SIMPLE-STRING . ,(c-typep-vector 'SIMPLE-STRING-P))
  8645.     (BIT-VECTOR . ,(c-typep-vector 'BIT-VECTOR-P))
  8646.     (SIMPLE-BIT-VECTOR . ,(c-typep-vector 'SIMPLE-BIT-VECTOR-P))
  8647. )  )
  8648. (defun c-TYPEP () ; vgl. TYPEP in type.lsp
  8649.   (test-list *form* 3 3)
  8650.   (let ((objform (second *form*))
  8651.         (typeform (third *form*)))
  8652.     (when (c-constantp typeform)
  8653.       (let ((type (c-constant-value typeform)) h)
  8654.         (cond ((symbolp type)
  8655.                 (cond ; Test auf Property TYPE-SYMBOL:
  8656.                       ((setq h (assoc type c-typep-alist1))
  8657.                         (setq h (cdr h))
  8658.                         (return-from c-TYPEP
  8659.                           (c-GLOBAL-FUNCTION-CALL-form `(,h ,objform))
  8660.                       ) )
  8661.                       ((setq h (assoc type c-typep-alist2))
  8662.                         (setq h (cdr h))
  8663.                         (return-from c-TYPEP
  8664.                           (let ((*form* `(,h ,objform)))
  8665.                             (c-FUNCALL-INLINE
  8666.                               (symbol-suffix '#:TYPEP (symbol-name type))
  8667.                               (list objform)
  8668.                               nil
  8669.                               h
  8670.                               nil
  8671.                       ) ) ) )
  8672.                       ; Test auf Property TYPE-LIST:
  8673.                       ((setq h (assoc type c-typep-alist3))
  8674.                         (setq h (cdr h))
  8675.                         (let* ((objvar (gensym))
  8676.                                (testform (funcall h objvar))
  8677.                                (lambdabody `((,objvar) ,testform)))
  8678.                           (return-from c-TYPEP
  8679.                             (let ((*form* `((lambda ,@lambdabody) ,objform)))
  8680.                               (c-FUNCALL-INLINE
  8681.                                 (symbol-suffix '#:TYPEP (symbol-name type))
  8682.                                 (list objform)
  8683.                                 nil
  8684.                                 lambdabody
  8685.                                 nil
  8686.                       ) ) ) ) )
  8687.                       #+CLISP ; Test auf Property DEFTYPE-EXPANDER:
  8688.                       ((setq h (get type 'SYS::DEFTYPE-EXPANDER))
  8689.                         (return-from c-TYPEP
  8690.                           (c-form `(TYPEP ,objform ',(funcall h (list type))))
  8691.                       ) )
  8692.                       #+CLISP ; Test auf Property DEFSTRUCT-DESCRIPTION:
  8693.                       ((get type 'SYS::DEFSTRUCT-DESCRIPTION)
  8694.                         (return-from c-TYPEP
  8695.                           (c-form `(SYS::%STRUCTURE-TYPE-P ',type ,objform))
  8696.                       ) )
  8697.                       #+CLISP ; Test auf Property CLOS::CLASS:
  8698.                       ((and (setq h (get type 'CLOS::CLASS)) (clos::class-p h)
  8699.                             (eq (clos:class-name h) type)
  8700.                        )
  8701.                         (return-from c-TYPEP
  8702.                           (c-form `(CLOS::SUBCLASSP (CLOS:CLASS-OF ,objform)
  8703.                                      (LOAD-TIME-VALUE (CLOS:FIND-CLASS ',type))
  8704.                                    )
  8705.                       ) ) )
  8706.               ) )
  8707.               ((and (consp type) (symbolp (first type)))
  8708.                 (catch 'c-TYPEP
  8709.                   (cond ((and (eq (first type) 'SATISFIES) (eql (length type) 2))
  8710.                           (let ((fun (second type)))
  8711.                             (unless (symbolp (second type))
  8712.                               (c-warn (DEUTSCH "~S: Argument zu SATISFIES mu▀ Symbol sein: ~S"
  8713.                                        ENGLISH "~S: argument to SATISFIES must be a symbol: ~S"
  8714.                                        FRANCAIS "~S : L'argument de SATISFIES doit Ωtre un symbole: ~S")
  8715.                                       'typep (second type)
  8716.                               )
  8717.                               (throw 'c-TYPEP nil)
  8718.                             )
  8719.                             (return-from c-TYPEP
  8720.                               (c-GLOBAL-FUNCTION-CALL-form `(,fun ,objform))
  8721.                         ) ) )
  8722.                         ((eq (first type) 'MEMBER)
  8723.                           (return-from c-TYPEP
  8724.                             (let ((*form* `(CASE ,objform (,(rest type) T) (t NIL))))
  8725.                               (c-CASE)
  8726.                         ) ) )
  8727.                         ((and (eq (first type) 'EQL) (eql (length type) 2))
  8728.                           (return-from c-TYPEP
  8729.                             (let ((*form* `(EQL ,objform ',(second type))))
  8730.                               (c-EQL)
  8731.                         ) ) )
  8732.                         ((and (eq (first type) 'NOT) (eql (length type) 2))
  8733.                           (return-from c-TYPEP
  8734.                             (c-GLOBAL-FUNCTION-CALL-form
  8735.                               `(NOT (TYPEP ,objform ',(second type)))
  8736.                         ) ) )
  8737.                         ((or (eq (first type) 'AND) (eq (first type) 'OR))
  8738.                           (return-from c-TYPEP
  8739.                             (c-form
  8740.                               (let ((objvar (gensym)))
  8741.                                 `(LET ((,objvar ,objform))
  8742.                                    (,(first type) ; AND oder OR
  8743.                                     ,@(mapcar #'(lambda (typei) `(TYPEP ,objvar ',typei)) (rest type))
  8744.                                  ) )
  8745.                         ) ) ) )
  8746.                         ((setq h (assoc (first type) c-typep-alist3))
  8747.                           (setq h (cdr h))
  8748.                           (let* ((objvar (gensym))
  8749.                                  (testform (apply h objvar (rest type)))
  8750.                                  (lambdabody `((,objvar) ,testform)))
  8751.                             (return-from c-TYPEP
  8752.                               (let ((*form* `((lambda ,@lambdabody) ,objform)))
  8753.                                 (c-FUNCALL-INLINE
  8754.                                   (symbol-suffix '#:TYPEP (symbol-name (first type)))
  8755.                                   (list objform)
  8756.                                   nil
  8757.                                   lambdabody
  8758.                                   nil
  8759.                         ) ) ) ) )
  8760.               ) ) )
  8761.               ((and (clos::class-p type) (eq (get (clos:class-name type) 'CLOS::CLASS) type))
  8762.                 (return-from c-TYPEP
  8763.                   (c-form `(CLOS::SUBCLASSP (CLOS:CLASS-OF ,objform)
  8764.                              (LOAD-TIME-VALUE (CLOS:FIND-CLASS ',(clos:class-name type)))
  8765.                            )
  8766.               ) ) )
  8767.     ) ) )
  8768.     (c-GLOBAL-FUNCTION-CALL 'TYPEP)
  8769. ) )
  8770.  
  8771.  
  8772.  
  8773. ;                     Z W E I T E R   P A S S
  8774.  
  8775. ; eine Tabelle von Paaren (fnode n).
  8776. ; Jedes Paar zeigt an, da▀ im 3. Pass in der Konstanten Nummer n des
  8777. ; funktionalen Objektes von fnode der dort stehende fnode durch das durch ihn
  8778. ; erzeugte funktionale Objekt zu ersetzen ist.
  8779. (defvar *fnode-fixup-table*)
  8780.  
  8781. ; macht aus dem ANODE-Baum zum fnode *func* ein funktionales Objekt:
  8782. (defun pass2 (*func*)
  8783.   (when (anode-p (fnode-code *func*)) ; falls 2. Pass noch nicht durchgefⁿhrt:
  8784.     ; erst den Code flachklopfen, optimieren und assemblieren:
  8785.     (let ((code-list (compile-to-LAP))) ; Code flachklopfen und in Stⁿcke zerteilen,
  8786.                                         ; optimieren und zu einer Liste machen
  8787.       (when (fnode-gf-p *func*) (setq code-list (CONST-to-LOADV code-list))) ; evtl. CONSTs umwandeln
  8788.       (let (#+CLISP3 (SPdepth (SP-depth code-list))) ; Stackbedarf bestimmen
  8789.         (setq code-list (insert-combined-LAPs code-list)) ; kombinierte Operationen einfⁿhren
  8790.         (create-fun-obj *func* (assemble-LAP code-list) #+CLISP3 SPdepth) ; assemblieren und funkt. Objekt
  8791.     ) )
  8792.     ; dann die Sub-Funktionen durch den 2. Pass jagen
  8793.     (dolist (x (fnode-Consts *func*)) (if (fnode-p x) (pass2 x)))
  8794. ) )
  8795.  
  8796. #|
  8797.  
  8798. pass2 ruft den 1. Schritt auf.
  8799.  
  8800. Nach dem 1. Schritt ist der Code in kleine Stⁿcke aufgeteilt, jeweils von
  8801. einem Label bis zu einem Wegsprung (JMP, JMPCASE, JMPCASE1-TRUE, JMPCASE1-FALSE,
  8802. JMPHASH, RETURN-FROM, GO, RET, THROW, BARRIER). Die Teile stecken (jeweils als
  8803. Liste in umgekehrter Reihenfolge, mit dem Label als letztem CDR) im Vektor
  8804. *code-parts*.
  8805. (symbol-value label) enthΣlt eine Liste der Referenzen von label, und zwar in
  8806. der Form:
  8807.  - Index in *code-parts*, wenn die Referenz der entsprechende Wegsprung ist;
  8808.  - opcode sonst, wobei opcode der Befehl ist, in dem label auftritt.
  8809. Nach dem 1. Schritt enthΣlt der Code nur noch Tags (Symbole) und Listen aus
  8810. Symbolen und Zahlen. Es darf daher mit SUBST und EQUAL gearbeitet werden.
  8811.  
  8812. Der 1. Schritt ruft, sobald er mit einem Stⁿck fertig ist, den 2. Schritt
  8813. auf.
  8814.  
  8815. Dann ruft pass2 den 3. Schritt auf. Es handelt sich hier um Optimierungen,
  8816. die, wenn sie erfolgreich waren, weitere dieser Optimierungen aufrufen.
  8817.  
  8818. |#
  8819.  
  8820. #|
  8821.                              1. Schritt:
  8822.           Expansion von Code-Teilen, Aufteilen des Codes in Stⁿcke
  8823.  
  8824. VerΣndert werden:
  8825.  
  8826. vorher                           nachher
  8827.  
  8828. (CONST const)                    (CONST n)
  8829. (FCONST fnode)                   (CONST n), Fixup fⁿr 3. Pass merken
  8830. (BCONST block)                   (CONST n)
  8831. (GCONST tagbody)                 (CONST n)
  8832. (GET var venvc stackz)           (LOAD n) oder (LOADI k n) oder (LOADC n m)
  8833.                                  oder (LOADIC k n m) oder (LOADV k m)
  8834.                                  oder (GETVALUE n) oder (CONST n)
  8835. (SET var venvc stackz)           (STORE n) oder (STOREI k n) oder (STOREC n m)
  8836.                                  oder (STOREIC k n m) oder (STOREV k m)
  8837.                                  oder (SETVALUE n)
  8838. (SETVALUE symbol)                (SETVALUE n)
  8839. (GETVALUE symbol)                (GETVALUE n)
  8840. (BIND const)                     (BIND n)
  8841. (UNWIND stackz1 stackz2 for-value) eine Folge von
  8842.                                  (SKIP n), (SKIPI k n), (SKIPSP k), (VALUES0),
  8843.                                  (UNWIND-PROTECT-CLEANUP), (UNBIND1),
  8844.                                  (BLOCK-CLOSE), (TAGBODY-CLOSE)
  8845. (UNWINDSP stackz1 stackz2)       eine Folge von (SKIPSP k)
  8846. (JMPIF label)                    (JMPCASE label new-label) new-label
  8847. (JMPIFNOT label)                 (JMPCASE new-label label) new-label
  8848. (JMPIF1 label)                   (JMPCASE1-TRUE label new-label) new-label
  8849. (JMPIFNOT1 label)                (JMPCASE1-FALSE new-label label) new-label
  8850. (JMPHASH test ((obj1 . label1) ... (objm . labelm)) label . labels)
  8851.                                  (JMPHASH n ht label . labels)
  8852.                                  wobei ht = Hash-Tabelle (obji -> labeli) ist
  8853. (VENV venvc stackz)              (VENV) oder (NIL)
  8854.                                  oder (LOAD n) oder (LOADI k n)
  8855. (COPY-CLOSURE fnode n)           (COPY-CLOSURE m n), Fixup fⁿr 3. Pass merken
  8856. (CALLP)                          gestrichen
  8857. (CALL k fun)                     (CALL k n)
  8858. (CALL0 fun)                      (CALL0 n)
  8859. (CALL1 fun)                      (CALL1 n)
  8860. (CALL2 fun)                      (CALL2 n)
  8861. (FUNCALLP)                       (PUSH)
  8862. (APPLYP)                         (PUSH)
  8863. (JMPIFBOUNDP var venvc stackz label)
  8864.                                  (JMPIFBOUNDP n label)
  8865. (BOUNDP var venvc stackz)        (BOUNDP n)
  8866. (BLOCK-OPEN const label)         (BLOCK-OPEN n label)
  8867. (RETURN-FROM const)              (RETURN-FROM n)
  8868. (RETURN-FROM block)              (RETURN-FROM n)
  8869. (RETURN-FROM block stackz)       (RETURN-FROM-I k n)
  8870. (TAGBODY-OPEN const label1 ... labelm)
  8871.                                  (TAGBODY-OPEN n label1 ... labelm)
  8872. (GO const l)                     (GO n l)
  8873. (GO tagbody l)                   (GO n l)
  8874. (GO tagbody l stackz)            (GO-I k n l)
  8875. (HANDLER-OPEN const stackz label1 ... labelm)
  8876.                                  (HANDLER-OPEN n v k label1 ... labelm)
  8877.  
  8878.  
  8879. unverΣndert bleiben:
  8880. (NIL)
  8881. (PUSH-NIL n)
  8882. (T)
  8883. (STORE n)
  8884. (UNBIND1)
  8885. (PROGV)
  8886. (PUSH)
  8887. (POP)
  8888. (RET)
  8889. (JMP label)
  8890. (JSR m label)
  8891. (BARRIER)
  8892. (MAKE-VECTOR1&PUSH n)
  8893. (CALLS1 n)
  8894. (CALLS2 n)
  8895. (CALLSR m n)
  8896. (CALLC)
  8897. (CALLCKEY)
  8898. (FUNCALL n)
  8899. (APPLY n)
  8900. (PUSH-UNBOUND n)
  8901. (UNLIST n m)
  8902. (UNLIST* n m)
  8903. (VALUES0)
  8904. (VALUES1)
  8905. (STACK-TO-MV n)
  8906. (MV-TO-STACK)
  8907. (NV-TO-STACK n)
  8908. (MV-TO-LIST)
  8909. (LIST-TO-MV)
  8910. (MVCALLP)
  8911. (MVCALL)
  8912. (BLOCK-CLOSE)
  8913. (TAGBODY-CLOSE-NIL)
  8914. (TAGBODY-CLOSE)
  8915. (CATCH-OPEN label)
  8916. (CATCH-CLOSE)
  8917. (THROW)
  8918. (UNWIND-PROTECT-OPEN label)
  8919. (UNWIND-PROTECT-NORMAL-EXIT)
  8920. (UNWIND-PROTECT-CLOSE label)
  8921. (UNWIND-PROTECT-CLEANUP)
  8922. (HANDLER-BEGIN)
  8923. (NOT)
  8924. (EQ)
  8925. (CAR)
  8926. (CDR)
  8927. (CONS)
  8928. (ATOM)
  8929. (CONSP)
  8930. (SYMBOL-FUNCTION)
  8931. (SVREF)
  8932. (SVSET)
  8933. (LIST n)
  8934. (LIST* n)
  8935.  
  8936. Neue Operationen:
  8937.  
  8938. (JMP label boolvalue)            Sprung zu label, boolvalue beschreibt den 1.
  8939.                                  Wert: FALSE falls =NIL, TRUE falls /=NIL,
  8940.                                  NIL falls unbekannt.
  8941.  
  8942. (JMPCASE label1 label2)          Sprung zu label1, falls A0 /= NIL,
  8943.                                  bzw. zu label2, falls A0 = NIL.
  8944.  
  8945. (JMPCASE1-TRUE label1 label2)    Falls A0 /= NIL: Sprung nach label1, 1 Wert.
  8946.                                  Falls A0 = NIL: Sprung nach label2.
  8947.  
  8948. (JMPCASE1-FALSE label1 label2)   Falls A0 /= NIL: Sprung nach label1.
  8949.                                  Falls A0 = NIL: Sprung nach label2, 1 Wert.
  8950.  
  8951. (JMPTAIL m n label)              Verkleinerung des Stack-Frames von n auf m,
  8952.                                  dann Sprung zu label mit undefinierten Werten.
  8953.  
  8954. |#
  8955.  
  8956. ; Ein Vektor mit Fill-Pointer, der die Codestⁿcke enthΣlt:
  8957. (defvar *code-parts*)
  8958.  
  8959. ; Ein gleichlanger Vektor mit Fill-Pointer, der zu jedem Codestⁿck eine
  8960. ; "Position" enthΣlt, wo das Stⁿck am Ende landen soll (0 = ganz am Anfang,
  8961. ; je h÷her, desto weiter hinten).
  8962. (defvar *code-positions*)
  8963.  
  8964. ; trΣgt eine Konstante in (fnode-consts *func*) ein und liefert deren Index n.
  8965. ; value ist der Wert der Konstanten, form eine Form mit diesem Wert oder NIL.
  8966. (defun const-index (value form &optional (func *func*))
  8967.   (let ((const-list (fnode-consts func))
  8968.         (forms-list (fnode-consts-forms func))
  8969.         (n (fnode-Consts-Offset func)))
  8970.     (if (null const-list)
  8971.       (progn
  8972.         (setf (fnode-consts func) (list value))
  8973.         (setf (fnode-consts-forms func) (list form))
  8974.         n
  8975.       )
  8976.       (loop
  8977.         (when (eql (car const-list) value)
  8978.           (when (and (null (car forms-list)) form) (setf (car forms-list) form))
  8979.           (return n)
  8980.         )
  8981.         (incf n)
  8982.         (when (null (cdr const-list))
  8983.           (setf (cdr const-list) (list value))
  8984.           (setf (cdr forms-list) (list form))
  8985.           (return n)
  8986.         )
  8987.         (setq const-list (cdr const-list))
  8988.         (setq forms-list (cdr forms-list))
  8989. ) ) ) )
  8990.  
  8991. ; sucht eine Konstante in (fnode-Keywords *func*) und in (fnode-Consts *func*),
  8992. ; trΣgt sie eventuell in (fnode-Consts *func*) ein. Liefert ihren Index n.
  8993. (defun kconst-index (value form &optional (func *func*))
  8994.   (when (keywordp value) ; nur bei Keywords lohnt sich die Suche
  8995.     (do ((n (fnode-Keyword-Offset func) (1+ n))
  8996.          (L (fnode-Keywords func) (cdr L)))
  8997.         ((null L))
  8998.       (if (eq (car L) value) (return-from kconst-index n))
  8999.   ) )
  9000.   (const-index value form func)
  9001. )
  9002. (defun kconst-index-1 (const)
  9003.   (kconst-index (const-value const) (const-form const))
  9004. )
  9005.  
  9006. ; (make-const-code value form) liefert den Code, der das Objekt value,
  9007. ; entstanden aus form, als 1 Wert nach A0 bringt.
  9008. (defun make-const-code (value form)
  9009.   (cond ((eq value 'nil) '(NIL) )
  9010.         ((eq value 't) '(T) )
  9011.         (t `(CONST ,(kconst-index value form)) )
  9012. ) )
  9013.  
  9014. ; (bconst-index block) liefert den Index in FUNC, an dem dieser Block steht.
  9015. (defun bconst-index (block &optional (func *func*))
  9016. ; (+ (fnode-Blocks-Offset func)
  9017. ;    (position block (fnode-Blocks func) :test #'eq)
  9018. ; )
  9019.   (do ((n (fnode-Blocks-Offset func) (1+ n))
  9020.        (L (fnode-Blocks func) (cdr L)))
  9021.       ((eq (car L) block) n)
  9022. ) )
  9023.  
  9024. ; (gconst-index tagbody) liefert den Index in FUNC, an dem dieser Tagbody steht.
  9025. (defun gconst-index (tagbody &optional (func *func*))
  9026. ; (+ (fnode-Tagbodys-Offset func)
  9027. ;    (position tagbody (fnode-Tagbodys func) :test #'eq)
  9028. ; )
  9029.   (do ((n (fnode-Tagbodys-Offset func) (1+ n))
  9030.        (L (fnode-Tagbodys func) (cdr L)))
  9031.       ((eq (car L) tagbody) n)
  9032. ) )
  9033.  
  9034. ; (fconst-index fnode) liefert den Index in FUNC, an dem dieser fnode in den
  9035. ; Konstanten steht. Wenn n÷tig, wird er eingefⁿgt und in *fnode-fixup-table*
  9036. ; vermerkt.
  9037. (defun fconst-index (fnode &optional (func *func*))
  9038.   (if (member fnode (fnode-Consts func))
  9039.     (const-index fnode nil)
  9040.     (let ((n (const-index fnode nil)))
  9041.       (push (list func n) *fnode-fixup-table*)
  9042.       n
  9043. ) ) )
  9044.  
  9045. ; Hilfsvariablen beim rekursiven Aufruf von traverse-anode:
  9046.  
  9047. ; Das aktuelle Codestⁿck, eine umgedrehte Liste von Instruktionen, die
  9048. ; mit dem Start-Label als letztem nthcdr endet.
  9049. (defvar *code-part*)
  9050.  
  9051. ; und seine Nummer (Index in *code-parts*)
  9052. (defvar *code-index*)
  9053.  
  9054. ; Flag, ob "toter Code" (d.h. Code, der nicht erreichbar ist) vorliegt
  9055. (defvar *dead-code*)
  9056.  
  9057. ; Fⁿr Sprungkettenverkⁿrzung in traverse-anode: Liste aller bereits
  9058. ; durchgefⁿhrten Label-Substitutionen ((old-label . new-label) ...)
  9059. (defvar *label-subst*)
  9060.  
  9061. ; Der aktuelle Wert, interpretiert als boolescher Wert:
  9062. ; FALSE falls =NIL, TRUE falls /=NIL, NIL falls unbekannt.
  9063. ; (Keine EinschrΣnkung an die Anzahl der Werte!)
  9064. (defvar *current-value*)
  9065.  
  9066. ; Liste der Variablen/Konstanten, deren Wert mit dem aktuellen ⁿbereinstimmt
  9067. ; (lexikalische Variablen als VARIABLE-Structures, dynamische Variablen als
  9068. ; Symbole, Konstanten als CONST-Structures).
  9069. ; Ist diese Liste nichtleer, so liegt auch genau 1 Wert vor.
  9070. (defvar *current-vars*)
  9071.  
  9072. ; Jedes Label (ein Gensym-Symbol) hat als Wert eine Liste aller Referenzen
  9073. ; auf label, und zwar jeweils entweder als Index i in *code-parts*, wenn es
  9074. ; sich um den Wegsprung (das Ende) von (aref *code-parts* i) handelt, oder
  9075. ; als Instruktion (einer Liste) in allen anderen FΣllen. Falls das Label
  9076. ; ein Codestⁿck beginnt, steht unter (get label 'code-part) der Index in
  9077. ; *code-part* des Codestⁿcks, das mit diesem Label anfΣngt. Unter
  9078. ; (get label 'for-value) steht, wieviele Werte bei einem m÷glichen Sprung
  9079. ; auf das Label von Bedeutung sind (NIL/ONE/ALL).
  9080. ; Eine Ausnahme stellt das "Label" NIL dar, das den Einsprungpunkt darstellt.
  9081.  
  9082. ; Ersetzt alle Referenzen auf old-label durch Referenzen auf new-label.
  9083. (defun label-subst (old-label new-label)
  9084.   ; alle Referenzen auf old-label verΣndern:
  9085.   (dolist (ref (symbol-value old-label))
  9086.     (nsubst new-label old-label
  9087.             (rest (if (integerp ref) (first (aref *code-parts* ref)) ref))
  9088.   ) )
  9089.   ; und als Referenzen auf new-label eintragen:
  9090.   (setf (symbol-value new-label)
  9091.     (nconc (symbol-value old-label) (symbol-value new-label))
  9092.   )
  9093.   (setf (symbol-value old-label) '())
  9094.   ; Mit old-label fΣngt kein Codestⁿck mehr an:
  9095.   (remprop old-label 'code-part)
  9096. )
  9097.  
  9098. ; Aktuelles Codestⁿck beenden und ein neues Codestⁿck anfangen:
  9099. (defun finish-code-part ()
  9100.   ; das aktuelle Codestⁿck vereinfachen:
  9101.   (simplify *code-part*)
  9102.   ; *code-part* in *code-parts* unterbringen:
  9103.   (vector-push-extend *code-part* *code-parts*)
  9104.   (vector-push-extend (incf *code-index*) *code-positions*)
  9105. )
  9106.  
  9107. ; Einen Wegsprung auf Label label emittieren.
  9108. ; Dadurch wird ein neues Codestⁿck angefangen.
  9109. (defun emit-jmp (label)
  9110.   ; mit einem Wegsprung:
  9111.   (push `(JMP ,label ,*current-value*) *code-part*)
  9112.   (push *code-index* (symbol-value label))
  9113.   (finish-code-part)
  9114. )
  9115.  
  9116. ; LΣuft durch den Code eines Anode durch, expandiert den Code und baut dabei
  9117. ; *code-part* weiter. Adjustiert die Variablen *current-value* usw. passend.
  9118. (defun traverse-anode (code)
  9119.   (dolist (item code)
  9120.     (if (atom item)
  9121.       (cond ((symbolp item) ; Label
  9122.              (if *dead-code*
  9123.                ; Code kann angesprungen werden, ist ab jetzt nicht mehr tot
  9124.                (setq *dead-code* nil)
  9125.                (if (symbolp *code-part*)
  9126.                  ; Label item sofort nach Label *code-part*
  9127.                  ; -> k÷nnen identifiziert werden
  9128.                  (let ((old-label *code-part*) (new-label item))
  9129.                    ; substituiere *code-parts* -> item
  9130.                    (label-subst old-label new-label)
  9131.                    (setq *label-subst*
  9132.                      (acons old-label new-label
  9133.                        (nsubst new-label old-label *label-subst*)
  9134.                  ) ) )
  9135.                  ; Label mitten im Codestⁿck -> aktuelles Codestⁿck beenden
  9136.                  (emit-jmp item)
  9137.              ) )
  9138.              ; jetzt geht das aktuelle Codestⁿck erst richtig los,
  9139.              ; mit dem Label item:
  9140.              (setq *code-part* item)
  9141.              (setf (get item 'code-part) (fill-pointer *code-parts*))
  9142.              ; Da noch Sprⁿnge auf dieses Label kommen k÷nnen, wissen wir
  9143.              ; nicht, was A0 enthΣlt:
  9144.              (setq *current-value* nil *current-vars* '())
  9145.             )
  9146.             ((anode-p item) (traverse-anode (anode-code item))) ; Anode -> rekursiv
  9147.             (t (compiler-error 'traverse-anode "ITEM"))
  9148.       )
  9149.       ; item ist eine normale Instruktion
  9150.       (unless *dead-code* ; nur erreichbarer Code braucht verarbeitet zu werden
  9151.         (nsublis *label-subst* (rest item)) ; bisherige Substitutionen durchfⁿhren
  9152.         (case (first item)
  9153.           (CONST
  9154.             (let* ((c (second item))
  9155.                    (cv (const-value c)))
  9156.               (unless ; ein (CONST cv) schon in *current-vars* enthalten?
  9157.                   (dolist (v *current-vars* nil)
  9158.                     (when (and (const-p v) (eq (const-value v) cv)) (return t))
  9159.                   )
  9160.                 (push (make-const-code cv (const-form c)) *code-part*)
  9161.                 (setq *current-value* (if (null cv) 'FALSE 'TRUE)
  9162.                       *current-vars* (list c)
  9163.           ) ) ) )
  9164.           (FCONST
  9165.             (push `(CONST ,(fconst-index (second item))) *code-part*)
  9166.             (setq *current-value* 'TRUE *current-vars* '())
  9167.           )
  9168.           (BCONST
  9169.             (push `(CONST ,(bconst-index (second item))) *code-part*)
  9170.             (setq *current-value* 'TRUE *current-vars* '())
  9171.           )
  9172.           (GCONST
  9173.             (push `(CONST ,(gconst-index (second item))) *code-part*)
  9174.             (setq *current-value* 'TRUE *current-vars* '())
  9175.           )
  9176.           (GET
  9177.             (let ((var (second item))
  9178.                   (venvc (third item))
  9179.                   (stackz (fourth item)))
  9180.               (unless (member var *current-vars* :test #'eq) ; Ist bereits der aktuelle Wert = var ?
  9181.                 (push
  9182.                   (if (var-constantp var)
  9183.                     (let* ((const (var-constant var))
  9184.                            (val (const-value const)))
  9185.                       (setq *current-value* (if (null val) 'FALSE 'TRUE))
  9186.                       (if (fnode-p val)
  9187.                         ; FNODEs als Werte k÷nnen (fast) nur von LABELS stammen
  9188.                         `(CONST ,(fconst-index val))
  9189.                         (make-const-code val (const-form const))
  9190.                     ) )
  9191.                     (progn
  9192.                       (setq *current-value* nil)
  9193.                       (if (var-specialp var)
  9194.                         `(GETVALUE ,(kconst-index (setq var (var-name var)) nil))
  9195.                         (if (var-closurep var)
  9196.                           (multiple-value-bind (k n m)
  9197.                               (zugriff-in-closure var venvc stackz)
  9198.                             (if n
  9199.                               (if k `(LOADIC ,k ,n ,m) `(LOADC ,n ,m))
  9200.                               `(LOADV ,k ,(1+ m))
  9201.                           ) )
  9202.                           ; lexikalisch und im Stack, also in derselben Funktion
  9203.                           (multiple-value-bind (k n)
  9204.                               (zugriff-in-stack stackz (var-stackz var))
  9205.                             (if k `(LOADI ,k ,n) `(LOAD ,n) )
  9206.                   ) ) ) ) )
  9207.                   *code-part*
  9208.                 )
  9209.                 (setq *current-vars* (list var))
  9210.           ) ) )
  9211.           (SET
  9212.             (let ((var (second item))
  9213.                   (venvc (third item))
  9214.                   (stackz (fourth item)))
  9215.               (unless (member var *current-vars* :test #'eq) ; Ist bereits der aktuelle Wert = var ?
  9216.                 (push
  9217.                   (if (var-specialp var)
  9218.                     `(SETVALUE ,(kconst-index (setq var (var-name var)) nil))
  9219.                     (if (var-closurep var)
  9220.                       (multiple-value-bind (k n m)
  9221.                           (zugriff-in-closure var venvc stackz)
  9222.                         (if n
  9223.                           (if k `(STOREIC ,k ,n ,m) `(STOREC ,n ,m))
  9224.                           `(STOREV ,k ,(1+ m))
  9225.                       ) )
  9226.                       ; lexikalisch und im Stack, also in derselben Funktion
  9227.                       (multiple-value-bind (k n)
  9228.                           (zugriff-in-stack stackz (var-stackz var))
  9229.                         (if k `(STOREI ,k ,n) `(STORE ,n) )
  9230.                   ) ) )
  9231.                   *code-part*
  9232.                 )
  9233.                 (push var *current-vars*) ; *current-value* bleibt unverΣndert
  9234.           ) ) )
  9235.           (GETVALUE
  9236.             (let ((symbol (second item)))
  9237.               (unless (member symbol *current-vars* :test #'eq)
  9238.                 (push `(GETVALUE ,(kconst-index symbol nil)) *code-part*)
  9239.                 (setq *current-value* nil *current-vars* (list symbol))
  9240.           ) ) )
  9241.           (SETVALUE
  9242.             (let ((symbol (second item)))
  9243.               (unless (member symbol *current-vars* :test #'eq)
  9244.                 (push `(SETVALUE ,(kconst-index symbol nil)) *code-part*)
  9245.                 (push symbol *current-vars*) ; *current-value* bleibt unverΣndert
  9246.           ) ) )
  9247.           (BIND
  9248.             (push `(BIND ,(kconst-index-1 (second item))) *code-part*)
  9249.             (setq *current-value* nil *current-vars* '()) ; undefinierte Werte
  9250.           )
  9251.           (UNWIND ; mehrzeilige Umwandlung
  9252.             (traverse-anode
  9253.               (expand-UNWIND (second item) (third item) (fourth item))
  9254.           ) )
  9255.           (UNWINDSP ; mehrzeilige Umwandlung
  9256.             (let ((k (spdepth-difference (second item) (third item))))
  9257.               (when (> k 0)
  9258.                 (push `(SKIPSP ,k) *code-part*)
  9259.           ) ) )
  9260.           ((JMPIF JMPIFNOT JMPIF1 JMPIFNOT1)
  9261.             (if (null *current-value*)
  9262.               (let ((label (second item))
  9263.                     (new-label (make-label 'NIL)))
  9264.                 (push
  9265.                   (case (first item)
  9266.                     (JMPIF `(JMPCASE ,label ,new-label))
  9267.                     (JMPIFNOT `(JMPCASE ,new-label ,label))
  9268.                     (JMPIF1 `(JMPCASE1-TRUE ,label ,new-label))
  9269.                     (JMPIFNOT1 `(JMPCASE1-FALSE ,new-label ,label))
  9270.                   )
  9271.                   *code-part*
  9272.                 )
  9273.                 (push *code-index* (symbol-value (second item)))
  9274.                 (push *code-index* (symbol-value new-label))
  9275.                 (finish-code-part)
  9276.                 (setf (get new-label 'code-part) (fill-pointer *code-parts*))
  9277.                 (setq *code-part* new-label)
  9278.                 ; *current-value* und *current-vars* bleiben unverΣndert.
  9279.               )
  9280.               ; boolescher Wert beim Wegsprung bekannt
  9281.               (if (if (eq *current-value* 'FALSE)
  9282.                     (memq (first item) '(JMPIF JMPIF1)) ; Wert=NIL -> JMPIF weglassen
  9283.                     (memq (first item) '(JMPIFNOT JMPIFNOT1)) ; Wert/=NIL -> JMPIFNOT weglassen
  9284.                   )
  9285.                 ; Sprung weglassen
  9286.                 nil
  9287.                 ; in JMP umwandeln:
  9288.                 (progn
  9289.                   (when (memq (first item) '(JMPIF1 JMPIFNOT1))
  9290.                     (push '(VALUES1) *code-part*) ; genau 1 Wert erzwingen
  9291.                   )
  9292.                   (emit-jmp (second item))
  9293.                   (setq *dead-code* t)
  9294.           ) ) ) )
  9295.           (JMPHASH
  9296.             (let ((hashtable (make-hash-table :test (second item)))
  9297.                   (labels (cddddr item)))
  9298.               (dolist (acons (third item))
  9299.                 (setf (gethash (car acons) hashtable)
  9300.                       (position (cdr acons) labels)
  9301.               ) )
  9302.               (push `(JMPHASH ,(const-index hashtable nil) ,hashtable
  9303.                               ,@(cdddr item)
  9304.                      )
  9305.                     *code-part*
  9306.             ) )
  9307.             ; Referenzen vermerken:
  9308.             (dolist (label (cdddr item))
  9309.               (push *code-index* (symbol-value label))
  9310.             )
  9311.             (finish-code-part)
  9312.             (setq *dead-code* t)
  9313.           )
  9314.           (VENV
  9315.             (let ((venvc (second item))
  9316.                   (stackz (third item)))
  9317.               (loop ; in venvc die NILs ⁿbergehen
  9318.                 (when (car venvc) (return))
  9319.                 (setq venvc (cdr venvc))
  9320.               )
  9321.               (push
  9322.                 (if (consp (car venvc)) ; aus dem Stack holen
  9323.                   (multiple-value-bind (k n)
  9324.                       (zugriff-in-stack stackz (cdr (car venvc)))
  9325.                     (if k `(LOADI ,k ,n) `(LOAD ,n) )
  9326.                   )
  9327.                   (if (eq (car venvc) *func*)
  9328.                     (if (fnode-Venvconst *func*) '(VENV) '(NIL))
  9329.                     (compiler-error 'traverse-anode 'VENV)
  9330.                 ) )
  9331.                 *code-part*
  9332.               )
  9333.               (if (equal (car *code-part*) '(NIL))
  9334.                 (setq *current-value* 'FALSE *current-vars* (list (make-const :value 'NIL)))
  9335.                 (setq *current-value* nil *current-vars* '())
  9336.               )
  9337.           ) )
  9338.           (COPY-CLOSURE
  9339.             (push `(COPY-CLOSURE ,(fconst-index (second item)) ,(third item))
  9340.                    *code-part*
  9341.             )
  9342.             (setq *current-value* 'TRUE *current-vars* '())
  9343.           )
  9344.           (CALLP) ; wird gestrichen
  9345.           (CALL
  9346.             (push `(CALL ,(second item) ,(kconst-index-1 (third item)))
  9347.                    *code-part*
  9348.             )
  9349.             (setq *current-value* nil *current-vars* '())
  9350.           )
  9351.           ((CALL0 CALL1 CALL2)
  9352.             (push `(,(first item) ,(kconst-index-1 (second item)))
  9353.                   *code-part*
  9354.             )
  9355.             (setq *current-value* nil *current-vars* '())
  9356.           )
  9357.           ((FUNCALLP APPLYP)
  9358.             (push '(PUSH) *code-part*)
  9359.             (setq *current-value* nil *current-vars* '())
  9360.           )
  9361.           ((JMPIFBOUNDP BOUNDP)
  9362.             (let ((var (second item))
  9363.                   (stackz (fourth item))
  9364.                  )
  9365.               (when (var-closurep var)
  9366.                 (compiler-error 'traverse-anode 'var-closurep)
  9367.               )
  9368.               (multiple-value-bind (k n)
  9369.                   (zugriff-in-stack stackz (var-stackz var))
  9370.                 (when k (compiler-error 'traverse-anode 'var-stackz))
  9371.                 (push `(,(first item) ,n ,@(cddddr item)) *code-part*)
  9372.                 (when (eq (first item) 'JMPIFBOUNDP)
  9373.                   (push (first *code-part*) (symbol-value (fifth item)))
  9374.                 )
  9375.                 (setq *current-value* nil *current-vars* '()) ; undefinierte Werte
  9376.           ) ) )
  9377.           (BLOCK-OPEN
  9378.             (let ((label (third item)))
  9379.               (push `(BLOCK-OPEN ,(kconst-index-1 (second item)) ,label)
  9380.                      *code-part*
  9381.               )
  9382.               (push (first *code-part*) (symbol-value label))
  9383.           ) )
  9384.           (RETURN-FROM
  9385.             (push
  9386.               (if (cddr item)
  9387.                 (multiple-value-bind (k n)
  9388.                     (zugriff-in-stack (third item) (block-stackz (second item)))
  9389.                   `(RETURN-FROM-I ,k ,n)
  9390.                 )
  9391.                 (if (block-p (second item))
  9392.                   `(RETURN-FROM ,(bconst-index (second item)))
  9393.                   `(RETURN-FROM ,(kconst-index-1 (second item)))
  9394.               ) )
  9395.               *code-part*
  9396.             )
  9397.             (finish-code-part)
  9398.             (setq *dead-code* t)
  9399.           )
  9400.           (TAGBODY-OPEN
  9401.             (push `(TAGBODY-OPEN ,(kconst-index-1 (second item)) ,@(cddr item))
  9402.                   *code-part*
  9403.             )
  9404.             (dolist (label (cddr item)) (push item (symbol-value label)))
  9405.           )
  9406.           (GO
  9407.             (push
  9408.               (if (cdddr item)
  9409.                 (multiple-value-bind (k n)
  9410.                     (zugriff-in-stack (fourth item) (tagbody-stackz (second item)))
  9411.                   `(GO-I ,k ,n ,(third item))
  9412.                 )
  9413.                 (if (tagbody-p (second item))
  9414.                   `(GO ,(gconst-index (second item)) ,(third item))
  9415.                   `(GO ,(kconst-index-1 (second item)) ,(third item))
  9416.               ) )
  9417.               *code-part*
  9418.             )
  9419.             (finish-code-part)
  9420.             (setq *dead-code* t)
  9421.           )
  9422.           ((NIL TAGBODY-CLOSE-NIL)
  9423.             (push item *code-part*)
  9424.             (setq *current-value* 'FALSE *current-vars* (list (make-const :value 'NIL)))
  9425.           )
  9426.           (HANDLER-OPEN
  9427.             (setq item
  9428.               (let ((v (const-value (second item)))
  9429.                     (k (spdepth-difference (third item) *func*)))
  9430.                 ; Aus v = #(type1 ... typem) mache v = #(type1 nil ... typem nil)
  9431.                 (setq v (coerce (mapcap #'(lambda (x) (list x nil)) (coerce v 'list)) 'vector))
  9432.                 `(HANDLER-OPEN ,(const-index (cons v k) nil) ,v ,k ,@(cdddr item))
  9433.             ) )
  9434.             (push item *code-part*)
  9435.             (dolist (label (cddddr item)) (push item (symbol-value label)))
  9436.           )
  9437.           (VALUES0
  9438.             (push item *code-part*)
  9439.             (setq *current-value* 'FALSE *current-vars* '())
  9440.           )
  9441.           ((SKIP SKIPI SKIPSP VALUES1 MVCALLP BLOCK-CLOSE TAGBODY-CLOSE
  9442.             CATCH-CLOSE UNWIND-PROTECT-NORMAL-EXIT HANDLER-BEGIN
  9443.             STORE ; STORE nur auf Funktionsargumente innerhalb eines
  9444.                   ; Funktionsaufrufs, vgl. c-DIRECT-FUNCTION-CALL
  9445.            )
  9446.             (push item *code-part*)
  9447.           )
  9448.           ((T)
  9449.             (push item *code-part*)
  9450.             (setq *current-value* 'TRUE *current-vars* (list (make-const :value 'T)))
  9451.           )
  9452.           ((RET BARRIER THROW)
  9453.             (push item *code-part*)
  9454.             (finish-code-part)
  9455.             (setq *dead-code* t)
  9456.           )
  9457.           (JMP
  9458.             (emit-jmp (second item))
  9459.             (setq *dead-code* t)
  9460.           )
  9461.           (JSR
  9462.             (push item *code-part*)
  9463.             (push item (symbol-value (third item)))
  9464.             (setq *current-value* nil *current-vars* '())
  9465.           )
  9466.           ((CATCH-OPEN UNWIND-PROTECT-OPEN)
  9467.             (push item *code-part*)
  9468.             (push item (symbol-value (second item)))
  9469.           )
  9470.           (UNWIND-PROTECT-CLOSE
  9471.             (push item *code-part*)
  9472.             (push item (symbol-value (second item)))
  9473.             (setq *current-value* nil *current-vars* '()) ; Werte werden weggeworfen
  9474.           )
  9475.           ((PUSH-NIL PROGV PUSH POP MAKE-VECTOR1&PUSH CALLS1 CALLS2 CALLSR
  9476.             CALLC CALLCKEY FUNCALL APPLY PUSH-UNBOUND UNLIST UNLIST*
  9477.             STACK-TO-MV MV-TO-STACK NV-TO-STACK MV-TO-LIST LIST-TO-MV MVCALL
  9478.             NOT EQ CAR CDR ATOM CONSP SYMBOL-FUNCTION SVREF SVSET
  9479.            )
  9480.             (push item *code-part*)
  9481.             (setq *current-value* nil *current-vars* '())
  9482.           )
  9483.           ((CONS LIST LIST*)
  9484.             (push item *code-part*)
  9485.             (setq *current-value* 'TRUE *current-vars* '())
  9486.           )
  9487.           ((UNWIND-PROTECT-CLEANUP)
  9488.             (push item *code-part*)
  9489.             (setq *current-vars* '()) ; Kann Variablenwerte zerst÷ren
  9490.           )
  9491.           ((UNBIND1)
  9492.             (push item *code-part*)
  9493.             (setq *current-vars* (delete-if #'symbolp *current-vars*)) ; Kann Werte dynamischer Variablen zerst÷ren
  9494.           )
  9495.           (t (compiler-error 'traverse-anode "LISTITEM"))
  9496. ) ) ) ) )
  9497.  
  9498. ; Hilfsfunktionen nach dem 1. Schritt:
  9499.  
  9500. ; Kommt eine Instruktion item dazu, die vielleicht Label-Referenzen enthΣlt,
  9501. ; so ist note-references aufzurufen. Dieses notiert die Label-Referenzen in
  9502. ; item. item geh÷re zu (aref *code-parts* index).
  9503. ; Wird eine Instruktion item entfernt, die vielleicht Label-Referenzen enthΣlt,
  9504. ; so ist remove-references aufzurufen. Dieses notiert das Wegfallen der
  9505. ; Label-Referenzen in item. item geh÷re zu (aref *code-parts* index).
  9506. ; Liefert auch die Liste der in item enthaltenen Labels.
  9507. (macrolet ((references ()
  9508.              `(case (first item)
  9509.                 (JMP (end-ref (second item)))
  9510.                 ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  9511.                  (end-ref (second item)) (end-ref (third item))
  9512.                 )
  9513.                 (JMPHASH (dolist (label (cdddr item)) (end-ref label)))
  9514.                 ((JMPIFBOUNDP CATCH-OPEN UNWIND-PROTECT-OPEN UNWIND-PROTECT-CLOSE)
  9515.                  (mid-ref (second item))
  9516.                 )
  9517.                 ((BLOCK-OPEN JSR) (mid-ref (third item)))
  9518.                 (JMPTAIL (mid-ref (fourth item)))
  9519.                 (TAGBODY-OPEN (dolist (label (cddr item)) (mid-ref label)))
  9520.                 (HANDLER-OPEN (dolist (label (cddddr item)) (mid-ref label)))
  9521.               )
  9522.           ))
  9523.   (defun note-references (item &optional index)
  9524.     (macrolet ((end-ref (label) `(push index (symbol-value ,label)))
  9525.                (mid-ref (label) `(push item (symbol-value ,label))))
  9526.       (references)
  9527.   ) )
  9528.   (defun remove-references (item &optional index &aux (labellist '()))
  9529.     (macrolet ((end-ref (label)
  9530.                  (let ((labelvar (gensym)))
  9531.                    `(let ((,labelvar ,label))
  9532.                       (setf (symbol-value ,labelvar) (delete index (symbol-value ,labelvar)))
  9533.                       (pushnew ,labelvar labellist)
  9534.                     )
  9535.                ) )
  9536.                (mid-ref (label)
  9537.                  (let ((labelvar (gensym)))
  9538.                    `(let ((,labelvar ,label))
  9539.                       (setf (symbol-value ,labelvar) (delete item (symbol-value ,labelvar)))
  9540.                       (pushnew ,labelvar labellist)
  9541.                     )
  9542.               )) )
  9543.       (references)
  9544.       labellist
  9545.   ) )
  9546. )
  9547.  
  9548. #|
  9549.                               2. Schritt
  9550.                 Vereinfachung von Folgen von Operationen
  9551.  
  9552. Dieses spielt sich auf umgedrehten Codestⁿcken ab; sie werden dabei destruktiv
  9553. verΣndert.
  9554.  
  9555. Vereinfachungsregeln fⁿr Operationen:
  9556.  
  9557. 1. (VALUES1) darf nach allen Instruktionen gestrichen werden, die sowieso nur
  9558.    einen Wert produzieren, und vor allen, die sowieso nur einen verwenden.
  9559.  
  9560. 2. (SKIP n1) (SKIP n2)               --> (SKIP n1+n2)
  9561.    (SKIPI k n1) (SKIP n2)            --> (SKIPI k n1+n2)
  9562.    (SKIP n1) (SKIPI k n2)            --> (SKIPI k n2)
  9563.    (SKIPI k1 n1) (SKIPI k2 n2)       --> (SKIPI k1+k2+1 n2)
  9564.    (SKIPSP k1) (SKIPI k2 n)          --> (SKIPI k1+k2 n)
  9565.    (SKIPSP k1) (SKIPSP k2)           --> (SKIPSP k1+k2)
  9566.  
  9567. 3. (NOT) (NOT) (NOT)                 --> (NOT)
  9568.    (ATOM) (NOT)                      --> (CONSP)
  9569.    (CONSP) (NOT)                     --> (ATOM)
  9570.  
  9571. 4. (LOAD 0) (SKIP n)                 --> (POP) (SKIP n-1)  fⁿr n>1
  9572.    (LOAD 0) (SKIP 1)                 --> (POP)             fⁿr n=1
  9573.    (PUSH) (SKIP n)                   --> (SKIP n-1)  fⁿr n>1
  9574.    (PUSH) (SKIP 1)                   -->             fⁿr n=1
  9575.    (NV-TO-STACK n) (SKIP n)          -->
  9576.    (NV-TO-STACK n+m) (SKIP n)        --> (NV-TO-STACK m)
  9577.    (NV-TO-STACK n) (SKIP n+m)        --> (SKIP m)
  9578.    (STORE m) (SKIP n)                --> (VALUES1) (SKIP n) fⁿr n>m
  9579.    (STORE 0) (POP)                   --> (VALUES1) (SKIP 1)
  9580.    (PUSH) (POP)                      --> (VALUES1)
  9581.    (POP) (PUSH)                      -->
  9582.    (SKIP n) (PUSH)                   --> (SKIP n-1) (STORE 0) fⁿr n>1
  9583.    (SKIP 1) (PUSH)                   --> (STORE 0)            fⁿr n=1
  9584.  
  9585. 5. (VALUES1)/... (MV-TO-STACK)       --> (VALUES1)/... (PUSH)
  9586.    (VALUES0) (MV-TO-STACK)           -->
  9587.    (STACK-TO-MV n) (MV-TO-STACK)     -->
  9588.    (STACK-TO-MV m) (NV-TO-STACK n)   --> (PUSH-NIL n-m)  fⁿr m<n
  9589.                                      -->                 fⁿr m=n
  9590.                                      --> (SKIP m-n)      fⁿr m>n
  9591.    (NIL)/(VALUES0) (NV-TO-STACK n)   --> (PUSH-NIL n)
  9592.    (VALUES1)/... (NV-TO-STACK n)     --> (VALUES1)/... (PUSH) (PUSH-NIL n-1)
  9593.  
  9594. 6. (PUSH-UNBOUND n) (PUSH-UNBOUND m) --> (PUSH-UNBOUND n+m)
  9595.  
  9596. 7. (LIST* 1)                         --> (CONS)
  9597.  
  9598. |#
  9599.  
  9600. ; Die Hash-Tabelle one-value-ops enthΣlt diejenigen Befehle,
  9601. ; die genau einen Wert erzeugen.
  9602. (defconstant one-value-ops
  9603.   (let ((ht (make-hash-table :test #'eq)))
  9604.     (dolist (op '(NIL T CONST LOAD LOADI LOADC LOADV LOADIC STORE STOREI
  9605.                   STOREC STOREV STOREIC GETVALUE SETVALUE POP VENV
  9606.                   COPY-CLOSURE BOUNDP VALUES1 MV-TO-LIST TAGBODY-CLOSE-NIL
  9607.                   NOT EQ CAR CDR CONS ATOM CONSP SYMBOL-FUNCTION SVREF SVSET
  9608.                   LIST LIST*
  9609.             )    )
  9610.       (setf (gethash op ht) t)
  9611.     )
  9612.     ht
  9613. ) )
  9614.  
  9615. ; Der Wert zu einem Key in dieser Hash-Tabelle gibt an, wieviele Werte bei
  9616. ; der Ausfⁿhrung der entsprechenden Operation ben÷tigt werden
  9617. ; (vgl. *for-value*):
  9618. ; NIL : Werte werden weggeworfen.
  9619. ; ONE : Ein Wert wird verwendet, die ⁿbrigen weggeworfen.
  9620. ; ALL : Alle Werte werden verwendet.
  9621. ; Operationen, die ihre Werte nicht verΣndern, werden hierin nicht
  9622. ; aufgefⁿhrt.
  9623. (defconstant for-value-table
  9624.   (let ((ht (make-hash-table :test #'eq)))
  9625.     (dolist (op '(NIL PUSH-NIL T CONST LOAD LOADI LOADC LOADV LOADIC
  9626.                   GETVALUE POP JSR JMPTAIL BARRIER VENV COPY-CLOSURE CALL
  9627.                   CALL0 CALLS1 CALLS2 CALLSR FUNCALL PUSH-UNBOUND JMPIFBOUNDP
  9628.                   BOUNDP VALUES0 STACK-TO-MV MVCALL
  9629.                   BLOCK-OPEN TAGBODY-OPEN TAGBODY-CLOSE-NIL GO GO-I
  9630.                   UNWIND-PROTECT-OPEN UNWIND-PROTECT-CLOSE
  9631.                   HANDLER-OPEN HANDLER-BEGIN
  9632.                   LIST
  9633.             )    )
  9634.       (setf (gethash op ht) 'NIL)
  9635.     )
  9636.     (dolist (op '(STORE STOREI STOREC STOREV STOREIC SETVALUE BIND PROGV PUSH
  9637.                   MAKE-VECTOR1&PUSH CALL1 CALL2 CALLC CALLCKEY APPLY UNLIST
  9638.                   UNLIST* VALUES1 LIST-TO-MV MVCALLP CATCH-OPEN
  9639.                   NOT EQ CAR CDR CONS ATOM CONSP SYMBOL-FUNCTION SVREF SVSET
  9640.                   LIST*
  9641.             )    )
  9642.       (setf (gethash op ht) 'ONE)
  9643.     )
  9644.     (dolist (op '(MV-TO-STACK NV-TO-STACK MV-TO-LIST RETURN-FROM RETURN-FROM-I
  9645.                   THROW UNWIND-PROTECT-NORMAL-EXIT
  9646.             )    )
  9647.       (setf (gethash op ht) 'ALL)
  9648.     )
  9649.     ; Nicht in der Tabelle, weil sie die Werte unverΣndert lassen:
  9650.     ;           '(UNBIND1 SKIP SKIPI SKIPSP BLOCK-CLOSE TAGBODY-CLOSE
  9651.     ;             CATCH-CLOSE UNWIND-PROTECT-CLEANUP
  9652.     ;            )
  9653.     ; Nicht in der Tabelle, weil es Wegsprⁿnge sind:
  9654.     ;   ONE:    '(JMPHASH)
  9655.     ;   ALL:    '(RET JMP JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  9656.     ht
  9657. ) )
  9658.  
  9659. ; Vereinfacht ein Codestⁿck (in umgedrehter Reihenfolge!).
  9660. ; Obige Vereinfachungsregeln werden durchgefⁿhrt, solange es geht.
  9661. ; Ergebnis ist meist NIL, oder aber (um anzuzeigen, da▀ weitere Optimierungen
  9662. ; m÷glich sind) das Anfangslabel, falls sich dessen Property for-value
  9663. ; abgeschwΣcht hat.
  9664. (defun simplify (codelist)
  9665.   (let ((for-value-at-end
  9666.           (let ((item (car codelist)))
  9667.             (case (first item)
  9668.               (JMP (get (second item) 'for-value))
  9669.               ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  9670.                 (if (or (and (not (eq (first item) 'JMPCASE1-TRUE))
  9671.                              (eq (get (second item) 'for-value) 'ALL)
  9672.                         )
  9673.                         (and (not (eq (first item) 'JMPCASE1-FALSE))
  9674.                              (eq (get (third item) 'for-value) 'ALL)
  9675.                     )   )
  9676.                   'ALL
  9677.                   'ONE
  9678.               ) )
  9679.               (JMPHASH 'ONE)
  9680.               ((BARRIER GO GO-I JMPTAIL) 'NIL)
  9681.               ((RETURN-FROM RETURN-FROM-I RET THROW) 'ALL)
  9682.               (t (compiler-error 'simplify "AT-END"))
  9683.         ) ) )
  9684.         (result nil)) ; evtl. das Anfangslabel
  9685.     ; for-value-at-end zeigt an, welche Werte vor dem Wegsprung ben÷tigt werden.
  9686.     (loop
  9687.       (let ((modified nil))
  9688.         (let* ((links codelist) (mitte (cdr links)) rechts (for-value for-value-at-end))
  9689.           ; Es wandern drei Pointer durch die Codeliste: ...links.mitte.rechts...
  9690.           ; for-value zeigt an, was fⁿr Werte nach Ausfⁿhrung von (car mitte),
  9691.           ; vor Ausfⁿhrung von (car links), gebraucht werden.
  9692.           (loop
  9693.             nochmal
  9694.             (when (atom mitte) (return))
  9695.             (setq rechts (cdr mitte))
  9696.             (macrolet ((ersetze1 (new) ; ersetze (car mitte) durch new
  9697.                          `(progn
  9698.                             (setf (car mitte) ,new)
  9699.                             (setq modified t) (go nochmal)
  9700.                           )
  9701.                        )
  9702.                        (ersetze2 (new) ; ersetze (car mitte) und (car rechts) durch new
  9703.                          `(progn
  9704.                             ,@(unless (equal new '(car mitte))
  9705.                                 `((setf (car mitte) ,new))
  9706.                               )
  9707.                             (setf (cdr mitte) (cdr rechts))
  9708.                             (setq modified t) (go nochmal)
  9709.                           )
  9710.                        )
  9711.                        (streiche1 () ; streiche (car mitte) ersatzlos
  9712.                          `(progn
  9713.                             (setf (cdr links) (setq mitte rechts))
  9714.                             (setq modified t) (go nochmal)
  9715.                           )
  9716.                        )
  9717.                        (streiche2 () ; streiche (car mitte) und (car rechts) ersatzlos
  9718.                          `(progn
  9719.                             (setf (cdr links) (setq mitte (cdr rechts)))
  9720.                             (setq modified t) (go nochmal)
  9721.                           )
  9722.                        )
  9723.                        (erweitere2 (new1 new2) ; ersetze (car mitte) durch new1 und new2
  9724.                          `(progn
  9725.                             (setf (car mitte) ,new1)
  9726.                             (setf (cdr mitte) (cons ,new2 rechts))
  9727.                             (setq modified t) (go nochmal)
  9728.                           )
  9729.                       ))
  9730.               (when (eq for-value 'NIL)
  9731.                 ; vor einer Operation, die keine Werte braucht:
  9732.                 (case (first (car mitte))
  9733.                   ((NIL T CONST LOAD LOADI LOADC LOADV LOADIC GETVALUE VENV
  9734.                     BOUNDP VALUES0 VALUES1 MV-TO-LIST LIST-TO-MV NOT CAR CDR
  9735.                     SYMBOL-FUNCTION ATOM CONSP
  9736.                    )
  9737.                     (streiche1)
  9738.                   )
  9739.                   ((LIST LIST* STACK-TO-MV) ; (LIST n) --> (SKIP n), n>0
  9740.                                             ; (LIST* n) --> (SKIP n), n>0
  9741.                                             ; (STACK-TO-MV n) --> (SKIP n), n>0
  9742.                     (ersetze1 `(SKIP ,(second (car mitte))))
  9743.                   )
  9744.                   ((POP EQ CONS SVREF) (ersetze1 '(SKIP 1)))
  9745.               ) )
  9746.               (when (eq for-value 'ONE)
  9747.                 ; vor einer Operation, die nur einen Wert braucht:
  9748.                 (case (first (car mitte))
  9749.                   (VALUES1 (streiche1))
  9750.                   (VALUES0 (ersetze1 '(NIL)))
  9751.                   (LIST-TO-MV (ersetze1 '(CAR)))
  9752.                   (STACK-TO-MV ; (STACK-TO-MV n) --> (SKIP n-1) (POP) fⁿr n>1
  9753.                     (let ((n (second (car mitte))))
  9754.                       (erweitere2 '(POP) `(SKIP ,(- n 1)))
  9755.               ) ) ) )
  9756.               (when (consp rechts)
  9757.                 ; Gucklock umfa▀t (car mitte) und (car rechts), evtl. auch mehr.
  9758.                 (case (first (car mitte))
  9759.                   (VALUES1 ; Regel 1
  9760.                     (when (gethash (first (car rechts)) one-value-ops nil)
  9761.                       ; (op ...) (VALUES1) --> (op ...)
  9762.                       (streiche1)
  9763.                   ) )
  9764.                   (NOT ; Regel 3
  9765.                     (case (first (car rechts))
  9766.                       (NOT
  9767.                         (when (and (consp (cdr rechts))
  9768.                                    (equal (cadr rechts) '(NOT))
  9769.                               )
  9770.                           ; (NOT) (NOT) (NOT) --> (NOT)
  9771.                           (streiche2)
  9772.                       ) )
  9773.                       (ATOM (ersetze2 '(CONSP))) ; (ATOM) (NOT) --> (CONSP)
  9774.                       (CONSP (ersetze2 '(ATOM))) ; (CONSP) (NOT) --> (ATOM)
  9775.                   ) )
  9776.                   (SKIP
  9777.                     (let ((n2 (second (car mitte)))) ; n2 > 0
  9778.                       (case (first (car rechts))
  9779.                         ; Regel 2
  9780.                         (SKIP ; (SKIP n1) (SKIP n2) --> (SKIP n1+n2)
  9781.                           (let ((n1 (second (car rechts))))
  9782.                             (ersetze2 `(SKIP ,(+ n1 n2)))
  9783.                         ) )
  9784.                         (SKIPI ; (SKIPI k n1) (SKIP n2) --> (SKIPI k n1+n2)
  9785.                           (let ((k (second (car rechts)))
  9786.                                 (n1 (third (car rechts))))
  9787.                             (ersetze2 `(SKIPI ,k ,(+ n1 n2)))
  9788.                         ) )
  9789.                         ; Regel 4
  9790.                         (LOAD ; (LOAD 0) (SKIP n) --> (POP) [(SKIP n-1)]
  9791.                           (when (eql (second (car rechts)) 0)
  9792.                             (if (eql n2 1)
  9793.                               (ersetze2 '(POP))
  9794.                               (progn (setf (car rechts) '(POP))
  9795.                                      (ersetze1 `(SKIP ,(- n2 1)))
  9796.                         ) ) ) )
  9797.                         (PUSH ; (PUSH) (SKIP n) --> [(SKIP n-1)]
  9798.                           (if (eql n2 1)
  9799.                             (streiche2)
  9800.                             (ersetze2 `(SKIP ,(- n2 1)))
  9801.                         ) )
  9802.                         (NV-TO-STACK
  9803.                           (let ((n1 (second (car rechts))))
  9804.                             (cond ((> n1 n2) (ersetze2 `(NV-TO-STACK ,(- n1 n2))))
  9805.                                   ((< n1 n2) (ersetze2 `(SKIP ,(- n2 n1))))
  9806.                                   (t (streiche2))
  9807.                         ) ) )
  9808.                         (STORE ; (STORE m) (SKIP n) --> (VALUES1) (SKIP n) fⁿr n>m
  9809.                           (let ((m (second (car rechts))))
  9810.                             (when (> n2 m)
  9811.                               (setf (car rechts) '(VALUES1))
  9812.                               (setq modified t) (go nochmal)
  9813.                   ) ) ) ) ) )
  9814.                   (SKIPI ; Regel 2
  9815.                     (case (first (car rechts))
  9816.                       (SKIP ; (SKIP n1) (SKIPI k n2) --> (SKIPI k n2)
  9817.                         (ersetze2 (car mitte))
  9818.                       )
  9819.                       (SKIPI ; (SKIPI k1 n1) (SKIPI k2 n2) --> (SKIPI k1+k2+1 n2)
  9820.                         (let ((k1 (second (car rechts)))
  9821.                               (k2 (second (car mitte)))
  9822.                               (n2 (third (car mitte))))
  9823.                           (ersetze2 `(SKIPI ,(+ k1 k2 1) ,n2))
  9824.                       ) )
  9825.                       (SKIPSP ; (SKIPSP k1) (SKIPI k2 n) --> (SKIPI k1+k2 n)
  9826.                         (let ((k1 (second (car rechts)))
  9827.                               (k2 (second (car mitte)))
  9828.                               (n2 (third (car mitte))))
  9829.                           (ersetze2 `(SKIPI ,(+ k1 k2) ,n2))
  9830.                   ) ) ) )
  9831.                   (SKIPSP ; Regel 2
  9832.                     (case (first (car rechts))
  9833.                       (SKIPSP ; (SKIPSP k1) (SKIPSP k2) --> (SKIPSP k1+k2)
  9834.                         (let ((k1 (second (car rechts)))
  9835.                               (k2 (second (car mitte))))
  9836.                           (ersetze2 `(SKIPSP ,(+ k1 k2)))
  9837.                   ) ) ) )
  9838.                   (POP ; Regel 4
  9839.                     (cond ((equal (car rechts) '(STORE 0))
  9840.                             ; (STORE 0) (POP) --> (VALUES1) (SKIP 1)
  9841.                             (setf (car rechts) '(VALUES1))
  9842.                             (ersetze1 '(SKIP 1))
  9843.                           )
  9844.                           ((equal (car rechts) '(PUSH))
  9845.                             ; (PUSH) (POP) --> (VALUES1)
  9846.                             (ersetze2 '(VALUES1))
  9847.                   ) )     )
  9848.                   (PUSH ; Regel 4
  9849.                     (case (first (car rechts))
  9850.                       (POP (streiche2)) ; (POP) (PUSH) streichen
  9851.                       (SKIP ; (SKIP n) (PUSH) --> [(SKIP n-1)] (STORE 0)
  9852.                         (let ((n (second (car rechts))))
  9853.                           (if (eql n 1)
  9854.                             (unless (and (consp (cdr rechts)) (equal (cadr rechts) '(LOAD 0)))
  9855.                               ; (LOAD 0) (SKIP 1) (PUSH) wird anders behandelt
  9856.                               (ersetze2 '(STORE 0))
  9857.                             )
  9858.                             (progn (setf (car rechts) `(SKIP ,(- n 1)))
  9859.                                    (ersetze1 '(STORE 0))
  9860.                   ) ) ) ) ) )
  9861.                   (MV-TO-STACK ; Regel 5
  9862.                     (when (gethash (first (car rechts)) one-value-ops nil)
  9863.                       ; (car rechts) liefert nur einen Wert -->
  9864.                       ; (MV-TO-STACK) durch (PUSH) ersetzen:
  9865.                       (ersetze1 '(PUSH))
  9866.                     )
  9867.                     (case (first (car rechts))
  9868.                       ((VALUES0 STACK-TO-MV) (streiche2))
  9869.                   ) )
  9870.                   (NV-TO-STACK ; Regel 5
  9871.                     (let ((n (second (car mitte))))
  9872.                       (case (first (car rechts))
  9873.                         (STACK-TO-MV
  9874.                           (let ((m (second (car rechts))))
  9875.                             (cond ((> n m) (ersetze2 `(PUSH-NIL ,(- n m))))
  9876.                                   ((< n m) (ersetze2 `(SKIP ,(- m n))))
  9877.                                   (t (streiche2))
  9878.                         ) ) )
  9879.                         ((VALUES0 NIL) (ersetze2 `(PUSH-NIL ,n)))
  9880.                         (t (when (gethash (first (car rechts)) one-value-ops nil)
  9881.                              (erweitere2 `(PUSH) `(PUSH-NIL ,(- n 1)))
  9882.                   ) ) ) )  )
  9883.                   (PUSH-UNBOUND ; Regel 6
  9884.                     (case (first (car rechts))
  9885.                       (PUSH-UNBOUND ; (PUSH-UNBOUND n) (PUSH-UNBOUND m) --> (PUSH-UNBOUND n+m)
  9886.                         (let ((n (second (car rechts)))
  9887.                               (m (second (car mitte))))
  9888.                           (ersetze2 `(PUSH-UNBOUND ,(+ n m)))
  9889.                   ) ) ) )
  9890.                   (LIST* ; Regel 7
  9891.                     (when (equal (rest (car mitte)) '(1))
  9892.                       (ersetze1 '(CONS))
  9893.                   ) )
  9894.             ) ) )
  9895.             (when (atom mitte) (return))
  9896.             ; Neues for-value berechnen, in AbhΣngigkeit von (car mitte):
  9897.             (setq for-value
  9898.               (gethash (first (car mitte)) for-value-table for-value)
  9899.             )
  9900.             ; weiterrⁿcken:
  9901.             (setq links mitte mitte rechts)
  9902.           )
  9903.           ; Codestⁿck zu Ende: (atom mitte)
  9904.           (when mitte
  9905.             ; mitte ist das Anfangslabel
  9906.             (let ((old-for-value (get mitte 'for-value)))
  9907.               ; Ist for-value besser als old-for-value ?
  9908.               (when (and (not (eq for-value old-for-value))
  9909.                          (or (eq old-for-value 'ALL) (eq for-value 'NIL))
  9910.                     )
  9911.                 ; ja -> Anfangslabel nachher als Ergebnis bringen:
  9912.                 (setf (get mitte 'for-value) for-value result mitte)
  9913.           ) ) )
  9914.         ) ; end let*
  9915.         (unless modified (return))
  9916.     ) ) ; end let, loop
  9917.     (let (codelistr)
  9918.       (when (and (eq (first (first codelist)) 'RET)
  9919.                  (consp (setq codelistr (cdr codelist)))
  9920.                  (or (eq (first (first codelistr)) 'JSR)
  9921.                      (and (eq (first (second codelist)) 'SKIP)
  9922.                           (consp (setq codelistr (cddr codelist)))
  9923.                           (eq (first (first codelistr)) 'JSR)
  9924.             )    )   )
  9925.         ; (JSR n label) [(SKIP m)] (RET) --> (JMPTAIL n n+m label)
  9926.         (let ((n (second (first codelistr)))
  9927.               (label (third (first codelistr)))
  9928.               (m (if (eq codelistr (cdr codelist)) 0 (second (second codelist)))))
  9929.           (setf (first codelist) `(JMPTAIL ,n ,(+ n m) ,label))
  9930.         )
  9931.         (remove-references (first codelistr)) ; (JSR ...) wird gestrichen
  9932.         (note-references (first codelist)) ; (JMPTAIL ...) wird eingefⁿgt
  9933.         (setf (cdr codelist) (cdr codelistr)) ; ein bzw. zwei Listenelemente streichen
  9934.         (setq for-value-at-end 'NIL) ; JMPTAIL braucht keine Werte
  9935.     ) )
  9936.     result
  9937. ) )
  9938.  
  9939. #|
  9940.                             3. Schritt:
  9941.                       Allgemeine Optimierungen
  9942.  
  9943. Wird eine Optimierung erfolgreich durchgefⁿhrt, so werden alle weiteren
  9944. Optimierungen nochmal probiert, die sich deswegen ergeben k÷nnten.
  9945.  
  9946. optimize-part    - ruft den 2. Schritt auf:
  9947.                    Peephole-Optimierung normaler Operationen.
  9948.  
  9949. optimize-label   - Codestⁿcke zu Labels, die nicht (mehr) referenziert werden,
  9950.                    werden entfernt.
  9951.                  - Wird ein Label nur von einem einzigen JMP referenziert,
  9952.                    der nicht vom selben Codestⁿck kommt, k÷nnen die beiden
  9953.                    betroffenen Stⁿcke aneinandergehΣngt werden.
  9954.  
  9955. optimize-short   - Liegt ein Codestⁿck vor, wo auf das Anfangslabel label1
  9956.                    sofort ein (JMP label2) folgt, so werden alle Referenzen
  9957.                    von label1 durch label2 ersetzt und das Codestⁿck entfernt.
  9958.                  - Liegt ein Codestⁿck vor, wo auf das Anfangslabel label
  9959.                    sofort ein
  9960.                    (JMPCASE/JMPCASE1-TRUE/JMPCASE1-FALSE label_true label_false)
  9961.                    folgt, so k÷nnen Referenzen (JMPCASE1-TRUE label l) und
  9962.                    (JMPCASE1-FALSE l label) vereinfacht werden.
  9963.                  - Ein kurzes Codestⁿck wird direkt an zugeh÷rige JMPs auf
  9964.                    sein Anfangslabel angehΣngt. (Ein Codestⁿck hei▀t "kurz",
  9965.                    wenn es h÷chstens 2 Befehle umfa▀t und nicht mit einem
  9966.                    JMPHASH (den man nicht duplizieren sollte) abgeschlossen
  9967.                    ist. Auch HANDLER-OPEN sollte man nicht duplizieren.)
  9968.  
  9969. optimize-jmpcase - (JMPCASE label label) wird vereinfacht zu (JMP label).
  9970.                  - (NOT) [...] (JMPCASE label_true label_false) wird
  9971.                    vereinfacht zu [...] (JMPCASE label_false label_true),
  9972.                    wobei [...] nur Befehle enthalten darf, die den 1. Wert
  9973.                    nicht verΣndern, und bei label_true und label_false keine
  9974.                    Werte gebraucht werden.
  9975.  
  9976. optimize-value   - Ein Wegsprung JMPCASE1-TRUE/JMPCASE1-FALSE kann durch
  9977.                    JMPCASE ersetzt werden, wenn am Ziel-Label der Wert
  9978.                    nicht gebraucht oder nur der 1. Wert gebraucht wird.
  9979.                  - Ein Wegsprung JMPCASE/JMPCASE1-TRUE/JMPCASE1-FALSE kann
  9980.                    durch ein JMP ersetzt werden, wenn der aktuelle Wert an
  9981.                    dieser Stelle als =NIL oder als /=NIL nachgewiesen werden
  9982.                    kann.
  9983.                  - Ein JMP kann die Information, welcher Wert gerade vorliegt,
  9984.                    zu seinem Ziel-Label weitertragen.
  9985.  
  9986. coalesce         - Lege Codeteile mit gleichem Ende (mind. 3 Befehle) zusammen.
  9987.  
  9988. |#
  9989.  
  9990. (defun optimize-part (code)
  9991.   (let ((label (simplify code)))
  9992.     (when label
  9993.       ; Die Property for-value von label wurde verbessert.
  9994.       (dolist (ref (symbol-value label))
  9995.         (when (integerp ref) (optimize-value ref))
  9996. ) ) ) )
  9997.  
  9998. (defun optimize-label (label &optional (index (get label 'code-part))
  9999.                                        (code (aref *code-parts* index))
  10000.                                        (lastc (last code))
  10001.                       )
  10002.   (unless (eq label (cdr lastc)) (compiler-error 'optimize-label))
  10003.   (when label
  10004.     ; label ist ein Label, es beginnt den Code
  10005.     ; code = (aref *code-parts* index), und es ist lastc = (last code).
  10006.     (let ((refs (symbol-value label))) ; Liste der Referenzen darauf
  10007.       (cond ((null refs)
  10008.               ; nicht referenziertes Label: Codestⁿck entfernen,
  10009.               ; Referenzen aus diesem Codestⁿck heraus eliminieren.
  10010.               (let ((labellist '())) ; Liste von Labels, die Referenzen
  10011.                                      ; verloren haben
  10012.                 (loop
  10013.                   (when (atom code) (return))
  10014.                   (setq labellist
  10015.                     (nreconc labellist (remove-references (pop code) index))
  10016.                 ) )
  10017.                 (setf (aref *code-parts* index) nil) ; Codestⁿck entfernen
  10018.                 ; Bei Labels mit weniger Referenzen weiteroptimieren:
  10019.                 ; (Vorsicht: Hierdurch kann sich *code-parts* verΣndern.)
  10020.                 (dolist (olabel labellist)
  10021.                   (let* ((oindex (get olabel 'code-part))
  10022.                          (ocode (aref *code-parts* oindex)))
  10023.                     (when ocode
  10024.                       (optimize-label olabel oindex ocode)
  10025.                 ) ) )
  10026.             ) )
  10027.             ((null (cdr refs))
  10028.               ; Label mit nur einer Referenz, und zwar durch JMP ?
  10029.               (let ((ref (first refs)))
  10030.                 (when (and (integerp ref) ; Ein JMP ist ein Wegsprung
  10031.                            (eq (first (car (aref *code-parts* ref))) 'JMP)
  10032.                            (not (eql index ref)) ; aus anderem Codestⁿck
  10033.                       )
  10034.                   ; AnhΣngen:
  10035.                   ; (aref *code-parts* ref) wird in die Schublade
  10036.                   ; (aref *code-parts* index) gesteckt.
  10037.                   (setf (cdr lastc) (rest (aref *code-parts* ref)))
  10038.                   (setf (aref *code-parts* ref) nil)
  10039.                   (let ((new-startlabel (cdr (last lastc)))) ; neues Startlabel von (aref *code-parts* index)
  10040.                     (when new-startlabel
  10041.                       (setf (get new-startlabel 'code-part) index)
  10042.                   ) )
  10043.                   (setf (symbol-value label) '()) ; altes Startlabel von (aref *code-parts* index) deaktivieren
  10044.                   ; neues Codestⁿck vereinfachen:
  10045.                   (optimize-part code)
  10046. ) ) ) )     ) ) )
  10047.  
  10048. (defun optimize-short (index &optional (code (aref *code-parts* index))
  10049.                              &aux      (lastc (last code))
  10050.                                        (label (cdr lastc))
  10051.                       )
  10052.   (when label
  10053.     ; label ist ein Label, es beginnt den Code
  10054.     ; code = (aref *code-parts* index), und es ist lastc = (last code).
  10055.     (when (eq code lastc)
  10056.       ; Eine einzige Operation nach dem Label.
  10057.       (let ((item (car code)))
  10058.         (case (first item)
  10059.           (JMP ; (JMP ...) sofort nach dem Label
  10060.             (let ((to-label (second item)))
  10061.               (unless (eq label to-label)
  10062.                 (label-subst label to-label) ; Referenzen umbiegen
  10063.                 (setf (aref *code-parts* index) nil) ; Codestⁿck entfernen
  10064.                 (setf (symbol-value to-label)
  10065.                       (delete index (symbol-value to-label)) ; Referenz fΣllt weg
  10066.                 )
  10067.                 (optimize-label to-label) ; m÷gliche Optimierung
  10068.             ) )
  10069.             (return-from optimize-short)
  10070.           )
  10071.           ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10072.             (let ((true-label (second item))
  10073.                   (false-label (third item)))
  10074.               (unless (or (eq label true-label) (eq label false-label))
  10075.                 (macrolet ((err () `(compiler-error 'optimize-short)))
  10076.                   ; JMPCASE1-Referenzen auf label vereinfachen:
  10077.                   (let ((modified-indices '())) ; Indizes von modifizierten Codestⁿcken
  10078.                     (dolist (refindex (symbol-value label))
  10079.                       (when (integerp refindex)
  10080.                         (let* ((refcode (aref *code-parts* refindex))
  10081.                                (ref (car refcode)))
  10082.                           (case (first ref)
  10083.                             (JMP
  10084.                               ; (JMP label) --> (JMPCASE/... true-label false-label)
  10085.                               (setf (car refcode) item)
  10086.                               ; neue Verweise auf true-label und false-label:
  10087.                               (push refindex (symbol-value true-label))
  10088.                               (push refindex (symbol-value false-label))
  10089.                               (push refindex modified-indices)
  10090.                             )
  10091.                             ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10092.                               ; (JMPCASE/... label1 label2)
  10093.                               (let ((label1 (second ref)) ; im TRUE-Fall: wohin springen
  10094.                                     (label2 (third ref)) ; im FALSE-Fall: wohin springen
  10095.                                     (1-true (eq (first ref) 'JMPCASE1-TRUE)) ; im TRUE-Fall: mit (VALUES1) ?
  10096.                                     (1-false (eq (first ref) 'JMPCASE1-FALSE))) ; im FALSE-Fall: mit (VALUES1) ?
  10097.                                 (when (eq label label1)
  10098.                                   ; Der (JMPCASE/... label ...) wird vereinfacht zu
  10099.                                   ; (JMPCASE/... true-label ...).
  10100.                                   (setq label1 true-label)
  10101.                                   ; neuer Verweis auf true-label:
  10102.                                   (push refindex (symbol-value true-label))
  10103.                                   (push refindex modified-indices)
  10104.                                   (when (eq (first item) 'JMPCASE1-TRUE)
  10105.                                     (setq 1-true t)
  10106.                                 ) )
  10107.                                 (when (eq label label2)
  10108.                                   ; Der (JMPCASE/... ... label) wird vereinfacht zu
  10109.                                   ; (JMPCASE/... ... false-label).
  10110.                                   (setq label2 false-label)
  10111.                                   ; neuer Verweis auf false-label:
  10112.                                   (push refindex (symbol-value false-label))
  10113.                                   (push refindex modified-indices)
  10114.                                   (when (eq (first item) 'JMPCASE1-FALSE)
  10115.                                     (setq 1-false t)
  10116.                                 ) )
  10117.                                 (unless (eq (get label1 'for-value) 'ALL)
  10118.                                   (setq 1-true nil)
  10119.                                 )
  10120.                                 (unless (eq (get label2 'for-value) 'ALL)
  10121.                                   (setq 1-false nil)
  10122.                                 )
  10123.                                 (when (and 1-true 1-false)
  10124.                                   (push '(VALUES1) (cdr refcode))
  10125.                                   (setq 1-true nil 1-false nil)
  10126.                                 )
  10127.                                 (setf (car refcode)
  10128.                                   `(,(cond (1-true 'JMPCASE1-TRUE)
  10129.                                            (1-false 'JMPCASE1-FALSE)
  10130.                                            (t 'JMPCASE)
  10131.                                      )
  10132.                                     ,label1
  10133.                                     ,label2
  10134.                                    )
  10135.                             ) ) )
  10136.                             (JMPHASH (err)) ; JMPHASH hat undefinierte Werte
  10137.                         ) )
  10138.                         ; spΣter:
  10139.                         ; (setf (symbol-value label) (delete refindex (symbol-value label)))
  10140.                     ) )
  10141.                     (setf (symbol-value label)
  10142.                           (delete-if #'integerp (symbol-value label))
  10143.                     )
  10144.                     ; evtl. Optimierung wegen verringerter Referenzen m÷glich:
  10145.                     (optimize-label label)
  10146.                     ; evtl. weitere Optimierung in verΣnderten Codeteilen:
  10147.                     (dolist (refindex modified-indices)
  10148.                       (simplify (aref *code-parts* refindex))
  10149.                       (optimize-value refindex)
  10150.                       (optimize-jmpcase refindex (aref *code-parts* refindex))
  10151.                     )
  10152.           ) ) ) ) )
  10153.     ) ) )
  10154.     ; Sonstige "kurze" Codestⁿcke, maximal 2 Operationen lang:
  10155.     (when (and (or (eq code lastc) (eq (cdr code) lastc))
  10156.                (not (eq (first (car code)) 'JMPHASH))
  10157.                (or (eq code lastc) (not (eq (first (cadr code)) 'HANDLER-OPEN)))
  10158.           )
  10159.       (let ((indices '())) ; Liste der Indizes der Codestⁿcke, an die wir code anhΣngen
  10160.         (setf (cdr lastc) '()) ; code vorlΣufig ohne das Label am Schlu▀
  10161.         (dolist (refindex (symbol-value label))
  10162.           (when (and (integerp refindex) (not (eql refindex index)))
  10163.             (let ((refcode (aref *code-parts* refindex)))
  10164.               (when (eq (first (car refcode)) 'JMP)
  10165.                 ; anhΣngen:
  10166.                 (let ((new-code (mapcar #'copy-list code)))
  10167.                   (dolist (op new-code) (note-references op refindex))
  10168.                   (setf (aref *code-parts* refindex) (nconc new-code (cdr refcode)))
  10169.                 )
  10170.                 (setf (symbol-value label) (delete refindex (symbol-value label)))
  10171.                 (push refindex indices)
  10172.         ) ) ) )
  10173.         (setf (cdr lastc) label) ; wieder das Label ans Listenende setzen
  10174.         (when indices
  10175.           ; m÷gliche weitere Optimierungen:
  10176.           (dolist (refindex indices)
  10177.             (optimize-part (aref *code-parts* refindex))
  10178.           )
  10179.           (optimize-label label) ; label hat weniger Referenzen -> optimieren
  10180.     ) ) )
  10181. ) )
  10182.  
  10183. ; get-boolean-value versucht zu einem Anfangsstⁿck eines Codestⁿcks
  10184. ; (einem (nthcdr n codelist) mit n>=1) zu bestimmen, welcher boolesche Wert
  10185. ; nach seiner Ausfⁿhrung vorliegt:
  10186. ; FALSE     sicher A0 = NIL,
  10187. ; TRUE      sicher A0 /= NIL,
  10188. ; NIL       keine Aussage.
  10189. (defun get-boolean-value (code)
  10190.   (macrolet ((err () `(compiler-error 'get-boolean-value)))
  10191.     (let ((invert nil)) ; ob von hier bis zum Ende der boolesche Wert invertiert wird
  10192.       ((lambda (value)
  10193.          (if invert
  10194.            (case value (TRUE 'FALSE) (FALSE 'TRUE) (t NIL))
  10195.            value
  10196.        ) )
  10197.        (block value
  10198.          (loop ; Codeliste durchlaufen
  10199.            (when (atom code) (return))
  10200.            (case (first (car code))
  10201.              ((NIL VALUES0 TAGBODY-CLOSE-NIL) ; produzieren Wert NIL
  10202.                (return-from value 'FALSE) ; Damit k÷nnen wir die Schleife abbrechen
  10203.              )
  10204.              ((T CONST CONS LIST LIST*) ; produzieren Wert /= NIL
  10205.                ; (CONST n), weil 1. man davon ausgehen kann, da▀ der Wert
  10206.                ; schon zur Compile-Zeit bekannt ist (siehe c-constantp und
  10207.                ; c-constant-value) und 2. die Konstante NIL in
  10208.                ; make-const-code bereits speziell behandelt wurde.
  10209.                ; (LIST n) und (LIST* n) wegen n>0.
  10210.                (return-from value 'TRUE) ; Damit k÷nnen wir die Schleife abbrechen
  10211.              )
  10212.              (NOT (setq invert (not invert))) ; invertiere spΣter den booleschen Wert
  10213.              ((UNBIND1 SKIP SKIPI SKIPSP STORE STOREI STOREV STOREC STOREIC SETVALUE
  10214.                VALUES1 BLOCK-CLOSE TAGBODY-CLOSE CATCH-CLOSE UNWIND-PROTECT-CLEANUP
  10215.              )) ; keine ─nderung des 1. Werts -> weiter in der Codeliste
  10216.              (t (return-from value nil))
  10217.            )
  10218.            (setq code (cdr code))
  10219.          )
  10220.          (when code
  10221.            ; code ist das Anfangslabel.
  10222.            ; Inspiziere alle Sprⁿnge auf das Label code:
  10223.            (let ((bisher nil))
  10224.              ; bisher = FALSE, falls bisher alle Sprⁿnge den booleschen Wert
  10225.              ;                 FALSE mitbringen,
  10226.              ; bisher = TRUE, falls bisher alle Sprⁿnge den booleschen Wert
  10227.              ;                TRUE mitbringen,
  10228.              ; bisher = NIL am Anfang.
  10229.              ; Falls ein Sprung einen unbekannten booleschen Wert mitbringt,
  10230.              ; kann man die Schleife gleich verlassen.
  10231.              (flet ((neu (value)
  10232.                       (cond ((null bisher) (setq bisher value))
  10233.                             ((not (eq value bisher)) (return-from value nil))
  10234.                    )) )
  10235.                (dolist (ref (symbol-value code))
  10236.                  (if (integerp ref)
  10237.                    (let ((refcode (first (aref *code-parts* ref)))) ; der Wegsprung hierher
  10238.                      ; Ein Wegsprung mit undefinierten Werten kann das nicht sein.
  10239.                      (case (first refcode)
  10240.                        (JMP
  10241.                          (if (third refcode)
  10242.                            ; Wert vor dem Sprung bekannt
  10243.                            (neu (third refcode))
  10244.                            ; Wert vor dem Sprung unbekannt
  10245.                            (return-from value nil)
  10246.                        ) )
  10247.                        ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10248.                          (when (eq code (second refcode)) (neu 'TRUE))
  10249.                          (when (eq code (third refcode)) (neu 'FALSE))
  10250.                        )
  10251.                        (t (err)) ; JMPHASH hat undefinierte Werte, und die
  10252.                                  ; anderen Wegsprⁿnge enthalten keine Labels.
  10253.                    ) )
  10254.                    (case (first ref)
  10255.                      ((JMPIFBOUNDP BLOCK-OPEN CATCH-OPEN)
  10256.                        (return-from value nil) ; Da k÷nnen wir nichts aussagen
  10257.                      )
  10258.                      (t (err)) ; An den Labels in TAGBODY-OPEN, JSR,
  10259.                                ; UNWIND-PROTECT-OPEN, UNWIND-PROTECT-CLOSE
  10260.                                ; liegen undefinierte Werte vor.
  10261.          ) ) ) ) ) )
  10262.          nil ; Default: nichts aussagbar
  10263.       ))
  10264. ) ) )
  10265.  
  10266. (defun optimize-jmpcase (index code)
  10267.   (when (eq (first (car code)) 'JMPCASE)
  10268.     ; Code endet mit (JMPCASE ...)
  10269.     (let ((true-label (second (car code)))
  10270.           (false-label (third (car code))))
  10271.       (if (eq true-label false-label)
  10272.         ; (JMPCASE label label) --> (JMP label ..)
  10273.         (progn
  10274.           (setf (car code) `(JMP ,true-label ,(get-boolean-value (cdr code))))
  10275.           ; doppelte Referenz wird zu einer einfachen:
  10276.           (setf (symbol-value true-label)
  10277.                 (delete index (symbol-value true-label) :count 1)
  10278.           )
  10279.           ; und weiter optimieren:
  10280.           (optimize-part code)
  10281.           (optimize-short (get true-label 'code-part))
  10282.         )
  10283.         (when (and (null (get true-label 'for-value))
  10284.                    (null (get false-label 'for-value))
  10285.               )
  10286.           ; Versuche NOTs zu eliminieren:
  10287.           (let ((invert 0)
  10288.                 (cr1 code)
  10289.                 (cr2 (cdr code))) ; stets cr2 = (cdr cr1)
  10290.             (loop
  10291.               (when (atom cr2) (return))
  10292.               (case (first (car cr2))
  10293.                 ((UNBIND1 SKIP SKIPI SKIPSP VALUES1 BLOCK-CLOSE TAGBODY-CLOSE
  10294.                   CATCH-CLOSE UNWIND-PROTECT-CLEANUP
  10295.                  ) ; diese Operationen brauchen keine Werte und lassen
  10296.                    ; den 1. Wert unverΣndert
  10297.                  (shiftf cr1 cr2 (cdr cr2))
  10298.                 )
  10299.                 (NOT
  10300.                   (setf (cdr cr1) (setq cr2 (cdr cr2))) ; (NOT) streichen
  10301.                   (incf invert)
  10302.                 )
  10303.                 (t (return))
  10304.             ) )
  10305.             ; invert = Anzahl, wie oft (NOT) gestrichen wurde
  10306.             (when (oddp invert)
  10307.               ; true-label und false-label vertauschen:
  10308.               (setf (car code) `(JMPCASE ,false-label ,true-label))
  10309.             )
  10310.             (when (plusp invert)
  10311.               ; und weiter optimieren:
  10312.               (optimize-part code)
  10313.               (optimize-short index)
  10314.         ) ) )
  10315. ) ) ) )
  10316.  
  10317. (defun optimize-value (index &optional (code (aref *code-parts* index)))
  10318.   (let ((item (car code)))
  10319.     (case (first item)
  10320.       ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10321.         ; (JMPCASE/... true-label false-label)
  10322.         (let ((true-label (second item))
  10323.               (false-label (third item)))
  10324.           (when (or (and (eq (first item) 'JMPCASE1-TRUE)
  10325.                          (not (eq (get true-label 'for-value) 'ALL))
  10326.                          ; Wertezahl 1 wird bei true-label nicht gebraucht
  10327.                          ; (JMPCASE1-TRUE ...) --> (JMPCASE ...)
  10328.                     )
  10329.                     (and (eq (first item) 'JMPCASE1-FALSE)
  10330.                          (not (eq (get false-label 'for-value) 'ALL))
  10331.                          ; Wertezahl 1 wird bei false-label nicht gebraucht
  10332.                          ; (JMPCASE1-FALSE ...) --> (JMPCASE ...)
  10333.                 )   )
  10334.             (setq item (setf (car code) `(JMPCASE ,@(rest item))))
  10335.             ; Weitere m÷gliche Optimierungen:
  10336.             (optimize-jmpcase index code)
  10337.           )
  10338.           ; Versuche, den booleschen Wert an dieser Stelle zu ermitteln
  10339.           ; und vereinfache gegebenenfalls:
  10340.           (case (get-boolean-value (cdr code))
  10341.             (TRUE ; Sprung geht immer auf true-label
  10342.               ; Referenz auf false-label streichen:
  10343.               (setf (symbol-value false-label)
  10344.                 (delete index (symbol-value false-label))
  10345.               )
  10346.               (setf (car code) `(JMP ,true-label TRUE))
  10347.               (when (eq (first item) 'JMPCASE1-TRUE)
  10348.                 (push '(VALUES1) (cdr code))
  10349.                 (simplify code)
  10350.               )
  10351.               (optimize-part code) ; weitere m÷gliche Optimierung
  10352.               ; weitere m÷gliche Optimierungen:
  10353.               (optimize-label false-label) ; wegen verringerter Referenzen
  10354.               (optimize-short index) ; wegen obigem optimize-part
  10355.             )
  10356.             (FALSE
  10357.               ; Referenz auf true-label streichen
  10358.               (setf (symbol-value true-label)
  10359.                 (delete index (symbol-value true-label))
  10360.               )
  10361.               (setf (car code) `(JMP ,false-label FALSE))
  10362.               (when (eq (first item) 'JMPCASE1-FALSE)
  10363.                 (push '(VALUES1) (cdr code))
  10364.                 (simplify code)
  10365.               )
  10366.               (optimize-part code) ; weitere m÷gliche Optimierung
  10367.               ; weitere m÷gliche Optimierungen:
  10368.               (optimize-label true-label) ; wegen verringerter Referenzen
  10369.               (optimize-short index) ; wegen obigem optimize-part
  10370.       ) ) ) )
  10371.       (JMP
  10372.         (let ((label (second item)))
  10373.           (when (get label 'for-value)
  10374.             ; Wert wird ben÷tigt
  10375.             (when (null (third item))
  10376.               ; aber er ist unbekannt.
  10377.               ; Vielleicht lΣ▀t sich der Wert herausbekommen ?
  10378.               (let ((value (get-boolean-value (cdr code))))
  10379.                 (when value
  10380.                   (setf (car code) `(JMP ,label ,value))
  10381.                   ; Wert jetzt bekannt, lΣ▀t sich vielleicht verwenden:
  10382.                   (optimize-value (get label 'code-part))
  10383. ) ) ) ) ) ) ) ) )
  10384.  
  10385. ; coalesce legt gleiche Codeteile in den gegebenen Codestⁿcken soweit wie
  10386. ; m÷glich zusammen und liefert als Ergebnis ein Flag, ob etwas geΣndert wurde.
  10387. (defun coalesce (&optional (indexlist
  10388.                              ; Liste aller m÷glichen Indizes
  10389.                              (let ((L '()))
  10390.                                (dotimes (i (fill-pointer *code-parts*)) (push i L))
  10391.                                (nreverse L)
  10392.                 )          ) )
  10393.   (let ((parts-ht ; Eine Hashtabelle, die eine Abbildung realisiert:
  10394.                   ; Codeende --> Liste aller Indizes von Codestⁿcken,
  10395.                   ;              die damit enden
  10396.           (let ((ht (make-hash-table :test #'equal :size (length indexlist))))
  10397.             (dolist (index indexlist)
  10398.               (let ((code (aref *code-parts* index))) ; ein Codestⁿck
  10399.                 ; Wegen der Vereinfachungsregel fⁿr "kurze" Codestⁿcke werden
  10400.                 ; nur Teile zusammengelegt, die in mindestens den letzten 3
  10401.                 ; Operationen ⁿbereinstimmen.
  10402.                 (when (and (consp code) (consp (cdr code)) (consp (cddr code)))
  10403.                   (push index
  10404.                     (gethash (list* (first code) (second code) (third code))
  10405.                              ht '()
  10406.                   ) )
  10407.             ) ) )
  10408.             ht
  10409.         ) )
  10410.         (modified nil))
  10411.     ; Dann ⁿber die m÷glichen Codeenden iterieren:
  10412.     (maphash
  10413.       #'(lambda (code-beginning indices)
  10414.           (declare (ignore code-beginning))
  10415.           (when (cdr indices) ; mindestens zwei Indizes mit diesem Codeende?
  10416.             ; Versuche, m÷glichst langes Codestⁿck zusammenzulegen:
  10417.             (let ((codes ; Liste der zusammenzulegenden Codestⁿcke
  10418.                     (mapcar #'(lambda (i) (aref *code-parts* i)) indices)
  10419.                   )
  10420.                   (new-code '()) ; hier wird der gemeinsame Code gesammelt
  10421.                   (new-index (fill-pointer *code-parts*)) ; Index dafⁿr
  10422.                   (new-order ; das gemeinsame Stⁿck wird beim letzten Teil einzusortiert
  10423.                     (reduce #'max (mapcar #'(lambda (i) (aref *code-positions* i)) indices))
  10424.                  ))
  10425.               (loop
  10426.                 ; stimmen noch alle ⁿberein?
  10427.                 (unless (every #'consp codes) (return))
  10428.                 (let* ((code1 (first codes)) ; ein beliebiges der Codestⁿcke
  10429.                        (code11 (car code1))) ; dessen letzte Operation
  10430.                   (unless (every #'(lambda (code) (equal (car code) code11))
  10431.                                  (rest codes)
  10432.                           )
  10433.                     (return)
  10434.                   )
  10435.                   ; ja. Alle Codestⁿcke aus codes um eine Operation verkⁿrzen:
  10436.                   (mapc #'(lambda (code index) ; Referenzen l÷schen
  10437.                             (remove-references (car code) index)
  10438.                           )
  10439.                         codes indices
  10440.                   )
  10441.                   ; verkⁿrzen: (setq codes (mapcar #'cdr codes)), oder:
  10442.                   (mapl #'(lambda (codesr)
  10443.                             (setf (car codesr) (cdr (car codesr)))
  10444.                           )
  10445.                         codes
  10446.                   )
  10447.                   (push code11 new-code) ; new-code verlΣngern
  10448.                   (note-references code11 new-index)
  10449.               ) )
  10450.               (let* ((new-label (make-label 'ALL))
  10451.                      ; Alle Codestⁿcke aus codes wurden verkⁿrzt, sie werden
  10452.                      ; jetzt verlΣngert um ein (JMP new-label NIL).
  10453.                      (jmpop `(JMP ,new-label NIL)))
  10454.                 (mapc #'(lambda (code index)
  10455.                           (setf (aref *code-parts* index) (cons jmpop code))
  10456.                         )
  10457.                       codes indices
  10458.                 )
  10459.                 (setf (symbol-value new-label) indices) ; Referenzen auf new-label
  10460.                 (setf (get new-label 'code-part) new-index)
  10461.                 (vector-push-extend (nreconc new-code new-label) *code-parts*)
  10462.                 (vector-push-extend new-order *code-positions*)
  10463.               )
  10464.               ; weitere m÷gliche Optimierungen:
  10465.               (optimize-part (aref *code-parts* new-index))
  10466.               (coalesce indices)
  10467.               (setq modified t) ; VerΣnderung hat stattgefunden
  10468.         ) ) )
  10469.       parts-ht
  10470.     )
  10471.     modified
  10472. ) )
  10473.  
  10474. ; Die Hauptfunktion des 3. Schritts:
  10475. ; Fⁿhrt alle Optimierungen durch, und fa▀t dann alle Codestⁿcke wieder zu
  10476. ; einer einzigen Codeliste zusammen und liefert diese.
  10477. (defun optimize-all ()
  10478.   ; Optimierungen:
  10479.   (loop
  10480.     ; Optimierungen aufrufen:
  10481.     ; Wird eine fⁿndig, so ruft sie auch gleich die Optimierungs-
  10482.     ; schritte auf, die sich dadurch ergeben k÷nnten. Daher brauchen
  10483.     ; sie hier nur einmal aufgefⁿhrt zu werden.
  10484.     ; Vorsicht hier: durch die Optimierungen k÷nnen *code-parts* und sein
  10485.     ; Inhalt sich v÷llig verΣndern.
  10486.     (do ((index 0 (1+ index)))
  10487.         ((eql index (fill-pointer *code-parts*)))
  10488.       (let ((code (aref *code-parts* index)))
  10489.         (when code
  10490.           (let* ((lastc (last code))
  10491.                  (label (cdr lastc)))
  10492.             (when label
  10493.               (unless (eql index (get label 'code-part))
  10494.                 (compiler-error 'optimize-all 'code-part)
  10495.             ) )
  10496.             (optimize-label label index code lastc)
  10497.       ) ) )
  10498.       (let ((code (aref *code-parts* index)))
  10499.         (when code
  10500.           (optimize-jmpcase index code)
  10501.       ) )
  10502.       (let ((code (aref *code-parts* index)))
  10503.         (when code
  10504.           (optimize-value index code)
  10505.       ) )
  10506.       (let ((code (aref *code-parts* index)))
  10507.         (when code
  10508.           (optimize-short index code)
  10509.     ) ) )
  10510.     (unless (coalesce) (return)) ; (coalesce) tat nichts -> fertig
  10511.   )
  10512.   ; Zu einer einzigen Codeliste zusammenfassen:
  10513.   ; (Dabei werden die Labels nun Listenelemente im Code statt nur NTHCDRs.)
  10514.   (let ((start-index 0)) ; Start-"Label" NIL beginnt Codestⁿck Nr. 0
  10515.     ; Erst jeweils ein Codestⁿck, das mit label anfΣngt, wenn m÷glich an ein
  10516.     ; Codestⁿck anhΣngen, das mit einem JMP oder JMPCASE/... zu label endet.
  10517.     (do ((index (fill-pointer *code-parts*)))
  10518.         ((eql (decf index) 0)) ; index durchlΣuft die Indizes von *code-parts*
  10519.                                ; von oben nach unten, ausgenommen start-index=0.
  10520.       (let ((code (aref *code-parts* index)))
  10521.         (when code
  10522.           (loop
  10523.             ; Betrachte das Label am Ende von code, im Codestⁿck Nr. index:
  10524.             (let* ((lastc (last code)) ; letztes Cons von code
  10525.                    (label (cdr lastc)) ; Label am Ende von code
  10526.                    (refs (symbol-value label)) ; Referenzen darauf
  10527.                    (pos (aref *code-positions* index)) ; Position von code
  10528.                    (jmp-ref nil) ; bisher beste gefundene JMP-Referenz auf label
  10529.                    (jmpcase-ref nil) ; bisher beste gefundene JMPCASE-Referenz auf label
  10530.                    (jmpcase1-ref nil)) ; bisher beste gefundene JMPCASE1-...-Referenz auf label
  10531.               (if (null label)
  10532.                 ; Das Start-Code-Stⁿck wurde umgehΣngt!
  10533.                 (progn
  10534.                   (setq start-index index)
  10535.                   (return) ; zum nΣchsten Index
  10536.                 )
  10537.                 (flet ((better (new-ref old-ref)
  10538.                          ; Eine Referenz new-ref ist "besser" als eine andere
  10539.                          ; old-ref, wenn sie nΣher dran ist. Dabei haben
  10540.                          ; VorwΣrtsreferenzen generell PrioritΣt gegenⁿber
  10541.                          ; RⁿckwΣrtsreferenzen.
  10542.                          (or (null old-ref) ; noch gar kein old-ref?
  10543.                              (let ((old-pos (aref *code-positions* old-ref))
  10544.                                    (new-pos (aref *code-positions* new-ref)))
  10545.                                (if (> old-pos pos) ; Habe bisher nur RⁿckwΣrtssprung?
  10546.                                  ; ja: new-pos ist besser, falls es
  10547.                                  ; < pos (VorwΣrtssprung) oder
  10548.                                  ; >=pos, <=old-pos (kⁿrzerer RⁿckwΣrtssprung) ist.
  10549.                                  (<= new-pos old-pos)
  10550.                                  ; nein: new-pos ist besser, falls es
  10551.                                  ; <=pos, >=old-pos (kⁿrzerer VorwΣrtssprung) ist.
  10552.                                  (<= old-pos new-pos pos)
  10553.                       )) )   ) )
  10554.                   (macrolet ((update (old-ref new-ref) ; zur Bestimmung des bisher Besten
  10555.                                `(when (better ,new-ref ,old-ref)
  10556.                                   (setq ,old-ref ,new-ref)
  10557.                                 )
  10558.                             ))
  10559.                     ; Bestimme die beste Referenz, an die das Codestⁿck
  10560.                     ; gehΣngt werden kann:
  10561.                     (dolist (refindex refs)
  10562.                       (when (and (integerp refindex)
  10563.                                  (not (eql refindex index)) ; nicht an sich selber hΣngen!
  10564.                             )
  10565.                         (let ((refcode1 (car (aref *code-parts* refindex))))
  10566.                           (case (first refcode1)
  10567.                             (JMP ; m÷gliches AnhΣngen an (JMP label ...)
  10568.                               (update jmp-ref refindex)
  10569.                             )
  10570.                             (JMPCASE ; m÷gliches AnhΣngen an (JMPCASE ... label ...)
  10571.                               (update jmpcase-ref refindex)
  10572.                             )
  10573.                             (JMPCASE1-TRUE ; m÷gliches AnhΣngen an (JMPCASE1-TRUE ... label)
  10574.                               (when (eq label (third refcode1))
  10575.                                 (update jmpcase1-ref refindex)
  10576.                             ) )
  10577.                             (JMPCASE1-FALSE ; m÷gliches AnhΣngen an (JMPCASE1-FALSE label ...)
  10578.                               (when (eq label (second refcode1))
  10579.                                 (update jmpcase1-ref refindex)
  10580.                             ) )
  10581.                     ) ) ) )
  10582.                     (cond (jmp-ref ; an (JMP label) anhΣngen
  10583.                             (setf (cdr lastc)
  10584.                                   (cons label (cdr (aref *code-parts* jmp-ref)))
  10585.                             )
  10586.                             (setf (aref *code-parts* jmp-ref) nil)
  10587.                             (setq code lastc)
  10588.                           )
  10589.                           (jmpcase1-ref
  10590.                             (let* ((refcode (aref *code-parts* jmpcase1-ref))
  10591.                                    (refcode1 (car refcode))
  10592.                                    (jmpop
  10593.                                      (if (eq label (second refcode1))
  10594.                                        `(JMPIFNOT1 ,(third refcode1))
  10595.                                        `(JMPIF1 ,(second refcode1))
  10596.                                   )) )
  10597.                               (setf (cdr lastc) (list* label jmpop (cdr refcode)))
  10598.                               (setf (aref *code-parts* jmpcase1-ref) nil)
  10599.                               (setq code lastc)
  10600.                           ) )
  10601.                           (jmpcase-ref
  10602.                             (let* ((refcode (aref *code-parts* jmpcase-ref))
  10603.                                    (refcode1 (car refcode))
  10604.                                    (for-value (or (get (second refcode1) 'for-value)
  10605.                                                   (get (third refcode1) 'for-value)
  10606.                                    )          )
  10607.                                    (jmpop
  10608.                                      (if (eq label (second refcode1))
  10609.                                        `(JMPIFNOT ,(third refcode1) ,for-value)
  10610.                                        `(JMPIF ,(second refcode1) ,for-value)
  10611.                                   )) )
  10612.                               (setf (cdr lastc) (list* label jmpop (cdr refcode)))
  10613.                               (setf (aref *code-parts* jmpcase-ref) nil)
  10614.                               (setq code lastc)
  10615.                           ) )
  10616.                           (t ; kein AnhΣngen m÷glich
  10617.                             (return) ; zum nΣchsten Index
  10618.           ) ) ) ) ) )     )
  10619.     ) ) )
  10620.     ; Sicherstellen, da▀ das Anfangs-Stⁿck auch an den Anfang kommt:
  10621.     ; (Das wⁿrde auch gehen, indem bei jeder der obigen AnhΣngungen
  10622.     ; ein (setf (aref *code-positions* index) (aref *code-positions* jmp..-ref))
  10623.     ; gemacht wⁿrde. Wieso tun wir das nicht??)
  10624.     (setf (aref *code-positions* start-index) 0)
  10625.     ; Codeliste zusammensetzen:
  10626.     (let ((code-parts (map 'list #'cons *code-parts* *code-positions*)))
  10627.       (setq code-parts (delete-if-not #'car code-parts)) ; code=nil bedeutet: gestrichen
  10628.       (setq code-parts (sort code-parts #'> :key #'cdr)) ; nach Reihenfolge sortieren
  10629.       ; Die Teile sind jetzt in der richtigen Ordnung, nur umgekehrt.
  10630.       (let ((codelist '()))
  10631.         (dolist (code-part code-parts)
  10632.           (let ((code (car code-part)))
  10633.             ; code an codelist anhΣngen, dabei aber den Wegsprung umwandeln:
  10634.             (let ((item (car code)))
  10635.               (case (first item)
  10636.                 (JMP (setf (car code) `(JMP ,(second item))))
  10637.                 (JMPCASE ; (JMPCASE true-label false-label)
  10638.                          ; --> (JMPIFNOT false-label fv) (JMP true-label)
  10639.                   (setq code
  10640.                     (list* `(JMP ,(second item))
  10641.                            `(JMPIFNOT ,(third item)
  10642.                                       ,(or (get (second item) 'for-value)
  10643.                                            (get (third item) 'for-value)
  10644.                                        )
  10645.                             )
  10646.                            (cdr code)
  10647.                 ) ) )
  10648.                 (JMPCASE1-TRUE ; (JMPCASE1-TRUE true-label false-label)
  10649.                                ; --> (JMPIF1 true-label) (JMP false-label)
  10650.                   (setq code
  10651.                     (list* `(JMP ,(third item))
  10652.                            `(JMPIF1 ,(second item))
  10653.                            (cdr code)
  10654.                 ) ) )
  10655.                 (JMPCASE1-FALSE ; (JMPCASE1-FALSE true-label false-label)
  10656.                                 ; --> (JMPIFNOT1 false-label) (JMP true-label)
  10657.                   (setq code
  10658.                     (list* `(JMP ,(second item))
  10659.                            `(JMPIFNOT1 ,(third item))
  10660.                            (cdr code)
  10661.             ) ) ) ) )
  10662.             ; Label zum Listenelement machen:
  10663.             (let ((lastc (last code)))
  10664.               (when (cdr lastc)
  10665.                 (setf (cdr lastc) (list (cdr lastc)))
  10666.             ) )
  10667.             ; Umdrehen und vor codelist hΣngen (deswegen wurde vorhin
  10668.             ; mit #'> statt #'< sortiert):
  10669.             (setq codelist (nreconc code codelist))
  10670.         ) )
  10671.         codelist
  10672. ) ) ) )
  10673.  
  10674. #| Debug-Hilfe:
  10675. (defun optimize-check ()
  10676.   (do ((index 0 (1+ index)))
  10677.       ((eql index (fill-pointer *code-parts*)))
  10678.     (let ((code (aref *code-parts* index)))
  10679.       (when code
  10680.         (let* ((lastc (last code))
  10681.                (label (cdr lastc)))
  10682.           (when label
  10683.             (unless (eql index (get label 'code-part))
  10684.               (compiler-error 'optimize-check 'code-part)
  10685. ) ) ) ) ) ) )
  10686. (trace
  10687.   (optimize-part    :pre (optimize-check) :post (optimize-check) :suppress-if t)
  10688.   (optimize-label   :pre (optimize-check) :post (optimize-check) :suppress-if t)
  10689.   (optimize-short   :pre (optimize-check) :post (optimize-check) :suppress-if t)
  10690.   (optimize-jmpcase :pre (optimize-check) :post (optimize-check) :suppress-if t)
  10691.   (optimize-value   :pre (optimize-check) :post (optimize-check) :suppress-if t)
  10692.   (coalesce         :pre (optimize-check) :post (optimize-check) :suppress-if t)
  10693.   (optimize-all     :pre (optimize-check) :post (optimize-check) :suppress-if t)
  10694. )
  10695. |#
  10696.  
  10697. #| Was ist mit den folgenden m÷glichen Optimierungen??
  10698.  
  10699. 10. Kommt vor einem (JMP label) ein (UNWIND-PROTECT-CLEANUP) und vor dem
  10700.    label ein (UNWIND-PROTECT-3 cleanup-label), so mu▀ es sich um denselben
  10701.    UNWIND-PROTECT-Frame handeln, und man kann (UNWIND-PROTECT-CLEANUP)
  10702.    streichen und (JMP label) durch (JMP newlabel) ersetzen, wobei newlabel
  10703.    ein neues Label ist, das vor dem (evtl. zu ergΣnzenden) (UNWIND-PROTECT-2)
  10704.    vor cleanup-label sitzt:
  10705.    (UNWIND-PROTECT-CLEANUP) (JMP label) ...
  10706.    ... [(UNWIND-PROTECT-2)] cleanup-label ... (UNWIND-PROTECT-3 cleanup-label) label
  10707.    -->
  10708.    (JMP newlabel) ...
  10709.    ... newlabel (UNWIND-PROTECT-2) cleanup-label ... (UNWIND-PROTECT-3 cleanup-label) label
  10710.  
  10711. 11. Kommt nach einem Label label ein (NIL), so darf jeder (JMPIFNOT label)
  10712.    und jeder (JMPIFNOT1 label) durch ein (JMPIFNOT1 z) ersetzt werden,
  10713.    wo z ein neues Label nach dem (NIL) ist:
  10714.           (JMPIFNOT label) ... label (NIL) ...
  10715.    -->       (JMPIFNOT1 z) ... label (NIL) z ...
  10716.  
  10717. |#
  10718.  
  10719. ; Fⁿhrt den 1. und 2.,3. Schritt aus:
  10720. (defun compile-to-LAP ()
  10721.   (let ((*code-parts* (make-array 10 :adjustable t :fill-pointer 0))
  10722.         (*code-positions* (make-array 10 :adjustable t :fill-pointer 0)))
  10723.     ; Expandiert den Code des Fnode *func* und teilt ihn in Stⁿcke auf.
  10724.     ; HinterlΣ▀t seine Werte in *code-parts* und *code-positions*.
  10725.     (let ((*code-part* (list '(START))) ; NIL als Start-"Label"
  10726.           (*code-index* 0)
  10727.           (*dead-code* nil)
  10728.           (*label-subst* '())
  10729.           (*current-value* nil)
  10730.           (*current-vars* '()))
  10731.       (traverse-anode (anode-code (fnode-code *func*)))
  10732.     )
  10733.     ; Optimiert in *code-parts* und *code-positions*, fa▀t dann den Code
  10734.     ; in einer Liste zusammen und liefert diese:
  10735.     (let ((code-list (optimize-all)))
  10736.       (unless (equal (pop code-list) '(START))
  10737.         (compiler-error 'compile-to-LAP 'start)
  10738.       )
  10739.       code-list
  10740. ) ) )
  10741.  
  10742.  
  10743. #|
  10744.                             4. Schritt:
  10745.                       Eliminieren von (CONST n)
  10746.  
  10747. Generische Funktionen haben eine feste LΣnge. Die Konstanten werden im
  10748. VENV-Const aufbewahrt. In diesem Schritt werden umgewandelt:
  10749.   (LOADV k m)    -->  (LOADV k+1 m)
  10750.   (STOREV k m)   -->  (STOREV k+1 m)
  10751.   (CONST n)      -->  (LOADV 0 n)
  10752.   (VENV)         -->  (LOADV 0 0)
  10753.   (JMPHASH n ht label . labels)  -->  (JMPHASHV n ht label . labels)
  10754.   (GETVALUE n)         -->  illegal
  10755.   (SETVALUE n)         -->  illegal
  10756.   (BIND n)             -->  illegal
  10757.   (COPY-CLOSURE m n)   -->  illegal
  10758.   (CALL k n)           -->  illegal
  10759.   (CALL0 n)            -->  illegal
  10760.   (CALL1 n)            -->  illegal
  10761.   (CALL2 n)            -->  illegal
  10762.   (BLOCK-OPEN n label) -->  illegal
  10763.   (RETURN-FROM n)      -->  illegal
  10764.   (TAGBODY-OPEN n ...) -->  illegal
  10765.   (GO n l)             -->  illegal
  10766. |#
  10767.  
  10768. (defun CONST-to-LOADV (code-list)
  10769.   (do ((codelistr code-list (cdr codelistr)))
  10770.       ((null codelistr))
  10771.     (let ((item (car codelistr)))
  10772.       (when (consp item)
  10773.         (case (first item)
  10774.           ((LOADV STOREV)
  10775.             (setf (car codelistr)
  10776.                   `(,(first item) ,(1+ (second item)) ,@(cddr item))
  10777.           ) )
  10778.           (CONST
  10779.             (setf (car codelistr) `(LOADV 0 ,@(cdr item)))
  10780.           )
  10781.           (VENV
  10782.             (setf (car codelistr) `(LOADV 0 0))
  10783.           )
  10784.           (JMPHASH
  10785.             (setf (car codelistr) `(JMPHASHV ,@(cdr item)))
  10786.           )
  10787.           ((GETVALUE SETVALUE BIND COPY-CLOSURE CALL CALL0 CALL1 CALL2
  10788.             BLOCK-OPEN RETURN-FROM TAGBODY-OPEN GO)
  10789.             (compiler-error 'CONST-to-LOADV "Illegal-in-GF")
  10790.           )
  10791.   ) ) ) )
  10792.   code-list
  10793. )
  10794.  
  10795.  
  10796. #|
  10797.                             5. Schritt:
  10798.                    Bestimmung des Stackbedarfs
  10799.  
  10800. Dieser Schritt bestimmt, wieviel SP-EintrΣge die Funktion maximal braucht.
  10801. |#
  10802.  
  10803. #+CLISP3
  10804. (defun SP-depth (code-list)
  10805.   (let ((max-depth 0) ; bisherige Maximal-Tiefe
  10806.         (unseen-label-alist '()) ; Labels, ab denen noch verfolgt werden mu▀
  10807.         (seen-label-alist '()) ; Labels, die schon verfolgt wurden
  10808.           ; jeweils Aliste ((label . depth) ...)
  10809.           ; Es ist durchaus m÷glich, da▀ dasselbe Codestⁿck mit unterschied-
  10810.           ; lichen SP-Tiefen durchgefⁿhrt werden kann (nΣmlich dann, wenn es
  10811.           ; mit einem Wegsprung THROW, RETURN-FROM, RETURN-FROM-I, GO, GO-I
  10812.           ; oder BARRIER endet)!
  10813.           ; seen-label-alist enthΣlt zu jedem Label die maximale Tiefe, mit
  10814.           ; der ab diesem Label schon verfolgt wurde.
  10815.           ; unsee-label-alist enthΣlt zu jedem Label die maximale bisher
  10816.           ; notierte Tiefe, mit der ab diesem Label noch verfolgt werden mu▀.
  10817.         (mitte code-list) ; restliche Codeliste
  10818.         (depth 0) ; aktuelle Tiefe
  10819.        )
  10820.     (macrolet ((check-depth (wanted-depth)
  10821.                  ; ⁿberprⁿft, ob depth gleich der Tiefe wanted-depth ist
  10822.                  `(unless (eql depth ,wanted-depth)
  10823.                     (compiler-error 'SP-depth)
  10824.                   )
  10825.               ))
  10826.       (loop
  10827.         ; mitte lΣuft durch die Codeliste, von der aktuellen Position
  10828.         ; bis zum nΣchsten Wegsprung, und zΣhlt die Tiefe mit.
  10829.         (loop
  10830.           (when (null mitte) (return))
  10831.           (let ((item (car mitte)))
  10832.             (if (atom item)
  10833.               ; Label
  10834.               (let ((h (assoc item seen-label-alist)))
  10835.                 (if h
  10836.                   (if (<= depth (cdr h)) (return) (setf (cdr h) depth))
  10837.                   (push (cons item depth) seen-label-alist)
  10838.               ) )
  10839.               ; Instruktion
  10840.               (macrolet ((note-label (labelform)
  10841.                            ; notiere, da▀ zu label gesprungen werden kann
  10842.                            (let ((label (gensym)))
  10843.                              `(let* ((,label ,labelform)
  10844.                                      (h (assoc ,label seen-label-alist)))
  10845.                                 (unless (and h (<= depth (cdr h)))
  10846.                                   (setq h (assoc ,label unseen-label-alist))
  10847.                                   (if h
  10848.                                     (unless (<= depth (cdr h)) (setf (cdr h) depth))
  10849.                                     (push (cons ,label depth) unseen-label-alist)
  10850.                               ) ) )
  10851.                          ) )
  10852.                          (note-inc (amount)
  10853.                            ; notiere, da▀ depth um amount erh÷ht wird
  10854.                            `(progn
  10855.                               (incf depth ,amount)
  10856.                               (when (> depth max-depth) (setq max-depth depth))
  10857.                             )
  10858.                          )
  10859.                          (note-dec (amount)
  10860.                            ; notiere, da▀ depth um amount erniedrigt wird
  10861.                            `(progn
  10862.                               (decf depth ,amount)
  10863.                               (when (minusp depth) (compiler-error 'SP-depth "<0"))
  10864.                             )
  10865.                          )
  10866.                          (note-jmp ()
  10867.                            ; notiere, da▀ weggesprungen wird
  10868.                            `(return)
  10869.                         ))
  10870.                 (case (first item)
  10871.                   (JMP ; (JMP label)
  10872.                     (note-label (second item))
  10873.                     (note-jmp)
  10874.                   )
  10875.                   ((JMPIF JMPIF1 JMPIFNOT JMPIFNOT1 JMPIFBOUNDP) ; (JMP... label)
  10876.                     (note-label (second item))
  10877.                   )
  10878.                   ((JMPHASH JMPHASHV JMPTAIL) ; (JMPHASH.. n ht label . labels), (JMPTAIL m n label)
  10879.                     (dolist (label (cdddr item)) (note-label label))
  10880.                     (note-jmp)
  10881.                   )
  10882.                   (JSR ; (JSR n label)
  10883.                     (let ((depth 0)) (note-label (third item)))
  10884.                   )
  10885.                   ((BARRIER THROW RETURN-FROM RETURN-FROM-I GO GO-I) ; (BARRIER), (THROW), (RETURN-FROM n), (RETURN-FROM-I k n), (GO n l), (GO-I k n l)
  10886.                     (note-jmp)
  10887.                   )
  10888.                   (RET ; (RET)
  10889.                     (check-depth 0)
  10890.                     (note-jmp)
  10891.                   )
  10892.                   (PROGV ; (PROGV)
  10893.                     (note-inc 1)
  10894.                   )
  10895.                   (CATCH-OPEN ; (CATCH-OPEN label)
  10896.                     (note-label (second item))
  10897.                     (note-inc (+ 2 *jmpbuf-size*))
  10898.                   )
  10899.                   (CATCH-CLOSE ; (CATCH-CLOSE)
  10900.                     (note-dec (+ 2 *jmpbuf-size*))
  10901.                   )
  10902.                   (UNWIND-PROTECT-OPEN ; (UNWIND-PROTECT-OPEN label)
  10903.                     ; eigentlich: (note-inc (+ 2 *jmpbuf-size*))
  10904.                     (note-inc 3) (note-label (second item)) (note-dec 3)
  10905.                     (note-inc (+ 2 *jmpbuf-size*))
  10906.                   )
  10907.                   (UNWIND-PROTECT-NORMAL-EXIT ; (UNWIND-PROTECT-NORMAL-EXIT), danach kommt label
  10908.                     (note-dec (+ 2 *jmpbuf-size*)) (note-inc 3)
  10909.                   )
  10910.                   (UNWIND-PROTECT-CLOSE ; (UNWIND-PROTECT-CLOSE label)
  10911.                     ; eigentlich: (note-dec 3)
  10912.                     (note-label (second item)) (note-dec 3)
  10913.                   )
  10914.                   (UNWIND-PROTECT-CLEANUP ; (UNWIND-PROTECT-CLEANUP)
  10915.                     ; eigentlich: (note-dec (+ 2 *jmpbuf-size*)) (note-inc 3) ... (note-dec 3)
  10916.                     (note-dec (+ 2 *jmpbuf-size*))
  10917.                   )
  10918.                   (BLOCK-OPEN ; (BLOCK-OPEN n label)
  10919.                     (note-label (third item))
  10920.                     (note-inc (+ 2 *jmpbuf-size*))
  10921.                   )
  10922.                   (BLOCK-CLOSE ; (BLOCK-CLOSE)
  10923.                     (note-dec (+ 2 *jmpbuf-size*))
  10924.                   )
  10925.                   (TAGBODY-OPEN ; (TAGBODY-OPEN n label1 ... labelm)
  10926.                     (note-inc (+ 1 *jmpbuf-size*))
  10927.                     (dolist (label (cddr item)) (note-label label))
  10928.                   )
  10929.                   ((TAGBODY-CLOSE-NIL TAGBODY-CLOSE) ; (TAGBODY-CLOSE-NIL), (TAGBODY-CLOSE)
  10930.                     (note-dec (+ 1 *jmpbuf-size*))
  10931.                   )
  10932.                   (HANDLER-OPEN ; (HANDLER-OPEN n v k label1 ... labelm)
  10933.                     (check-depth (fourth item))
  10934.                     (dolist (label (cddddr item)) (note-label label))
  10935.                   )
  10936.                   ((MVCALLP HANDLER-BEGIN) ; (MVCALLP), (HANDLER-BEGIN)
  10937.                     (note-inc 1)
  10938.                   )
  10939.                   (MVCALL ; (MVCALL)
  10940.                     (note-dec 1)
  10941.                   )
  10942.                   (SKIPSP ; (SKIPSP k)
  10943.                     (note-dec (second item))
  10944.                   )
  10945.                   (SKIPI ; (SKIPI k n)
  10946.                     (note-dec (+ (second item) 1))
  10947.                   )
  10948.               ) )
  10949.           ) )
  10950.           (setq mitte (cdr mitte))
  10951.         )
  10952.         ; NΣchstes zu verfolgendes Label suchen:
  10953.         (loop
  10954.           (when (null unseen-label-alist) ; fertig ?
  10955.             (return-from SP-depth max-depth)
  10956.           )
  10957.           (let* ((unseen (pop unseen-label-alist)) ; nΣchstes zu verfolgendes
  10958.                  (label (car unseen))) ; Label
  10959.             (setq depth (cdr unseen))
  10960.             (let ((h (assoc label seen-label-alist)))
  10961.               (unless (and h (<= depth (cdr h)))
  10962.                 ; Ab diesem Label die Codeliste abarbeiten:
  10963.                 ; (Dadurch wird (label . depth) in seen-label-alist aufgenommen,
  10964.                 ; es ist bereits aus unseen-label-alist entfernt.)
  10965.                 (setq mitte (member label code-list :test #'eq))
  10966.                 (return)
  10967.         ) ) ) )
  10968. ) ) ) )
  10969.  
  10970.  
  10971. #|
  10972.                             6. Schritt:
  10973.                  Einfⁿhrung von Kurz-Operationen
  10974.  
  10975. Dieser Schritt arbeitet auf der Codeliste und verΣndert sie dabei destruktiv.
  10976.  
  10977. 1. (ATOM) (JMPIF label NIL)             --> (JMPIFATOM label)
  10978.    (ATOM) (JMPIFNOT label NIL)          --> (JMPIFCONSP label)
  10979.    (CONSP) (JMPIF label NIL)            --> (JMPIFCONSP label)
  10980.    (CONSP) (JMPIFNOT label NIL)         --> (JMPIFATOM label)
  10981.    (ATOM)                               --> (PUSH) (CALLS ATOM)
  10982.    (CONSP)                              --> (PUSH) (CALLS CONSP)
  10983.  
  10984. 2. (NIL) (PUSH)                         --> (NIL&PUSH)
  10985.    (NIL) (PUSH) ... (NIL) (PUSH)        --> (PUSH-NIL n)
  10986.    (NIL) (STORE n)                      --> (NIL&STORE n)
  10987.    (PUSH-NIL 1)                         --> (NIL&PUSH)
  10988.  
  10989. 3. (T) (PUSH)                           --> (T&PUSH)
  10990.    (T) (STORE n)                        --> (T&STORE n)
  10991.  
  10992. 4. (CONST n) (PUSH)                     --> (CONST&PUSH n)
  10993.    (CONST n) (SYMBOL-FUNCTION) (PUSH)   --> (CONST&SYMBOL-FUNCTION&PUSH n)
  10994.    (CONST n) (SYMBOL-FUNCTION) (STORE m)--> (CONST&SYMBOL-FUNCTION&STORE n m)
  10995.    (CONST n) (SYMBOL-FUNCTION)          --> (CONST&SYMBOL-FUNCTION n)
  10996.  
  10997. 5. (COPY-CLOSURE n m) (PUSH)            --> (COPY-CLOSURE&PUSH n m)
  10998.  
  10999. 6. (LOAD n) (PUSH)                      --> (LOAD&PUSH n)
  11000.    (LOAD k) (STOREC n m)                --> (LOAD&STOREC k n m)
  11001.    (LOAD n) (JMPIF label fv)            --> (LOAD&JMPIF n label)
  11002.    (LOAD n) (JMPIFNOT label fv)         --> (LOAD&JMPIFNOT n label)
  11003.    (LOAD n) (CAR) (PUSH)                --> (LOAD&CAR&PUSH n)
  11004.    (LOAD n) (CDR) (PUSH)                --> (LOAD&CDR&PUSH n)
  11005.    (LOAD n) (CDR) (STORE n)             --> (LOAD&CDR&STORE n)
  11006.    (LOAD n+1) (CONS) (STORE n)          --> (LOAD&CONS&STORE n)
  11007.    (LOAD n) (PUSH) (CALLS 1+) (STORE n) --> (LOAD&INC&STORE n)
  11008.    (LOAD n) (PUSH) (CALLS 1-) (STORE n) --> (LOAD&DEC&STORE n)
  11009.    (LOAD n) (PUSH) (CALLS 1+) (PUSH)    --> (LOAD&INC&PUSH n)
  11010.    (LOAD n) (PUSH) (CALLS 1-) (PUSH)    --> (LOAD&DEC&PUSH n)
  11011.    (LOAD n) (CAR) (STORE m)             --> (LOAD&CAR&STORE n m)
  11012.  
  11013. 7. (JMPIFBOUNDP n l) (NIL) (STORE n) l  --> (UNBOUND->NIL n) l
  11014.  
  11015. 8. (LOADI n1 n2) (PUSH)                 --> (LOADI&PUSH n1 n2)
  11016.    (LOADC n1 n2) (PUSH)                 --> (LOADC&PUSH n1 n2)
  11017.    (LOADV n1 n2) (PUSH)                 --> (LOADV&PUSH n1 n2)
  11018.  
  11019. 9. (GETVALUE n) (PUSH)                  --> (GETVALUE&PUSH n)
  11020.  
  11021. 10. (UNBIND1) ... (UNBIND1)             --> (UNBIND n)
  11022.  
  11023. 11. (CAR) (PUSH)                        --> (CAR&PUSH)
  11024.     (CDR) (PUSH)                        --> (CDR&PUSH)
  11025.     (CONS) (PUSH)                       --> (CONS&PUSH)
  11026.     (LIST n) (PUSH)                     --> (LIST&PUSH n)
  11027.     (LIST* n) (PUSH)                    --> (LIST*&PUSH n)
  11028.     (FUNCALL n) (PUS)                   --> (FUNCALL&PUSH n)
  11029.     (APPLY n) (PUSH)                    --> (APPLY&PUSH n)
  11030.  
  11031. 12. (POP) (STORE n)                      --> (POP&STORE n)
  11032.  
  11033. 13. (SKIP n) (RET)                      --> (SKIP&RET n)
  11034.     ; (RET)                             --> (SKIP&RET 0)
  11035.     ; kommt nicht vor, da im Stack stets noch die Closure selbst sitzt
  11036.  
  11037. 14. (UNWIND-PROTECT-CLOSE label)        --> (UNWIND-PROTECT-CLOSE)
  11038.  
  11039. 15. (JMPHASH n ht label . labels)       --> (JMPHASH n ht label)
  11040.     (JMPHASHV n ht label . labels)      --> (JMPHASHV n ht label)
  11041.  
  11042. 16. (JSR n label)                       --> (JSR label)
  11043.     (JSR n label) (PUSH)                --> (JSR&PUSH label)
  11044.  
  11045. 17. (CALL m n) (PUSH)                   --> (CALL&PUSH m n)
  11046.     (CALL1 n) (PUSH)                    --> (CALL1&PUSH n)
  11047.     (CALL2 n) (PUSH)                    --> (CALL2&PUSH n)
  11048.     (CALLS1 n) (PUSH)                   --> (CALLS1&PUSH n)
  11049.     (CALLS2 n) (PUSH)                   --> (CALLS2&PUSH n)
  11050.     (CALLSR m n) (PUSH)                 --> (CALLSR&PUSH m n)
  11051.     (CALLC) (PUSH)                      --> (CALLC&PUSH)
  11052.     (CALLCKEY) (PUSH)                   --> (CALLCKEY&PUSH)
  11053.  
  11054. 18. (CALL1 n) (JMPIF label fv)          --> (CALL1&JMPIF n label)
  11055.     (CALL1 n) (JMPIFNOT label fv)       --> (CALL1&JMPIFNOT n label)
  11056.     (CALL2 n) (JMPIF label fv)          --> (CALL2&JMPIF n label)
  11057.     (CALL2 n) (JMPIFNOT label fv)       --> (CALL2&JMPIFNOT n label)
  11058.     (CALLS1 n) (JMPIF label fv)         --> (CALLS1&JMPIF n label)
  11059.     (CALLS1 n) (JMPIFNOT label fv)      --> (CALLS1&JMPIFNOT n label)
  11060.     (CALLS2 n) (JMPIF label fv)         --> (CALLS2&JMPIF n label)
  11061.     (CALLS2 n) (JMPIFNOT label fv)      --> (CALLS2&JMPIFNOT n label)
  11062.     (CALLSR m n) (JMPIF label fv)       --> (CALLSR&JMPIF m n label)
  11063.     (CALLSR m n) (JMPIFNOT label fv)    --> (CALLSR&JMPIFNOT m n label)
  11064.  
  11065. 19. (CALLS1 n) (STORE k)                --> (CALLS1&STORE n k)
  11066.     (CALLS2 n) (STORE k)                --> (CALLS2&STORE n k)
  11067.     (CALLSR m n) (STORE k)              --> (CALLSR&STORE m n k)
  11068.  
  11069. 20. (EQ) (JMPIF label NIL)              --> (JMPIFEQ label)
  11070.     (EQ) (JMPIFNOT label NIL)           --> (JMPIFNOTEQ label)
  11071.     (CONST n) (EQ) (JMPIF label NIL)    --> (JMPIFEQTO n label)
  11072.     (CONST n) (EQ) (JMPIFNOT label NIL) --> (JMPIFNOTEQTO n label)
  11073.  
  11074. 21. (APPLY n) (SKIP k) (RET)            --> (APPLY&SKIP&RET n k)
  11075.  
  11076. 22. (HANDLER-BEGIN) (PUSH)              --> (HANDLER-BEGIN&PUSH)
  11077.  
  11078. 23. (BARRIER)                           -->
  11079.  
  11080. |#
  11081.  
  11082. (let ((CALLS-1+ (CALLS-code (gethash '1+ function-codes)))
  11083.       (CALLS-1- (CALLS-code (gethash '1- function-codes)))
  11084.       (CALLS-atom (CALLS-code (gethash 'atom function-codes)))
  11085.       (CALLS-consp (CALLS-code (gethash 'consp function-codes))))
  11086.   (defun insert-combined-LAPs (code-list)
  11087.     ; ZunΣchst die ATOM/CONSP-Umwandlung, weil diese PUSHs einfⁿhren kann:
  11088.     (do ((crest code-list (cdr crest)))
  11089.         ((null crest))
  11090.       (let ((item (car crest)))
  11091.         (when (and (consp item)
  11092.                    (memq (setq item (first item)) '(ATOM CONSP))
  11093.               )
  11094.           (if (and #| (consp (cdr crest)) |#
  11095.                    (consp (cadr crest))
  11096.                    (memq (first (cadr crest)) '(JMPIF JMPIFNOT))
  11097.                    (null (third (cadr crest)))
  11098.               )
  11099.             ; z.B. (ATOM) (JMPIF label NIL) --> (JMPIFATOM label)
  11100.             (setf (car crest)
  11101.                   `(,(if (eq (first (cadr crest)) 'JMPIF)
  11102.                        (if (eq item 'ATOM) 'JMPIFATOM 'JMPIFCONSP)
  11103.                        (if (eq item 'ATOM) 'JMPIFCONSP 'JMPIFATOM)
  11104.                      )
  11105.                     ,(second (cadr crest))
  11106.                    )
  11107.                   (cdr crest) (cddr crest)
  11108.             )
  11109.             ; z.B. (ATOM) --> (PUSH) (CALLS ATOM)
  11110.             (setf (car crest) '(PUSH)
  11111.                   (cdr crest) (cons (if (eq item 'ATOM) CALLS-atom CALLS-consp)
  11112.                                     (cdr crest)
  11113.             )                 )
  11114.     ) ) ) )
  11115.     ; Nun die sonstigen Umformungen: Ein einziger Durchlauf.
  11116.     ; Zwei Pointer laufen durch die Codeliste: ...mitte.rechts...
  11117.     (do* ((mitte code-list rechts)
  11118.           (rechts (cdr mitte) (cdr rechts)))
  11119.          ((null mitte))
  11120.       (macrolet ((ersetze (length new-code)
  11121.                    ; ersetzt die nΣchsten length Elemente
  11122.                    ; (nth 0 mitte) ... (nth (- length 1) mitte)
  11123.                    ; durch ein einziges Element new-code.
  11124.                    (assert (typep length '(INTEGER 0 4)))
  11125.                    `(progn
  11126.                       ,(case length
  11127.                          (0 `(setf (cdr mitte) (setq rechts (cons (car mitte) rechts))
  11128.                                    (car mitte) ,new-code
  11129.                          )   )
  11130.                          (1 `(setf (car mitte) ,new-code))
  11131.                          (t `(setf (car mitte) ,new-code
  11132.                                    (cdr mitte) ,(setq rechts
  11133.                                                   (case length
  11134.                                                     (2 `(cdr rechts))
  11135.                                                     (3 `(cddr rechts))
  11136.                                                     (4 `(cdddr rechts))
  11137.                                                 ) )
  11138.                        ) )   )
  11139.                       (go weiter)
  11140.                     )
  11141.                 ))
  11142.         (let ((item (car mitte)))
  11143.           (when (consp item)
  11144.             ; Untersuchung des Befehls item und der nachfolgenden:
  11145.             (when (and #| (consp rechts) |# (consp (car rechts)))
  11146.               ; normale Umwandlungen, mit AneinanderhΣngen der Argumente:
  11147.               (let ((new-op
  11148.                       (cdr (assoc (first item)
  11149.                                   (case (first (car rechts))
  11150.                                     (PUSH  '((T        . T&PUSH)
  11151.                                              (CONST    . CONST&PUSH)
  11152.                                              (LOADI    . LOADI&PUSH)
  11153.                                              (LOADC    . LOADC&PUSH)
  11154.                                              (LOADV    . LOADV&PUSH)
  11155.                                              (GETVALUE . GETVALUE&PUSH)
  11156.                                              (CALL     . CALL&PUSH)
  11157.                                              (CALL1    . CALL1&PUSH)
  11158.                                              (CALL2    . CALL2&PUSH)
  11159.                                              (CALLS1   . CALLS1&PUSH)
  11160.                                              (CALLS2   . CALLS2&PUSH)
  11161.                                              (CALLSR   . CALLSR&PUSH)
  11162.                                              (CALLC    . CALLC&PUSH)
  11163.                                              (CALLCKEY . CALLCKEY&PUSH)
  11164.                                              (CAR      . CAR&PUSH)
  11165.                                              (CDR      . CDR&PUSH)
  11166.                                              (CONS     . CONS&PUSH)
  11167.                                              (LIST     . LIST&PUSH)
  11168.                                              (LIST*    . LIST*&PUSH)
  11169.                                              (FUNCALL  . FUNCALL&PUSH)
  11170.                                              (APPLY    . APPLY&PUSH)
  11171.                                              (COPY-CLOSURE . COPY-CLOSURE&PUSH)
  11172.                                              (HANDLER-BEGIN . HANDLER-BEGIN&PUSH)
  11173.                                     )       )
  11174.                                     (JMPIF
  11175.                                       (let ((alist
  11176.                                               '((EQ     . JMPIFEQ)
  11177.                                                 (LOAD   . LOAD&JMPIF)
  11178.                                                 (CALL1  . CALL1&JMPIF)
  11179.                                                 (CALL2  . CALL2&JMPIF)
  11180.                                                 (CALLS1 . CALLS1&JMPIF)
  11181.                                                 (CALLS2 . CALLS2&JMPIF)
  11182.                                                 (CALLSR . CALLSR&JMPIF)
  11183.                                                )
  11184.                                            ))
  11185.                                         (when (third (car rechts))
  11186.                                           (setq alist (cdr alist))
  11187.                                         )
  11188.                                         (setf (cddr (car rechts)) '())
  11189.                                         alist
  11190.                                     ) )
  11191.                                     (JMPIFNOT
  11192.                                       (let ((alist
  11193.                                               '((EQ     . JMPIFNOTEQ)
  11194.                                                 (LOAD   . LOAD&JMPIFNOT)
  11195.                                                 (CALL1  . CALL1&JMPIFNOT)
  11196.                                                 (CALL2  . CALL2&JMPIFNOT)
  11197.                                                 (CALLS1 . CALLS1&JMPIFNOT)
  11198.                                                 (CALLS2 . CALLS2&JMPIFNOT)
  11199.                                                 (CALLSR . CALLSR&JMPIFNOT)
  11200.                                                )
  11201.                                            ))
  11202.                                         (when (third (car rechts))
  11203.                                           (setq alist (cdr alist))
  11204.                                         )
  11205.                                         (setf (cddr (car rechts)) '())
  11206.                                         alist
  11207.                                     ) )
  11208.                                     (STORE '((NIL    . NIL&STORE)
  11209.                                              (T      . T&STORE)
  11210.                                              (POP    . POP&STORE)
  11211.                                              (CALLS1 . CALLS1&STORE)
  11212.                                              (CALLS2 . CALLS2&STORE)
  11213.                                              (CALLSR . CALLSR&STORE)
  11214.                                     )       )
  11215.                                     (STOREC '((LOAD . LOAD&STOREC)))
  11216.                                     (RET '((SKIP . SKIP&RET)))
  11217.                                   )
  11218.                                   :test #'eq
  11219.                    )) )    )
  11220.                 (when new-op
  11221.                   (ersetze 2 `(,new-op ,@(rest item) ,@(rest (car rechts))))
  11222.             ) ) )
  11223.             ; weitere Umwandlungen:
  11224.             (case (first item)
  11225.               ((NIL PUSH-NIL)
  11226.                 (flet ((nilpusher-p (coder)
  11227.                          ; Kommt (NIL) (PUSH) --> 1,
  11228.                          ; kommt (PUSH-NIL n) --> n,
  11229.                          ; sonst nil.
  11230.                          (and #| (consp coder) |# (consp (car coder))
  11231.                               (case (first (car coder))
  11232.                                 (PUSH-NIL (second (car coder)))
  11233.                                 ((NIL) (when (equal (cadr coder) '(PUSH))
  11234.                                          (setf (cdr coder) (cddr coder))
  11235.                                          1
  11236.                                 )      )
  11237.                                 (t nil)
  11238.                       )) )    )
  11239.                   (let ((count (nilpusher-p mitte)))
  11240.                     (when count
  11241.                       (setq rechts (cdr mitte))
  11242.                       (loop
  11243.                         (let ((next-count (nilpusher-p rechts)))
  11244.                           (unless next-count (return))
  11245.                           (incf count next-count)
  11246.                         )
  11247.                         (setq rechts (cdr rechts))
  11248.                       )
  11249.                       (setf (car mitte) (if (eql count 1) '(NIL&PUSH) `(PUSH-NIL ,count))
  11250.                             (cdr mitte) rechts
  11251.                       )
  11252.                       (go weiter)
  11253.               ) ) ) )
  11254.               (CONST
  11255.                 (when (and #| (consp rechts) |# (consp (car rechts)))
  11256.                   (case (first (car rechts))
  11257.                     (SYMBOL-FUNCTION
  11258.                       (let ((n (second item)))
  11259.                         (cond ((and #| (consp (cdr rechts)) |#
  11260.                                     (equal (cadr rechts) '(PUSH))
  11261.                                )
  11262.                                (ersetze 3 `(CONST&SYMBOL-FUNCTION&PUSH ,n))
  11263.                               )
  11264.                               ((and #| (consp (cdr rechts)) |#
  11265.                                     (consp (cadr rechts))
  11266.                                     (eq (first (cadr rechts)) 'STORE)
  11267.                                )
  11268.                                (ersetze 3
  11269.                                  `(CONST&SYMBOL-FUNCTION&STORE ,n ,(second (cadr rechts)))
  11270.                               ))
  11271.                               (t (ersetze 2 `(CONST&SYMBOL-FUNCTION ,n)))
  11272.                     ) ) )
  11273.                     (EQ
  11274.                       (when (and #| (consp (cdr rechts)) |#
  11275.                                  (consp (cadr rechts))
  11276.                                  (memq (first (cadr rechts)) '(JMPIF JMPIFNOT))
  11277.                                  (null (third (cadr rechts)))
  11278.                             )
  11279.                         (ersetze 3
  11280.                           `(,(if (eq (first (cadr rechts)) 'JMPIF)
  11281.                                'JMPIFEQTO
  11282.                                'JMPIFNOTEQTO
  11283.                              )
  11284.                             ,(second item)
  11285.                             ,(second (cadr rechts))
  11286.                            )
  11287.               ) ) ) ) ) )
  11288.               (LOAD
  11289.                 (when (and #| (consp rechts) |# (consp (car rechts)))
  11290.                   (let ((n (second item)))
  11291.                     (case (first (car rechts))
  11292.                       (CAR
  11293.                         (when (and #| (consp (cdr rechts)) |# (consp (cadr rechts)))
  11294.                           (case (first (cadr rechts))
  11295.                             (PUSH (ersetze 3 `(LOAD&CAR&PUSH ,n)))
  11296.                             (STORE
  11297.                               (ersetze 3
  11298.                                 `(LOAD&CAR&STORE ,n ,(second (cadr rechts)))
  11299.                       ) ) ) ) )
  11300.                       (CDR
  11301.                         (when (and #| (consp (cdr rechts)) |# (consp (cadr rechts)))
  11302.                           (case (first (cadr rechts))
  11303.                             (PUSH (ersetze 3 `(LOAD&CDR&PUSH ,n)))
  11304.                             (STORE
  11305.                               (when (eql n (second (cadr rechts)))
  11306.                                 (ersetze 3 `(LOAD&CDR&STORE ,n))
  11307.                       ) ) ) ) )
  11308.                       (CONS
  11309.                         (when (and #| (consp (cdr rechts)) |# (consp (cadr rechts))
  11310.                                    (eq (first (cadr rechts)) 'STORE)
  11311.                                    (eql (second (cadr rechts)) (- n 1))
  11312.                               )
  11313.                           (ersetze 3 `(LOAD&CONS&STORE ,(- n 1)))
  11314.                       ) )
  11315.                       (PUSH
  11316.                         (when (and #| (consp (cdr rechts)) |# (consp (cadr rechts))
  11317.                                    (or (equal (cadr rechts) CALLS-1+)
  11318.                                        (equal (cadr rechts) CALLS-1-)
  11319.                                    )
  11320.                                    #| (consp (cddr rechts)) |# (consp (caddr rechts))
  11321.                               )
  11322.                           (when (equal (caddr rechts) '(PUSH))
  11323.                             (ersetze 4
  11324.                               `(,(if (equal (cadr rechts) CALLS-1+)
  11325.                                    'LOAD&INC&PUSH
  11326.                                    'LOAD&DEC&PUSH
  11327.                                  )
  11328.                                 ,n
  11329.                                )
  11330.                           ) )
  11331.                           (when (and (eq (first (caddr rechts)) 'STORE)
  11332.                                      (eql (second (caddr rechts)) n)
  11333.                                 )
  11334.                             (ersetze 4
  11335.                               `(,(if (equal (cadr rechts) CALLS-1+)
  11336.                                    'LOAD&INC&STORE
  11337.                                    'LOAD&DEC&STORE
  11338.                                  )
  11339.                                 ,n
  11340.                                )
  11341.                         ) ) )
  11342.                         (ersetze 2 `(LOAD&PUSH ,n))
  11343.               ) ) ) ) )
  11344.               (JMPIFBOUNDP ; vereinfache (JMPIFBOUNDP n l) (NIL) (STORE n) l
  11345.                 (when (and #| (consp rechts) |#
  11346.                            (equal (car rechts) '(NIL))
  11347.                            #| (consp (cdr rechts)) |#
  11348.                            (consp (cadr rechts))
  11349.                            (eq (first (cadr rechts)) 'STORE)
  11350.                            (eql (second (cadr rechts)) (second item))
  11351.                            #| (consp (cddr rechts)) |#
  11352.                            (eq (caddr rechts) (third item))
  11353.                       )
  11354.                   (ersetze 3 `(UNBOUND->NIL ,(second item)))
  11355.               ) )
  11356.               (JSR
  11357.                 (if (and #| (consp rechts) |# (equal (car rechts) '(PUSH)))
  11358.                   (ersetze 2 `(JSR&PUSH ,(third item)))
  11359.                   (ersetze 1 `(JSR ,(third item)))
  11360.               ) )
  11361.               (UNBIND1
  11362.                 (let ((count 1))
  11363.                   (loop
  11364.                     (unless (and #| (consp rechts) |#
  11365.                                  (equal (car rechts) '(UNBIND1))
  11366.                             )
  11367.                       (return)
  11368.                     )
  11369.                     (incf count)
  11370.                     (setq rechts (cdr rechts))
  11371.                   )
  11372.                   (unless (eql count 1)
  11373.                     (setf (car mitte) `(UNBIND ,count))
  11374.                     (setf (cdr mitte) rechts)
  11375.                     (go weiter)
  11376.               ) ) )
  11377.               ;(RET (ersetze 1 '(SKIP&RET 0))) ; kommt nicht vor!
  11378.               (UNWIND-PROTECT-CLOSE (ersetze 1 '(UNWIND-PROTECT-CLOSE)))
  11379.               ((JMPIF JMPIFNOT) (ersetze 1 `(,(first item) ,(second item))))
  11380.               ((JMPHASH JMPHASHV)
  11381.                 (let ((hashtable (third item))
  11382.                       (labels (cddddr item)))
  11383.                   (maphash
  11384.                     #'(lambda (obj index) ; (gethash obj hashtable) = index
  11385.                         (setf (gethash obj hashtable) (nth index labels))
  11386.                       )
  11387.                     hashtable
  11388.                 ) )
  11389.                 (setf (cddddr item) '())
  11390.               )
  11391.               (HANDLER-OPEN
  11392.                 (do ((v (third item))
  11393.                      (labels (cddddr item) (cdr labels))
  11394.                      (i 1 (+ i 2)))
  11395.                     ((null labels))
  11396.                   (setf (svref v i) (car labels))
  11397.                 )
  11398.                 (setf (cdddr item) '())
  11399.               )
  11400.               (APPLY
  11401.                 (when (and #| (consp rechts) |#
  11402.                            (consp (car rechts))
  11403.                            (eq (first (car rechts)) 'SKIP)
  11404.                            #| (consp (cdr rechts)) |#
  11405.                            (equal (cadr rechts) '(RET))
  11406.                       )
  11407.                   (ersetze 3 `(APPLY&SKIP&RET ,(second item) ,(second (car rechts))))
  11408.               ) )
  11409.       ) ) ) )
  11410.       weiter ; Hier ist man mit (car mitte) fertig.
  11411.       (when (equal (car rechts) '(BARRIER))
  11412.         ; streiche Element (car rechts)
  11413.         (setf (cdr mitte) (setq rechts (cdr rechts)))
  11414.       )
  11415.     )
  11416.     code-list
  11417.   )
  11418. )
  11419.  
  11420.  
  11421. #|
  11422.                                 7. Schritt:
  11423.                 Umwandlung der Instruktionen in eine Byte-Folge
  11424.  
  11425. Erster Teilschritt: jeder Instruktion wird eine Klassifikation der Instruktion
  11426. und die LΣnge der Instruktion (Label-Operanden nicht mitgezΣhlt)
  11427. vorangestellt, jedem Label wird sein PC als Wert zugewiesen.
  11428. Dabei werden die OperandenlΣngen - soweit m÷glich - bestimmt, in Instruktionen
  11429. auftretende Labels werden durch (vermutliche VerweislΣnge . label) ersetzt.
  11430. So wird aus (BLOCK-OPEN 2 #:G7) --> (NL 2 . (67 2 (1 . #:G7))) .
  11431. Weitere Teilschritte:
  11432. Immer wieder wird die Codeliste durchlaufen, dabei werden Sprungverweise
  11433. eventuell von 1 auf 2 oder 6 Byte verlΣngert. Dadurch kann der Code insgesamt
  11434. nur lΣnger werden.
  11435. Letzter Teilschritt:
  11436. Die Sprungverweise werden in Distanzen umgesetzt, und die Codeliste wird
  11437. als Liste von Bytes neu aufgebaut.
  11438. |#
  11439. ; gibt an, wieviel Bytes ein numerischer Operand braucht:
  11440. (defun num-operand-length (n)
  11441.   (cond ((< n 128) 1) ; 7 Bit in 1 Byte
  11442.         ((< n 32768) 2) ; 15 Bit in 2 Bytes
  11443.         (t 6) ; sonst 6 Bytes
  11444. ) )
  11445. ; assembliert eine Code-Liste und liefert eine Bytecode-Liste:
  11446. (defun assemble-LAP (code-list)
  11447.   ; erster Teilschritt:
  11448.   (do ((code-listr code-list (cdr code-listr))
  11449.        (PC 0))
  11450.       ((null code-listr))
  11451.     (let ((item (car code-listr)))
  11452.       (if (atom item)
  11453.         (setf (symbol-value item) PC)
  11454.         (let ((instr-code (gethash (first item) instruction-codes)))
  11455.           (unless instr-code (compiler-error 'assemble-LAP "ILLEGAL INSTRUCTION"))
  11456.           (let ((instr-class (second (svref instruction-table instr-code)))
  11457.                 (instr-length 1))
  11458.             (if (and (eq instr-class 'K)
  11459.                      (< (second item)
  11460.                         (svref short-code-opsize (position (first item) instruction-table-K))
  11461.                 )    )
  11462.               (progn
  11463.                 (setq instr-code
  11464.                   (+ (svref short-code-ops
  11465.                             (position (first item) instruction-table-K)
  11466.                      )
  11467.                      (second item)
  11468.                 ) )
  11469.                 (setq instr-class 'O)
  11470.                 (setq item (list (first item)))
  11471.               )
  11472.               (case instr-class
  11473.                 (O)
  11474.                 ((K N NC) (incf instr-length (num-operand-length (second item))))
  11475.                 (B (incf instr-length 1))
  11476.                 (L (incf PC 1) (push 1 (second item)))
  11477.                 (NN (incf instr-length (num-operand-length (second item)))
  11478.                     (incf instr-length (num-operand-length (third item))) )
  11479.                 (NB (incf instr-length (num-operand-length (second item)))
  11480.                     (incf instr-length 1) )
  11481.                 (BN (incf instr-length 1)
  11482.                     (incf instr-length (num-operand-length (third item))) )
  11483.                 (NNN (incf instr-length (num-operand-length (second item)))
  11484.                      (incf instr-length (num-operand-length (third item)))
  11485.                      (incf instr-length (num-operand-length (fourth item))) )
  11486.                 (NBN (incf instr-length (num-operand-length (second item)))
  11487.                      (incf instr-length 1)
  11488.                      (incf instr-length (num-operand-length (fourth item))) )
  11489.                 (NL (incf instr-length (num-operand-length (second item)))
  11490.                     (incf PC 1) (push 1 (third item)) )
  11491.                 (BL (incf instr-length 1)
  11492.                     (incf PC 1) (push 1 (third item)) )
  11493.                 (NNL (incf instr-length (num-operand-length (second item)))
  11494.                      (incf instr-length (num-operand-length (third item)))
  11495.                      (incf PC 1) (push 1 (fourth item)) )
  11496.                 (NBL (incf instr-length (num-operand-length (second item)))
  11497.                      (incf instr-length 1)
  11498.                      (incf PC 1) (push 1 (fourth item)) )
  11499.                 (NHL (incf instr-length (num-operand-length (second item)))
  11500.                      (incf PC 1) (push 1 (fourth item)) )
  11501.                 (NLX (incf instr-length (num-operand-length (second item)))
  11502.                      (do ((L (cddr item) (cdr L)))
  11503.                          ((null L))
  11504.                        (incf PC 1) (push 1 (car L))
  11505.                 )    )
  11506.             ) )
  11507.             (incf PC instr-length)
  11508.             (setf (car code-listr)
  11509.               (list* instr-class instr-length instr-code (cdr item))
  11510.             )
  11511.   ) ) ) ) )
  11512.   ; weitere Teilschritte:
  11513.   (loop
  11514.     (unless
  11515.       (let ((modified nil) (PC 0))
  11516.         (dolist (item code-list)
  11517.           (if (atom item)
  11518.             (setf (symbol-value item) PC)
  11519.             (progn
  11520.               (incf PC (cadr item))
  11521.               (when (memq (car item) '(L NL BL NNL NBL NHL NLX))
  11522.                 (let ((itemargs (cdddr item)))
  11523.                   (dolist (x (case (car item)
  11524.                                (L itemargs)
  11525.                                ((NL BL NLX) (cdr itemargs))
  11526.                                ((NNL NBL NHL) (cddr itemargs))
  11527.                           )  )
  11528.                     (incf PC (car x))
  11529.                     (let ((new-dist (- (symbol-value (cdr x)) PC)))
  11530.                       ; bisher angenommene SprunglΣnge und neu errechnete abgleichen:
  11531.                       (if (<= -64 new-dist 63) ; 7 Bits in 1 Byte
  11532.                         () ; SprunglΣnge bleibt 1
  11533.                         (if (<= -16384 new-dist 16383) ; 15 Bits in 2 Bytes
  11534.                           (case (car x)
  11535.                             (1 (setf (car x) 2) ; neue SprunglΣnge=2
  11536.                                (incf PC 1) ; gibt 2-1=1 Bytes VerlΣngerung
  11537.                                (setq modified t)
  11538.                           ) )
  11539.                           ; 32 Bits in 6 Bytes
  11540.                           (case (car x)
  11541.                             (1 (setf (car x) 6) ; neue SprunglΣnge=6
  11542.                                (incf PC 5) ; gibt 6-1=5 Bytes VerlΣngerung
  11543.                                (setq modified t)
  11544.                             )
  11545.                             (2 (setf (car x) 6) ; neue SprunglΣnge=6
  11546.                                (incf PC 4) ; gibt 6-2=4 Bytes VerlΣngerung
  11547.                                (setq modified t)
  11548.                       ) ) ) )
  11549.               ) ) ) )
  11550.         ) ) )
  11551.         modified
  11552.       )
  11553.       (return) ; nichts mehr verΣndert -> alle SprunglΣngen optimal
  11554.   ) )
  11555.   ; letzter Teilschritt:
  11556.   (let ((byte-list '()) (PC 0))
  11557.     (flet ((new-byte (n) (push n byte-list)))
  11558.       (flet ((num-operand (n)
  11559.                (cond ((< n 128) (new-byte n))
  11560.                      ((< n 32768) (new-byte (+ 128 (ldb (byte 7 8) n)))
  11561.                                   (new-byte (ldb (byte 8 0) n))
  11562.                      )
  11563.                      (t (compiler-error 'assemble-LAP "15 BIT"))
  11564.              ) )
  11565.              (label-operand (x)
  11566.                (incf PC (car x))
  11567.                (let ((dist (- (symbol-value (cdr x)) PC)))
  11568.                  (case (car x)
  11569.                    (1 (new-byte (ldb (byte 7 0) dist)))
  11570.                    (2 (new-byte (+ 128 (ldb (byte 7 8) dist)))
  11571.                       (new-byte (ldb (byte 8 0) dist))
  11572.                    )
  11573.                    (6 (new-byte 128) (new-byte 0)
  11574.                       (new-byte (ldb (byte 8 24) dist))
  11575.                       (new-byte (ldb (byte 8 16) dist))
  11576.                       (new-byte (ldb (byte 8 8) dist))
  11577.                       (new-byte (ldb (byte 8 0) dist))
  11578.                  ) )
  11579.             )) )
  11580.         (dolist (item code-list)
  11581.           (when (consp item)
  11582.             (incf PC (cadr item))
  11583.             (new-byte (caddr item))
  11584.             (case (car item)
  11585.               (O) ; darin fallen auch die 1-Byte-Befehle vom Typ K
  11586.               ((K N) (num-operand (second (cddr item))))
  11587.               (B (new-byte (second (cddr item))))
  11588.               (L (label-operand (second (cddr item))))
  11589.               (NN (num-operand (second (cddr item)))
  11590.                   (num-operand (third (cddr item))) )
  11591.               (NB (num-operand (second (cddr item)))
  11592.                   (new-byte (third (cddr item))) )
  11593.               (BN (new-byte (second (cddr item)))
  11594.                   (num-operand (third (cddr item))) )
  11595.               (NNN (num-operand (second (cddr item)))
  11596.                    (num-operand (third (cddr item)))
  11597.                    (num-operand (fourth (cddr item))) )
  11598.               (NBN (num-operand (second (cddr item)))
  11599.                    (new-byte (third (cddr item)))
  11600.                    (num-operand (fourth (cddr item))) )
  11601.               (NL (num-operand (second (cddr item)))
  11602.                   (label-operand (third (cddr item))) )
  11603.               (BL (new-byte (second (cddr item)))
  11604.                   (label-operand (third (cddr item))) )
  11605.               (NNL (num-operand (second (cddr item)))
  11606.                    (num-operand (third (cddr item)))
  11607.                    (label-operand (fourth (cddr item))) )
  11608.               (NBL (num-operand (second (cddr item)))
  11609.                    (new-byte (third (cddr item)))
  11610.                    (label-operand (fourth (cddr item))) )
  11611.               (NHL (num-operand (second (cddr item)))
  11612.                    (let ((ht (third (cddr item))))
  11613.                      (maphash
  11614.                        #'(lambda (obj x) ; x = (gethash obj ht)
  11615.                            (setf (gethash obj ht) (- (symbol-value x) PC))
  11616.                          )
  11617.                        ht
  11618.                    ) )
  11619.                    (label-operand (fourth (cddr item)))
  11620.               )
  11621.               (NC (num-operand (second (cddr item)))
  11622.                   (let* ((v (third (cddr item)))
  11623.                          (m (length v)))
  11624.                     (do ((i 1 (+ i 2)))
  11625.                         ((>= i m))
  11626.                       (setf (svref v i) (symbol-value (svref v i)))
  11627.               )   ) )
  11628.               (NLX (num-operand (second (cddr item)))
  11629.                    (dolist (x (cddr (cddr item))) (label-operand x)) )
  11630.             )
  11631.         ) )
  11632.     ) )
  11633.     (nreverse byte-list)
  11634. ) )
  11635.  
  11636. ; die Umkehrung zu assemble-LAP : liefert zu einer Bytecode-Liste die dazu
  11637. ; geh÷rige Codeliste. In dieser steht allerdings vor jedem Item noch der PC.
  11638. (defun disassemble-LAP (byte-list const-list)
  11639.   (let ((code-list '()) (PC 0) instr-PC (label-alist '()))
  11640.     ; label-alist ist eine Liste von Conses (PC . label), in der die PCs streng
  11641.     ; fallend geordnet sind.
  11642.     (flet ((PC->label-a (PC)
  11643.              (cons PC (make-symbol
  11644.                         (concatenate 'string "L" (prin1-to-string PC))
  11645.            ) )        )
  11646.            (next-byte () (incf PC) (pop byte-list))
  11647.           )
  11648.       (flet ((num-operand ()
  11649.                (let ((a (next-byte)))
  11650.                  (cond ((< a 128) a)
  11651.                        (t (+ (* 256 (- a 128)) (next-byte)))
  11652.              ) ) )
  11653.              (label-operand
  11654.                   (&optional
  11655.                     (dist
  11656.                       (let ((a (next-byte)))
  11657.                         (cond ((< a 128) (if (< a 64) a (- a 128)))
  11658.                               (t (setq a (- a 128))
  11659.                                  (unless (< a 64) (setq a (- a 128)))
  11660.                                  (setq a (+ (* 256 a) (next-byte)))
  11661.                                  (if (zerop a)
  11662.                                    (+ (* 256 (+ (* 256 (+ (* 256 (next-byte))
  11663.                                                           (next-byte)
  11664.                                                 )      )
  11665.                                                 (next-byte)
  11666.                                       )      )
  11667.                                       (next-byte)
  11668.                                    )
  11669.                                    a
  11670.                     ) ) )     )  )
  11671.                     (label-PC (+ PC dist))
  11672.                   )
  11673.                ; Suche label-PC in label-alist:
  11674.                (do* ((L1 nil L2)
  11675.                      (L2 label-alist (cdr L2))) ; L1 = nil oder L2 = (cdr L1)
  11676.                     ((cond
  11677.                        ((or (null L2) (> label-PC (caar L2))) ; einfⁿgen
  11678.                         (setq L2 (cons (PC->label-a label-PC) L2))
  11679.                         (if L1 (setf (cdr L1) L2) (setq label-alist L2))
  11680.                         t)
  11681.                        ((= label-PC (caar L2)) t)
  11682.                        (t nil)
  11683.                      )
  11684.                      (cdar L2)
  11685.             )) )    )
  11686.         (loop
  11687.           (when (null byte-list) (return))
  11688.           (setq instr-PC PC) ; PC beim Start der Instruktion
  11689.           (let ((instruction
  11690.                   (let ((instr-code (next-byte)))
  11691.                     (if (>= instr-code short-code-base)
  11692.                       (let* ((q (position instr-code short-code-ops :test #'>= :from-end t))
  11693.                              (r (- instr-code (svref short-code-ops q))))
  11694.                         (list (svref instruction-table-K q) r)
  11695.                       )
  11696.                       (let* ((table-entry (svref instruction-table instr-code))
  11697.                              (instr-name (first table-entry)))
  11698.                         (case (second table-entry)
  11699.                           (O (list instr-name))
  11700.                           ((K N) (list instr-name (num-operand)))
  11701.                           (B (list instr-name (next-byte)))
  11702.                           (L (list instr-name (label-operand)))
  11703.                           (NN (list instr-name (num-operand) (num-operand)))
  11704.                           (NB (list instr-name (num-operand) (next-byte)))
  11705.                           (BN (list instr-name (next-byte) (num-operand)))
  11706.                           (NNN (list instr-name (num-operand) (num-operand) (num-operand)))
  11707.                           (NBN (list instr-name (num-operand) (next-byte) (num-operand)))
  11708.                           (NL (list instr-name (num-operand) (label-operand)))
  11709.                           (BL (list instr-name (next-byte) (label-operand)))
  11710.                           (NNL (list instr-name (num-operand) (num-operand) (label-operand)))
  11711.                           (NBL (list instr-name (num-operand) (next-byte) (label-operand)))
  11712.                           (NHL (let* ((n (num-operand))
  11713.                                       (ht (if (eq instr-name 'JMPHASH)
  11714.                                             (nth n const-list)           ; JMPHASH
  11715.                                             (svref (first const-list) n) ; JMPHASHV
  11716.                                       )   )
  11717.                                       (labels '()))
  11718.                                  (maphash
  11719.                                    #'(lambda (obj dist)
  11720.                                        (declare (ignore obj))
  11721.                                        (push (label-operand dist) labels)
  11722.                                      )
  11723.                                    ht
  11724.                                  )
  11725.                                  (list* instr-name n (label-operand) labels)
  11726.                           )    )
  11727.                           (NC (let* ((n (num-operand))
  11728.                                      (v (car (nth n const-list)))
  11729.                                      (m (length v))
  11730.                                      (labels '()))
  11731.                                 (do ((i 1 (+ i 2)))
  11732.                                     ((>= i m))
  11733.                                   (push (label-operand nil (svref v i)) labels)
  11734.                                 )
  11735.                                 (list* instr-name n (nreverse labels))
  11736.                           )   )
  11737.                           (NLX (let* ((n (num-operand))
  11738.                                       (m (length (nth n const-list)))
  11739.                                       (L '()))
  11740.                                  (dotimes (i m) (push (label-operand) L))
  11741.                                  (list* instr-name n (nreverse L))
  11742.                           )    )
  11743.                )) ) ) ) )
  11744.             (push (cons instr-PC instruction) code-list)
  11745.         ) )
  11746.     ) )
  11747.     ; (setq label-alist (sort label-alist #'> :key #'car))
  11748.     ; code-list umdrehen und dabei die Labels einfⁿgen:
  11749.     (let ((new-code-list '()))
  11750.       (loop
  11751.         (when (and new-code-list label-alist
  11752.                    (= (caar new-code-list) (caar label-alist))
  11753.               )
  11754.           (push (car label-alist) new-code-list)
  11755.           (setq label-alist (cdr label-alist))
  11756.         )
  11757.         (when (null code-list) (return))
  11758.         ; eine Instruktion von code-list in new-code-list ⁿbernehmen:
  11759.         (psetq code-list (cdr code-list)
  11760.                new-code-list (rplacd code-list new-code-list)
  11761.       ) )
  11762.       new-code-list
  11763. ) ) )
  11764.  
  11765.  
  11766. #|
  11767.                            8. Schritt:
  11768.                     funktionales Objekt bilden
  11769.  
  11770. Die Funktion make-closure wird dazu vorausgesetzt.
  11771. |#
  11772. ; trΣgt eine Byteliste als Code in fnode ein.
  11773. (defun create-fun-obj (fnode byte-list #+CLISP3 SPdepth)
  11774.   (setf (fnode-code fnode)
  11775.     (make-closure
  11776.       :name (fnode-name fnode)
  11777.       :codevec
  11778.         (macrolet ((as-word (anz)
  11779.                      (if *big-endian*
  11780.                        ; BIG-ENDIAN-Prozessor
  11781.                        `(floor ,anz 256)
  11782.                        ; LITTLE-ENDIAN-Prozessor
  11783.                        `(multiple-value-bind (q r) (floor ,anz 256) (values r q))
  11784.                   )) )
  11785.           (multiple-value-call #'list*
  11786.             #+CLISP3 (as-word SPdepth)
  11787.             (as-word (fnode-req-anz fnode))
  11788.             (as-word (fnode-opt-anz fnode))
  11789.             (+ (if (fnode-rest-flag fnode) 1 0)
  11790.                (if (fnode-gf-p fnode) 16 0)
  11791.                (if (fnode-keyword-flag fnode)
  11792.                  (+ 128 (if (fnode-allow-other-keys-flag fnode) 64 0))
  11793.                  0
  11794.             )  )
  11795.             (values ; Argumenttyp-Kⁿrzel
  11796.               (let ((req-anz (fnode-req-anz fnode))
  11797.                     (opt-anz (fnode-opt-anz fnode))
  11798.                     (rest (fnode-rest-flag fnode))
  11799.                     (key (fnode-keyword-flag fnode)))
  11800.                 (cond ((and (not rest) (not key) (< (+ req-anz opt-anz) 6))
  11801.                        (+ (svref '#(1 7 12 16 19 21) opt-anz) req-anz)
  11802.                       )
  11803.                       ((and rest (not key) (zerop opt-anz) (< req-anz 5))
  11804.                        (+ 22 req-anz)
  11805.                       )
  11806.                       ((and (not rest) key (< (+ req-anz opt-anz) 5))
  11807.                        (+ (svref '#(27 32 36 39 41) opt-anz) req-anz)
  11808.                       )
  11809.                       (t 0)
  11810.             ) ) )
  11811.             (if (fnode-keyword-flag fnode)
  11812.               (multiple-value-call #'values
  11813.                 (as-word (length (fnode-keywords fnode)))
  11814.                 (as-word (fnode-Keyword-Offset fnode))
  11815.               )
  11816.               (values)
  11817.             )
  11818.             byte-list
  11819.         ) )
  11820.       :consts
  11821.         (let* ((spare-list (make-list (fnode-Keyword-Offset fnode)))
  11822.                (l (append
  11823.                     spare-list
  11824.                     (fnode-keywords fnode)
  11825.                     (if *compiling-from-file*
  11826.                       (mapcar #'(lambda (value form)
  11827.                                   (if form (make-load-time-eval form) value)
  11828.                                 )
  11829.                               (fnode-Consts fnode) (fnode-Consts-forms fnode)
  11830.                       )
  11831.                       (fnode-Consts fnode)
  11832.               ))  ) )
  11833.           (if (fnode-gf-p fnode)
  11834.             (append spare-list (list (coerce l 'simple-vector)))
  11835.             l
  11836.         ) )
  11837.   ) )
  11838.   fnode
  11839. )
  11840.  
  11841. ; Liefert die Signatur eines funktionalen Objekts,
  11842. ; als Werte:
  11843. ; 1. req-anz
  11844. ; 2. opt-anz
  11845. ; 3. rest-p
  11846. ; 4. key-p
  11847. ; 5. keyword-list
  11848. ; 6. allow-other-keys-p
  11849. ; und zusΣtzlich
  11850. ; 7. byte-list
  11851. ; 8. const-list
  11852. (defun signature (closure)
  11853.   (let ((const-list (closure-consts closure))
  11854.         (byte-list (closure-codevec closure)))
  11855.     (macrolet ((pop2 (listvar)
  11856.                  (if *big-endian*
  11857.                    ; BIG-ENDIAN-Prozessor
  11858.                    `(+ (* 256 (pop ,listvar)) (pop ,listvar))
  11859.                    ; LITTLE-ENDIAN-Prozessor
  11860.                    `(+ (pop ,listvar) (* 256 (pop ,listvar)))
  11861.               )) )
  11862.       #+CLISP3 (progn (pop byte-list) (pop byte-list))
  11863.       (let* ((req-anz (pop2 byte-list))
  11864.              (opt-anz (pop2 byte-list))
  11865.              (h (pop byte-list))
  11866.              (key-p (logbitp 7 h)))
  11867.         (pop byte-list)
  11868.         (values
  11869.           req-anz
  11870.           opt-anz
  11871.           (logbitp 0 h)
  11872.           key-p
  11873.           (when key-p
  11874.             (let ((kw-count (pop2 byte-list))
  11875.                   (kw-offset (pop2 byte-list)))
  11876.               (subseq (if (logbitp 4 h) ; generische Funktion?
  11877.                         (coerce (first const-list) 'list)
  11878.                         const-list
  11879.                       )
  11880.                       kw-offset (+ kw-offset kw-count)
  11881.           ) ) )
  11882.           (logbitp 6 h)
  11883.           byte-list
  11884.           const-list
  11885. ) ) ) ) )
  11886.  
  11887.  
  11888. ;                  D R I T T E R   P A S S
  11889.  
  11890. (defun pass3 ()
  11891.   (dolist (pair *fnode-fixup-table*)
  11892.     (let ((code (fnode-code (first pair))) (n (second pair)))
  11893.       (macrolet ((closure-const (code n)
  11894.                    #-CLISP `(nth ,n (closure-consts ,code))
  11895.                    #+CLISP `(sys::%record-ref ,code (+ 2 ,n))
  11896.                 ))
  11897.         (setf (closure-const code n) (fnode-code (closure-const code n)))
  11898. ) ) ) )
  11899.  
  11900.  
  11901. ;             T O P - L E V E L - A U F R U F
  11902.  
  11903. ; compiliert einen Lambdabody und liefert seinen Code.
  11904. (defun compile-lambdabody (name lambdabody)
  11905.   (let ((fnode (c-lambdabody name lambdabody)))
  11906.     (unless *no-code*
  11907.       (let ((*fnode-fixup-table* '()))
  11908.         (pass2 fnode)
  11909.         (pass3)
  11910.       )
  11911.       (fnode-code fnode)
  11912. ) ) )
  11913.  
  11914. ; wird bei (lambda (...) (declare (compile)) ...) aufgerufen und liefert ein
  11915. ; zu diesem Lambda-Ausdruck Σquivalentes funktionales Objekt.
  11916. (defun compile-lambda (name lambdabody %venv% %fenv% %benv% %genv% %denv%)
  11917.   (let ((*compiling* t)
  11918.         (*compiling-from-file* nil)
  11919.         (*c-listing-output* nil)
  11920.         (*c-error-output* *error-output*)
  11921.         (*known-special-vars* '())
  11922.         (*constant-special-vars* '())
  11923.         (*func* nil)
  11924.         (*fenv* %fenv%)
  11925.         (*benv* %benv%)
  11926.         (*genv* %genv%)
  11927.         (*venv* %venv%)
  11928.         (*venvc* nil)
  11929.         (*denv* %denv%)
  11930.         (*error-count* 0) (*warning-count* 0)
  11931.         (*no-code* nil)
  11932.        )
  11933.     (let ((funobj (compile-lambdabody name lambdabody)))
  11934.       (unless (zerop *error-count*)
  11935.         (return-from compile-lambda (compile-lambdabody name '(() NIL)))
  11936.       )
  11937.       funobj
  11938. ) ) )
  11939.  
  11940. ; wird bei (let/let*/multiple-value-bind ... (declare (compile)) ...) aufgerufen
  11941. ; und liefert ein funktionales Objekt, das - mit 0 Argumenten aufgerufen - diese
  11942. ; Form ausfⁿhrt.
  11943. (let ((form-count 0))
  11944.   (defun compile-form (form %venv% %fenv% %benv% %genv% %denv%)
  11945.     (compile-lambda (symbol-suffix '#:COMPILED-FORM (incf form-count))
  11946.                     `(() ,form)
  11947.                     %venv% %fenv% %benv% %genv% %denv%
  11948.   ) )
  11949. )
  11950.  
  11951. ; Common-Lisp-Funktion COMPILE
  11952. #-CROSS
  11953. (defun compile (name &optional (definition nil svar)
  11954.                      &aux (macro-flag nil) (trace-flag nil) (save-flag nil))
  11955.   (unless (function-name-p name)
  11956.     (error-of-type 'error
  11957.       (DEUTSCH "Name einer zu compilierenden Funktion mu▀ ein Symbol sein, nicht: ~S"
  11958.        ENGLISH "Name of function to be compiled must be a symbol, not ~S"
  11959.        FRANCAIS "Le nom d'une fonction α compiler doit Ωtre un symbole et non ~S")
  11960.       name
  11961.   ) )
  11962.   (let ((symbol (get-funname-symbol name)))
  11963.     (if svar
  11964.       ; Neudefinition von name als Funktion.
  11965.       (progn
  11966.         ; Ist name getraced -> falls vorher Macro, erst untracen.
  11967.         (when (and name (setq svar (get symbol 'sys::traced-definition)))
  11968.           (if (consp svar)
  11969.             (progn
  11970.               (warn (DEUTSCH "~S: ~S war getraced und wird umdefiniert!"
  11971.                      ENGLISH "~S: redefining ~S; it was traced!"
  11972.                      FRANCAIS "~S: ~S est redΘfinie, alors qu'elle Θtait tracΘe!")
  11973.                     'compile name
  11974.               )
  11975.               (sys::untrace2 name)
  11976.             )
  11977.             (setq trace-flag t)
  11978.         ) )
  11979.         (when (compiled-function-p definition)
  11980.           (warn (DEUTSCH "~S ist schon compiliert."
  11981.                  ENGLISH "~S is already compiled."
  11982.                  FRANCAIS "~S est dΘjα compilΘe.")
  11983.                 definition
  11984.           )
  11985.           (when name
  11986.             (if trace-flag
  11987.               (setf (get symbol 'sys::traced-definition) definition)
  11988.               (setf (symbol-function symbol) definition)
  11989.           ) )
  11990.           (return-from compile name)
  11991.         )
  11992.         (when name
  11993.           (setq save-flag
  11994.                 (cons `(SETF (FDEFINITION ',name) ',definition)
  11995.                       sys::*toplevel-environment*
  11996.         ) )     )
  11997.       )
  11998.       ; Compilierung der vorhandenen Funktions-/Macro-Definition.
  11999.       (progn
  12000.         (unless (fboundp symbol)
  12001.           (error-of-type 'undefined-function
  12002.             :name name
  12003.             (DEUTSCH "Funktion ~S ist undefiniert."
  12004.              ENGLISH "Undefined function ~S"
  12005.              FRANCAIS "Fonction non dΘfinie ~S.")
  12006.             name
  12007.         ) )
  12008.         (if (setq definition (get symbol 'sys::traced-definition))
  12009.           (setq trace-flag t)
  12010.           (setq definition (symbol-function symbol))
  12011.         )
  12012.         (when (and (consp definition) (eq (car definition) 'system::macro))
  12013.           (setq macro-flag t)
  12014.           (setq definition (cdr definition))
  12015.         )
  12016.         (when (compiled-function-p definition)
  12017.           (warn (DEUTSCH "~S ist schon compiliert."
  12018.                  ENGLISH "~S is already compiled."
  12019.                  FRANCAIS "~S est dΘjα compilΘe.")
  12020.                 name
  12021.           )
  12022.           (return-from compile name)
  12023.     ) ) )
  12024.     (unless (or (and (consp definition) (eq (car definition) 'lambda))
  12025.                 (sys::closurep definition)
  12026.             )
  12027.       (error-of-type 'error
  12028.         (DEUTSCH "Das ist weder ein Lambda-Ausdruck noch ein funktionales Objekt:~%~S"
  12029.          ENGLISH "Not a lambda expression nor a function: ~S"
  12030.          FRANCAIS "Ni expression lambda ni fonction : ~S")
  12031.         definition
  12032.     ) )
  12033.     (let ((*compiling* t)
  12034.           (*error-count* 0)
  12035.           (*warning-count* 0)
  12036.           (*compiling-from-file* nil)
  12037.           (*c-listing-output* nil)
  12038.           (*c-error-output* *error-output*)
  12039.           (*known-special-vars* '())
  12040.           (*constant-special-vars* '())
  12041.           (*func* nil)
  12042.           (*fenv* (if (sys::closurep definition)
  12043.                     (sys::%record-ref definition 5)
  12044.                     nil
  12045.           )       )
  12046.           (*benv* (if (sys::closurep definition)
  12047.                     (sys::%record-ref definition 6)
  12048.                     nil
  12049.           )       )
  12050.           (*genv* (if (sys::closurep definition)
  12051.                     (sys::%record-ref definition 7)
  12052.                     nil
  12053.           )       )
  12054.           (*venv* (if (sys::closurep definition)
  12055.                     (sys::%record-ref definition 4)
  12056.                     nil
  12057.           )       )
  12058.           (*venvc* nil)
  12059.           (*denv* (if (sys::closurep definition)
  12060.                     (sys::%record-ref definition 8)
  12061.                     *toplevel-denv*
  12062.           )       )
  12063.           (*no-code* nil))
  12064.       (let ((lambdabody (if (sys::closurep definition)
  12065.                           (sys::%record-ref definition 1)
  12066.                           (cdr definition)
  12067.            ))           )
  12068.         (let ((funobj (compile-lambdabody name lambdabody)))
  12069.           (unless (zerop *error-count*) (return-from compile nil))
  12070.           (if name
  12071.             (progn
  12072.               (when macro-flag (setq funobj (cons 'system::macro funobj)))
  12073.               (if trace-flag
  12074.                 (setf (get symbol 'sys::traced-definition) funobj)
  12075.                 (setf (symbol-function symbol) funobj)
  12076.               )
  12077.               (when save-flag
  12078.                 (setf (get symbol 'sys::definition) save-flag)
  12079.               )
  12080.               name
  12081.             )
  12082.             funobj
  12083. ) ) ) ) ) )
  12084.  
  12085. ; Top-Level-Formen mⁿssen einzeln aufs .fas-File rausgeschrieben werden,
  12086. ; wegen der Semantik von EVAL-WHEN und LOAD-TIME-VALUE.
  12087. ; Da Top-Level-Formen bei EVAL-WHEN, PROGN und LOCALLY auseinandergebrochen
  12088. ; werden k÷nnen, mu▀ man LET () verwenden, wenn man dies umgehen will.
  12089.  
  12090. ; Compiliert eine Top-Level-Form fⁿr COMPILE-FILE. Der *toplevel-name* wird
  12091. ; meist unverΣndert durchgereicht. *toplevel-for-value* gibt an, ob der Wert
  12092. ; gebraucht wird (fⁿr LOAD :PRINT T) oder nicht.
  12093. (defvar *toplevel-for-value*)
  12094. (defun compile-toplevel-form (form &optional (*toplevel-name* *toplevel-name*))
  12095.   (declare (special *toplevel-name*))
  12096.   (catch 'c-error
  12097.     ; CLtL2 S. 90: "Processing of top-level forms in the file compiler ..."
  12098.     ; 1. Schritt: Macroexpandieren
  12099.     (if (atom form)
  12100.       (when (symbolp form)
  12101.         (let ((h (venv-search-macro form *venv*)))
  12102.           (when (symbol-macro-p h) ; Symbol-Macro ?
  12103.             (return-from compile-toplevel-form
  12104.               (compile-toplevel-form (sys::%record-ref h 0)) ; -> expandieren
  12105.       ) ) ) )
  12106.       (let ((fun (first form)))
  12107.         (when (symbolp fun)
  12108.           (multiple-value-bind (a b c) (fenv-search fun)
  12109.             (declare (ignore b c))
  12110.             (if (null a)
  12111.               ; nicht lokal definiert
  12112.               (case fun
  12113.                 (PROGN ; vgl. c-PROGN
  12114.                   (test-list form 1)
  12115.                   (let ((L (cdr form))) ; Liste der Formen
  12116.                     (cond ((null L) (compile-toplevel-form 'NIL)) ; keine Form
  12117.                           ((null (cdr L)) (compile-toplevel-form (car L))) ; genau eine Form
  12118.                           (t (let ((subform-count 0))
  12119.                                (do ((Lr L))
  12120.                                    ((null Lr))
  12121.                                  (let* ((subform (pop Lr))
  12122.                                         (*toplevel-for-value* (and *toplevel-for-value* (null Lr))))
  12123.                                    (compile-toplevel-form subform
  12124.                                      (symbol-suffix *toplevel-name* (incf subform-count))
  12125.                   ) )     )  ) ) ) )
  12126.                   (return-from compile-toplevel-form)
  12127.                 )
  12128.                 ((LOCALLY EVAL-WHEN COMPILER-LET MACROLET SYMBOL-MACROLET)
  12129.                   (let ((*form* form))
  12130.                     ; c-LOCALLY bzw. c-EVAL-WHEN bzw. c-COMPILER-LET bzw.
  12131.                     ; c-MACROLET bzw. c-SYMBOL-MACROLET aufrufen:
  12132.                     (funcall (gethash fun c-form-table) #'compile-toplevel-form)
  12133.                   )
  12134.                   (return-from compile-toplevel-form)
  12135.                 )
  12136.                 (t (when (macro-function fun) ; globaler Macro ?
  12137.                      (return-from compile-toplevel-form
  12138.                        (compile-toplevel-form (macroexpand-1 form (vector *venv* *fenv*))) ; -> expandieren
  12139.               ) )  ) )
  12140.               ; lokal definiert
  12141.               (when (eq a 'SYSTEM::MACRO) ; lokaler Macro
  12142.                 (return-from compile-toplevel-form
  12143.                   (compile-toplevel-form (macroexpand-1 form (vector *venv* *fenv*))) ; -> expandieren
  12144.               ) )
  12145.     ) ) ) ) )
  12146.     ; 2. Schritt: compilieren und rausschreiben
  12147.     (when (and (not *toplevel-for-value*) (c-constantp form))
  12148.       (return-from compile-toplevel-form)
  12149.     )
  12150.     (let ((*package-tasks* '()))
  12151.       (setq form
  12152.         (compile-lambdabody *toplevel-name*
  12153.           `(() ,form ,@(if *toplevel-for-value* '() '((VALUES)) ) )
  12154.       ) )
  12155.       (when *c-listing-output*
  12156.         (disassemble-closures form *c-listing-output*)
  12157.       )
  12158.       (when *fasoutput-stream*
  12159.         (terpri *fasoutput-stream*)
  12160.         (write form :stream *fasoutput-stream* :pretty t
  12161.                     :readably t
  12162.                     ; :closure t :circle t :array t :gensym t
  12163.                     ; :escape t :level nil :length nil :radix t
  12164.       ) )
  12165.       (when *package-tasks*
  12166.         (c-eval-when-compile `(PROGN ,@(nreverse *package-tasks*)))
  12167.       )
  12168. ) ) )
  12169.  
  12170. ; Common-Lisp-Funktion COMPILE-FILE
  12171. ; file          sollte ein Pathname/String/Symbol sein.
  12172. ; :output-file  sollte nil oder t oder ein Pathname/String/Symbol oder
  12173. ;               ein Output-Stream sein. Default: t.
  12174. ; :listing      sollte nil oder t oder ein Pathname/String/Symbol oder
  12175. ;               ein Output-Stream sein. Default: nil.
  12176. ; :warnings     gibt an, ob die Warnings auch auf dem Bildschirm erscheinen
  12177. ;               sollen.
  12178. ; :verbose      gibt an, ob die Errors auch auf dem Bildschirm erscheinen
  12179. ;               sollen.
  12180. (defun compile-file (file &key (output-file 'T) listing
  12181.                                ((:warnings *compile-warnings*) *compile-warnings*)
  12182.                                ((:verbose *compile-verbose*) *compile-verbose*)
  12183.                                ((:print *compile-print*) *compile-print*)
  12184.                           &aux (top-call nil) liboutput-file
  12185.                                (new-output-stream nil) (new-listing-stream nil)
  12186.                     )
  12187.   (setq file (or (first (search-file file *source-file-types*))
  12188.                  (merge-pathnames file (merge-pathnames '#".lsp"))
  12189.   )          )
  12190.   (when (and output-file (not (streamp output-file)))
  12191.     (setq output-file (if (eq output-file 'T)
  12192.                         (merge-pathnames '#".fas" file)
  12193.                         (merge-pathnames output-file)
  12194.     )                 )
  12195.     (setq liboutput-file (merge-pathnames '#".lib" output-file))
  12196.     (setq new-output-stream t)
  12197.   )
  12198.   (when (and listing (not (streamp listing)))
  12199.     (setq listing (if (eq listing 'T)
  12200.                     (merge-pathnames '#".lis" file)
  12201.                     (merge-pathnames listing)
  12202.     )             )
  12203.     (setq new-listing-stream t)
  12204.   )
  12205.   (with-open-file (istream file :direction :input-immutable)
  12206.     (let ((listing-stream (if new-listing-stream
  12207.                             (open listing :direction :output)
  12208.                             (if (streamp listing) listing nil)
  12209.          ))               ) ; ein Stream oder NIL
  12210.       (unwind-protect
  12211.         (let ((*compile-file-pathname* file)
  12212.               (*compile-file-truename* (truename file))
  12213.               (*compile-file-lineno1* nil)
  12214.               (*compile-file-lineno2* nil)
  12215.               (*fasoutput-stream* (if new-output-stream
  12216.                                     (open output-file :direction :output)
  12217.                                     (if (streamp output-file) output-file nil)
  12218.               )                   ) ; ein Stream oder NIL
  12219.               (*liboutput-stream* (if new-output-stream
  12220.                                     (open liboutput-file :direction :output)
  12221.                                     nil
  12222.               )                   ) ; ein Stream oder NIL
  12223.               (compilation-successful nil))
  12224.           (unwind-protect
  12225.             (progn
  12226.               (when listing-stream
  12227.                 (format listing-stream
  12228.                   (DEUTSCH "~&Listing der Compilation von File ~A~%am ~@? durch ~A in der Version ~A"
  12229.                    ENGLISH "~&Listing of compilation of file ~A~%on ~@? by ~A, version ~A"
  12230.                    FRANCAIS "~&Listage de la compilation du fichier ~A~%le ~@? par ~A, version ~A")
  12231.                   file
  12232.                   (date-format)
  12233.                   (multiple-value-list (get-decoded-time))
  12234.                     ; Liste (sec min hour day month year ...)
  12235.                   (lisp-implementation-type) (lisp-implementation-version)
  12236.               ) )
  12237.               (unless *compiling* ; Variablen setzen, nicht binden!
  12238.                 (setq *functions-with-errors* '())
  12239.                 (setq *known-special-vars* '()) (setq *unknown-free-vars* '())
  12240.                 (setq *constant-special-vars* '())
  12241.                 (setq *known-functions* '()) (setq *unknown-functions* '())
  12242.                 (setq *inline-functions* '()) (setq *notinline-functions* '())
  12243.                 (setq *inline-definitions* '())
  12244.                 (setq *user-declaration-types* '())
  12245.                 (setq *compiled-modules* '())
  12246.                 (setq top-call t)
  12247.               )
  12248.               (let ((*compiling* t)
  12249.                     (*compiling-from-file* t)
  12250.                     (*package* *package*)
  12251.                     (*readtable* *readtable*)
  12252.                     (*c-listing-output* listing-stream)
  12253.                     (*c-error-output*
  12254.                       (if listing-stream
  12255.                         (make-broadcast-stream *error-output* listing-stream)
  12256.                         *error-output*
  12257.                     ) )
  12258.                     (*func* nil)
  12259.                     (*fenv* nil)
  12260.                     (*benv* nil)
  12261.                     (*genv* nil)
  12262.                     (*venv* nil)
  12263.                     (*venvc* nil)
  12264.                     (*denv* *toplevel-denv*)
  12265.                     (*error-count* 0) (*warning-count* 0)
  12266.                     (*no-code* (and (null *fasoutput-stream*) (null listing-stream)))
  12267.                     (*toplevel-for-value* t)
  12268.                     (eof-value "EOF")
  12269.                     (form-count 0)
  12270.                    )
  12271.                 (c-comment (DEUTSCH "~%File ~A wird compiliert..."
  12272.                             ENGLISH "~%Compiling file ~A ..."
  12273.                             FRANCAIS "~%Compilation du fichier ~A...")
  12274.                            file
  12275.                 )
  12276.                 (when *fasoutput-stream*
  12277.                   (let ((*package* *keyword-package*))
  12278.                     (write `(SYSTEM::VERSION ',(version)) :stream *fasoutput-stream*
  12279.                            :readably t
  12280.                            ; :escape t :level nil :length nil :radix t
  12281.                 ) ) )
  12282.                 (loop
  12283.                   (peek-char t istream nil eof-value)
  12284.                   (setq *compile-file-lineno1* (line-number istream))
  12285.                   (let ((form (read istream nil eof-value)))
  12286.                     (setq *compile-file-lineno2* (line-number istream))
  12287.                     (when (eql form eof-value) (return))
  12288.                     (when *compile-print*
  12289.                       (format t "~%; ~A" (sys::write-to-short-string form (- sys::*prin-linelength* 2)))
  12290.                     )
  12291.                     (compile-toplevel-form form
  12292.                       (symbol-suffix '#:TOP-LEVEL-FORM (incf form-count))
  12293.                 ) ) )
  12294.                 (c-comment (DEUTSCH "~&~%Compilation von File ~A beendet."
  12295.                             ENGLISH "~&~%Compilation of file ~A is finished."
  12296.                             FRANCAIS "~&~%Compilation du fichier ~A terminΘe.")
  12297.                            file
  12298.                 )
  12299.                 (c-comment (DEUTSCH "~%~D Error~:P, ~D Warnung~:[en~;~]"
  12300.                             ENGLISH "~%~D error~:P, ~D warning~:P"
  12301.                             FRANCAIS "~%~D erreur~:P, ~D avertissement~:P")
  12302.                            *error-count* *warning-count* (DEUTSCH (eql *warning-count* 1))
  12303.                 )
  12304.                 (when top-call
  12305.                   (when *functions-with-errors*
  12306.                     (c-comment (DEUTSCH "~%Es gab Errors in den folgenden Funktionen:~%~{~<~%~:; ~S~>~^~}"
  12307.                                 ENGLISH "~%There were errors in the following functions:~%~{~<~%~:; ~S~>~^~}"
  12308.                                 FRANCAIS "~%Il y a des erreurs dans les fonctions :~%~{~<~%~:; ~S~>~^~}" )
  12309.                                (nreverse *functions-with-errors*)
  12310.                   ) )
  12311.                   (setq *unknown-functions*
  12312.                     (nset-difference *unknown-functions* *known-functions* :test #'equal)
  12313.                   )
  12314.                   (when *unknown-functions*
  12315.                     (c-comment (DEUTSCH "~%Folgende Funktionen wurden verwendet, aber nicht definiert:~%~{~<~%~:; ~S~>~^~}"
  12316.                                 ENGLISH "~%The following functions were used but not defined:~%~{~<~%~:; ~S~>~^~}"
  12317.                                 FRANCAIS "~%Les fonctions suivantes sont utilisΘes mais non dΘfinies :~%~{~<~%~:; ~S~>~^~}")
  12318.                                (nreverse *unknown-functions*)
  12319.                   ) )
  12320.                   (let ((unknown-vars (set-difference *unknown-free-vars* *known-special-vars*))
  12321.                         (too-late-vars (intersection *unknown-free-vars* *known-special-vars*)))
  12322.                     (when unknown-vars
  12323.                       (c-comment (DEUTSCH "~%Folgende Special-Variablen wurden nicht definiert:~%~{~<~%~:; ~S~>~^~}"
  12324.                                   ENGLISH "~%The following special variables were not defined:~%~{~<~%~:; ~S~>~^~}"
  12325.                                   FRANCAIS "~%Les variables utilisΘes comme SPECIAL ne sont pas dΘfinies :~%~{~<~%~:; ~S~>~^~}")
  12326.                                  (nreverse unknown-vars)
  12327.                     ) )
  12328.                     (when too-late-vars
  12329.                       (c-comment (DEUTSCH "~%Folgende Special-Variablen wurden zu spΣt definiert:~%~{~<~%~:; ~S~>~^~}"
  12330.                                   ENGLISH "~%The following special variables were defined too late:~%~{~<~%~:; ~S~>~^~}"
  12331.                                   FRANCAIS "~%Les variables dΘclarΘes SPECIAL sont dΘfinies trop tard :~%~{~<~%~:; ~S~>~^~}")
  12332.                                  (nreverse too-late-vars)
  12333.                 ) ) ) )
  12334.                 (c-comment "~%")
  12335.                 (setq compilation-successful
  12336.                   (zerop *error-count*) ; Wert T, falls Compilation erfolgreich
  12337.             ) ) )
  12338.             (when new-output-stream
  12339.               (close *fasoutput-stream*) (close *liboutput-stream*)
  12340.               (unless compilation-successful
  12341.                 (delete-file output-file) (delete-file liboutput-file)
  12342.             ) )
  12343.         ) )
  12344.         (when new-listing-stream (close listing-stream))
  12345. ) ) ) )
  12346.  
  12347. ; Das mu▀ mit compile-file (s.o.) konsistent sein!
  12348. (defun compile-file-pathname (file &key (output-file 'T) listing warnings verbose print)
  12349.   (declare (ignore listing warnings verbose print))
  12350.   (setq file (or (first (search-file file *source-file-types*))
  12351.                  (merge-pathnames file (merge-pathnames '#".lsp"))
  12352.   )          )
  12353.   (when (and output-file (not (streamp output-file)))
  12354.     (setq output-file (if (eq output-file 'T)
  12355.                         (merge-pathnames '#".fas" file)
  12356.                         (merge-pathnames output-file)
  12357.     )                 )
  12358.   )
  12359.   output-file
  12360. )
  12361.  
  12362. (defun disassemble-closures (closure stream)
  12363.   (let ((closures '()))
  12364.     (labels ((mark (cl) ; trΣgt eine Closure cl (rekursiv) in closures ein.
  12365.                (push cl closures) ; cl markieren
  12366.                (dolist (c (closure-consts cl)) ; und alle Teil-Closures
  12367.                  (when #+CLISP (and (sys::closurep c) (compiled-function-p c))
  12368.                        #-CLISP (closure-p c)
  12369.                    (unless (member c closures) (mark c)) ; ebenfalls markieren
  12370.             )) ) )
  12371.       (mark closure) ; Haupt-Closure markieren
  12372.     )
  12373.     (dolist (c (nreverse closures)) ; alle Closures disassemblieren
  12374.       (disassemble-closure c stream)
  12375. ) ) )
  12376.  
  12377. #-CLISP
  12378. (defun disassemble-closure (closure &optional (stream *standard-output*))
  12379.   (format stream (DEUTSCH "~%~%Disassembly von Funktion ~S"
  12380.                   ENGLISH "~%~%Disassembly of function ~S"
  12381.                   FRANCAIS "~%~%DΘassemblage de la fonction ~S")
  12382.                  (closure-name closure)
  12383.   )
  12384.   (multiple-value-bind (req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p
  12385.                         byte-list const-list)
  12386.       (signature closure)
  12387.     (do ((L const-list (cdr L))
  12388.          (i 0 (1+ i)))
  12389.         ((null L))
  12390.       (format stream "~%(CONST ~S) = ~S" i (car L))
  12391.     )
  12392.     (format stream (DEUTSCH "~%~S notwendige Argumente"
  12393.                     ENGLISH "~%~S required arguments"
  12394.                     FRANCAIS "~%~S arguments nΘcessaires")
  12395.                    req-anz
  12396.     )
  12397.     (format stream (DEUTSCH "~%~S optionale Argumente"
  12398.                     ENGLISH "~%~S optional arguments"
  12399.                     FRANCAIS "~%~S arguments facultatifs")
  12400.                    opt-anz
  12401.     )
  12402.     (format stream (DEUTSCH "~%~:[Kein Rest-Parameter~;Rest-Parameter vorhanden~]"
  12403.                     ENGLISH "~%~:[No rest parameter~;Rest parameter~]"
  12404.                     FRANCAIS "~%~:[Pas de paramΦtre &REST~;ParamΦtre &REST~]")
  12405.                    rest-p
  12406.     )
  12407.     (if key-p
  12408.       (let ((kw-count (length keyword-list)))
  12409.         (format stream (DEUTSCH "~%~S Keyword-Parameter: ~{~S~^, ~}."
  12410.                         ENGLISH "~%~S keyword parameter~:P: ~{~S~^, ~}."
  12411.                         FRANCAIS "~%~S Mot~:P-clΘ : ~{~S~^, ~}.")
  12412.                        kw-count keyword-list
  12413.         )
  12414.         (when allow-other-keys-p
  12415.           (format stream (DEUTSCH "~%Andere Keywords sind zugelassen."
  12416.                           ENGLISH "~%Other keywords are allowed."
  12417.                           FRANCAIS "~%D'autres mots-clΘ sont permis.")
  12418.       ) ) )
  12419.       (format stream (DEUTSCH "~%Keine Keyword-Parameter"
  12420.                       ENGLISH "~%No keyword parameters"
  12421.                       FRANCAIS "~%Pas de mot-clΘ")
  12422.     ) )
  12423.     (let ((const-string-list (mapcar #'write-to-string const-list)))
  12424.       (do ((L (disassemble-LAP byte-list const-list) (cdr L)))
  12425.           ((null L))
  12426.         (let ((PC (caar L))
  12427.               (instr (cdar L)))
  12428.           (format stream "~%~S~6T~A" PC instr)
  12429.           (multiple-value-bind ... ; siehe unten
  12430.             ...
  12431.     ) ) ) )
  12432.     (format stream "~%")
  12433. ) )
  12434. #+CLISP
  12435. (defun disassemble-closure (closure &optional (stream *standard-output*))
  12436.   (terpri stream)
  12437.   (terpri stream)
  12438.   (write-string (DEUTSCH "Disassembly von Funktion "
  12439.                  ENGLISH "Disassembly of function "
  12440.                  FRANCAIS "DΘassemblage de la fonction ")
  12441.                 stream
  12442.   )
  12443.   (prin1 (closure-name closure) stream)
  12444.   (multiple-value-bind (req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p
  12445.                         byte-list const-list)
  12446.       (signature closure)
  12447.     (do ((L const-list (cdr L))
  12448.          (i 0 (1+ i)))
  12449.         ((null L))
  12450.       (terpri stream)
  12451.       (write-string "(CONST " stream)
  12452.       (prin1 i stream)
  12453.       (write-string ") = " stream)
  12454.       (prin1 (car L) stream)
  12455.     )
  12456.     (terpri stream)
  12457.     (prin1 req-anz stream)
  12458.     (write-string (DEUTSCH " notwendige Argumente"
  12459.                    ENGLISH " required arguments"
  12460.                    FRANCAIS " arguments nΘcessaires")
  12461.                   stream
  12462.     )
  12463.     (terpri stream)
  12464.     (prin1 opt-anz stream)
  12465.     (write-string (DEUTSCH " optionale Argumente"
  12466.                    ENGLISH " optional arguments"
  12467.                    FRANCAIS " arguments facultatifs")
  12468.                   stream
  12469.     )
  12470.     (terpri stream)
  12471.     (if rest-p
  12472.       (write-string (DEUTSCH "Rest-Parameter vorhanden"
  12473.                      ENGLISH "Rest parameter"
  12474.                      FRANCAIS "ParamΦtre &REST")
  12475.                     stream
  12476.       )
  12477.       (write-string (DEUTSCH "Kein Rest-Parameter"
  12478.                      ENGLISH "No rest parameter"
  12479.                      FRANCAIS "Pas de paramΦtre &REST")
  12480.                     stream
  12481.     ) )
  12482.     (if key-p
  12483.       (let ((kw-count (length keyword-list)))
  12484.         (terpri stream)
  12485.         (prin1 kw-count stream)
  12486.         (language-case
  12487.           (DEUTSCH (write-string " Keyword-Parameter: " stream))
  12488.           (ENGLISH (write-string " keyword parameter" stream)
  12489.                    (unless (eql kw-count 1) (write-string "s" stream))
  12490.                    (write-string ": " stream)
  12491.           )
  12492.           (FRANCAIS (write-string " mot" stream)
  12493.                     (unless (eql kw-count 1) (write-string "s" stream))
  12494.                     (write-string "-clΘ" stream)
  12495.         ) )
  12496.         (do ((L keyword-list))
  12497.             ((endp L))
  12498.           (prin1 (pop L) stream)
  12499.           (if (endp L) (write-string "." stream) (write-string ", " stream))
  12500.         )
  12501.         (when allow-other-keys-p
  12502.           (terpri stream)
  12503.           (write-string (DEUTSCH "Andere Keywords sind zugelassen."
  12504.                          ENGLISH "Other keywords are allowed."
  12505.                          FRANCAIS "D'autres mots-clΘ sont permis.")
  12506.                         stream
  12507.       ) ) )
  12508.       (progn
  12509.         (terpri stream)
  12510.         (write-string (DEUTSCH "Keine Keyword-Parameter"
  12511.                        ENGLISH "No keyword parameters"
  12512.                        FRANCAIS "Pas de mot-clΘ")
  12513.                       stream
  12514.     ) ) )
  12515.     (let ((const-string-list
  12516.             (mapcar #'(lambda (x) (sys::write-to-short-string x 35)) const-list)
  12517.          ))
  12518.       (do ((L (disassemble-LAP byte-list const-list) (cdr L)))
  12519.           ((null L))
  12520.         (let ((PC (caar L))
  12521.               (instr (cdar L)))
  12522.           (terpri stream)
  12523.           (prin1 PC stream)
  12524.           (dotimes (i (- 6 (sys::line-position stream))) (write-char #\Space stream)) ; Tab 6
  12525.           (princ instr stream) ; instr ausgeben, Symbole ohne Package-Marker!
  12526.           (multiple-value-bind (commentp comment)
  12527.             (when (consp instr)
  12528.               (case (first instr)
  12529.                 ((CALLS1 CALLS1&PUSH CALLS1&STORE CALLS1&JMPIFNOT CALLS1&JMPIF)
  12530.                   (values t (%funtabref (second instr)))
  12531.                 )
  12532.                 ((CALLS2 CALLS2&PUSH CALLS2&STORE CALLS2&JMPIFNOT CALLS2&JMPIF)
  12533.                   (values t (%funtabref (+ 256 (second instr))))
  12534.                 )
  12535.                 ((CALLSR CALLSR&PUSH CALLSR&STORE CALLSR&JMPIFNOT CALLSR&JMPIF)
  12536.                   (values t (%funtabref (+ funtabR-index (third instr))))
  12537.                 )
  12538.                 ((CALL CALL&PUSH)
  12539.                   (values 'string (nth (third instr) const-string-list))
  12540.                 )
  12541.                 ((CALL0 CALL1 CALL1&PUSH CALL1&JMPIFNOT CALL1&JMPIF
  12542.                   CALL2 CALL2&PUSH CALL2&JMPIFNOT CALL2&JMPIF
  12543.                   JMPIFEQTO JMPIFNOTEQTO CONST CONST&PUSH SETVALUE GETVALUE
  12544.                   GETVALUE&PUSH BIND CONST&STORE CONST&SYMBOL-FUNCTION&PUSH
  12545.                   CONST&SYMBOL-FUNCTION COPY-CLOSURE&PUSH COPY-CLOSURE
  12546.                   CONST&SYMBOL-FUNCTION&STORE TAGBODY-OPEN HANDLER-OPEN
  12547.                  )
  12548.                   (values 'string (nth (second instr) const-string-list))
  12549.             ) ) )
  12550.             (when commentp
  12551.               (dotimes (i (max 1 (- 42 (sys::line-position stream)))) (write-char #\Space stream)) ; Tab 42
  12552.               (write-string "; " stream)
  12553.               (if (eq commentp 'string)
  12554.                 (write-string comment stream)
  12555.                 (prin1 comment stream)
  12556.     ) ) ) ) ) )
  12557.     (terpri stream)
  12558. ) )
  12559.  
  12560. #-CROSS
  12561. (defun disassemble (object &aux name)
  12562.   (when (function-name-p object)
  12563.     (unless (fboundp object)
  12564.       (error-of-type 'undefined-function
  12565.         :name object
  12566.         (DEUTSCH "Funktion ~S ist undefiniert."
  12567.          ENGLISH "Undefined function ~S"
  12568.          FRANCAIS "Fonction non-dΘfinie ~S")
  12569.         object
  12570.     ) )
  12571.     (setq name object)
  12572.     (setq object (get-funname-symbol object))
  12573.     (setq object (or (get object 'sys::traced-definition)
  12574.                      (symbol-function object)
  12575.   ) )            )
  12576.   (when (and (consp object) (eq (car object) 'system::macro))
  12577.     (setq object (cdr object))
  12578.   )
  12579.   (unless (sys::closurep object)
  12580.     (error-of-type 'error
  12581.       (DEUTSCH "~S kann nicht disassembliert werden."
  12582.        ENGLISH "Cannot disassemble ~S"
  12583.        FRANCAIS "Impossible de dΘassembler ~S")
  12584.       object
  12585.   ) )
  12586.   ; object ist eine Closure.
  12587.   (unless (compiled-function-p object)
  12588.     (setq object
  12589.       (compile-lambda (sys::%record-ref object 0) ; name
  12590.                       (sys::%record-ref object 1) ; lambdabody
  12591.                       (sys::%record-ref object 4) ; venv
  12592.                       (sys::%record-ref object 5) ; fenv
  12593.                       (sys::%record-ref object 6) ; benv
  12594.                       (sys::%record-ref object 7) ; genv
  12595.                       (sys::%record-ref object 8) ; denv
  12596.   ) ) )
  12597.   ; object ist eine compilierte Closure.
  12598.   (disassemble-closure object) ; Disassemblieren
  12599.   object ; compilierte Closure als Wert
  12600. )
  12601.