home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / compiler.lsp < prev    next >
Lisp/Scheme  |  1977-12-31  |  566KB  |  13,185 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.         (multiple-value-bind (macrop expansion)
  99.             (venv-search-macro form (svref env 0))
  100.           (if macrop
  101.             (values expansion t)
  102.             (values form nil)
  103.         ) )
  104.         (values form nil)
  105.   ) ) )
  106.   (defun macroexpand (form &optional (env (vector nil nil)))
  107.     (multiple-value-bind (a b) (macroexpand-1 form env)
  108.       (if b
  109.         (loop
  110.           (multiple-value-setq (a b) (macroexpand-1 a env))
  111.           (unless b (return (values a t)))
  112.         )
  113.         (values form nil)
  114.   ) ) )
  115.   (defun parse-body (body &optional docstring-allowed env)
  116.     (do ((bodyr body (cdr bodyr))
  117.          (declarations nil)
  118.          (docstring nil)
  119.          (form nil))
  120.         ((null bodyr) (values bodyr declarations docstring))
  121.       (cond ((and (stringp (car bodyr)) (cdr bodyr) (null docstring) docstring-allowed)
  122.              (setq docstring (car bodyr))
  123.             )
  124.             ((not (listp (setq form (macroexpand (car bodyr) env))))
  125.              (return (values bodyr declarations docstring))
  126.             )
  127.             ((eq (car form) 'DECLARE)
  128.              (dolist (decl (cdr form)) (push decl declarations))
  129.             )
  130.             (t (return (values bodyr declarations docstring)))
  131.   ) ) )
  132.   (defstruct (load-time-eval
  133.               (:print-function
  134.                 (lambda (object stream depth)
  135.                   (declare (ignore depth))
  136.                   (write-string "#." stream)
  137.                   (write (load-time-eval-form object) :stream stream)
  138.               ) )
  139.               (:constructor make-load-time-eval (form))
  140.              )
  141.     form
  142.   )
  143.   (defstruct (symbol-macro (:constructor make-symbol-macro (expansion)))
  144.     expansion
  145.   )
  146.   (defun symbol-macro-expand (v)
  147.     (and (boundp v) (symbol-macro-p (symbol-value v))
  148.          (values t (symbol-macro-expansion (symbol-value v)))
  149.   ) )
  150.   (defun fixnump (object) (typep object 'FIXNUM))
  151.   (defun short-float-p (object) (typep object 'SHORT-FLOAT))
  152.   (defun single-float-p (object) (typep object 'SINGLE-FLOAT))
  153.   (defun double-float-p (object) (typep object 'DOUBLE-FLOAT))
  154.   (defun long-float-p (object) (typep object 'LONG-FLOAT))
  155.   ; Sucht ein Programm-File. Siehe INIT.LSP :
  156.   (defun search-file (filename extensions
  157.                       &aux (use-extensions (null (pathname-type filename))) )
  158.     (when use-extensions
  159.       (setq extensions ; Case-Konversionen auf den Extensions durchführen
  160.         (mapcar #'pathname-type extensions)
  161.     ) )
  162.     ; Defaults einmergen:
  163.     (setq filename (merge-pathnames filename '#".*"))
  164.     ; Suchen:
  165.     (let ((already-searched nil))
  166.       (dolist (dir (cons '#"" '()))
  167.         (let ((search-filename
  168.                 (merge-pathnames (merge-pathnames filename dir))
  169.              ))
  170.           (unless (member search-filename already-searched :test #'equal)
  171.             (let ((xpathnames (directory search-filename :full t :circle t)))
  172.               (when use-extensions
  173.                 ; nach passenden Extensions filtern:
  174.                 (setq xpathnames
  175.                   (delete-if-not ; hat xpathname eine der gegebenen Extensions?
  176.                     #'(lambda (xpathname)
  177.                         (member (pathname-type (first xpathname)) extensions
  178.                                 :test #'string=
  179.                       ) )
  180.                     xpathnames
  181.               ) ) )
  182.               (when xpathnames
  183.                 ; nach Datum sortiert, zurückgeben:
  184.                 (dolist (xpathname xpathnames)
  185.                   (setf (rest xpathname)
  186.                         (apply #'encode-universal-time (third xpathname))
  187.                 ) )
  188.                 (return (mapcar #'first (sort xpathnames #'> :key #'rest)))
  189.             ) )
  190.             (push search-filename already-searched)
  191.       ) ) )
  192.   ) )
  193.   (defun make-macro-expander (macrodef)
  194.     (let ((dummysym (make-symbol (symbol-name (car macrodef)))))
  195.       (eval `(DEFMACRO ,dummysym ,@(cdr macrodef)))
  196.       #'(lambda (form &rest env)
  197.           (apply #'lisp:macroexpand-1 (cons dummysym (cdr form)) env)
  198.         )
  199.   ) )
  200.   ; siehe DEFS1.LSP :
  201.   (defun date-format ()
  202.     #L{
  203.     DEUTSCH "~1{~3@*~D.~4@*~D.~5@*~D ~2@*~2,'0D:~1@*~2,'0D:~0@*~2,'0D~:}"
  204.     ENGLISH "~1{~5@*~D/~4@*~D/~3@*~D ~2@*~2,'0D.~1@*~2,'0D.~0@*~2,'0D~:}"
  205.     FRANCAIS "~1{~3@*~D/~4@*~D/~5@*~D ~2@*~2,'0D:~1@*~2,'0D:~0@*~2,'0D~:}"
  206.     }
  207.  
  208. }
  209.  
  210.   )
  211.   (defun sys::line-number (stream) nil)
  212. )
  213.  
  214.  
  215. ; Version des Evaluators:
  216. ; CLISP2 : C-Version mit SP-Manipulierbarkeit
  217. ; CLISP3 : C-Version ohne SP-Manipulierbarkeit
  218. #+(and CROSS (not (or CLISP2 CLISP3)))
  219. (eval-when (eval load compile)
  220.   (pushnew
  221.     (if (y-or-n-p 
  222.          #L{
  223.          DEUTSCH "Kann man von C aus den SP verändern?"
  224.          ENGLISH "Can C manipulate the SP stack pointer?"
  225.          FRANCAIS "Peut-on modifier le pointeur de pile en C?"
  226.          }
  227.         )
  228.       'CLISP2
  229.       'CLISP3
  230.     )
  231.     *features*
  232. ) )
  233. #+CROSS
  234. (defconstant *jmpbuf-size*
  235.   (progn
  236.     (format *query-io* 
  237.             #L{
  238.             DEUTSCH "~%Bitte *jmpbuf-size* eingeben: "
  239.             ENGLISH "~%Please input *jmpbuf-size*: "
  240.             FRANCAIS "~%Veuillez entrer *jmpbuf-size* :"
  241.             }
  242.     )
  243.     (read *query-io*)
  244. ) )
  245. #+CROSS
  246. (defconstant *big-endian*
  247.   #+(or AMIGA SUN3 SUN4) t ; BIG-ENDIAN-Prozessor
  248.   #+(or SUN386 PC386) nil ; LITTLE-ENDIAN-Prozessor
  249.   #-(or AMIGA SUN3 SUN4 SUN386 PC386)
  250.     (y-or-n-p 
  251.      #L{
  252.      DEUTSCH "Prozessor BIG-ENDIAN?"
  253.      ENGLISH "processor big endian?"
  254.      FRANCAIS "Processeur BIG-ENDIAN?"
  255.      }
  256.     )
  257. )
  258. #+CROSS
  259. (defun version ()
  260.   (list ' #+CLISP2 SYSTEM::CLISP2 #+CLISP3 SYSTEM::CLISP3
  261.         *jmpbuf-size*
  262.         *big-endian*
  263.         '130695
  264. ) )
  265.  
  266. (defconstant *keyword-package* (find-package "KEYWORD"))
  267. (defconstant *lisp-package* (find-package "LISP"))
  268.  
  269. ; Variablen für Top-Level-Aufruf:
  270. (defvar *compiling* nil) ; gibt an, ob gerade beim Compilieren
  271. ; (defvar *error-count*) ; Anzahl der aufgetretenen Errors
  272. ; (defvar *warning-count*) ; Anzahl der aufgetretenen Warnungen
  273. (defvar *compile-warnings* t) ; ob Compiler-Warnungen ausgegeben werden
  274. (defvar *compile-verbose* t) ; ob Compiler-Kommentare ausgegeben werden
  275. (defvar *compile-print* nil) ; ob der Compiler ausgibt, wo er gerade ist
  276. (defvar *compiling-from-file*) ; NIL oder T wenn von COMPILE-FILE aufgerufen
  277. (defvar *compile-file-pathname* nil) ; CLtL2 S. 680
  278. (defvar *compile-file-truename* nil) ; CLtL2 S. 680
  279. (defvar *compile-file-lineno1* nil)
  280. (defvar *compile-file-lineno2* nil)
  281. (defvar *c-listing-output*) ; Compiler-Listing-Stream oder nil
  282. (defvar *c-error-output*) ; Compiler-Error-Stream
  283. ; Es ist im wesentlichen
  284. ; *c-error-output* = (make-broadcast-stream *error-output* *c-listing-output*)
  285. (defvar *known-special-vars*) ; Namen von deklarierten dynamischen Variablen
  286. (defvar *constant-special-vars*) ; Namen und Werte von konstanten Variablen
  287.  
  288. ; Variablen für COMPILE-FILE:
  289. (defvar *fasoutput-stream* nil) ; Compiler-Output-Stream oder nil
  290. (defvar *liboutput-stream* nil) ; Compiler-Library-Stream oder nil
  291. (defvar *coutput-file* nil) ; Compiler-C-Output-File oder nil
  292. (defvar *coutput-stream* nil) ; Compiler-C-Output-Stream oder nil
  293. (defvar *functions-with-errors* nil) ; Namen der Funktionen, wo es Fehler gab
  294. (defvar *known-functions*) ; Namen der bisher bekannten Funktionen,
  295.                            ; wird vom Macroexpander von DEFUN verändert
  296. (defvar *unknown-functions*) ; Namen der bisher unbekannten Funktionen
  297. (defvar *unknown-free-vars*) ; Namen von undeklarierten dynamischen Variablen
  298. (defvar *inline-functions*) ; global inline-deklarierte Funktionssymbole
  299. (defvar *notinline-functions*) ; global notinline-deklarierte Funktionssymbole
  300. (defvar *inline-definitions*) ; Aliste globaler inlinebarer Funktionsdefinitionen
  301. (defvar *user-declaration-types*) ; global definierte zusätzliche Deklarationen
  302. (defvar *compiled-modules*) ; bereits "geladene" (compilierte) Modulnamen
  303. (defvar *package-tasks*) ; noch durchzuführende Package-Anforderungen
  304. (defvar *ffi-module* nil) ; Daten, die das FFI ansammelt
  305.  
  306. #|
  307. Basis für den Zielcode ist eine Stackmaschine mit zwei Stacks:
  308. STACK (Stack für LISP-Objekte und Frames) und SP (Stack für sonstiges).
  309. Mehrfache Werte werden kurzfristig in A0/A1/A2/MV_SPACE (D7.W Werte, bei D7.W=0
  310. ist A0=NIL) gehalten, längerfristig auf dem STACK abgelegt.
  311.  
  312. 1. Pass des Compilers:
  313. Macro-Expansion, Codegenerierung (symbolisch), Allokation von Variablen auf
  314. dem STACK oder in Closures, Optimierung auf LISP-Ebene.
  315. Danach steht für jede beteiligte Funktion das Stack-Layout fest.
  316. Die Information steckt in einem Netz von ANODEs.
  317. 2. Pass des Compilers:
  318. Auflösung der Variablenbezüge, Optimierung auf Code-Ebene
  319. (Peephole-Optimierung), Kreation compilierter funktionaler Objekte.
  320. 3. Pass des Compilers:
  321. Auflösung von Bezügen zwischen den einzelnen funktionalen Objekten.
  322.  
  323. Zielsprache:
  324. ============
  325.  
  326. ein Bytecode-Interpreter.
  327.  
  328. Ein compiliertes funktionales Objekt (Closure) hat folgenden Aufbau:
  329. FUNC = #Closure( Name
  330.                  CODEVEC
  331.                  [VenvConst] {BlockConst}* {TagbodyConst}*
  332.                  {Keyword}* {sonstige Const}*
  333.                )
  334.  
  335. VenvConst, BlockConst, TagbodyConst : diese LISP-Objekte werden innerhalb der
  336. Funktion als Konstanten betrachtet. Sie werden beim Aufbau der Funktion zur
  337. Laufzeit mitgegeben. Sollten diese drei Teile fehlen (d.h. diese Funktion ist
  338. von der Inkarnation unabhängig, weil sie auf keine lexikalischen Variablen,
  339. Blocks oder Tags zugreift, die im compilierten Code außerhalb von ihr definiert
  340. werden), so heißt die Funktion autonom.
  341.  
  342. Keyword : die Keywords in der richtigen Reihenfolge. Werden vom Interpreter bei
  343. der Parameterübergabe gebraucht.
  344.  
  345. sonstige Const: sonstige Konstanten, auf die vom Innern der Funktion aus Bezug
  346. genommen wird. Sie sind untereinander und zu allen Keywords paarweise nicht EQL.
  347.  
  348. CODEVEC = Code-Vektor, ein SIMPLE-BIT-VECTOR,
  349.                  Falls nicht FAST_SP:
  350.                    2 Bytes : maximale SP-Tiefe
  351.                  2 Bytes : Anzahl der required parameter
  352.                  2 Bytes : Anzahl der optionalen Parameter
  353.                  1 Byte : Flags. Bit 0: ob &REST - Parameter angegeben
  354.                                  Bit 7: ob Keyword-Parameter angegeben
  355.                                  Bit 6: &ALLOW-OTHER-KEYS-Flag
  356.                                  Bit 4: ob generische Funktion
  357.                  1 Byte : Kürzel für den Argumenttyp, für schnelleres FUNCALL
  358.                  Falls Keyword-Parameter angegeben:
  359.                    4 Bytes : 2 Bytes : Anzahl der Keyword-Parameter
  360.                              2 Bytes : Offset in FUNC der Keywords
  361.                  dann
  362.                  eine Folge von Byte-Instruktionen.
  363.  
  364. |#
  365. ; externe Repräsentation einer Closure:
  366. ; #Y(name
  367. ;    #LängeY(Byte in Hex ... Byte in Hex)
  368. ;    weitere Konstanten
  369. ;   )
  370.  
  371. #-CLISP
  372. (progn
  373.   (defstruct (closure (:print-function print-closure))
  374.     name    ; der Name der Closure
  375.     codevec ; Liste der Bytes des Codevektor
  376.     consts  ; Liste der Konstanten
  377.   )
  378.   (defun print-closure (closure stream depth)
  379.     (declare (ignore depth))
  380.     (write-string "#Y(" stream)
  381.     (write (closure-name closure) :stream stream)
  382.     (write-char #\space stream)
  383.     (write-char #\# stream)
  384.     (write (length (closure-codevec closure)) :stream stream :base 10. :radix nil :readably nil)
  385.     (write-char #\Y stream)
  386.     ;(write (closure-codevec closure) :stream stream :base 16.) ; stattdessen:
  387.     (write-char #\( stream)
  388.     (do ((i 0 (1- i))
  389.          (L (closure-codevec closure) (cdr L)))
  390.         ((endp L))
  391.       (when (zerop i) (write-char #\newline stream) (setq i 25))
  392.       (write-char #\space stream)
  393.       (write (car L) :stream stream :base 16. :radix nil :readably nil)
  394.     )
  395.     (write-char #\) stream)
  396.     (write-char #\newline stream)
  397.     (dolist (x (closure-consts closure))
  398.       (write-char #\space stream)
  399.       (write x :stream stream)
  400.     )
  401.     (write-char #\) stream)
  402.   )
  403. )
  404.  
  405. #+CLISP
  406. (progn
  407.   (defsetf sys::%record-ref sys::%record-store)
  408.   (defsetf closure-name (closure) (new-name)
  409.     `(sys::%record-store ,closure 0 ,new-name)
  410.   )
  411.   (defun make-closure (&key name codevec consts)
  412.     (sys::%make-closure name (sys::make-code-vector codevec) consts)
  413.   )
  414. )
  415.  
  416. #-CLISP
  417. (set-dispatch-macro-character #\# #\Y
  418.   #'(lambda (stream subchar arg)
  419.       (declare (ignore subchar))
  420.       (if arg
  421.         ; Codevector lesen
  422.         (let ((obj (let ((*read-base* 16.)) (read stream t nil t))))
  423.           (unless (= (length obj) arg)
  424.             (error 
  425.              #L{
  426.              DEUTSCH "Falsche Länge eines Closure-Vektors: ~S"
  427.              ENGLISH "Bad length of closure vector: ~S"
  428.              FRANCAIS "Mauvaise longueur pour un vecteur de fermeture : ~S"
  429.              }
  430.              arg
  431.           ) )
  432.           obj
  433.         )
  434.         ; Closure lesen
  435.         (let ((obj (read stream t nil t)))
  436.           (make-closure :name (first obj) :codevec (second obj) :consts (cddr obj))
  437.     ) ) )
  438. )
  439.  
  440. #|
  441. Instruktionen:
  442. Instruktionen können Operanden haben.
  443. Operanden, die Sprungziele (labels) darstellen, sind (um Codelänge zu sparen)
  444. relativ angegeben:
  445.     PC := PC(in der Instruktion) + Operand(signed)
  446. Operanden, die Zahlen darstellen, sind Integers >=0.
  447. Format der Operanden:
  448. bei LOAD, ... mit kleinem Operanden: implizit im Code.
  449. bei allen anderen Instruktionen:
  450.   nächstes Byte:
  451.     Bit 7 = 0 --> Bits 6..0 sind der Operand (7 Bits).
  452.     Bit 7 = 1 --> Bits 6..0 und nächstes Byte bilden den Operanden (15 Bits).
  453.                   Bei Sprungdistanzen: Sollte dieser =0 sein, so bilden
  454.                   die nächsten 4 Bytes den Operanden (32 Bits).
  455.  
  456.  
  457. (1) Instruktionen für Konstanten:
  458.  
  459. Mnemonic                      Bedeutung
  460.  
  461. (NIL)                         A0 := NIL, 1 Wert
  462.  
  463. (PUSH-NIL n)                  n-mal: -(STACK) := NIL, undefinierte Werte
  464.  
  465. (T)                           A0 := T, 1 Wert
  466.  
  467. (CONST n)                     A0 := Konstante Nr. n aus FUNC, 1 Wert
  468.  
  469.  
  470. (2) Instruktionen für statische Variablen
  471.  
  472. Mnemonic                      Bedeutung
  473.  
  474. (LOAD n)                      A0 := (STACK+4*n), 1 Wert
  475.  
  476. (LOADI k n)                   A0 := ((SP+4*k)+4*n), 1 Wert
  477.  
  478. (LOADC n m)                   A0 := (svref (STACK+4*n) 1+m), 1 Wert
  479.  
  480. (LOADV k m)                   A0 := (svref ... m)
  481.                                     (svref ... 0) ; k mal wiederholt
  482.                                     VenvConst,
  483.                               1 Wert
  484.  
  485. (LOADIC k n m)                A0 := (svref ((SP+4*k)+4*n) 1+m), 1 Wert
  486.  
  487. (STORE n)                     (STACK+4*n) := A0, 1 Wert
  488.  
  489. (STOREI k n)                  ((SP+4*k)+4*n) := A0, 1 Wert
  490.  
  491. (STOREC n m)                  (svref (STACK+4*n) 1+m) := A0, 1 Wert
  492.  
  493. (STOREV k m)                  (svref ... m)
  494.                               (svref ... 0) ; k mal wiederholt
  495.                               VenvConst
  496.                               := A0, 1 Wert
  497.  
  498. (STOREIC k n m)               (svref ((SP+4*k)+4*n) 1+m) := A0, 1 Wert
  499.  
  500.  
  501. (3) Instruktionen für dynamische Variablen
  502.  
  503. Mnemonic                      Bedeutung
  504.  
  505. (GETVALUE n)                  A0 := (symbol-value (CONST n)), 1 Wert
  506.  
  507. (SETVALUE n)                  (setf (symbol-value (CONST n)) A0), 1 Wert
  508.  
  509. (BIND n)                      bindet (CONST n), ein Symbol, dynamisch an A0.
  510.                               Undefinierte Werte.
  511.  
  512. (UNBIND1)                     löst einen Bindungsframe auf
  513. (UNBIND n)                    löst n Bindungsframes auf
  514.  
  515. (PROGV)                       bindet dynamisch die Symbole in der Liste
  516.                               (STACK)+ an die Werte in der Liste A0 und baut
  517.                               dabei genau einen Bindungsframe auf,
  518.                               undefinierte Werte
  519.  
  520.  
  521. (4) Instruktionen für Stackoperationen
  522.  
  523. Mnemonic                      Bedeutung
  524.  
  525. (PUSH)                        -(STACK) := A0, undefinierte Werte
  526.  
  527. (POP)                         A0 := (STACK)+, 1 Wert
  528.  
  529. (SKIP n)                      STACK := STACK+4*n
  530.  
  531. (SKIPI k n)                   STACK := (SP+4*k)+4*n, SP:=SP+4*(k+1)
  532.  
  533. (SKIPSP k)                    SP := SP+4*k
  534.  
  535.  
  536. (5) Instruktionen für Programmfluß und Sprünge
  537.  
  538. Mnemonic                      Bedeutung
  539.  
  540. (SKIP&RET n)                  STACK := STACK+4*n, beendet die Funktion
  541.                               mit den Werten A0/...
  542.  
  543. (JMP label)                   Sprung zu label
  544.  
  545. (JMPIF label)                 falls A0 /= NIL : Sprung zu label.
  546.  
  547. (JMPIFNOT label)              falls A0 = NIL : Sprung zu label.
  548.  
  549. (JMPIF1 label)                falls A0 /= NIL : 1 Wert, Sprung zu label.
  550.  
  551. (JMPIFNOT1 label)             falls A0 = NIL : 1 Wert, Sprung zu label.
  552.  
  553. (JMPIFATOM label)             falls A0 kein Cons : Sprung zu label.
  554.                               Undefinierte Werte.
  555.  
  556. (JMPIFCONSP label)            falls A0 ein Cons : Sprung zu label.
  557.                               Undefinierte Werte.
  558.  
  559. (JMPIFEQ label)               falls A0 EQ zu (STACK)+ : Sprung zu label.
  560.                               Undefinierte Werte.
  561.  
  562. (JMPIFNOTEQ label)            falls A0 nicht EQ zu (STACK)+ : Sprung zu label.
  563.                               Undefinierte Werte.
  564.  
  565. (JMPIFEQTO n label)           falls (STACK)+ EQ zu (CONST n) : Sprung zu label.
  566.                               Undefinierte Werte.
  567.  
  568. (JMPIFNOTEQTO n label)        falls (STACK)+ nicht EQ zu (CONST n) : Sprung zu label.
  569.                               Undefinierte Werte.
  570.  
  571. (JMPHASH n label)             Sucht A0 in der EQ- oder EQL-Hash-Tabelle
  572.                               (CONST n). Gefunden: Sprung ans von GETHASH
  573.                               gelieferte Label. Nicht gefunden: Sprung zu
  574.                               label. Undefinierte Werte.
  575.  
  576. (JMPHASHV n label)            Sucht A0 in der EQ- oder EQL-Hash-Tabelle
  577.                               (svref (CONST 0) n). Gefunden: Sprung ans von
  578.                               GETHASH gelieferte Label. Nicht gefunden: Sprung
  579.                               zu label. Undefinierte Werte.
  580.  
  581. (JSR label)                   Unterprogrammaufruf: lege Closure auf den STACK und
  582.                               springe zu label (mit undefinierten Werten),
  583.                               (RET) setzt das Programm an der Stelle nach
  584.                               dem (JSR label) fort.
  585.  
  586. (JMPTAIL m n label)           Wiederverwendung eines Stack-Frames: n>=m.
  587.                               Der Stack-Frame der Größe n wird auf Größe m
  588.                               verkleinert, indem die unteren m Einträge um
  589.                               n-m nach oben kopiert werden:
  590.                               (STACK+4*(n-m)...STACK+4*(n-1)) := (STACK+4*0...STACK+4*(m-1)),
  591.                               STACK := STACK + 4*(n-m),
  592.                               dann -(STACK) := Closure,
  593.                               Sprung zu label mit undefinierten Werten.
  594.  
  595.  
  596. (6) Instruktionen für Environments und Closures
  597.  
  598. Mnemonic                      Bedeutung
  599.  
  600. (VENV)                        A0 := VenvConst aus FUNC, 1 Wert
  601.  
  602. (MAKE-VECTOR1&PUSH n)         kreiert einen simple-vector mit n+1 (n>=0) Kom-
  603.                               ponenten und steckt A0 als Komponente 0 hinein.
  604.                               -(STACK) := der neue Vektor. Undefinierte Werte.
  605.  
  606. (COPY-CLOSURE m n)            kopiert die Closure (CONST m) aus FUNC und
  607.                               ersetzt in der Kopie für i=0,...,n-1 (n>0) die
  608.                               Komponente (CONST i) durch (STACK+4*(n-1-i)).
  609.                               STACK := STACK+4*n.
  610.                               A0 := Closure-Kopie, 1 Wert
  611.  
  612.  
  613. (7) Instruktionen für Funktionsaufrufe
  614.  
  615. Mnemonic                      Bedeutung
  616.  
  617. (CALL k n)                    ruft die Funktion (CONST n) mit k Argumenten
  618.                               (STACK+4*(k-1)),...,(STACK+4*0) auf,
  619.                               STACK:=STACK+4*k,
  620.                               Ergebnis kommt nach A0/...
  621.  
  622. (CALL0 n)                     ruft die Funktion (CONST n) mit 0 Argumenten
  623.                               auf, Ergebnis kommt nach A0/...
  624.  
  625. (CALL1 n)                     ruft die Funktion (CONST n) mit einem Argument
  626.                               (STACK)+ auf, Ergebnis kommt nach A0/...
  627.  
  628. (CALL2 n)                     ruft die Funktion (CONST n) mit zwei Argumenten
  629.                               4(STACK),(STACK) auf, STACK:=STACK+8,
  630.                               Ergebnis kommt nach A0/...
  631.  
  632. (CALLS1 n)                    ruft die Funktion (FUNTAB n)
  633. (CALLS2 n)                    bzw. (FUNTAB 256+n)
  634.                               (ein SUBR ohne Rest-Parameter) auf,
  635.                               mit der korrekten Argumentezahl auf dem STACK.
  636.                               STACK wird bereinigt, Ergebnis kommt nach A0/...
  637.  
  638. (CALLSR m n)                  ruft die Funktion (FUNTABR n)
  639.                               (ein SUBR mit Rest-Parameter) auf,
  640.                               mit der korrekten Argumentezahl und zusätzlich
  641.                               m restlichen Argumenten auf dem STACK.
  642.                               STACK wird bereinigt, Ergebnis kommt nach A0/...
  643.  
  644. (CALLC)                       ruft die Funktion A0 (eine compilierte Closure
  645.                               ohne Keyword-Parameter) auf. Argumente
  646.                               sind schon im richtigen Format auf dem STACK,
  647.                               STACK wird bereinigt, Ergebnis kommt nach A0/...
  648.  
  649. (CALLCKEY)                    ruft die Funktion A0 (eine compilierte Closure
  650.                               mit Keyword-Parameter) auf. Argumente
  651.                               sind schon im richtigen Format auf dem STACK,
  652.                               STACK wird bereinigt, Ergebnis kommt nach A0/...
  653.  
  654. (FUNCALL n)                   ruft die Funktion (STACK+4*n) mit n (n>=0)
  655.                               Argumenten (alle auf dem Stack) auf,
  656.                               STACK:=STACK+4*(n+1)
  657.                               Ergebnis kommt nach A0/...
  658.  
  659. (APPLY n)                     ruft die Funktion (STACK+4*n) mit n (n>=0)
  660.                               Argumenten (alle auf dem Stack) und weiteren
  661.                               Argumenten (Liste in A0) auf,
  662.                               STACK:=STACK+4*(n+1),
  663.                               Ergebnis kommt nach A0/...
  664.  
  665.  
  666. (8) Instruktionen für optionale und Keyword-Argumente
  667.  
  668. Mnemonic                      Bedeutung
  669.  
  670. (PUSH-UNBOUND n)              n-mal: -(STACK) := #<UNBOUND>, undefinierte Werte
  671.  
  672. (UNLIST n m)                  Liste A0 n mal verkürzen: -(STACK) := (car A0),
  673.                               A0 := (cdr A0). Bei den letzten m Mal darf A0
  674.                               schon zu Ende sein, dann -(STACK) := #<UNBOUND>
  675.                               stattdessen. Am Schluß muß A0 = NIL sein,
  676.                               undefinierte Werte. 0 <= m <= n.
  677.  
  678. (UNLIST* n m)                 Liste A0 n mal verkürzen: -(STACK) := (car A0),
  679.                               A0 := (cdr A0). Bei den letzten m Mal darf A0
  680.                               schon zu Ende sein, dann -(STACK) := #<UNBOUND>.
  681.                               stattdessen. Dann -(STACK) := (nthcdr n A0),
  682.                               undefinierte Werte. 0 <= m <= n, n > 0.
  683.  
  684. (JMPIFBOUNDP n label)         falls (STACK+4*n) /= #<UNBOUND> :
  685.                                 Sprung zu label, A0 := (STACK+4*n), 1 Wert.
  686.                               Sonst undefinierte Werte.
  687.  
  688. (BOUNDP n)                    A0 := (NIL falls (STACK+4*n)=#<UNBOUND>, T sonst), 1 Wert
  689.  
  690. (UNBOUND->NIL n)              Falls (STACK+4*n) = #<UNBOUND>: (STACK+4*n) := NIL
  691.  
  692.  
  693. (9) Instruktionen zur Behandlung mehrerer Werte
  694.  
  695. Mnemonic                      Bedeutung
  696.  
  697. (VALUES0)                     A0 := NIL, 0 Werte
  698.  
  699. (VALUES1)                     A0 := A0, 1 Wert
  700.  
  701. (STACK-TO-MV n)               holt n Werte von (STACK)+ herab,
  702.                               STACK:=STACK+4*n
  703.  
  704. (MV-TO-STACK)                 Multiple Values A0/A1/... auf -(STACK), 1. Wert
  705.                               zuoberst, STACK:=STACK-4*D7.W,
  706.                               danach undefinierte Werte
  707.  
  708. (NV-TO-STACK n)               die ersten n Werte (n>=0) auf -(STACK), 1. Wert
  709.                               zuoberst, STACK:=STACK-4*n, undefinierte Werte
  710.  
  711. (MV-TO-LIST)                  Multiple Values A0/... als Liste nach A0, 1 Wert
  712.  
  713. (LIST-TO-MV)                  A0/... := (values-list A0)
  714.  
  715. (MVCALLP)                     rette STACK auf -(SP), rette A0 auf -(STACK)
  716.  
  717. (MVCALL)                      führe einen Funktionsaufruf aus, wobei zwischen
  718.                               STACK und STACK:=(SP)+ die Funktion (ganz oben)
  719.                               und die Argumente stehen,
  720.                               Ergebnis kommt nach A0/...
  721.  
  722.  
  723. (10) Instruktionen für BLOCK
  724.  
  725. Mnemonic                      Bedeutung
  726.  
  727. (BLOCK-OPEN n label)          Legt einen Block-Cons (mit CAR=(CONST n) und
  728.                               CDR=Framepointer) auf -(STACK) ab, baut einen
  729.                               Block-Frame auf. Bei einem RETURN auf diesen
  730.                               Frame wird zu label gesprungen.
  731.  
  732. (BLOCK-CLOSE)                 Verlasse den Block und baue dabei einen Block-
  733.                               Frame ab (inklusive der Block-Cons-Variablen)
  734.  
  735. (RETURN-FROM n)               Verlasse den Block, dessen Block-Cons
  736.                               (CONST n) ist, mit den Werten A0/...
  737.  
  738. (RETURN-FROM-I k n)           Verlasse den Block, dessen Block-Cons
  739.                               ((SP+4*k)+4*n) ist, mit den Werten A0/...
  740.  
  741.  
  742. (11) Instruktionen für TAGBODY
  743.  
  744. Mnemonic                      Bedeutung
  745.  
  746. (TAGBODY-OPEN n label1 ... labelm)
  747.                               Legt einen Tagbody-Cons (mit CAR = (CONST n),
  748.                               einem Simple-Vector der Länge m, und
  749.                               CDR=Framepointer) auf -(STACK) ab, baut einen
  750.                               Tagbody-Frame auf. Bei einem GO mit Nummer l
  751.                               wird zu labell gesprungen. Undefinierte Werte.
  752.  
  753. (TAGBODY-CLOSE-NIL)           Verlasse den Tagbody und baue dabei einen
  754.                               Tagbody-Frame ab (inklusive der Tagbody-Cons-
  755.                               Variablen).
  756.                               A0 := NIL, 1 Wert
  757.  
  758. (TAGBODY-CLOSE)               Verlasse den Tagbody und baue dabei
  759.                               einen Tagbody-Frame ab (inklusive der
  760.                               Tagbody-Cons-Variablen).
  761.  
  762. (GO n l)                      Springe im Tagbody, dessen Tagbody-Cons
  763.                               (CONST n) ist, an Tag Nummer l
  764.  
  765. (GO-I k n l)                  Springe im Tagbody, dessen Tagbody-Cons
  766.                               ((SP+4*k)+4*n) ist, an Tag Nummer l
  767.  
  768.  
  769. (12) Instruktionen für CATCH und THROW
  770.  
  771. Mnemonic                      Bedeutung
  772.  
  773. (CATCH-OPEN label)            baut einen CATCH-Frame auf mit A0 als Tag;
  774.                               bei einem THROW auf dieses Tag wird zu label
  775.                               gesprungen
  776.  
  777. (CATCH-CLOSE)                 löst einen CATCH-Frame auf
  778.  
  779. (THROW)                       führt ein THROW auf den Catch-Tag (STACK)+ aus,
  780.                               mit den Werten A0/...
  781.  
  782.  
  783. (13) Instruktionen für UNWIND-PROTECT
  784.  
  785. Mnemonic                      Bedeutung
  786.  
  787. (UNWIND-PROTECT-OPEN label)   baut einen UNWIND-PROTECT-Frame auf;
  788.                               bei einem Unwind wird unter Rettung
  789.                               der Werte zu label gesprungen
  790.  
  791. (UNWIND-PROTECT-NORMAL-EXIT)  löst einen Unwind-Protect-Frame auf, schreibt
  792.                               eine Weitermach-Adresse auf SP, rettet die
  793.                               Werte und fängt an, den folgenden Cleanup-Code
  794.                               auszuführen
  795.  
  796. (UNWIND-PROTECT-CLOSE)        beendet den Cleanup-Code: schreibt die
  797.                               geretteten Werte zurück, führt ein RTS aus
  798.  
  799. (UNWIND-PROTECT-CLEANUP)      löst einen Unwind-Protect-Frame auf,
  800.                               schreibt eine Weitermach-Adresse und
  801.                               den PC auf SP, rettet die Werte und
  802.                               fängt an, den Cleanup-Code auszuführen
  803.  
  804.  
  805. (14) Instruktionen für HANDLER-BIND
  806.  
  807. Mnemonic                      Bedeutung
  808.  
  809. (HANDLER-OPEN n)              baut einen HANDLER-Frame auf; (CONST n) enthält
  810.                               die Condition-Typen, die entsprechenden Labels
  811.                               und die aktuelle SP-Tiefe
  812.  
  813. (HANDLER-BEGIN&PUSH)          beginnt einen Handler: stellt den SP-Zustand
  814.                               wie beim HANDLER-OPEN her,
  815.                               A0 := dem Handler übergebene Condition, 1 Wert,
  816.                               -(STACK) := A0
  817.  
  818.  
  819. (15) Kurz-Instruktionen für einige Funktionen
  820.  
  821. Mnemonic                      Bedeutung
  822.  
  823. (NOT)                         A0 := (not A0), 1 Wert
  824.  
  825. (EQ)                          A0 := (eq (STACK)+ A0), 1 Wert
  826.  
  827. (CAR)                         A0 := (car A0), 1 Wert
  828.  
  829. (CDR)                         A0 := (cdr A0), 1 Wert
  830.  
  831. (CONS)                        A0 := (cons (STACK)+ A0), 1 Wert
  832.  
  833. (SYMBOL-FUNCTION)             A0 := (symbol-function A0), 1 Wert
  834.  
  835. (SVREF)                       A0 := (svref (STACK)+ A0), 1 Wert
  836.  
  837. (SVSET)                       (setf (svref (STACK) A0) (STACK+4)),
  838.                               A0 := (STACK+4), 1 Wert, STACK:=STACK+8
  839.  
  840. (LIST n)                      Bildet eine Liste aus den untersten n auf dem STACK
  841.                               liegenden Objekten, STACK := STACK + 4*n,
  842.                               Liste nach A0, 1 Wert
  843.  
  844. (LIST* n)                     Bildet eine Liste aus den untersten n auf dem STACK
  845.                               liegenden Objekten und A0, STACK := STACK + 4*n,
  846.                               Liste nach A0, 1 Wert
  847.  
  848.  
  849. (16)
  850. Zusätzlich gibt es kombinierte Operationen im Format
  851. (<OP1>&<OP2>&...&<OPn> <Operanden_1> <Operanden_2> ... <Operanden_n>) .
  852.  
  853. Mnemonic                           Bedeutung
  854.  
  855. (NIL&PUSH)                         (NIL) (PUSH)
  856. (T&PUSH)                           (T) (PUSH)
  857. (CONST&PUSH n)                     (CONST n) (PUSH)
  858. (LOAD&PUSH n)                      (LOAD n) (PUSH)
  859. (LOADI&PUSH k n)                   (LOADI k n) (PUSH)
  860. (LOADC&PUSH n m)                   (LOADC n m) (PUSH)
  861. (LOADV&PUSH k m)                   (LOADV k m) (PUSH)
  862. (POP&STORE n)                      (POP) (STORE n)
  863. (GETVALUE&PUSH n)                  (GETVALUE n) (PUSH)
  864. (JSR&PUSH label)                   (JSR label) (PUSH)
  865. (COPY-CLOSURE&PUSH m n)            (COPY-CLOSURE m n) (PUSH)
  866. (CALL&PUSH k n)                    (CALL k n) (PUSH)
  867. (CALL1&PUSH n)                     (CALL1 n) (PUSH)
  868. (CALL2&PUSH n)                     (CALL2 n) (PUSH)
  869. (CALLS1&PUSH n)                    (CALLS1 n) (PUSH)
  870. (CALLS2&PUSH n)                    (CALLS2 n) (PUSH)
  871. (CALLSR&PUSH m n)                  (CALLSR m n) (PUSH)
  872. (CALLC&PUSH)                       (CALLC) (PUSH)
  873. (CALLCKEY&PUSH)                    (CALLCKEY) (PUSH)
  874. (FUNCALL&PUSH n)                   (FUNCALL n) (PUSH)
  875. (APPLY&PUSH n)                     (APPLY n) (PUSH)
  876. (CAR&PUSH)                         (CAR) (PUSH)
  877. (CDR&PUSH)                         (CDR) (PUSH)
  878. (CONS&PUSH)                        (CONS) (PUSH)
  879. (LIST&PUSH n)                      (LIST n) (PUSH)
  880. (LIST*&PUSH n)                     (LIST* n) (PUSH)
  881. (NIL&STORE n)                      (NIL) (STORE n)
  882. (T&STORE n)                        (T) (STORE n)
  883. (LOAD&STOREC k n m)                (LOAD k) (STOREC n m)
  884. (CALLS1&STORE n k)                 (CALLS1 n) (STORE k)
  885. (CALLS2&STORE n k)                 (CALLS2 n) (STORE k)
  886. (CALLSR&STORE m n k)               (CALLSR m n) (STORE k)
  887. (LOAD&CDR&STORE n)                 (LOAD n) (CDR) (STORE n)
  888. (LOAD&CONS&STORE n)                (LOAD n+1) (CONS) (STORE n)
  889. (LOAD&INC&STORE n)                 (LOAD n) (CALL1 #'1+) (STORE n)
  890. (LOAD&DEC&STORE n)                 (LOAD n) (CALL1 #'1-) (STORE n)
  891. (LOAD&CAR&STORE m n)               (LOAD m) (CAR) (STORE n)
  892. (CALL1&JMPIF n label)              (CALL1 n) (JMPIF label)
  893. (CALL1&JMPIFNOT n label)           (CALL1 n) (JMPIFNOT label)
  894. (CALL2&JMPIF n label)              (CALL2 n) (JMPIF label)
  895. (CALL2&JMPIFNOT n label)           (CALL2 n) (JMPIFNOT label)
  896. (CALLS1&JMPIF n label)             (CALLS1 n) (JMPIF label)
  897. (CALLS1&JMPIFNOT n label)          (CALLS1 n) (JMPIFNOT label)
  898. (CALLS2&JMPIF n label)             (CALLS2 n) (JMPIF label)
  899. (CALLS2&JMPIFNOT n label)          (CALLS2 n) (JMPIFNOT label)
  900. (CALLSR&JMPIF m n label)           (CALLSR m n) (JMPIF label)
  901. (CALLSR&JMPIFNOT m n label)        (CALLSR m n) (JMPIFNOT label)
  902. (LOAD&JMPIF n label)               (LOAD n) (JMPIF label)
  903. (LOAD&JMPIFNOT n label)            (LOAD n) (JMPIFNOT label)
  904. (LOAD&CAR&PUSH n)                  (LOAD n) (CAR) (PUSH)
  905. (LOAD&CDR&PUSH n)                  (LOAD n) (CDR) (PUSH)
  906. (LOAD&INC&PUSH n)                  (LOAD n) (CALL1 #'1+) (PUSH)
  907. (LOAD&DEC&PUSH n)                  (LOAD n) (CALL1 #'1-) (PUSH)
  908. (CONST&SYMBOL-FUNCTION n)          (CONST n) (SYMBOL-FUNCTION)
  909. (CONST&SYMBOL-FUNCTION&PUSH n)     (CONST n) (SYMBOL-FUNCTION) (PUSH)
  910. (CONST&SYMBOL-FUNCTION&STORE n k)  (CONST n) (SYMBOL-FUNCTION) (STORE k)
  911.  
  912.  
  913. |#
  914.  
  915. ; Instruktionen-Klassifikation:
  916. ; O = Instruktion ohne Operand
  917. ; K = numerischer Operand oder
  918. ;     Kurz-Operand (dann ist das Byte = short-code-ops[x] + Operand)
  919. ; N = numerischer Operand
  920. ; B = Byte-Operand
  921. ; L = Label-Operand
  922. ; NH = numerischer Operand, der eine Hashtable referenziert
  923. ; NC = numerischer Operand, der ein Handler-Cons referenziert
  924. ; LX = so viele Label-Operanden, wie der vorangehende Operand angibt
  925.  
  926. ; Die Position in der Instruction-Table liefert den eigentlichen Code der
  927. ; Instruktion (>= 0, < short-code-base), Codes >= short-code-base werden
  928. ; von den K-Instruktionen belegt.
  929. (defconstant instruction-table
  930.   '#(; (1) Konstanten
  931.      (NIL O) (PUSH-NIL N) (T O) (CONST K)
  932.      ; (2) statische Variablen
  933.      (LOAD K) (LOADI NN) (LOADC NN) (LOADV NN) (LOADIC NNN)
  934.      (STORE K) (STOREI NN) (STOREC NN) (STOREV NN) (STOREIC NNN)
  935.      ; (3) dynamische Variablen
  936.      (GETVALUE N) (SETVALUE N) (BIND N) (UNBIND1 O) (UNBIND N) (PROGV O)
  937.      ; (4) Stackoperationen
  938.      (PUSH O) (POP O) (SKIP N) (SKIPI NN) (SKIPSP N)
  939.      ; (5) Programmfluß und Sprünge
  940.      (SKIP&RET N) (JMP L) (JMPIF L) (JMPIFNOT L) (JMPIF1 L) (JMPIFNOT1 L)
  941.      (JMPIFATOM L) (JMPIFCONSP L) (JMPIFEQ L) (JMPIFNOTEQ L)
  942.      (JMPIFEQTO NL) (JMPIFNOTEQTO NL) (JMPHASH NHL) (JMPHASHV NHL) (JSR L)
  943.      (JMPTAIL NNL)
  944.      ; (6) Environments und Closures
  945.      (VENV O) (MAKE-VECTOR1&PUSH N) (COPY-CLOSURE NN)
  946.      ; (7) Funktionsaufrufe
  947.      (CALL NN) (CALL0 N) (CALL1 N) (CALL2 N)
  948.      (CALLS1 B) (CALLS2 B) (CALLSR NB) (CALLC O) (CALLCKEY O)
  949.      (FUNCALL N) (APPLY N)
  950.      ; (8) optionale und Keyword-Argumente
  951.      (PUSH-UNBOUND N) (UNLIST NN) (UNLIST* NN) (JMPIFBOUNDP NL) (BOUNDP N)
  952.      (UNBOUND->NIL N)
  953.      ; (9) Behandlung mehrerer Werte
  954.      (VALUES0 O) (VALUES1 O) (STACK-TO-MV N) (MV-TO-STACK O) (NV-TO-STACK N)
  955.      (MV-TO-LIST O) (LIST-TO-MV O) (MVCALLP O) (MVCALL O)
  956.      ; (10) BLOCK
  957.      (BLOCK-OPEN NL) (BLOCK-CLOSE O) (RETURN-FROM N) (RETURN-FROM-I NN)
  958.      ; (11) TAGBODY
  959.      (TAGBODY-OPEN NLX) (TAGBODY-CLOSE-NIL O) (TAGBODY-CLOSE O) (GO NN)
  960.      (GO-I NNN)
  961.      ; (12) CATCH und THROW
  962.      (CATCH-OPEN L) (CATCH-CLOSE O) (THROW O)
  963.      ; (13) UNWIND-PROTECT
  964.      (UNWIND-PROTECT-OPEN L) (UNWIND-PROTECT-NORMAL-EXIT O)
  965.      (UNWIND-PROTECT-CLOSE O) (UNWIND-PROTECT-CLEANUP O)
  966.      ; (14) HANDLER
  967.      (HANDLER-OPEN NC) (HANDLER-BEGIN&PUSH O)
  968.      ; (15) einige Funktionen
  969.      (NOT O) (EQ O) (CAR O) (CDR O) (CONS O) (SYMBOL-FUNCTION O) (SVREF O)
  970.      (SVSET O) (LIST N) (LIST* N)
  971.      ; (16) kombinierte Operationen
  972.      (NIL&PUSH O) (T&PUSH O) (CONST&PUSH K)
  973.      (LOAD&PUSH K) (LOADI&PUSH NN) (LOADC&PUSH NN) (LOADV&PUSH NN) (POP&STORE N)
  974.      (GETVALUE&PUSH N)
  975.      (JSR&PUSH L)
  976.      (COPY-CLOSURE&PUSH NN)
  977.      (CALL&PUSH NN) (CALL1&PUSH N) (CALL2&PUSH N)
  978.      (CALLS1&PUSH B) (CALLS2&PUSH B) (CALLSR&PUSH NB)
  979.      (CALLC&PUSH O) (CALLCKEY&PUSH O)
  980.      (FUNCALL&PUSH N) (APPLY&PUSH N)
  981.      (CAR&PUSH O) (CDR&PUSH O) (CONS&PUSH O)
  982.      (LIST&PUSH N) (LIST*&PUSH N)
  983.      (NIL&STORE N) (T&STORE N) (LOAD&STOREC NNN)
  984.      (CALLS1&STORE BN) (CALLS2&STORE BN) (CALLSR&STORE NBN)
  985.      (LOAD&CDR&STORE N) (LOAD&CONS&STORE N) (LOAD&INC&STORE N) (LOAD&DEC&STORE N)
  986.      (LOAD&CAR&STORE NN)
  987.      (CALL1&JMPIF NL) (CALL1&JMPIFNOT NL)
  988.      (CALL2&JMPIF NL) (CALL2&JMPIFNOT NL)
  989.      (CALLS1&JMPIF BL) (CALLS1&JMPIFNOT BL)
  990.      (CALLS2&JMPIF BL) (CALLS2&JMPIFNOT BL)
  991.      (CALLSR&JMPIF NBL) (CALLSR&JMPIFNOT NBL)
  992.      (LOAD&JMPIF NL) (LOAD&JMPIFNOT NL)
  993.      (LOAD&CAR&PUSH N) (LOAD&CDR&PUSH N) (LOAD&INC&PUSH N) (LOAD&DEC&PUSH N)
  994.      (CONST&SYMBOL-FUNCTION N) (CONST&SYMBOL-FUNCTION&PUSH N)
  995.      (CONST&SYMBOL-FUNCTION&STORE NN)
  996.      (APPLY&SKIP&RET NN)
  997. )   )
  998. (dotimes (i (length instruction-table))
  999.   (setf (get (first (svref instruction-table i)) 'INSTRUCTION) i)
  1000. )
  1001. (defconstant instruction-codes
  1002.   (let ((hashtable (make-hash-table :test #'eq)))
  1003.     (dotimes (i (length instruction-table))
  1004.       (setf (gethash (first (svref instruction-table i)) hashtable) i)
  1005.     )
  1006.     hashtable
  1007. ) )
  1008.  
  1009. ; K-Instruktionen:
  1010. (defconstant instruction-table-K
  1011.   '#(LOAD LOAD&PUSH CONST CONST&PUSH STORE)
  1012. )
  1013. (defconstant short-code-base 155)
  1014. (defconstant short-code-opsize '#(15   25   21   30   10))
  1015. (defconstant short-code-ops '#(155  170  195  216  246));256
  1016.  
  1017.  
  1018. #|
  1019.  
  1020. Zwischensprache nach dem 1. Pass:
  1021. =================================
  1022.  
  1023. 1. Konstanten:
  1024.  
  1025. (NIL)                            A0 := NIL, 1 Wert
  1026.  
  1027. (PUSH-NIL n)                     n-mal: -(STACK) := NIL, undefinierte Werte
  1028.  
  1029. (T)                              A0 := T, 1 Wert
  1030.  
  1031. (CONST const)                    A0 := 'const, 1 Wert
  1032.  
  1033. (FCONST fnode)                   A0 := das Compilat des fnode, 1 Wert
  1034.  
  1035. (BCONST block)                   A0 := das Block-Cons dieses Blockes (eine
  1036.                                  Konstante aus FUNC), 1 Wert
  1037.  
  1038. (GCONST tagbody)                 A0 := das Tagbody-Cons dieses Tagbody (eine
  1039.                                  Konstante aus FUNC), 1 Wert
  1040.  
  1041. 2.,3. Variablen:
  1042.  
  1043. (GET var venvc stackz)           A0 := var, 1 Wert
  1044.                                  (venvc ist das aktuelle Closure-Venv,
  1045.                                   stackz der aktuelle Stackzustand)
  1046.  
  1047. (SET var venvc stackz)           var := A0, 1 Wert
  1048.                                  (venvc ist das aktuelle Closure-Venv,
  1049.                                   stackz der aktuelle Stackzustand)
  1050.  
  1051. (STORE n)                        (STACK+4*n) := A0, 1 Wert
  1052.  
  1053. (GETVALUE symbol)                A0 := (symbol-value 'symbol), 1 Wert
  1054.  
  1055. (SETVALUE symbol)                (setf (symbol-value 'symbol) A0), 1 Wert
  1056.  
  1057. (BIND const)                     bindet const (ein Symbol) dynamisch an A0.
  1058.                                  Undefinierte Werte.
  1059.  
  1060. (UNBIND1)                        löst einen Bindungsframe auf
  1061.  
  1062. (PROGV)                          bindet dynamisch die Symbole in der Liste
  1063.                                  (STACK)+ an die Werte in der Liste A0 und
  1064.                                  baut dabei genau einen Bindungsframe auf,
  1065.                                  undefinierte Werte
  1066.  
  1067. 4. Stackoperationen:
  1068.  
  1069. (PUSH)                           -(STACK) := A0, undefinierte Werte
  1070.  
  1071. (POP)                            A0 := (STACK)+, 1 Wert
  1072.  
  1073. (UNWIND stackz1 stackz2 for-value) Führt ein Unwind binnen einer Funktion aus:
  1074.                                  Bereinigt den Stack, um vom Stackzustand
  1075.                                  stackz1 zum Stackzustand stackz2 zu kommen.
  1076.                                  Löst dazwischen liegende Frames auf. for-value
  1077.                                  gibt an, ob dabei die Werte A0/... gerettet
  1078.                                  werden müssen.
  1079.  
  1080. (UNWINDSP stackz1 stackz2)       modifiziert den SP, um vom Stackzustand
  1081.                                  stackz1 zum Stackzustand stackz2 zu kommen.
  1082.                                  STACK und die Werte A0/... bleiben unverändert.
  1083.  
  1084. 5. Programmfluß und Sprünge:
  1085.  
  1086. (RET)                            beendet die Funktion mit den Werten A0/...
  1087.  
  1088. (JMP label)                      Sprung zu label
  1089.  
  1090. (JMPIF label)                    falls A0 /= NIL : Sprung zu label.
  1091.  
  1092. (JMPIFNOT label)                 falls A0 = NIL : Sprung zu label.
  1093.  
  1094. (JMPIF1 label)                   falls A0 /= NIL : 1 Wert, Sprung zu label.
  1095.  
  1096. (JMPIFNOT1 label)                falls A0 = NIL : 1 Wert, Sprung zu label.
  1097.  
  1098. (JMPHASH test ((obj1 . label1) ... (objm . labelm)) label . labels)
  1099.                                  Sprung zu labeli, falls A0 = obji (im Sinne
  1100.                                  des angegebenen Vergleichs), sonst zu label.
  1101.                                  Undefinierte Werte.
  1102.  
  1103. (JSR m label)                    ruft den Code ab label als Unterprogramm auf,
  1104.                                  mit m Argumenten auf dem Stack
  1105.  
  1106. (BARRIER)                        wird nie erreicht, zählt als Wegsprung
  1107.  
  1108. 6. Environments und Closures:
  1109.  
  1110. (VENV venvc stackz)              A0 := das Venv, das venvc entspricht
  1111.                                  (aus dem Stack, als Konstante aus
  1112.                                  FUNC, oder NIL, falls in FUNC nicht vorhanden),
  1113.                                  1 Wert
  1114.                                  (stackz ist der aktuelle Stackzustand)
  1115.  
  1116. (MAKE-VECTOR1&PUSH n)            kreiert einen simple-vector mit n+1 (n>=0)
  1117.                                  Komponenten und steckt A0 als Komponente 0
  1118.                                  hinein. -(STACK) := der neue Vektor.
  1119.                                  Undefinierte Werte.
  1120.  
  1121. (COPY-CLOSURE fnode n)           kopiert die Closure, die dem fnode entspricht
  1122.                                  und ersetzt in der Kopie für i=0,...,n-1 (n>0)
  1123.                                  die Komponente (CONST i) durch (STACK+4*(n-1-i)).
  1124.                                  STACK := STACK+4*n. A0 := Closure-Kopie, 1 Wert
  1125.  
  1126. 7. Funktionsaufrufe:
  1127.  
  1128. (CALLP)                          beginnt den Aufbau eines Funktionsaufruf-Frames
  1129.                                  (wird im 2. Pass ersatzlos gestrichen)
  1130.  
  1131. (CALL k const)                   ruft die Funktion const mit k Argumenten
  1132.                                  (STACK+4*(k-1)),...,(STACK+4*0) auf,
  1133.                                  STACK:=STACK+4*k, Ergebnis kommt nach A0/...
  1134.  
  1135. (CALL0 const)                    ruft die Funktion const mit 0 Argumenten auf,
  1136.                                  Ergebnis kommt nach A0/...
  1137.  
  1138. (CALL1 const)                    ruft die Funktion const mit 1 Argument A0 auf,
  1139.                                  Ergebnis kommt nach A0/...
  1140.  
  1141. (CALL2 const)                    ruft die Funktion const mit 2 Argumenten (STACK)
  1142.                                  und A0 auf, STACK:=STACK+4,
  1143.                                  Ergebnis kommt nach A0/...
  1144.  
  1145. (CALLS1 n)                       ruft die Funktion (FUNTAB n)
  1146. (CALLS2 n)                       bzw. (FUNTAB 256+n)
  1147.                                  (ein SUBR ohne Rest-Parameter) auf,
  1148.                                  mit der korrekten Argumentezahl auf dem STACK.
  1149.                                  STACK wird bereinigt, Ergebnis kommt nach A0/...
  1150.  
  1151. (CALLSR m n)                     ruft die Funktion (FUNTABR n)
  1152.                                  (ein SUBR mit Rest-Parameter) auf,
  1153.                                  mit der korrekten Argumentezahl und zusätzlich
  1154.                                  m restlichen Argumenten auf dem STACK.
  1155.                                  STACK wird bereinigt, Ergebnis kommt nach A0/...
  1156.  
  1157. (CALLC)                          ruft die Funktion A0 (eine compilierte Closure
  1158.                                  ohne Keyword-Parameter) auf. Argumente
  1159.                                  sind schon im richtigen Format auf dem STACK,
  1160.                                  STACK wird bereinigt, Ergebnis kommt nach A0/...
  1161.  
  1162. (CALLCKEY)                       ruft die Funktion A0 (eine compilierte Closure
  1163.                                  mit Keyword-Parameter) auf. Argumente
  1164.                                  sind schon im richtigen Format auf dem STACK,
  1165.                                  STACK wird bereinigt, Ergebnis kommt nach A0/...
  1166.  
  1167. (FUNCALLP)                       fängt den Aufbau eines FUNCALL-Frames an,
  1168.                                  auszuführende Funktion ist in A0
  1169.  
  1170. (FUNCALL n)                      ruft die angegebene Funktion mit n (n>=0)
  1171.                                  Argumenten (alle auf dem Stack) auf,
  1172.                                  beseitigt den FUNCALL-Frame,
  1173.                                  Ergebnis kommt nach A0/...
  1174.  
  1175. (APPLYP)                         fängt den Aufbau eines APPLY-Frames an,
  1176.                                  auszuführende Funktion ist in A0
  1177.  
  1178. (APPLY n)                        ruft die angegebene Funktion mit n (n>=0)
  1179.                                  Argumenten (alle auf dem Stack) und weiteren
  1180.                                  Argumenten (Liste in A0) auf,
  1181.                                  beseitigt den APPLY-Frame,
  1182.                                  Ergebnis kommt nach A0/...
  1183.  
  1184. 8. optionale und Keyword-Argumente:
  1185.  
  1186. (PUSH-UNBOUND n)                 n-mal: -(STACK) := #<UNBOUND>, undefinierte Werte
  1187.  
  1188. (UNLIST n m)                     Liste A0 n mal verkürzen: -(STACK) := (car A0),
  1189.                                  A0 := (cdr A0). Bei den letzten m Mal darf A0
  1190.                                  schon zu Ende sein, dann -(STACK) := #<UNBOUND>
  1191.                                  stattdessen. Am Schluß muß A0 = NIL sein,
  1192.                                  undefinierte Werte. 0 <= m <= n.
  1193.  
  1194. (UNLIST* n m)                    Liste A0 n mal verkürzen: -(STACK) := (car A0),
  1195.                                  A0 := (cdr A0). Bei den letzten m Mal darf A0
  1196.                                  schon zu Ende sein, dann -(STACK) := #<UNBOUND>.
  1197.                                  stattdessen. Dann -(STACK) := (nthcdr n A0),
  1198.                                  undefinierte Werte. 0 <= m <= n, n > 0.
  1199.  
  1200. (JMPIFBOUNDP var venvc stackz label)
  1201.                                  falls Variable /= #<UNBOUND> :
  1202.                                    Sprung zu label, A0 := Variable, 1 Wert.
  1203.                                  Sonst undefinierte Werte.
  1204.                                  (stackz ist der aktuelle Stackzustand)
  1205.  
  1206. (BOUNDP var venvc stackz)        A0 := (NIL falls Variable=#<UNBOUND>, T sonst),
  1207.                                  1 Wert
  1208.                                  (stackz ist der aktuelle Stackzustand)
  1209.  
  1210. 9. Behandlung mehrerer Werte:
  1211.  
  1212. (VALUES0)                        A0 := NIL, 0 Werte
  1213.  
  1214. (VALUES1)                        A0 := A0, 1 Wert
  1215.  
  1216. (STACK-TO-MV n)                  holt n Werte von (STACK)+ herab,
  1217.                                  STACK:=STACK+4*n, n>1
  1218.  
  1219. (MV-TO-STACK)                    Multiple Values A0/A1/... auf -(STACK),
  1220.                                  1. Wert zuoberst, STACK:=STACK-4*D7.W,
  1221.                                  danach undefinierte Werte
  1222.  
  1223. (NV-TO-STACK n)                  die ersten n Werte (n>=0) auf -(STACK),
  1224.                                  1. Wert zuoberst, STACK:=STACK-4*n,
  1225.                                  undefinierte Werte
  1226.  
  1227. (MV-TO-LIST)                     Multiple Values A0/... als Liste nach A0,
  1228.                                  1 Wert
  1229.  
  1230. (LIST-TO-MV)                     A0/... := (values-list A0)
  1231.  
  1232. (MVCALLP)                        bereitet einen MULTIPLE-VALUE-CALL auf die
  1233.                                  Funktion in A0 vor
  1234.  
  1235. (MVCALL)                         führt einen MULTIPLE-VALUE-CALL mit den im
  1236.                                  Stack liegenden Argumenten aus
  1237.  
  1238. 10. BLOCK:
  1239.  
  1240. (BLOCK-OPEN const label)         Legt einen Block-Cons (mit CAR=const und CDR=
  1241.                                  Framepointer) auf -(STACK) ab, baut einen
  1242.                                  Block-Frame auf. Bei einem RETURN auf diesen
  1243.                                  Frame wird zu label gesprungen.
  1244.  
  1245. (BLOCK-CLOSE)                    Verlasse den Block und baue dabei einen Block-
  1246.                                  Frame ab (inklusive der Block-Cons-Variablen)
  1247.  
  1248. (RETURN-FROM const)              Verlasse den Block, dessen Block-Cons angegeben
  1249.                                  ist, mit den Werten A0/...
  1250. (RETURN-FROM block)              Verlasse den angegebenen Block (sein Block-Cons
  1251.                                  kommt unter den BlockConsts von FUNC vor) mit
  1252.                                  den Werten A0/...
  1253. (RETURN-FROM block stackz)       Verlasse den angegebenen Block (sein Block-Cons
  1254.                                  kommt im Stack vor) mit den Werten A0/...
  1255.  
  1256. 11. TAGBODY:
  1257.  
  1258. (TAGBODY-OPEN const label1 ... labelm)
  1259.                                  Legt einen Tagbody-Cons (mit CAR=const
  1260.                                  und CDR=Framepointer) auf -(STACK) ab, baut einen
  1261.                                  Tagbody-Frame auf. Bei einem GO mit Nummer l
  1262.                                  wird zu labell gesprungen.
  1263.  
  1264. (TAGBODY-CLOSE-NIL)              Verlasse den Tagbody und baue dabei einen
  1265.                                  Tagbody-Frame ab (inklusive der Tagbody-Cons-
  1266.                                  Variablen). A0 := NIL, 1 Wert
  1267.  
  1268. (TAGBODY-CLOSE)                  Verlasse den Tagbody und baue dabei einen
  1269.                                  Tagbody-Frame ab (inklusive der Tagbody-Cons-
  1270.                                  Variablen).
  1271.  
  1272. (GO const l)                     Springe im Tagbody, dessen Tagbody-Cons
  1273.                                  angegeben ist, an Tag (svref (car const) l)
  1274. (GO tagbody l)                   Springe im angegebenen Tagbody an Tag Nummer l
  1275.                                  in (tagbody-used-far tagbody)
  1276. (GO tagbody l stackz)            Springe im angegebenen Tagbody an Tag Nummer l
  1277.                                  in (tagbody-used-far tagbody), sein Tagbody-
  1278.                                  Cons liegt im Stack
  1279.  
  1280. 12. CATCH und THROW:
  1281.  
  1282. (CATCH-OPEN label)               baut einen CATCH-Frame auf mit A0 als Tag;
  1283.                                  bei einem THROW auf dieses Tag wird zu label
  1284.                                  gesprungen
  1285.  
  1286. (CATCH-CLOSE)                    löst einen CATCH-Frame auf
  1287.  
  1288. (THROW)                          führt ein THROW auf den Catch-Tag (STACK)+
  1289.                                  aus, mit den Werten A0/...
  1290.  
  1291. 13. UNWIND-PROTECT:
  1292.  
  1293. (UNWIND-PROTECT-OPEN label)      baut einen UNWIND-PROTECT-Frame auf; bei einem
  1294.                                  Unwind wird unter Rettung der Werte zu label
  1295.                                  gesprungen
  1296.  
  1297. (UNWIND-PROTECT-NORMAL-EXIT)     löst einen Unwind-Protect-Frame auf, schreibt
  1298.                                  eine Weitermach-Adresse auf SP, rettet die
  1299.                                  Werte und fängt an, den folgenden Cleanup-Code
  1300.                                  auszuführen
  1301.  
  1302. (UNWIND-PROTECT-CLOSE label)     beendet den Cleanup-Code: schreibt die
  1303.                                  geretteten Werte zurück, führt ein RTS aus.
  1304.                                  Der Cleanup-Code fängt bei label an.
  1305.  
  1306. (UNWIND-PROTECT-CLEANUP)         löst einen Unwind-Protect-Frame auf, schreibt
  1307.                                  eine Weitermach-Adresse und den PC auf SP,
  1308.                                  rettet die Werte und fängt an, den Cleanup-
  1309.                                  Code auszuführen
  1310.  
  1311. 14. HANDLER:
  1312.  
  1313. (HANDLER-OPEN const stackz label1 ... labelm)
  1314.                                  baut einen HANDLER-Frame auf; const enthält
  1315.                                  die Condition-Typen; die entsprechenden
  1316.                                  Handler beginnen bei labeli
  1317.  
  1318. (HANDLER-BEGIN)                  beginnt einen Handler: stellt den SP-Zustand
  1319.                                  wie beim HANDLER-OPEN her,
  1320.                                  A0 := dem Handler übergebene Condition, 1 Wert
  1321.  
  1322. 15. einige Funktionen:
  1323.  
  1324. (NOT)                            = (CALL1 #'NOT)
  1325.  
  1326. (EQ)                             = (CALL2 #'EQ)
  1327.  
  1328. (CAR)                            = (CALL1 #'CAR)
  1329.  
  1330. (CDR)                            = (CALL1 #'CDR)
  1331.  
  1332. (CONS)                           = (CALL2 #'CONS)
  1333.  
  1334. (ATOM)                           = (CALL1 #'ATOM)
  1335.  
  1336. (CONSP)                          = (CALL1 #'CONSP)
  1337.  
  1338. (SYMBOL-FUNCTION)                = (CALL1 #'SYMBOL-FUNCTION)
  1339.  
  1340. (SVREF)                          = (CALL2 #'SVREF)
  1341.  
  1342. (SVSET)                          (setf (svref (STACK) A0) (STACK+4)),
  1343.                                  A0 := (STACK+4), 1 Wert, STACK:=STACK+8
  1344.  
  1345. (LIST n)                         = (CALL n #'LIST), n>0
  1346.  
  1347. (LIST* n)                        = (CALL n+1 #'LIST*), n>0
  1348.  
  1349.  
  1350. Dabei bedeuten jeweils:
  1351.  
  1352. n, m, k     eine ganze Zahl >=0
  1353.  
  1354. stackz      einen Stackzustand (siehe STACK-VERWALTUNG).
  1355.             Das Stack-Layout steht nach dem 1. Pass fest.
  1356.  
  1357. venvc       das Environment der Closure-Variablen (siehe VARIABLEN-VERWALTUNG).
  1358.             Dies steht nach dem 1. Pass auch fest.
  1359.  
  1360. var         eine Variable (siehe VARIABLEN-VERWALTUNG). Ob sie
  1361.             special/konstant/lexikalisch ist, steht nach dem 1. Pass fest.
  1362.  
  1363. const       eine Konstante
  1364.  
  1365. symbol      ein Symbol
  1366.  
  1367. fun         entweder (CONST const) eine Konstante, die ein Symbol ist,
  1368.             oder (FUNTAB index) eine Indizierung in die feste Funktionentabelle.
  1369.  
  1370. fnode       ein fnode (siehe FUNKTIONEN-VERWALTUNG)
  1371.  
  1372. label       ein Label (uninterniertes Symbol)
  1373.  
  1374. block       ein Block-Descriptor (siehe BLOCK-VERWALTUNG)
  1375.  
  1376. test        EQ oder EQL oder EQUAL
  1377.  
  1378. for-value   NIL oder T
  1379.  
  1380. |#
  1381.  
  1382. #-CLISP ; Die Funktionentabelle steckt in EVAL.
  1383. (eval-when (compile load eval)
  1384.   ; die Funktionstabelle mit max. 3*256 Funktionen (spart Konstanten in FUNC) :
  1385.   (defconstant funtab
  1386.     '#(system::%funtabref system::subr-info
  1387.        #| svref system::%svstore |# row-major-aref system::row-major-store
  1388.        array-element-type array-rank array-dimension array-dimensions
  1389.        array-total-size adjustable-array-p bit-and bit-ior bit-xor bit-eqv
  1390.        bit-nand bit-nor bit-andc1 bit-andc2 bit-orc1 bit-orc2 bit-not
  1391.        array-has-fill-pointer-p fill-pointer system::set-fill-pointer
  1392.        vector-push vector-pop vector-push-extend make-array adjust-array
  1393.        standard-char-p graphic-char-p string-char-p alpha-char-p upper-case-p
  1394.        lower-case-p both-case-p digit-char-p alphanumericp char-code char-bits
  1395.        char-font code-char make-char character char-upcase char-downcase
  1396.        digit-char char-int int-char char-name char-bit set-char-bit char schar
  1397.        system::store-char system::store-schar string= string/= string< string>
  1398.        string<= string>= string-equal string-not-equal string-lessp
  1399.        string-greaterp string-not-greaterp string-not-lessp
  1400.        system::search-string= system::search-string-equal make-string
  1401.        system::string-both-trim nstring-upcase string-upcase nstring-downcase
  1402.        string-downcase nstring-capitalize string-capitalize string name-char
  1403.        substring
  1404.        symbol-value #| symbol-function |# boundp fboundp special-form-p set makunbound
  1405.        fmakunbound #| values-list |# system::driver system::unwind-to-driver
  1406.        macro-function macroexpand macroexpand-1 proclaim eval evalhook applyhook
  1407.        constantp system::parse-body system::keyword-test
  1408.        room
  1409.        invoke-debugger
  1410.        make-hash-table gethash system::puthash remhash maphash clrhash
  1411.        hash-table-count system::hash-table-iterator system::hash-table-iterate
  1412.        clos::class-gethash sxhash
  1413.        copy-readtable set-syntax-from-char set-macro-character
  1414.        get-macro-character make-dispatch-macro-character
  1415.        set-dispatch-macro-character get-dispatch-macro-character read
  1416.        read-preserving-whitespace read-delimited-list read-line read-char
  1417.        unread-char peek-char listen read-char-no-hang clear-input
  1418.        read-from-string parse-integer write prin1 print pprint princ
  1419.        write-to-string prin1-to-string princ-to-string write-char write-string
  1420.        write-line terpri fresh-line finish-output force-output clear-output
  1421.        system::line-position
  1422.        #| car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar
  1423.        cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
  1424.        cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr cons |# tree-equal endp
  1425.        list-length nth #| first second third fourth |# fifth sixth seventh eighth
  1426.        ninth tenth #| rest |# nthcdr last make-list copy-list copy-alist copy-tree
  1427.        revappend nreconc system::list-nreverse butlast nbutlast ldiff rplaca
  1428.        system::%rplaca rplacd system::%rplacd subst subst-if subst-if-not nsubst
  1429.        nsubst-if nsubst-if-not sublis nsublis member member-if member-if-not
  1430.        tailp adjoin acons pairlis assoc assoc-if assoc-if-not rassoc rassoc-if
  1431.        rassoc-if-not
  1432.        lisp-implementation-type lisp-implementation-version software-type
  1433.        software-version identity get-universal-time get-internal-run-time
  1434.        get-internal-real-time system::%sleep system::%%time
  1435.        make-symbol find-package package-name package-nicknames rename-package
  1436.        package-use-list package-used-by-list package-shadowing-symbols
  1437.        list-all-packages intern find-symbol unintern export unexport import
  1438.        shadowing-import shadow use-package unuse-package make-package
  1439.        system::%in-package in-package find-all-symbols system::map-symbols
  1440.        system::map-external-symbols system::map-all-symbols
  1441.        parse-namestring pathname pathname-host pathname-device
  1442.        pathname-directory pathname-name pathname-type pathname-version
  1443.        file-namestring directory-namestring host-namestring merge-pathnames
  1444.        enough-namestring make-pathname namestring truename probe-file
  1445.        delete-file rename-file open directory cd make-dir delete-dir
  1446.        file-write-date file-author savemem
  1447.        #| eq |# eql equal equalp consp atom symbolp stringp numberp
  1448.        compiled-function-p #| null not |# system::closurep listp integerp
  1449.        system::fixnump rationalp floatp system::short-float-p
  1450.        system::single-float-p system::double-float-p system::long-float-p
  1451.        realp complexp streamp random-state-p readtablep hash-table-p pathnamep
  1452.        system::logical-pathname-p characterp functionp clos::generic-function-p
  1453.        packagep arrayp system::simple-array-p bit-vector-p vectorp
  1454.        simple-vector-p simple-string-p simple-bit-vector-p commonp type-of
  1455.        clos:class-of clos:find-class coerce
  1456.        system::%record-ref system::%record-store system::%record-length
  1457.        system::%structure-ref system::%structure-store system::%make-structure
  1458.        system::%copy-structure system::%structure-type-p system::closure-name
  1459.        system::closure-codevec system::closure-consts system::make-code-vector
  1460.        system::%make-closure system::make-load-time-eval clos::std-instance-p
  1461.        clos::allocate-std-instance clos:slot-value clos::set-slot-value
  1462.        clos:slot-boundp clos:slot-makunbound clos:slot-exists-p
  1463.        system::sequencep elt system::%setelt subseq copy-seq length reverse
  1464.        nreverse make-sequence reduce fill replace remove remove-if remove-if-not
  1465.        delete delete-if delete-if-not remove-duplicates delete-duplicates
  1466.        substitute substitute-if substitute-if-not nsubstitute nsubstitute-if
  1467.        nsubstitute-if-not find find-if find-if-not position position-if
  1468.        position-if-not count count-if count-if-not mismatch search sort
  1469.        stable-sort merge
  1470.        system::file-stream-p make-synonym-stream system::synonym-stream-p
  1471.        system::broadcast-stream-p system::concatenated-stream-p
  1472.        make-two-way-stream system::two-way-stream-p make-echo-stream
  1473.        system::echo-stream-p make-string-input-stream
  1474.        system::string-input-stream-index make-string-output-stream
  1475.        get-output-stream-string system::make-string-push-stream
  1476.        system::string-stream-p input-stream-p output-stream-p
  1477.        stream-element-type close read-byte write-byte file-position file-length
  1478.        system::%putd system::%proclaim-constant get getf get-properties
  1479.        system::%putplist system::%put remprop symbol-package symbol-plist
  1480.        symbol-name keywordp gensym system::special-variable-p gensym
  1481.        system::decimal-string zerop plusp minusp oddp evenp 1+ 1- conjugate exp
  1482.        expt log sqrt isqrt abs phase signum sin cos tan cis asin acos atan sinh
  1483.        cosh tanh asinh acosh atanh float rational rationalize numerator
  1484.        denominator floor ceiling truncate round mod rem ffloor fceiling
  1485.        ftruncate fround decode-float scale-float float-radix float-sign
  1486.        float-digits float-precision integer-decode-float complex realpart
  1487.        imagpart lognand lognor logandc1 logandc2 logorc1 logorc2 boole lognot
  1488.        logtest logbitp ash logcount integer-length byte byte-size byte-position
  1489.        ldb ldb-test mask-field dpb deposit-field random make-random-state !
  1490.        exquo long-float-digits system::%set-long-float-digits system::log2
  1491.        system::log10
  1492.        vector aref system::store array-in-bounds-p array-row-major-index bit
  1493.        sbit char= char/= char< char> char<= char>= char-equal char-not-equal
  1494.        char-lessp char-greaterp char-not-greaterp char-not-lessp string-concat
  1495.        apply system::%funcall funcall mapcar maplist mapc mapl mapcan mapcon
  1496.        values error system::error-of-type clos::class-tuple-gethash list list*
  1497.        append nconc concatenate map some every notany notevery
  1498.        make-broadcast-stream make-concatenated-stream = /= < > <= >= max min
  1499.        + - * / gcd lcm logior logxor logand logeqv
  1500.   )   )
  1501.   (defun %funtabref (index)
  1502.     (if (and (<= 0 index) (< index (length funtab))) (svref funtab index) nil)
  1503.   )
  1504. )
  1505. #+CROSS
  1506. (eval-when (compile load eval)
  1507.   (defun subr-info (sym)
  1508.     (values-list
  1509.       (assoc sym
  1510.         '(; Das ist die Tabelle aller SUBRs, wie in SUBR.D.
  1511.           ; SUBRs, die in verschiedenen Implementationen verschiedene
  1512.           ; Signaturen haben und/oder deren Spezifikation sich noch ändern
  1513.           ; könnte, sind dabei allerdings auskommentiert.
  1514.           (! 1 0 nil nil nil)
  1515.           (system::%%time 0 0 nil nil nil)
  1516.           (system::%copy-structure 1 0 nil nil nil)
  1517.           (system::%defseq 1 0 nil nil nil)
  1518.           (system::%exit 0 1 nil nil nil)
  1519.           (system::%funcall 1 0 t nil nil)
  1520.           (system::%funtabref 1 0 nil nil nil)
  1521.           (system::%in-package 1 0 nil (:nicknames :use) nil)
  1522.           (system::%make-closure 3 0 nil nil nil)
  1523.           (system::%make-structure 2 0 nil nil nil)
  1524.           (system::%proclaim-constant 2 0 nil nil nil)
  1525.           (system::%put 3 0 nil nil nil)
  1526.           (system::%putd 2 0 nil nil nil)
  1527.           (system::%putplist 2 0 nil nil nil)
  1528.           (system::%record-length 1 0 nil nil nil)
  1529.           (system::%record-ref 2 0 nil nil nil)
  1530.           (system::%record-store 3 0 nil nil nil)
  1531.           (system::%rplaca 2 0 nil nil nil)
  1532.           (system::%rplacd 2 0 nil nil nil)
  1533.           (system::%set-long-float-digits 1 0 nil nil nil)
  1534.           (system::%setelt 3 0 nil nil nil)
  1535.           ;(system::%sleep 1 0 nil nil nil)
  1536.           ;(system::%sleep 2 0 nil nil nil)
  1537.           (system::%structure-ref 3 0 nil nil nil)
  1538.           (system::%structure-store 4 0 nil nil nil)
  1539.           (system::%structure-type-p 2 0 nil nil nil)
  1540.           (system::%svstore 3 0 nil nil nil)
  1541.           (* 0 0 t nil nil)
  1542.           (+ 0 0 t nil nil)
  1543.           (- 1 0 t nil nil)
  1544.           (/ 1 0 t nil nil)
  1545.           (/= 1 0 t nil nil)
  1546.           (1+ 1 0 nil nil nil)
  1547.           (1- 1 0 nil nil nil)
  1548.           (< 1 0 t nil nil)
  1549.           (<= 1 0 t nil nil)
  1550.           (= 1 0 t nil nil)
  1551.           (> 1 0 t nil nil)
  1552.           (>= 1 0 t nil nil)
  1553.           (abs 1 0 nil nil nil)
  1554.           (acons 3 0 nil nil nil)
  1555.           (acos 1 0 nil nil nil)
  1556.           (acosh 1 0 nil nil nil)
  1557.           (adjoin 2 0 nil (:test :test-not :key) nil)
  1558.           (adjust-array 2 0 nil (:element-type :initial-element :initial-contents :fill-pointer :displaced-to :displaced-index-offset) nil)
  1559.           (adjustable-array-p 1 0 nil nil nil)
  1560.           (alpha-char-p 1 0 nil nil nil)
  1561.           (alphanumericp 1 0 nil nil nil)
  1562.           (append 0 0 t nil nil)
  1563.           (apply 2 0 t nil nil)
  1564.           (applyhook 4 1 nil nil nil)
  1565.           (aref 1 0 t nil nil)
  1566.           (array-dimension 2 0 nil nil nil)
  1567.           (array-dimensions 1 0 nil nil nil)
  1568.           (array-element-type 1 0 nil nil nil)
  1569.           (array-has-fill-pointer-p 1 0 nil nil nil)
  1570.           (array-in-bounds-p 1 0 t nil nil)
  1571.           (array-rank 1 0 nil nil nil)
  1572.           (system::array-reader 3 0 nil nil nil)
  1573.           (array-row-major-index 1 0 t nil nil)
  1574.           (array-total-size 1 0 nil nil nil)
  1575.           (arrayp 1 0 nil nil nil)
  1576.           (ash 2 0 nil nil nil)
  1577.           (asin 1 0 nil nil nil)
  1578.           (asinh 1 0 nil nil nil)
  1579.           (assoc 2 0 nil (:test :test-not :key) nil)
  1580.           (assoc-if 2 0 nil (:key) nil)
  1581.           (assoc-if-not 2 0 nil (:key) nil)
  1582.           (atan 1 1 nil nil nil)
  1583.           (atanh 1 0 nil nil nil)
  1584.           (atom 1 0 nil nil nil)
  1585.           (system::binary-reader 3 0 nil nil nil)
  1586.           (bit 1 0 t nil nil)
  1587.           (bit-and 2 1 nil nil nil)
  1588.           (bit-andc1 2 1 nil nil nil)
  1589.           (bit-andc2 2 1 nil nil nil)
  1590.           (bit-eqv 2 1 nil nil nil)
  1591.           (bit-ior 2 1 nil nil nil)
  1592.           (bit-nand 2 1 nil nil nil)
  1593.           (bit-nor 2 1 nil nil nil)
  1594.           (bit-not 1 1 nil nil nil)
  1595.           (bit-orc1 2 1 nil nil nil)
  1596.           (bit-orc2 2 1 nil nil nil)
  1597.           (bit-vector-p 1 0 nil nil nil)
  1598.           (system::bit-vector-reader 3 0 nil nil nil)
  1599.           (bit-xor 2 1 nil nil nil)
  1600.           (boole 3 0 nil nil nil)
  1601.           (both-case-p 1 0 nil nil nil)
  1602.           (boundp 1 0 nil nil nil)
  1603.           (system::broadcast-stream-p 1 0 nil nil nil)
  1604.           (butlast 1 1 nil nil nil)
  1605.           (byte 2 0 nil nil nil)
  1606.           (byte-position 1 0 nil nil nil)
  1607.           (byte-size 1 0 nil nil nil)
  1608.           (caaaar 1 0 nil nil nil)
  1609.           (caaadr 1 0 nil nil nil)
  1610.           (caaar 1 0 nil nil nil)
  1611.           (caadar 1 0 nil nil nil)
  1612.           (caaddr 1 0 nil nil nil)
  1613.           (caadr 1 0 nil nil nil)
  1614.           (caar 1 0 nil nil nil)
  1615.           (cadaar 1 0 nil nil nil)
  1616.           (cadadr 1 0 nil nil nil)
  1617.           (cadar 1 0 nil nil nil)
  1618.           (caddar 1 0 nil nil nil)
  1619.           (cadddr 1 0 nil nil nil)
  1620.           (caddr 1 0 nil nil nil)
  1621.           (cadr 1 0 nil nil nil)
  1622.           (car 1 0 nil nil nil)
  1623.           (cd 0 1 nil nil nil)
  1624.           (cdaaar 1 0 nil nil nil)
  1625.           (cdaadr 1 0 nil nil nil)
  1626.           (cdaar 1 0 nil nil nil)
  1627.           (cdadar 1 0 nil nil nil)
  1628.           (cdaddr 1 0 nil nil nil)
  1629.           (cdadr 1 0 nil nil nil)
  1630.           (cdar 1 0 nil nil nil)
  1631.           (cddaar 1 0 nil nil nil)
  1632.           (cddadr 1 0 nil nil nil)
  1633.           (cddar 1 0 nil nil nil)
  1634.           (cdddar 1 0 nil nil nil)
  1635.           (cddddr 1 0 nil nil nil)
  1636.           (cdddr 1 0 nil nil nil)
  1637.           (cddr 1 0 nil nil nil)
  1638.           (cdr 1 0 nil nil nil)
  1639.           (ceiling 1 1 nil nil nil)
  1640.           (char 2 0 nil nil nil)
  1641.           (char-bit 2 0 nil nil nil)
  1642.           (char-bits 1 0 nil nil nil)
  1643.           (char-code 1 0 nil nil nil)
  1644.           (char-downcase 1 0 nil nil nil)
  1645.           (char-equal 1 0 t nil nil)
  1646.           (char-font 1 0 nil nil nil)
  1647.           (char-greaterp 1 0 t nil nil)
  1648.           (char-int 1 0 nil nil nil)
  1649.           (char-lessp 1 0 t nil nil)
  1650.           (char-name 1 0 nil nil nil)
  1651.           (char-not-equal 1 0 t nil nil)
  1652.           (char-not-greaterp 1 0 t nil nil)
  1653.           (char-not-lessp 1 0 t nil nil)
  1654.           (system::char-reader 3 0 nil nil nil)
  1655.           (char-upcase 1 0 nil nil nil)
  1656.           (char/= 1 0 t nil nil)
  1657.           (char< 1 0 t nil nil)
  1658.           (char<= 1 0 t nil nil)
  1659.           (char= 1 0 t nil nil)
  1660.           (char> 1 0 t nil nil)
  1661.           (char>= 1 0 t nil nil)
  1662.           (character 1 0 nil nil nil)
  1663.           (characterp 1 0 nil nil nil)
  1664.           (cis 1 0 nil nil nil)
  1665.           (clos::class-gethash 2 0 nil nil nil)
  1666.           (clos:class-of 1 0 nil nil nil)
  1667.           (clos::class-p 1 0 nil nil nil)
  1668.           (clos::class-tuple-gethash 2 0 t nil nil)
  1669.           (clear-input 0 1 nil nil nil)
  1670.           (clear-output 0 1 nil nil nil)
  1671.           (close 1 0 nil (:abort) nil)
  1672.           (system::closure-codevec 1 0 nil nil nil)
  1673.           (system::closure-consts 1 0 nil nil nil)
  1674.           (system::closure-name 1 0 nil nil nil)
  1675.           (system::closure-reader 3 0 nil nil nil)
  1676.           (system::closurep 1 0 nil nil nil)
  1677.           (clrhash 1 0 nil nil nil)
  1678.           (code-char 1 2 nil nil nil)
  1679.           (coerce 2 0 nil nil nil)
  1680.           (system::comment-reader 3 0 nil nil nil)
  1681.           (commonp 1 0 nil nil nil)
  1682.           (compiled-function-p 1 0 nil nil nil)
  1683.           (complex 1 1 nil nil nil)
  1684.           (system::complex-reader 3 0 nil nil nil)
  1685.           (complexp 1 0 nil nil nil)
  1686.           (concatenate 1 0 t nil nil)
  1687.           (system::concatenated-stream-p 1 0 nil nil nil)
  1688.           (conjugate 1 0 nil nil nil)
  1689.           (cons 2 0 nil nil nil)
  1690.           (consp 1 0 nil nil nil)
  1691.           (constantp 1 0 nil nil nil)
  1692.           (copy-alist 1 0 nil nil nil)
  1693.           (copy-list 1 0 nil nil nil)
  1694.           (copy-readtable 0 2 nil nil nil)
  1695.           (copy-seq 1 0 nil nil nil)
  1696.           (copy-tree 1 0 nil nil nil)
  1697.           (cos 1 0 nil nil nil)
  1698.           (cosh 1 0 nil nil nil)
  1699.           (count 2 0 nil (:from-end :start :end :key :test :test-not) nil)
  1700.           (count-if 2 0 nil (:from-end :start :end :key) nil)
  1701.           (count-if-not 2 0 nil (:from-end :start :end :key) nil)
  1702.           (system::debug 0 0 nil nil nil)
  1703.           (system::decimal-string 1 0 nil nil nil)
  1704.           (decode-float 1 0 nil nil nil)
  1705.           (delete 2 0 nil (:from-end :start :end :key :test :test-not :count) nil)
  1706.           (delete-dir 1 0 nil nil nil)
  1707.           (delete-duplicates 1 0 nil (:from-end :start :end :key :test :test-not) nil)
  1708.           (delete-file 1 0 nil nil nil)
  1709.           (delete-if 2 0 nil (:from-end :start :end :key :count) nil)
  1710.           (delete-if-not 2 0 nil (:from-end :start :end :key :count) nil)
  1711.           (denominator 1 0 nil nil nil)
  1712.           (deposit-field 3 0 nil nil nil)
  1713.           (system::describe-frame 2 0 nil nil nil)
  1714.           (digit-char 1 2 nil nil nil)
  1715.           (digit-char-p 1 1 nil nil nil)
  1716.           (directory 0 1 nil (:circle :full) nil)
  1717.           (directory-namestring 1 0 nil nil nil)
  1718.           (system::double-float-p 1 0 nil nil nil)
  1719.           (dpb 3 0 nil nil nil)
  1720.           (system::driver 1 0 nil nil nil)
  1721.           (system::echo-stream-p 1 0 nil nil nil)
  1722.           (eighth 1 0 nil nil nil)
  1723.           (elt 2 0 nil nil nil)
  1724.           (endp 1 0 nil nil nil)
  1725.           (enough-namestring 1 1 nil nil nil)
  1726.           (eq 2 0 nil nil nil)
  1727.           (eql 2 0 nil nil nil)
  1728.           (equal 2 0 nil nil nil)
  1729.           (equalp 2 0 nil nil nil)
  1730.           (error 1 0 t nil nil)
  1731.           (system::error-of-type 2 0 t nil nil)
  1732.           (eval 1 0 nil nil nil)
  1733.           (system::eval-at 2 0 nil nil nil)
  1734.           (system::eval-frame-p 1 0 nil nil nil)
  1735.           (evalhook 3 1 nil nil nil)
  1736.           (evenp 1 0 nil nil nil)
  1737.           (every 2 0 t nil nil)
  1738.           ;(execute 1 2 nil nil nil)
  1739.           ;(execute 1 0 t nil nil)
  1740.           (exp 1 0 nil nil nil)
  1741.           (export 1 1 nil nil nil)
  1742.           (expt 2 0 nil nil nil)
  1743.           (exquo 2 0 nil nil nil)
  1744.           (fboundp 1 0 nil nil nil)
  1745.           (fceiling 1 1 nil nil nil)
  1746.           (system::feature-reader 3 0 nil nil nil)
  1747.           (ffloor 1 1 nil nil nil)
  1748.           (fifth 1 0 nil nil nil)
  1749.           (file-author 1 0 nil nil nil)
  1750.           (file-length 1 0 nil nil nil)
  1751.           (file-namestring 1 0 nil nil nil)
  1752.           (file-position 1 1 nil nil nil)
  1753.           (system::file-stream-p 1 0 nil nil nil)
  1754.           (file-write-date 1 0 nil nil nil)
  1755.           (fill 2 0 nil (:start :end) nil)
  1756.           (fill-pointer 1 0 nil nil nil)
  1757.           (find 2 0 nil (:from-end :start :end :key :test :test-not) nil)
  1758.           (find-all-symbols 1 0 nil nil nil)
  1759.           (clos:find-class 1 2 nil nil nil)
  1760.           (find-if 2 0 nil (:from-end :start :end :key) nil)
  1761.           (find-if-not 2 0 nil (:from-end :start :end :key) nil)
  1762.           (find-package 1 0 nil nil nil)
  1763.           (find-symbol 1 1 nil nil nil)
  1764.           (finish-output 0 1 nil nil nil)
  1765.           (first 1 0 nil nil nil)
  1766.           (system::fixnump 1 0 nil nil nil)
  1767.           (float 1 1 nil nil nil)
  1768.           (float-digits 1 1 nil nil nil)
  1769.           (float-precision 1 0 nil nil nil)
  1770.           (float-radix 1 0 nil nil nil)
  1771.           (float-sign 1 1 nil nil nil)
  1772.           (floatp 1 0 nil nil nil)
  1773.           (floor 1 1 nil nil nil)
  1774.           (fmakunbound 1 0 nil nil nil)
  1775.           (force-output 0 1 nil nil nil)
  1776.           (fourth 1 0 nil nil nil)
  1777.           (system::frame-down 2 0 nil nil nil)
  1778.           (system::frame-down-1 2 0 nil nil nil)
  1779.           (system::frame-up 2 0 nil nil nil)
  1780.           (system::frame-up-1 2 0 nil nil nil)
  1781.           (fresh-line 0 1 nil nil nil)
  1782.           (fround 1 1 nil nil nil)
  1783.           (ftruncate 1 1 nil nil nil)
  1784.           (funcall 1 0 t nil nil)
  1785.           (system::function-reader 3 0 nil nil nil)
  1786.           (functionp 1 0 nil nil nil)
  1787.           (gc 0 0 nil nil nil)
  1788.           (gcd 0 0 t nil nil)
  1789.           (clos::generic-function-p 1 0 nil nil nil)
  1790.           (gensym 0 1 nil nil nil)
  1791.           (get 2 1 nil nil nil)
  1792.           (get-dispatch-macro-character 2 1 nil nil nil)
  1793.           (get-internal-real-time 0 0 nil nil nil)
  1794.           (get-internal-run-time 0 0 nil nil nil)
  1795.           (get-macro-character 1 1 nil nil nil)
  1796.           (get-output-stream-string 1 0 nil nil nil)
  1797.           (get-properties 2 0 nil nil nil)
  1798.           (get-universal-time 0 0 nil nil nil)
  1799.           (getf 2 1 nil nil nil)
  1800.           (gethash 2 1 nil nil nil)
  1801.           (graphic-char-p 1 0 nil nil nil)
  1802.           (hash-table-count 1 0 nil nil nil)
  1803.           (hash-table-rehash-size 1 0 nil nil nil)
  1804.           (hash-table-rehash-threshold 1 0 nil nil nil)
  1805.           (hash-table-size 1 0 nil nil nil)
  1806.           (hash-table-test 1 0 nil nil nil)
  1807.           (system::hash-table-iterate 1 0 nil nil nil)
  1808.           (system::hash-table-iterator 1 0 nil nil nil)
  1809.           (hash-table-p 1 0 nil nil nil)
  1810.           (system::hexadecimal-reader 3 0 nil nil nil)
  1811.           (host-namestring 1 0 nil nil nil)
  1812.           (identity 1 0 nil nil nil)
  1813.           (imagpart 1 0 nil nil nil)
  1814.           (import 1 1 nil nil nil)
  1815.           (in-package 1 0 nil (:nicknames :use) nil)
  1816.           (system::initial-contents-aux 1 0 nil nil nil)
  1817.           (input-stream-p 1 0 nil nil nil)
  1818.           (int-char 1 0 nil nil nil)
  1819.           (integer-decode-float 1 0 nil nil nil)
  1820.           (integer-length 1 0 nil nil nil)
  1821.           (integerp 1 0 nil nil nil)
  1822.           (intern 1 1 nil nil nil)
  1823.           (invoke-debugger 1 0 nil nil nil)
  1824.           (isqrt 1 0 nil nil nil)
  1825.           (system::keyword-test 2 0 nil nil nil)
  1826.           (keywordp 1 0 nil nil nil)
  1827.           (system::label-definiion-reader 3 0 nil nil nil)
  1828.           (system::label-reference-reader 3 0 nil nil nil)
  1829.           (last 1 1 nil nil nil)
  1830.           (lcm 0 0 t nil nil)
  1831.           (ldb 2 0 nil nil nil)
  1832.           (ldb-test 2 0 nil nil nil)
  1833.           (ldiff 2 0 nil nil nil)
  1834.           (length 1 0 nil nil nil)
  1835.           (system::line-comment-reader 2 0 nil nil nil)
  1836.           (system::line-number 1 0 nil nil nil)
  1837.           (system::line-position 0 1 nil nil nil)
  1838.           (lisp-implementation-type 0 0 nil nil nil)
  1839.           (lisp-implementation-version 0 0 nil nil nil)
  1840.           (list 0 0 t nil nil)
  1841.           (list* 1 0 t nil nil)
  1842.           (system::list-access 2 0 nil nil nil)
  1843.           (system::list-access-set 3 0 nil nil nil)
  1844.           (list-all-packages 0 0 nil nil nil)
  1845.           (system::list-elt 2 0 nil nil nil)
  1846.           (system::list-endtest 2 0 nil nil nil)
  1847.           (system::list-fe-init 1 0 nil nil nil)
  1848.           (system::list-fe-init-end 2 0 nil nil nil)
  1849.           (system::list-init-start 2 0 nil nil nil)
  1850.           (list-length 1 0 nil nil nil)
  1851.           (system::list-llength 1 0 nil nil nil)
  1852.           (system::list-nreverse 1 0 nil nil nil)
  1853.           (system::list-set-elt 3 0 nil nil nil)
  1854.           (system::list-upd 2 0 nil nil nil)
  1855.           (listen 0 1 nil nil nil)
  1856.           (listp 1 0 nil nil nil)
  1857.           (system::load-eval-reader 3 0 nil nil nil)
  1858.           (log 1 1 nil nil nil)
  1859.           (system::log10 1 0 nil nil nil)
  1860.           (system::log2 1 0 nil nil nil)
  1861.           (logand 0 0 t nil nil)
  1862.           (logandc1 2 0 nil nil nil)
  1863.           (logandc2 2 0 nil nil nil)
  1864.           (logbitp 2 0 nil nil nil)
  1865.           (logcount 1 0 nil nil nil)
  1866.           (logeqv 0 0 t nil nil)
  1867.           (system::logical-pathname-p 1 0 nil nil nil)
  1868.           (logior 0 0 t nil nil)
  1869.           (lognand 2 0 nil nil nil)
  1870.           (lognor 2 0 nil nil nil)
  1871.           (lognot 1 0 nil nil nil)
  1872.           (logorc1 2 0 nil nil nil)
  1873.           (logorc2 2 0 nil nil nil)
  1874.           (logtest 2 0 nil nil nil)
  1875.           (logxor 0 0 t nil nil)
  1876.           (long-float-digits 0 0 nil nil nil)
  1877.           (system::long-float-p 1 0 nil nil nil)
  1878.           (lower-case-p 1 0 nil nil nil)
  1879.           (system::lpar-reader 2 0 nil nil nil)
  1880.           ;(machine-instance 0 0 nil nil nil)
  1881.           ;(machine-type 0 0 nil nil nil)
  1882.           ;(machine-version 0 0 nil nil nil)
  1883.           (macro-function 1 0 nil nil nil)
  1884.           (macroexpand 1 1 nil nil nil)
  1885.           (macroexpand-1 1 1 nil nil nil)
  1886.           (make-array 1 0 nil (:adjustable :element-type :initial-element :initial-contents :fill-pointer :displaced-to :displaced-index-offset) nil)
  1887.           (system::make-bit-vector 1 0 nil nil nil)
  1888.           (make-broadcast-stream 0 0 t nil nil)
  1889.           (make-buffered-input-stream 2 0 nil nil nil)
  1890.           (make-buffered-output-stream 1 0 nil nil nil)
  1891.           (make-char 1 2 nil nil nil)
  1892.           (system::make-code-vector 1 0 nil nil nil)
  1893.           (make-concatenated-stream 0 0 t nil nil)
  1894.           (make-dir 1 0 nil nil nil)
  1895.           (make-dispatch-macro-character 1 2 nil nil nil)
  1896.           (make-echo-stream 2 0 nil nil nil)
  1897.           (make-hash-table 0 0 nil (:initial-contents :test :size :rehash-size :rehash-threshold) nil)
  1898.           (make-list 1 0 nil (:initial-element) nil)
  1899.           (system::make-load-time-eval 1 0 nil nil nil)
  1900.           (make-package 1 0 nil (:nicknames :use) nil)
  1901.           (make-pathname 0 0 nil (:defaults :case :host :device :directory :name :type :version) nil)
  1902.           #+(or UNIX OS/2) (make-pipe-input-stream 1 0 nil nil nil)
  1903.           #+(or UNIX OS/2) (make-pipe-output-stream 1 0 nil nil nil)
  1904.           (make-random-state 0 1 nil nil nil)
  1905.           (make-sequence 2 0 nil (:initial-element :update) nil)
  1906.           (make-string 1 0 nil (:initial-element) nil)
  1907.           (make-string-input-stream 1 2 nil nil nil)
  1908.           (make-string-output-stream 0 1 nil nil nil)
  1909.           (system::make-string-push-stream 1 0 nil nil nil)
  1910.           (make-symbol 1 0 nil nil nil)
  1911.           (make-synonym-stream 1 0 nil nil nil)
  1912.           (make-two-way-stream 2 0 nil nil nil)
  1913.           (makunbound 1 0 nil nil nil)
  1914.           (map 3 0 t nil nil)
  1915.           (system::map-all-symbols 1 0 nil nil nil)
  1916.           (system::map-external-symbols 2 0 nil nil nil)
  1917.           (system::map-symbols 2 0 nil nil nil)
  1918.           (mapc 2 0 t nil nil)
  1919.           (mapcan 2 0 t nil nil)
  1920.           (mapcar 2 0 t nil nil)
  1921.           (mapcon 2 0 t nil nil)
  1922.           (maphash 2 0 nil nil nil)
  1923.           (mapl 2 0 t nil nil)
  1924.           (maplist 2 0 t nil nil)
  1925.           (mask-field 2 0 nil nil nil)
  1926.           (max 1 0 t nil nil)
  1927.           (member 2 0 nil (:test :test-not :key) nil)
  1928.           (member-if 2 0 nil (:key) nil)
  1929.           (member-if-not 2 0 nil (:key) nil)
  1930.           (merge 4 0 nil (:key) nil)
  1931.           (merge-pathnames 1 2 nil (:wild) nil)
  1932.           (min 1 0 t nil nil)
  1933.           (minusp 1 0 nil nil nil)
  1934.           (mismatch 2 0 nil (:from-end :start1 :end1 :start2 :end2 :key :test :test-not) nil)
  1935.           (mod 2 0 nil nil nil)
  1936.           (name-char 1 0 nil nil nil)
  1937.           (namestring 1 1 nil nil nil)
  1938.           (nbutlast 1 1 nil nil nil)
  1939.           (nconc 0 0 t nil nil)
  1940.           (ninth 1 0 nil nil nil)
  1941.           (not 1 0 nil nil nil)
  1942.           (system::not-feature-reader 3 0 nil nil nil)
  1943.           (system::not-readable-reader 3 0 nil nil nil)
  1944.           (notany 2 0 t nil nil)
  1945.           (notevery 2 0 t nil nil)
  1946.           (nreconc 2 0 nil nil nil)
  1947.           (nreverse 1 0 nil nil nil)
  1948.           (nstring-capitalize 1 0 nil (:start :end) nil)
  1949.           (nstring-downcase 1 0 nil (:start :end) nil)
  1950.           (nstring-upcase 1 0 nil (:start :end) nil)
  1951.           (nsublis 2 0 nil (:test :test-not :key) nil)
  1952.           (nsubst 3 0 nil (:test :test-not :key) nil)
  1953.           (nsubst-if 3 0 nil (:key) nil)
  1954.           (nsubst-if-not 3 0 nil (:key) nil)
  1955.           (nsubstitute 3 0 nil (:from-end :start :end :key :test :test-not :count) nil)
  1956.           (nsubstitute-if 3 0 nil (:from-end :start :end :key :count) nil)
  1957.           (nsubstitute-if-not 3 0 nil (:from-end :start :end :key :count) nil)
  1958.           (nth 2 0 nil nil nil)
  1959.           (nthcdr 2 0 nil nil nil)
  1960.           (null 1 0 nil nil nil)
  1961.           (numberp 1 0 nil nil nil)
  1962.           (numerator 1 0 nil nil nil)
  1963.           (system::octal-reader 3 0 nil nil nil)
  1964.           (oddp 1 0 nil nil nil)
  1965.           (open 1 0 nil (:direction :element-type :if-exists :if-does-not-exist) nil)
  1966.           (output-stream-p 1 0 nil nil nil)
  1967.           (package-name 1 0 nil nil nil)
  1968.           (package-nicknames 1 0 nil nil nil)
  1969.           (package-shadowing-symbols 1 0 nil nil nil)
  1970.           (package-use-list 1 0 nil nil nil)
  1971.           (package-used-by-list 1 0 nil nil nil)
  1972.           (packagep 1 0 nil nil nil)
  1973.           (pairlis 2 1 nil nil nil)
  1974.           (system::parse-body 1 2 nil nil nil)
  1975.           (parse-integer 1 0 nil (:start :end :radix :junk-allowed) nil)
  1976.           (parse-namestring 1 2 nil (:start :end :junk-allowed) nil)
  1977.           (pathname 1 0 nil nil nil)
  1978.           (pathname-device 1 0 nil (:case) nil)
  1979.           (pathname-directory 1 0 nil (:case) nil)
  1980.           (pathname-host 1 0 nil (:case) nil)
  1981.           (pathname-match-p 2 0 nil nil nil)
  1982.           (pathname-name 1 0 nil (:case) nil)
  1983.           (system::pathname-reader 3 0 nil nil nil)
  1984.           (pathname-type 1 0 nil (:case) nil)
  1985.           (pathname-version 1 0 nil nil nil)
  1986.           (pathnamep 1 0 nil nil nil)
  1987.           (peek-char 0 5 nil nil nil)
  1988.           (phase 1 0 nil nil nil)
  1989.           (plusp 1 0 nil nil nil)
  1990.           (position 2 0 nil (:from-end :start :end :key :test :test-not) nil)
  1991.           (position-if 2 0 nil (:from-end :start :end :key) nil)
  1992.           (position-if-not 2 0 nil (:from-end :start :end :key) nil)
  1993.           (pprint 1 1 nil nil nil)
  1994.           (prin1 1 1 nil nil nil)
  1995.           (prin1-to-string 1 0 nil nil nil)
  1996.           (princ 1 1 nil nil nil)
  1997.           (princ-to-string 1 0 nil nil nil)
  1998.           (print 1 1 nil nil nil)
  1999.           (probe-file 1 0 nil nil nil)
  2000.           (proclaim 1 0 nil nil nil)
  2001.           (system::puthash 3 0 nil nil nil)
  2002.           (system::quote-reader 2 0 nil nil nil)
  2003.           (system::radix-reader 3 0 nil nil nil)
  2004.           (random 1 1 nil nil nil)
  2005.           (random-state-p 1 0 nil nil nil)
  2006.           (rassoc 2 0 nil (:test :test-not :key) nil)
  2007.           (rassoc-if 2 0 nil (:key) nil)
  2008.           (rassoc-if-not 2 0 nil (:key) nil)
  2009.           (rational 1 0 nil nil nil)
  2010.           (rationalize 1 0 nil nil nil)
  2011.           (rationalp 1 0 nil nil nil)
  2012.           (read 0 4 nil nil nil)
  2013.           (read-byte 1 2 nil nil nil)
  2014.           (read-char 0 4 nil nil nil)
  2015.           (read-char-no-hang 0 4 nil nil nil)
  2016.           (read-delimited-list 1 2 nil nil nil)
  2017.           (system::read-eval-print 1 1 nil nil nil)
  2018.           (system::read-eval-reader 3 0 nil nil nil)
  2019.           (system::read-form 1 1 nil nil nil)
  2020.           (read-from-string 1 2 nil (:preserve-whitespace :start :end) nil)
  2021.           (read-line 0 4 nil nil nil)
  2022.           (read-preserving-whitespace 0 4 nil nil nil)
  2023.           (readtablep 1 0 nil nil nil)
  2024.           (realp 1 0 nil nil nil)
  2025.           (realpart 1 0 nil nil nil)
  2026.           (system::redo-eval-frame 1 0 nil nil nil)
  2027.           (reduce 2 0 nil (:from-end :start :end :key :initial-value) nil)
  2028.           (rem 2 0 nil nil nil)
  2029.           (remhash 2 0 nil nil nil)
  2030.           (remove 2 0 nil (:from-end :start :end :key :test :test-not :count) nil)
  2031.           (remove-duplicates 1 0 nil (:from-end :start :end :key :test :test-not) nil)
  2032.           (remove-if 2 0 nil (:from-end :start :end :key :count) nil)
  2033.           (remove-if-not 2 0 nil (:from-end :start :end :key :count) nil)
  2034.           (remprop 2 0 nil nil nil)
  2035.           (rename-file 2 0 nil nil nil)
  2036.           (rename-package 2 1 nil nil nil)
  2037.           (replace 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2038.           (rest 1 0 nil nil nil)
  2039.           (system::return-from-eval-frame 2 0 nil nil nil)
  2040.           (revappend 2 0 nil nil nil)
  2041.           (reverse 1 0 nil nil nil)
  2042.           (room 0 0 nil nil nil)
  2043.           (round 1 1 nil nil nil)
  2044.           (row-major-aref 2 0 nil nil nil)
  2045.           (system::row-major-store 3 0 nil nil nil)
  2046.           (system::rpar-reader 2 0 nil nil nil)
  2047.           (rplaca 2 0 nil nil nil)
  2048.           (rplacd 2 0 nil nil nil)
  2049.           (system::same-env-as 2 0 nil nil nil)
  2050.           (savemem 1 0 nil nil nil)
  2051.           (sbit 1 0 t nil nil)
  2052.           (scale-float 2 0 nil nil nil)
  2053.           (schar 2 0 nil nil nil)
  2054.           (search 2 0 nil (:from-end :start1 :end1 :start2 :end2 :key :test :test-not) nil)
  2055.           (system::search-string-equal 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2056.           (system::search-string= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2057.           (second 1 0 nil nil nil)
  2058.           (system::sequencep 1 0 nil nil nil)
  2059.           (set 2 0 nil nil nil)
  2060.           (set-char-bit 3 0 nil nil nil)
  2061.           (set-dispatch-macro-character 3 1 nil nil nil)
  2062.           (system::set-fill-pointer 2 0 nil nil nil)
  2063.           (set-macro-character 2 2 nil nil nil)
  2064.           (set-syntax-from-char 2 2 nil nil nil)
  2065.           (seventh 1 0 nil nil nil)
  2066.           (shadow 1 1 nil nil nil)
  2067.           (shadowing-import 1 1 nil nil nil)
  2068.           ;(shell 0 1 nil nil nil)
  2069.           (system::short-float-p 1 0 nil nil nil)
  2070.           (show-stack 0 0 nil nil nil)
  2071.           (signum 1 0 nil nil nil)
  2072.           (system::simple-array-p 1 0 nil nil nil)
  2073.           (simple-bit-vector-p 1 0 nil nil nil)
  2074.           (simple-string-p 1 0 nil nil nil)
  2075.           (simple-vector-p 1 0 nil nil nil)
  2076.           (sin 1 0 nil nil nil)
  2077.           (system::single-float-p 1 0 nil nil nil)
  2078.           (sinh 1 0 nil nil nil)
  2079.           (sixth 1 0 nil nil nil)
  2080.           (clos:slot-value 2 0 nil nil nil)
  2081.           (clos::set-slot-value 3 0 nil nil nil)
  2082.           (clos:slot-boundp 2 0 nil nil nil)
  2083.           (clos:slot-makunbound 2 0 nil nil nil)
  2084.           (clos:slot-exists-p 2 0 nil nil nil)
  2085.           (software-type 0 0 nil nil nil)
  2086.           (software-version 0 0 nil nil nil)
  2087.           (some 2 0 t nil nil)
  2088.           (sort 2 0 nil (:key :start :end) nil)
  2089.           (special-form-p 1 0 nil nil nil)
  2090.           (system::special-variable-p 1 0 nil nil nil)
  2091.           (sqrt 1 0 nil nil nil)
  2092.           (stable-sort 2 0 nil (:key :start :end) nil)
  2093.           (standard-char-p 1 0 nil nil nil)
  2094.           (system::store 2 0 t nil nil)
  2095.           (system::store-char 3 0 nil nil nil)
  2096.           (system::store-schar 3 0 nil nil nil)
  2097.           (stream-element-type 1 0 nil nil nil)
  2098.           (streamp 1 0 nil nil nil)
  2099.           (string 1 0 nil nil nil)
  2100.           (system::string-both-trim 3 0 nil nil nil)
  2101.           (string-capitalize 1 0 nil (:start :end) nil)
  2102.           (string-char-p 1 0 nil nil nil)
  2103.           (string-concat 0 0 t nil nil)
  2104.           (string-downcase 1 0 nil (:start :end) nil)
  2105.           (string-equal 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2106.           (string-greaterp 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2107.           (system::string-input-stream-index 1 0 nil nil nil)
  2108.           (string-lessp 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2109.           (string-not-equal 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2110.           (string-not-greaterp 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2111.           (string-not-lessp 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2112.           (system::string-reader 2 0 nil nil nil)
  2113.           (system::string-stream-p 1 0 nil nil nil)
  2114.           (string-upcase 1 0 nil (:start :end) nil)
  2115.           (string/= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2116.           (string< 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2117.           (string<= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2118.           (string= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2119.           (string> 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2120.           (string>= 2 0 nil (:start1 :end1 :start2 :end2) nil)
  2121.           (stringp 1 0 nil nil nil)
  2122.           (system::structure-reader 3 0 nil nil nil)
  2123.           (sublis 2 0 nil (:test :test-not :key) nil)
  2124.           (system::subr-info 1 0 nil nil nil)
  2125.           (subseq 2 1 nil nil nil)
  2126.           (subst 3 0 nil (:test :test-not :key) nil)
  2127.           (subst-if 3 0 nil (:key) nil)
  2128.           (subst-if-not 3 0 nil (:key) nil)
  2129.           (substitute 3 0 nil (:from-end :start :end :key :test :test-not :count) nil)
  2130.           (substitute-if 3 0 nil (:from-end :start :end :key :count) nil)
  2131.           (substitute-if-not 3 0 nil (:from-end :start :end :key :count) nil)
  2132.           (substring 2 1 nil nil nil)
  2133.           (svref 2 0 nil nil nil)
  2134.           (system::svstore 3 0 nil nil nil)
  2135.           (sxhash 1 0 nil nil nil)
  2136.           (symbol-function 1 0 nil nil nil)
  2137.           (symbol-name 1 0 nil nil nil)
  2138.           (symbol-package 1 0 nil nil nil)
  2139.           (symbol-plist 1 0 nil nil nil)
  2140.           (symbol-value 1 0 nil nil nil)
  2141.           (symbolp 1 0 nil nil nil)
  2142.           (system::synonym-stream-p 1 0 nil nil nil)
  2143.           (system::syntax-error-reader 3 0 nil nil nil)
  2144.           (tailp 2 0 nil nil nil)
  2145.           (tan 1 0 nil nil nil)
  2146.           (tanh 1 0 nil nil nil)
  2147.           (tenth 1 0 nil nil nil)
  2148.           (terpri 0 1 nil nil nil)
  2149.           (system::the-frame 0 0 nil nil nil)
  2150.           (third 1 0 nil nil nil)
  2151.           (translate-pathname 3 0 nil (:all :merge) nil)
  2152.           (tree-equal 2 0 nil (:test :test-not) nil)
  2153.           (truename 1 0 nil nil nil)
  2154.           (truncate 1 1 nil nil nil)
  2155.           (system::two-way-stream-p 1 0 nil nil nil)
  2156.           (type-of 1 0 nil nil nil)
  2157.           (unexport 1 1 nil nil nil)
  2158.           (unintern 1 1 nil nil nil)
  2159.           (system::uninterned-reader 3 0 nil nil nil)
  2160.           (unread-char 1 1 nil nil nil)
  2161.           (unuse-package 1 1 nil nil nil)
  2162.           (system::unwind-to-driver 0 0 nil nil nil)
  2163.           (upper-case-p 1 0 nil nil nil)
  2164.           (use-package 1 1 nil nil nil)
  2165.           (system::use-package-aux 1 0 nil nil nil)
  2166.           #+(or UNIX WIN32-UNIX) (user-homedir-pathname 0 1 nil nil nil)
  2167.           (values 0 0 t nil nil)
  2168.           (values-list 1 0 nil nil nil)
  2169.           (vector 0 0 t nil nil)
  2170.           (system::vector-endtest 2 0 nil nil nil)
  2171.           (system::vector-fe-endtest 2 0 nil nil nil)
  2172.           (system::vector-fe-init 1 0 nil nil nil)
  2173.           (system::vector-fe-init-end 2 0 nil nil nil)
  2174.           (system::vector-fe-upd 2 0 nil nil nil)
  2175.           (system::vector-init 1 0 nil nil nil)
  2176.           (system::vector-init-start 2 0 nil nil nil)
  2177.           (system::vector-length 1 0 nil nil nil)
  2178.           (vector-pop 1 0 nil nil nil)
  2179.           (vector-push 2 0 nil nil nil)
  2180.           (vector-push-extend 2 1 nil nil nil)
  2181.           (system::vector-reader 3 0 nil nil nil)
  2182.           (system::vector-upd 2 0 nil nil nil)
  2183.           (vectorp 1 0 nil nil nil)
  2184.           (system::version 0 1 nil nil nil)
  2185.           (wild-pathname-p 1 1 nil nil nil)
  2186.           (write 1 0 nil (:case :level :length :gensym :escape :radix :base :array :circle :pretty :closure :readably :stream) nil)
  2187.           (write-byte 2 0 nil nil nil)
  2188.           (write-char 1 1 nil nil nil)
  2189.           (write-line 1 1 nil (:start :end) nil)
  2190.           (write-string 1 1 nil (:start :end) nil)
  2191.           (write-to-string 1 0 nil (:case :level :length :gensym :escape :radix :base :array :circle :pretty :closure :readably) nil)
  2192.           (xgcd 0 0 t nil nil)
  2193.           (zerop 1 0 nil nil nil)
  2194. ) ) ) )  )
  2195. (defconstant function-codes
  2196.   (let ((hashtable (make-hash-table :test #'eq)))
  2197.     (dotimes (i (* 3 256))
  2198.       (let ((sym (%funtabref i))) ; Name der Funktion FUNTAB[i]
  2199.         (when sym (setf (gethash sym hashtable) i))
  2200.     ) )
  2201.     hashtable
  2202. ) )
  2203. (defconstant funtabR-index ; Startindex der FUNTABR bzgl. FUNTAB
  2204.   (dotimes (i (* 3 256))
  2205.     (let ((sym (%funtabref i)))
  2206.       (multiple-value-bind (name req opt rest-p) (subr-info sym)
  2207.         (declare (ignore name req opt))
  2208.         (when rest-p (return i))
  2209. ) ) ) )
  2210. (defun CALLS-code (funtab-index)
  2211.   (if (< funtab-index 256)
  2212.     `(CALLS1 ,funtab-index)
  2213.     `(CALLS2 ,(- funtab-index 256))
  2214. ) )
  2215.  
  2216. ; Hilfsfunktion: mapcan, aber mit append statt nconc:
  2217. #|
  2218. #-CLISP
  2219. (defun mapcap (fun &rest lists &aux (L nil))
  2220.   (loop
  2221.     (setq L
  2222.       (nconc
  2223.         (reverse
  2224.           (apply fun
  2225.             (maplist #'(lambda (listsr)
  2226.                          (if (atom (car listsr))
  2227.                            (return)
  2228.                            (pop (car listsr))
  2229.                        ) )
  2230.                      lists
  2231.         ) ) )
  2232.         L
  2233.       )
  2234.   ) )
  2235.   (nreverse L)
  2236. )
  2237. |#
  2238. #-CLISP
  2239. (defun mapcap (fun &rest lists)
  2240.   (apply #'append (apply #'mapcar fun lists))
  2241. )
  2242.  
  2243. ; Hilfsfunktion: mapcon, aber mit append statt nconc:
  2244. #|
  2245. #-CLISP
  2246. (defun maplap (fun &rest lists &aux (L nil))
  2247.   (loop
  2248.     (setq L
  2249.       (nconc
  2250.         (reverse
  2251.           (apply fun
  2252.             (maplist #'(lambda (listsr)
  2253.                          (if (atom (car listsr))
  2254.                            (return)
  2255.                            (prog1
  2256.                              (car listsr)
  2257.                              (setf (car listsr) (cdr (car listsr)))
  2258.                        ) ) )
  2259.                      lists
  2260.         ) ) )
  2261.         L
  2262.       )
  2263.   ) )
  2264.   (nreverse L)
  2265. )
  2266. |#
  2267. #-CLISP
  2268. (defun maplap (fun &rest lists)
  2269.   (apply #'append (apply #'maplist fun lists))
  2270. )
  2271.  
  2272. ; (memq item const-symbollist) == (member item const-symbollist :test #'eq),
  2273. ; nur der boolesche Wert.
  2274. (defmacro memq (item list)
  2275.   (if (and (constantp list) (listp (eval list)))
  2276.     `(case ,item (,(eval list) t) (t nil))
  2277.     `(member ,item ,list :test #'eq)
  2278. ) )
  2279.  
  2280. ; Fehlermeldungsfunktion
  2281. (defun compiler-error (caller &optional where)
  2282.   (error 
  2283.    #L{
  2284.    DEUTSCH "Fehler im Compiler!! Aufgetreten in ~A~@[ bei ~A~]."
  2285.    ENGLISH "Compiler bug!! Occurred in ~A~@[ at ~A~]."
  2286.    FRANCAIS "Erreur dans le compilateur!! Arrivé dans ~A~@[ au point ~A~]."
  2287.    }
  2288.    caller where
  2289. ) )
  2290.  
  2291.  
  2292.  
  2293. ;                      S T A C K - V E R W A L T U N G
  2294.  
  2295. ; Ein Stackzustand beschreibt, was sich zur Laufzeit alles auf den beiden
  2296. ; Stacks befinden wird.
  2297. ; Genaue Struktur:
  2298. ; (item1 ... itemk . fun)
  2299. ; Das ist im Speicher in Wirklichkeit eine Baumstruktur!
  2300. ; Es bedeuten hierbei:
  2301. ;  fun = FNODE der Funktion, in der gezählt wird.
  2302. ;  item = eines der folgenden:
  2303. ;    n (Integer >=0) : n Lisp-Objekte auf dem STACK
  2304. ;                      belegt n STACK-Einträge
  2305. ;    (BIND n)        : einen Bindungsframe für n Variablen,
  2306. ;                      belegt 1+2*n STACK-Einträge und 0 SP-Einträge
  2307. ;                      Muß bei Unwind explizit aufgelöst werden
  2308. ;    PROGV           : ein Bindungsframe für beliebig viele Variablen,
  2309. ;                      belegt ? STACK-Einträge und 1 SP-Eintrag (Pointer über
  2310. ;                      den Frame = alter STACK)
  2311. ;                      Muß bei Unwind explizit aufgelöst werden
  2312. ;    CATCH           : ein CATCH-Frame
  2313. ;                      belegt 3 STACK-Einträge und 2+*jmpbuf-size* SP-Einträge
  2314. ;    UNWIND-PROTECT  : ein Unwind-Protect-Frame
  2315. ;                      belegt 2 STACK-Einträge und 2+*jmpbuf-size* SP-Einträge
  2316. ;                      Muß bei Unwind aufgelöst und der Cleanup ausgeführt
  2317. ;                      werden
  2318. ;    CLEANUP         : während der Cleanup-Phase eines UNWIND-PROTECT
  2319. ;                      belegt ? STACK-Einträge und 3 SP-Einträge
  2320. ;                      (der untere ist Pointer über den Frame = alter STACK)
  2321. ;    BLOCK           : ein BLOCK-Frame
  2322. ;                      belegt 3 STACK-Einträge und 2+*jmpbuf-size* SP-Einträge
  2323. ;                      Muß bei Unwind explizit aufgelöst werden
  2324. ;    (TAGBODY n)     : ein TAGBODY-Frame, der n Tags aufhebt
  2325. ;                      belegt 3+n STACK-Einträge und 1+*jmpbuf-size* SP-Einträge
  2326. ;                      Muß bei Unwind explizit aufgelöst werden
  2327. ;    MVCALLP         : Vorbereitung für MVCALL
  2328. ;                      belegt 1 STACK-Eintrag und 1 SP-Eintrag (Pointer über
  2329. ;                      FRAME = STACK)
  2330. ;    MVCALL          : viele Lisp-Objekte
  2331. ;                      belegt ? STACK-Einträge und 1 SP-Eintrag (Pointer über
  2332. ;                      Frame = alter STACK)
  2333. ;    ANYTHING        : viele Lisp-Objekte und Frames
  2334. ;                      belegt ? STACK-Einträge und 1 SP-Eintrag (Pointer über
  2335. ;                      Frame = alter STACK)
  2336.  
  2337. (defvar *stackz*)    ; der aktuelle Stackzustand
  2338.  
  2339. ; (stackz-fun stackz) extrahiert aus einem Stackzustand die Funktion, in der
  2340. ; gerade gearbeitet wird.
  2341. #|
  2342. (defun stackz-fun (stackz)
  2343.   (loop (when (atom stackz) (return)) (setq stackz (cdr stackz)))
  2344.   stackz
  2345. )
  2346. |#
  2347. ; äquivalent, aber schneller:
  2348. (defun stackz-fun (stackz)
  2349.   (if (atom stackz) stackz (cdr (last stackz)))
  2350. )
  2351.  
  2352. ; (in-same-function-p stackz1 stackz2) stellt fest, ob in beiden Stackzuständen
  2353. ; in derselben Funktion gearbeitet wird.
  2354. (defun in-same-function-p (stackz1 stackz2)
  2355.   (eq (stackz-fun stackz1) (stackz-fun stackz2))
  2356. )
  2357.  
  2358. ; (zugriff-in-stack stackz1 stackz2)
  2359. ; Für den Zugriff auf lokale Variablen im Stack:
  2360. ; ergibt zu zwei Stackzuständen stackz1 und stackz2, die beide innerhalb
  2361. ; derselben Funktion liegen und wo stackz1 "tiefer" ist als stackz2:
  2362. ; 2 Werte: NIL und n, falls (stackz2) = (STACK+4*n) von stackz1 aus,
  2363. ;          k und n, falls (stackz2) = ((SP+4*k)+4*n) von stackz1 aus.
  2364. ; (Falls stackz2 mit BLOCK oder TAGBODY beginnt, ist immer der Zugriff auf die
  2365. ;  consvar eines Block- bzw. Tagbody-Frames gemeint.)
  2366. (defun zugriff-in-stack (stackz1 stackz2 &aux (k nil) (n 0) (kd 0))
  2367.   (loop ; beim Durchlaufen der Stacks nach oben:
  2368.     ; momentanes STACK ist STACK+4*n (bei k=NIL) bzw. (SP+4*k)+4*n,
  2369.     ; momentanes SP ist SP+4*kd (bei k=NIL) bzw. SP+4*(k+kd).
  2370.     (when (eq stackz1 stackz2) (return))
  2371.     (when (atom stackz1) (compiler-error 'zugriff-in-stack "STACKZ-END"))
  2372.     (let ((item (car stackz1)))
  2373.       (cond ((integerp item) (setq n (+ n item)))
  2374.             ((consp item)
  2375.              (case (first item)
  2376.                (BIND    (setq n (+ n (+ 1 (* 2 (second item))))))
  2377.                (TAGBODY (setq kd (+ kd (+ 1 *jmpbuf-size*))
  2378.                               n (+ n (+ 3 (second item)))
  2379.                )        )
  2380.                (t (compiler-error 'zugriff-in-stack "STACKZ-LISTITEM"))
  2381.             ))
  2382.             (t
  2383.              (case item
  2384.                (PROGV          (setq k (if k (+ k kd) kd) kd 1 n 0))
  2385.                (CATCH          (setq kd (+ kd (+ 2 *jmpbuf-size*)) n (+ n 3)))
  2386.                (UNWIND-PROTECT (setq kd (+ kd (+ 2 *jmpbuf-size*)) n (+ n 2)))
  2387.                (CLEANUP        (setq k (if k (+ k kd) kd) kd 3 n 0))
  2388.                (BLOCK          (setq kd (+ kd (+ 2 *jmpbuf-size*)) n (+ n 3)))
  2389.                (MVCALLP        (setq kd (+ kd 1) n (+ n 1)))
  2390.                ((MVCALL ANYTHING)
  2391.                                (setq k (if k (+ k kd) kd) kd 1 n 0))
  2392.                (t (compiler-error 'zugriff-in-stack "STACKZ-ITEM"))
  2393.     ) )     ))
  2394.     (setq stackz1 (cdr stackz1))
  2395.   )
  2396.   (when (and (consp stackz2) ; beim Zugriff auf BLOCK- bzw. TAGBODY-consvar:
  2397.              (or (eq (car stackz2) 'BLOCK)
  2398.                  (and (consp (car stackz2)) (eq (first (car stackz2)) 'TAGBODY))
  2399.         )    )
  2400.     (setq n (+ n 2)) ; consvar liegt genau 2 Einträge höher als Frameanfang
  2401.   )
  2402.   (values k n)
  2403. )
  2404.  
  2405. ; (may-UNWIND stackz1 stackz2)
  2406. ; stellt fest, ob (UNWIND stackz1 stackz2 for-value) legal ist. Dazu ist
  2407. ; notwendig, daß der Compiler über die Frames zwischen stackz1 und stackz2
  2408. ; genau Bescheid weiß.
  2409. (defun may-UNWIND (stackz1 stackz2)
  2410.   (loop
  2411.     (when (eq stackz1 stackz2) (return t))
  2412.     (when (atom stackz1) (compiler-error 'may-UNWIND "STACKZ-END"))
  2413.     (when (eq (car stackz1) 'ANYTHING) (return nil))
  2414.     (setq stackz1 (cdr stackz1))
  2415. ) )
  2416.  
  2417. ; (expand-UNWIND stackz1 stackz2 for-value)
  2418. ; liefert ein zu (UNWIND stackz1 stackz2 for-value) äquivalentes Codestück,
  2419. ; bestehend aus
  2420. ; (SKIP n), (SKIPI k n), (SKIPSP k), (VALUES0), (UNWIND-PROTECT-CLEANUP),
  2421. ; (UNBIND1), (BLOCK-CLOSE), (TAGBODY-CLOSE).
  2422. ; Es muß - ausgehend von stackz1 - den Stack so bereinigen, daß danach der
  2423. ; Stackzustand stackz2 vorliegt. Bei for-value=NIL können die Werte dabei
  2424. ; weggeworfen werden.
  2425. (defun expand-UNWIND (stackz1 stackz2 for-value
  2426.                       &aux (k nil) (n 0) (kd 0) (codelist nil))
  2427.   (flet ((here () ; bis hierher erst einmal die Stacks hochsetzen
  2428.            (if k
  2429.              (progn
  2430.                (push `(SKIPI ,k ,n) codelist)
  2431.                (when (<= kd 0) (compiler-error 'expand-UNWIND "SP-depth"))
  2432.                (when (> kd 1) (push `(SKIPSP ,(- kd 1)) codelist))
  2433.              )
  2434.              (progn
  2435.                (when (> n 0) (push `(SKIP ,n) codelist))
  2436.                (when (> kd 0) (push `(SKIPSP ,kd) codelist))
  2437.            ) )
  2438.            (setq k nil n 0 kd 0)
  2439.         ))
  2440.     (loop ; beim Durchlaufen der Stacks nach oben:
  2441.       ; momentanes STACK ist STACK+4*n (bei k=NIL) bzw. (SP+4*k)+4*n,
  2442.       ; momentanes SP ist SP+4*kd (bei k=NIL) bzw. SP+4*(k+kd).
  2443.       (when (eq stackz1 stackz2) (here) (return))
  2444.       (when (atom stackz1) (compiler-error 'expand-UNWIND "STACKZ-END"))
  2445.       (let ((item (car stackz1)))
  2446.         (cond ((integerp item) (setq n (+ n item)))
  2447.               ((consp item)
  2448.                (case (first item)
  2449.                  (BIND    (here) (push '(UNBIND1) codelist))
  2450.                  (TAGBODY (here) (push '(TAGBODY-CLOSE) codelist))
  2451.                  (t (compiler-error 'expand-UNWIND "STACKZ-LISTITEM"))
  2452.               ))
  2453.               (t
  2454.                (case item
  2455.                  (PROGV (here) (push '(UNBIND1) codelist) (setq kd 1))
  2456.                  (CATCH (setq kd (+ kd (+ 2 *jmpbuf-size*)) n (+ n 3)))
  2457.                  (UNWIND-PROTECT
  2458.                    (here)
  2459.                    (unless for-value
  2460.                       ; bei for-value=NIL wird beim ersten auftretenden
  2461.                       ; UNWIND-PROTECT-Frame ein '(VALUES0) eingefügt.
  2462.                      (setq for-value t)
  2463.                      (push '(VALUES0) codelist)
  2464.                    )
  2465.                    (push '(UNWIND-PROTECT-CLEANUP) codelist)
  2466.                  )
  2467.                  (CLEANUP (setq k (if k (+ k kd) kd) kd 3 n 0))
  2468.                  (BLOCK (here) (push '(BLOCK-CLOSE) codelist))
  2469.                  (MVCALLP (setq kd (+ kd 1) n (+ n 1)))
  2470.                  (MVCALL (setq k (if k (+ k kd) kd) kd 1 n 0))
  2471.                  (t (compiler-error 'expand-UNWIND "STACKZ-ITEM"))
  2472.       ) )     ))
  2473.       (setq stackz1 (cdr stackz1))
  2474.     )
  2475.     (nreverse codelist)
  2476. ) )
  2477.  
  2478. ; (spdepth-difference stackz1 stackz2)
  2479. ; liefert den Unterschied k von SP bei stackz1 und SP bei stackz2.
  2480. ; Um den SP von stackz1 zu stackz2 hochzusetzen, reicht also ein (SKIPSP k).
  2481. (defun spdepth-difference (stackz1 stackz2 &aux (k 0))
  2482.   (loop
  2483.     (when (eq stackz1 stackz2) (return))
  2484.     (when (atom stackz1) (compiler-error 'spdepth-difference "STACKZ-END"))
  2485.     (let ((item (car stackz1)))
  2486.       (if (consp item)
  2487.         (case (first item)
  2488.           (TAGBODY (incf k (+ 1 *jmpbuf-size*)))
  2489.         )
  2490.         (case item
  2491.           ((PROGV MVCALLP MVCALL ANYTHING) (incf k 1))
  2492.           ((CATCH UNWIND-PROTECT BLOCK) (incf k (+ 2 *jmpbuf-size*)))
  2493.           (CLEANUP (incf k 3))
  2494.     ) ) )
  2495.     (setq stackz1 (cdr stackz1))
  2496.   )
  2497.   k
  2498. )
  2499.  
  2500.  
  2501.  
  2502. ;        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
  2503.  
  2504. ; mitgegeben vom Interpreter: %fenv%
  2505.  
  2506. ; Interpreter-Funktions-Environment hat die Gestalt
  2507. ; %fenv% = NIL oder #(f1 def1 ... fn defn NEXT-ENV), NEXT-ENV von derselben
  2508. ; Gestalt.
  2509. ; Damit ist eine Abbildung fi --> defi realisiert.
  2510. ; defi = (SYSTEM::MACRO . expander)  bedeutet einen lokalen Macro.
  2511. ; defi = Closure                     bedeutet, daß defi die lokale
  2512. ;                                    Funktionsdefinition von fi ist
  2513. ; defi = NIL                         bedeutet, daß eine lokale Funktions-
  2514. ;                                    definition noch hineinkommt (vgl. LABELS)
  2515.  
  2516. ; neu konstruiert:
  2517. (defvar *fenv*)
  2518. ; enthält die neuen lexikalischen Funktionsbindungen.
  2519. ; *fenv* hat dieselbe Gestalt wie %fenv% und endet mit %fenv%:
  2520. ; #(f1 def1 ... fn defn NEXT-ENV), was eine Abbildung fi --> defi
  2521. ; realisiert.
  2522. ; defi = (SYSTEM::MACRO expander)  bedeutet einen lokalen Makro.
  2523. ; defi = (fdescr . var)            bedeutet, daß die lokale Funktionsdefinition
  2524. ;           von fi zur Laufzeit in der lexikalischen Variablen var steckt.
  2525. ;           fnode ist der zu fi gehörige fnode, anfangs noch NIL.
  2526. ; defi = (fdescr . const)          bedeutet, daß die lokale Funktionsdefinition
  2527. ;           von fi autonom ist und in der Konstanten const steckt.
  2528. ;           fnode ist der zu fi gehörige fnode, anfangs noch NIL.
  2529. ; Dabei ist fdescr ein Cons (fnode . lambdadescr),
  2530. ;           fnode der zu fi gehörige fnode oder NIL,
  2531. ;           lambdadescr = (LABELS . Liste der Werte von analyze-lambdalist)
  2532. ;           oder lambdadescr = (GENERIC . Signature) oder NIL.
  2533.  
  2534. ; Suche die lokale Funktionsdefinition des Symbols f in fenv :
  2535. ; Ergebnis ist:
  2536. ; SYSTEM::MACRO, expander           bei einem lokalen Macro,
  2537. ; GLOBAL, Vektor, Index             wenn defi = (svref Vektor Index)
  2538. ;                                   (also in %fenv% gefunden)
  2539. ; LOCAL, def, fdescr                wenn defi = def eine Variable oder Konstante
  2540. ;                                   (also in *fenv* ohne %fenv% gefunden)
  2541. ; NIL                               falls nicht lokal definiert.
  2542. (defun fenv-search (f &optional (fenv *fenv*))
  2543.   (loop
  2544.     (when (null fenv) (return-from fenv-search 'NIL))
  2545.     (unless (simple-vector-p fenv) (compiler-error 'fenv-search))
  2546.     (do ((l (1- (length fenv)))
  2547.          (i 0 (+ i 2)))
  2548.         ((= i l) (setq fenv (svref fenv i)))
  2549.       (if (equal f (svref fenv i))
  2550.         (let ((def (svref fenv (1+ i))))
  2551.           (return-from fenv-search
  2552.             (if (consp def)
  2553.               (if (eq (car def) 'SYSTEM::MACRO)
  2554.                 (values 'SYSTEM::MACRO (cdr def))
  2555.                 (values 'LOCAL (cdr def) (car def))
  2556.               )
  2557.               (values 'GLOBAL fenv (1+ i))
  2558.   ) ) ) ) ) )
  2559. )
  2560. ; Stellt fest, ob ein Funktionsname im Function-Environment fenv nicht
  2561. ; definiert ist und daher auf die globale Funktion verweist.
  2562. (defun global-in-fenv-p (s fenv)
  2563.   (eq (fenv-search s fenv) 'NIL)
  2564. )
  2565.  
  2566. ; Mit einem Vektor aus
  2567. ; - einem solchen Variablen-Environment (verkettete Vektoren, mit
  2568. ;   defi = #<SYMBOL-MACRO expansion> für Symbol-Macro-Definitionen),
  2569. ; - einem solchen Funktions-Environment (verkettete Vektoren, mit
  2570. ;   defi = (SYSTEM::MACRO . expander) für Macro-Definitionen zu fi)
  2571. ; arbeiten die Funktionen
  2572. ; MACROEXPAND-1, MACROEXPAND, PARSE-BODY:
  2573. #|
  2574. (MACROEXPAND-1 form env) expandiert die gegebene Form im Macroexpansions-
  2575. Environment env und liefert die 1 mal expandierte Form und T
  2576. (oder form und NIL, falls nicht expandierbar).
  2577.  
  2578. (MACROEXPAND form env) expandiert die gegebene Form im Macroexpansions-
  2579. Environment env und liefert die sooft wie möglich expandierte Form und T
  2580. (oder form und NIL, falls nicht expandierbar).
  2581.  
  2582. (PARSE-BODY body docstring-allowed env) analysiert den body und spaltet von
  2583. ihm die Deklarationen und den Docstring (falls erlaubt und vorhanden) ab.
  2584. 3 Werte: der übrige body-rest, eine Liste der vorgekommenen declspecs,
  2585. der Docstring (oder NIL).
  2586. |#
  2587.  
  2588.  
  2589. ;           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
  2590.  
  2591. ; mitgegeben vom Interpreter: %benv%
  2592.  
  2593. ; Interpreter-Block-Environment hat die Gestalt
  2594. ; %benv% = ((name1 . status1) ... (namen . statusn))
  2595. ; wobei namei ein Symbol und statusi der Status dieses lexikalisch umfassenden
  2596. ; Blocks ist: #<DISABLED> falls der Block bereits verlassen wurde, sonst ein
  2597. ; Pointer in den Stack auf den zugehörigen Block-Frame.
  2598.  
  2599. ; neu konstruiert:
  2600. (defvar *benv*)
  2601.  
  2602. ; *benv* hat die Gestalt
  2603. ; ((name1 . block1) ... (namen . blockn) . %benv%)
  2604. ; wobei blocki der Descriptor des Blocks mit Namen namei ist:
  2605. (defstruct (block (:copier nil))
  2606.   fnode                 ; Funktion, in der dieser Block definiert ist, ein FNODE
  2607.   label                 ; label, an dem dieser Block zu Ende ist
  2608.   stackz                ; Stackzustand nach dem Aufbau des Block-Frames
  2609.   consvar               ; Variable, die im Stack im Block-Frame liegt und den
  2610.                         ; Block-Cons enthält (dessen CDR beim Verlassen des
  2611.                         ; Blockes auf #<DISABLED> gesetzt wird)
  2612.   used-far              ; Flag, gibt an, ob dieser Block aus einer anderen
  2613.                         ; Funktion heraus mit RETURN-FROM verlassen wird.
  2614.   for-value             ; gibt an, ob das gesamte Block-Konstrukt Werte
  2615.                         ; zurückliefern soll.
  2616. )
  2617. #+CLISP (remprop 'block 'sys::defstruct-description)
  2618.  
  2619. ; Sucht nach einem Block mit dem Namen name und liefert:
  2620. ; NIL                          falls nicht gefunden,
  2621. ; Block-Descriptor             falls in *benv* gefunden,
  2622. ; Block-Cons (name . status)   falls in %benv% gefunden.
  2623. (defun benv-search (name &optional (benv *benv*))
  2624.   (loop
  2625.     (when (atom benv) (return nil))
  2626.     (when (eq (caar benv) name)
  2627.       (if (block-p (cdar benv))
  2628.         (return (cdar benv))
  2629.         (return (car benv))
  2630.     ) )
  2631.     (setq benv (cdr benv))
  2632. ) )
  2633.  
  2634.  
  2635. ;         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
  2636.  
  2637. ; mitgegeben vom Interpreter: %genv%
  2638.  
  2639. ; Interpreter-Tagbody-Environment hat die Gestalt
  2640. ; %genv% = ((Tagvektor1 . status1) ... (Tagvektorn . statusn))
  2641. ; wobei Tagvektori ein simple-vector ist, der die anspringbaren Tags enthält,
  2642. ; statusi der Status dieses lexikalisch umfassenden Tagbodys
  2643. ; ist: #<DISABLED> falls der Tagbody bereits verlassen wurde, sonst ein
  2644. ; Pointer in den Stack auf den zugehörigen Tagbody-Frame.
  2645.  
  2646. ; neu konstruiert:
  2647. (defvar *genv*)
  2648.  
  2649. ; *genv* hat die Gestalt
  2650. ; ((Tagvektor1 . tagbody1) ... (Tagvektorn . tagbodyn) . %genv%)
  2651. ; wobei tagbodyi der Descriptor des Tagbodys i ist:
  2652. (defstruct (tagbody (:copier nil))
  2653.   fnode               ; Funktion, in der dieser Tagbody definiert ist, ein FNODE
  2654.   labellist           ; Liste der Labels, parallel zum Tagvektor
  2655.   stackz              ; Stackzustand nach dem Aufbau des Tagbody-Frames
  2656.   consvar             ; Variable, die im Stack im Tagbody-Frame liegt und den
  2657.                       ; Tagbody-Cons enthält (dessen CDR beim Verlassen des
  2658.                       ; Tagbodys auf #<DISABLED> gesetzt wird)
  2659.   used-far            ; Vektor mit Fill-Pointer, enthält all die Tags, die
  2660.                       ; aus einer anderen Funktion heraus mit GO angesprungen
  2661.                       ; werden.
  2662. )
  2663. #+CLISP (remprop 'tagbody 'sys::defstruct-description)
  2664.  
  2665. ; Sucht nach einem Tag mit dem Namen name und liefert:
  2666. ; NIL                                         falls nicht gefunden,
  2667. ; Tagbody-Descriptor, Index                   falls in *genv* gefunden,
  2668. ; Tagbody-Cons (Tagvektor . status), Index    falls in %genv% gefunden.
  2669. (defun genv-search (name &optional (genv *genv*))
  2670.   (loop
  2671.     (when (atom genv) (return nil))
  2672.     (do* ((v (caar genv))
  2673.           (l (length v))
  2674.           (i 0 (1+ i)))
  2675.          ((= i l))
  2676.       (when (eql (svref v i) name)
  2677.         (return-from genv-search
  2678.           (values (if (tagbody-p (cdar genv)) (cdar genv) (car genv)) i)
  2679.     ) ) )
  2680.     (setq genv (cdr genv))
  2681. ) )
  2682.  
  2683.  
  2684. ;       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
  2685.  
  2686. ; mitgegeben vom Interpreter: %venv%
  2687.  
  2688. ; Interpreter-Variablen-Environment hat die Gestalt
  2689. ; %venv% = NIL oder #(v1 val1 ... vn valn NEXT-ENV), NEXT-ENV von derselben
  2690. ; Gestalt.
  2691. (defparameter specdecl
  2692.   #+CLISP (eval
  2693.             '(let ((*evalhook*
  2694.                      #'(lambda (form env) (declare (ignore form))
  2695.                          (svref (svref env 0) 1)
  2696.                          ; Der Evalhook-Mechanismus übergibt das Environment.
  2697.                          ; (svref...0) davon ist das Variablen-Environment,
  2698.                          ; (svref...1) davon ist von der *evalhook*-Bindung
  2699.                          ; der assoziierte "Wert" #<SPECIAL REFERENCE>.
  2700.                   ))   )
  2701.                0
  2702.           )  )
  2703.   #-CLISP (cons nil nil)
  2704. )
  2705. ; stellt fest, ob das Symbol var eine Special-Variable darstellt
  2706. #+CLISP
  2707. (defun proclaimed-special-p (var)
  2708.   (or (sys::special-variable-p var)
  2709.       (not (null (member var *known-special-vars* :test #'eq)))
  2710. ) )
  2711. #-CLISP
  2712. (defun proclaimed-special-p (var)
  2713.   (or
  2714.     (eq var '*evalhook*)
  2715.     (eq var '*applyhook*)
  2716.     (eq var '*macroexpand-hook*)
  2717.     (let ((obj (cons nil nil)))
  2718.       (eval
  2719.         `(let ((,var ',obj))
  2720.            (and (boundp ',var) (eq (symbol-value ',var) ',obj))
  2721.     ) )  )
  2722.     (not (null (member var *known-special-vars* :test #'eq)))
  2723. ) )
  2724.  
  2725. ; neu konstruiert:
  2726. (defvar *venv*)                  ; Variablen-Environment, Feinstruktur
  2727. (defvar *venvc*)                 ; Variablen-Environment, Grobstruktur
  2728.  
  2729. ; *venv* hat dieselbe Gestalt wie %venv% und endet mit %venv%:
  2730. ; #(v1 var1 ... vn varn NEXT_ENV), wo vari Variablen-Konstrukte oder
  2731. ; Symbolmacros oder Interpreter-Werte sind und NEXT-ENV von derselben Gestalt.
  2732.  
  2733. ; *venvc* simuliert das Laufzeit-Variablen-Environment zur Laufzeit, soweit
  2734. ; es sich um Closure-Variablen handelt.
  2735. ; *venvc* hat die Gestalt
  2736. ; (item1 ... itemn)
  2737. ; jedes item ist
  2738. ;   NIL :            ein LET/LET*/MULTIPLE-VALUE-BIND/Funktionseintritt/
  2739. ;                    FLET/LABELS, der keine Closure aufmacht
  2740. ;   fnode :          eine neue Funktion
  2741. ;   ((var1 ... vark) . stackz) : durch ein LET/LET*/MULTIPLE-VALUE-BIND/
  2742. ;                    Funktionseintritt/FLET/LABELS kommen die Variablen
  2743. ;                    Var1, ..., Vark in eine Closure.
  2744. ;                    Diese Closure liegt im Stack; angegeben der
  2745. ;                    Stackzustand, an der sie erreichbar ist.
  2746.  
  2747. ; Eine Variable wird beschrieben dadurch, daß sie entweder special ist oder
  2748. ; - falls lexikalisch - der Stackaufbau nach dem Anlegen der Variablen im Stack
  2749. ; bzw. der Ort in der Closure festliegt.
  2750. (defstruct (var (:copier nil))
  2751.   (name nil :read-only t)     ; Symbol
  2752.   (specialp nil :read-only t) ; special deklariert (oder lexikalisch gebunden) ?
  2753.   constantp                   ; Konstante ?
  2754.   constant                    ; wenn Konstante: Wert und Herkunft der Konstanten
  2755.                               ;   (der Wert ist zur Compile-Zeit bekannt)
  2756.   usedp                       ; falls lexikalisch:
  2757.                               ;   wurde die Variable jemals abgefragt ?
  2758.                               ;   (Eine durch NIL oder T beendete Liste der
  2759.                               ;    Referenzen auf die Variable)
  2760.   really-usedp                ; falls lexikalisch:
  2761.                               ;   wurde die Variable jemals wirklich
  2762.                               ;   (um den Wert zu wissen) abgefragt ?
  2763.   (modified-list '())         ; falls lexikalisch: zu jedem SET auf die Variable
  2764.                               ;   eine Liste (value-anode set-anode . for-value)
  2765.   (replaceable-list '())      ; falls lexikalisch:
  2766.                               ;   zu jeder movable-Variablen, die während ihrer
  2767.                               ;   gesamten Existenz denselben Wert wie diese
  2768.                               ;   hat und deswegen ersetzbar ist, jeweils eine
  2769.                               ;   Liste (var init-anode . bind-anode)
  2770.   closurep                    ; falls lexikalisch:
  2771.                               ;   NIL falls im Stack, T falls in der Closure
  2772.   (stackz nil :read-only t)   ; falls lexikalisch:
  2773.                               ;   Stackzustand nach dem Anlegen der Variablen
  2774.                               ;   (falls Variable im Stack: ihr Ort im Stack)
  2775.   (venvc nil :read-only t)    ; falls lexikalisch und in der Closure:
  2776.                               ;   das *venvc*, in dessen erstem Item diese
  2777.                               ;   Variable vorkommt.
  2778. )
  2779. #+CLISP (remprop 'var 'sys::defstruct-description)
  2780.  
  2781. ; (venv-search v) sucht in *venv* nach einer Variablen mit dem Symbol v.
  2782. ; Ergebnis ist:
  2783. ; NIL                   falls nicht gefunden
  2784. ; SPECIAL               falls als Special-deklarierte Variable gefunden
  2785. ; LOCAL, vector, index  falls interpretativ lexikalisch gebunden, Wert im Vektor
  2786. ; T, var                falls lexikalisch gebunden, im Stack oder in der Closure
  2787. (defun venv-search (v &optional (venv *venv*))
  2788.   (when (or (constantp v) (proclaimed-special-p v))
  2789.     (return-from venv-search 'SPECIAL)
  2790.   )
  2791.   (loop
  2792.     (cond ((null venv) (return-from venv-search 'NIL))
  2793.           ((simple-vector-p venv)
  2794.            (do ((l (1- (length venv)))
  2795.                 (i 0 (+ i 2)))
  2796.                ((= i l) (setq venv (svref venv i)))
  2797.              (if (eq v (svref venv i))
  2798.                (let ((val (svref venv (1+ i))))
  2799.                  (return-from venv-search
  2800.                    (if (and (var-p val) #| (eq (var-name val) v) |# )
  2801.                      (if (var-specialp val) 'SPECIAL (values T val))
  2802.                      (if (eq val specdecl) 'SPECIAL (values 'LOCAL venv (1+ i)))
  2803.           )) ) ) ) )
  2804.           (t (compiler-error 'venv-search))
  2805.   ) )
  2806. )
  2807.  
  2808. ; (venv-search-macro v) sucht in *venv* nach einer Variablen mit dem Symbol v.
  2809. ; Ergebnis ist:
  2810. ;   Wenn v ein Symbol-Macro darstellt:  T, Expansion.
  2811. ;   Sonst:                              NIL.
  2812. (defun venv-search-macro (v &optional (venv *venv*))
  2813.   (multiple-value-bind (a b c) (venv-search v venv)
  2814.     (case a
  2815.       ((NIL) (symbol-macro-expand v))
  2816.       ((LOCAL) (and (symbol-macro-p (svref b c))
  2817.                     (values t (sys::%record-ref (svref b c) 0))
  2818.       )        )
  2819.       (t nil)
  2820. ) ) )
  2821.  
  2822. ; (push-*venv* var1 ... varn) erweitert *venv* um var1, ..., varn,
  2823. ; sozusagen wie durch  (dolist (v (list var1 ... varn)) (push v *venv*)).
  2824. (defun push-*venv* (&rest varlist)
  2825.   (when varlist
  2826.     (let ((l (list *venv*)))
  2827.       (dolist (var varlist) (setq l (list* (var-name var) var l)))
  2828.       (setq *venv* (apply #'vector l))
  2829. ) ) )
  2830.  
  2831. ; (zugriff-in-closure var venvc stackz)
  2832. ; liefert zu einer Closure-Variablen var, wie man auf sie zugreifen kann
  2833. ; (von einem Ort aus, an der Stack und das Closure-Environment durch stackz und
  2834. ;  venvc beschrieben werden):
  2835. ; 3 Werte k, n, m; die Variable sitzt in (svref ... 1+m) von
  2836. ;     nil, n, m  : (STACK+4*n)
  2837. ;     k, nil, m  : (svref ... 0)^k VenvConst
  2838. ;     k, n,   m  : ((SP+4*k)+4*n)
  2839. (defun zugriff-in-closure (var venvc stackz &aux (k nil) n)
  2840.   ; Grobschleife, stellt die Closure-Tiefe k ab VenvConst fest:
  2841.   (loop
  2842.     (when (eq venvc (var-venvc var)) (return))
  2843.     (let ((item (car venvc)))
  2844.       (if (null k)
  2845.         (when (not (listp item)) (setq k 0)) ; Zählanfang, (not (listp item)) == (fnode-p item)
  2846.         (when (consp item) (incf k)) ; zählen
  2847.     ) )
  2848.     (setq venvc (cdr venvc))
  2849.   )
  2850.   (if k
  2851.     (setq n nil)
  2852.     (multiple-value-setq (k n) (zugriff-in-stack stackz (cdr (first venvc))))
  2853.   )
  2854.   (let ((m (do ((L (car (first venvc)) (cdr L))
  2855.                 (i 0 (1+ i)))
  2856.                ((eq (car L) var) i)
  2857.        ))  )
  2858.     (values k n m)
  2859. ) )
  2860.  
  2861.  
  2862. ;             K O N S T A N T E N - V E R W A L T U N G
  2863.  
  2864. ; Eine Konstante ist eine Box mit dem Wert der Konstanten:
  2865. (defstruct (const (:copier nil))
  2866.   value               ; Wert der Konstanten
  2867.   form                ; Form, die bei Auswertung value ergibt
  2868.   horizont            ; Gültigkeitsbereich von value und form:
  2869.                       ; :VALUE  -  nur value ist gültig
  2870.                       ;            (dann ist implizit form = `(QUOTE ,value) )
  2871.                       ; :ALL    -  value und form beide gültig
  2872.                       ; :FORM   -  nur form gültig
  2873.     ; Bei *compiling-from-file* = nil ist nur :VALUE und :ALL möglich.
  2874.     ; Was im 3. Pass in den Fnode eingetragen wird, ist:
  2875.     ;   Bei *compiling-from-file* = nil: nur value.
  2876.     ;   Bei *compiling-from-file* /= nil:
  2877.     ;     Falls (eq horizont ':value), value, sonst form.
  2878. )
  2879. #+CLISP (remprop 'const 'sys::defstruct-description)
  2880. ; Im 2. Pass werden auch Variablen mit constantp=T als Konstanten behandelt.
  2881.  
  2882.  
  2883. ;           D E K L A R A T I O N E N - V E R W A L T U N G
  2884.  
  2885. (defparameter *declaration-types*
  2886.   '(special ; Bindungen
  2887.     type ftype function ; Typen
  2888.     inline notinline ; Funktionen-Compilation
  2889.     ignore optimize dynamic-extent ; Compiler-Hinweise
  2890.     declaration ; Zusatzdeklarationen
  2891.     ; Typen nach Tabelle 4-1 :
  2892.     array atom bignum bit bit-vector character common compiled-function
  2893.     complex cons double-float fixnum float function hash-table integer keyword
  2894.     list long-float nil null number package pathname random-state ratio rational
  2895.     readtable sequence short-float simple-array simple-bit-vector simple-string
  2896.     simple-vector single-float standard-char stream string string-char symbol t
  2897.     vector
  2898.     ; zusätzliche Deklarationen:
  2899.     compile ; Anweisung, daß die Form bzw. Funktion zu compilieren ist
  2900.     sys::source ; der Source-Lambdabody (unexpandiert) innerhalb eines Lambdabody
  2901.     sys::in-defun ; zeigt an, zu welcher globalen Funktion der Code gehört
  2902.     ignorable ; markiert Variablen als vielleicht ignorierbar
  2903.               ; (NB: Gensym-Variablen sind immer automatisch ignorable.)
  2904. )  )
  2905.  
  2906. ; mitgegeben vom Interpreter: %denv%
  2907.  
  2908. ; neu konstruiert:
  2909. (defvar *denv*)
  2910. ; *denv* hat dieselbe Gestalt wie %denv% und endet mit %denv%.
  2911. ; *denv* hat die Gestalt (item1 ... itemn), wo jedes item die Bauart
  2912. ; (declaration-type argument ...) hat.
  2913. ; Sonderbehandlung von
  2914. ;   SPECIAL : wird weggelassen, stattdessen in *venv* notiert.
  2915. ;   IGNORE, IGNORABLE : wird weggelassen, stattdessen bei der
  2916. ;                       verarbeitenden Form selber verarbeitet.
  2917. ; Zusätzliche Deklaration (INLINING symbol) gegen rekursives Inlining.
  2918.  
  2919. ; (process-declarations declspeclist) pusht die Deklarationen (wie sie von
  2920. ; PARSE-BODY kommen) auf *denv* und liefert:
  2921. ; eine Liste der Special-deklarierten Symbole,
  2922. ; eine Liste der Ignore-deklarierten Symbole,
  2923. ; eine Liste der Ignorable-deklarierten Symbole.
  2924. (defun process-declarations (declspeclist &aux (specials nil) (ignores nil) (ignorables nil))
  2925.   (setq declspeclist (nreverse declspeclist))
  2926.   (dolist (declspec declspeclist)
  2927.     (if (or (atom declspec) (cdr (last declspec)))
  2928.       (c-warn 
  2929.        #L{
  2930.        DEUTSCH "Falsche Deklarationen-Syntax: ~S~%Wird ignoriert."
  2931.        ENGLISH "Bad declaration syntax: ~S~%Will be ignored."
  2932.        FRANCAIS "Mauvaise syntaxe pour une déclaration : ~S~%Ignorée."
  2933.        }
  2934.        declspec
  2935.       )
  2936.       (let ((declspectype (car declspec)))
  2937.         (if (and (symbolp declspectype)
  2938.                  (or (member declspectype *declaration-types* :test #'eq)
  2939.                      (do ((L *denv* (cdr L)))
  2940.                          ((null L) nil)
  2941.                        (if (and (eq (first (car L)) 'DECLARATION)
  2942.                                 (member declspectype (rest (car L)) :test #'eq)
  2943.                            )
  2944.                          (return t)
  2945.                      ) )
  2946.                      (and *compiling-from-file*
  2947.                        (member declspectype *user-declaration-types* :test #'eq)
  2948.             )    )   )
  2949.           (cond ((eq declspectype 'SPECIAL)
  2950.                  (dolist (x (cdr declspec))
  2951.                    (if (symbolp x)
  2952.                      (push x specials)
  2953.                      (c-warn 
  2954.                       #L{
  2955.                       DEUTSCH "Nur Symbole können SPECIAL-deklariert werden, nicht ~S."
  2956.                       ENGLISH "Non-symbol ~S may not be declared SPECIAL."
  2957.                       FRANCAIS "Seuls les symboles peuvent être déclarés SPECIAL, pas ~S."
  2958.                       }
  2959.                       x
  2960.                 )) ) )
  2961.                 ((eq declspectype 'IGNORE)
  2962.                  (dolist (x (cdr declspec))
  2963.                    (if (symbolp x)
  2964.                      (push x ignores)
  2965.                      (c-warn 
  2966.                       #L{
  2967.                       DEUTSCH "Nur Symbole können IGNORE-deklariert werden, nicht ~S."
  2968.                       ENGLISH "Non-symbol ~S may not be declared IGNORE."
  2969.                       FRANCAIS "Seuls les symboles peuvent être déclarés IGNORE, pas ~S."
  2970.                       }
  2971.                       x
  2972.                 )) ) )
  2973.                 ((eq declspectype 'IGNORABLE)
  2974.                  (dolist (x (cdr declspec))
  2975.                    (if (symbolp x)
  2976.                      (push x ignorables)
  2977.                      (c-warn 
  2978.                       #L{
  2979.                       DEUTSCH "Nur Symbole können IGNORABLE-deklariert werden, nicht ~S."
  2980.                       ENGLISH "Non-symbol ~S may not be declared IGNORABLE."
  2981.                       FRANCAIS "Seuls les symboles peuvent être déclarés IGNORABLE."
  2982.                       }
  2983.                       x
  2984.                 )) ) )
  2985.                 (t (push declspec *denv*))
  2986.           )
  2987.           (c-warn 
  2988.            #L{
  2989.            DEUTSCH "Unbekannte Deklaration ~S.~%Die ganze Deklaration ~S wird ignoriert."
  2990.            ENGLISH "Unknown declaration ~S.~%The whole declaration will be ignored."
  2991.            FRANCAIS "Déclaration inconnue ~S.~%Toute la déclaration ~S est ignorée."
  2992.            }
  2993.            declspectype declspec
  2994.   ) ) ) ) )
  2995.   (values specials ignores ignorables)
  2996. )
  2997.  
  2998. ; (declared-notinline fun denv) stellt fest, ob fun - ein Symbol, das eine
  2999. ; globale Funktion, die nicht durch eine lokale Funktionsdefinition verdeckt
  3000. ; ist, benennt - in denv als NOTINLINE deklariert ist.
  3001. ; Was ist mit lokalen Funktionen ??
  3002. (defun declared-notinline (fun &optional (denv *denv*))
  3003.   (when (member `(INLINING ,fun) *denv* :test #'equal)
  3004.     (return-from declared-notinline t) ; keine Funktion rekursiv inline expandieren!
  3005.   )
  3006.   (loop
  3007.     (when (atom denv)
  3008.       (when *compiling-from-file*
  3009.         (when (member fun *notinline-functions* :test #'equal) (return t))
  3010.         (when (member fun *inline-functions* :test #'equal) (return nil))
  3011.       )
  3012.       (return (eq (get (sys::get-funname-symbol fun) 'inlinable) 'notinline))
  3013.     )
  3014.     (let ((declspec (car denv)))
  3015.       (when (and (eq (car declspec) 'INLINE) (member fun (cdr declspec) :test #'equal))
  3016.         (return nil)
  3017.       )
  3018.       (when (and (eq (car declspec) 'NOTINLINE) (member fun (cdr declspec) :test #'equal))
  3019.         (return t)
  3020.     ) )
  3021.     (setq denv (cdr denv))
  3022. ) )
  3023.  
  3024.  
  3025. ;             F U N K T I O N E N - V E R W A L T U N G
  3026.  
  3027. ; Ein FNODE enthält die nötige Information für eine Funktion:
  3028. (defstruct (fnode (:copier nil))
  3029.   name            ; Name, ein Symbol oder (SETF symbol)
  3030.   code            ; Code dieser Funktion (zuerst nichts, dann ein ANODE,
  3031.                   ; dann eine Closure)
  3032.   ; Ab hier Beschreibungen für die kommende Closure:
  3033.   venvconst       ; Flag, ob das Venv dieser Funktion explizit beim Aufbau
  3034.                   ; mitgegeben werden muß (oder immer NIL ist)
  3035.   venvc           ; Aussehen des Venv, das dieser Funktion beim Aufbau
  3036.                   ; mitgegeben werden muß (wenn überhaupt)
  3037.   Blocks-Offset   ; Anzahl der Konstanten bis hierher
  3038.   (Blocks nil)    ; Liste der Block-Konstrukte, die dieser Funktion beim Aufbau
  3039.                   ; mitgegeben werden müssen
  3040.   Tagbodys-Offset ; Anzahl der Konstanten bis hierher
  3041.   (Tagbodys nil)  ; Liste der Tagbody-Konstrukte, die dieser Funktion beim
  3042.                   ; Aufbau mitgegeben werden müssen
  3043.   Keyword-Offset  ; Anzahl der lokalen Konstanten bis hierher
  3044.                   ; = Anfangsoffset der Keywords in FUNC
  3045.                   ; (also =0 genau dann, wenn die Funktion autonom ist)
  3046.   (req-anz 0)     ; Anzahl der required parameter
  3047.   (opt-anz 0)     ; Anzahl der optionalen Parameter
  3048.   (rest-flag nil) ; Flag, ob &REST - Parameter angegeben.
  3049.   (keyword-flag nil) ; Flag, ob &KEY - Parameter angegeben.
  3050.   (keywords nil)  ; Liste der Keyword-Konstanten (in der richtigen Reihenfolge)
  3051.   allow-other-keys-flag ; &ALLOW-OTHER-KEYS-Flag
  3052.   Consts-Offset   ; Anzahl der lokalen Konstanten bis hierher
  3053.   (consts nil)    ; Liste der sonstigen Konstanten dieser Funktion
  3054.                   ; Diese Liste wird erst im 2. Pass aufgebaut.
  3055.   (consts-forms nil) ; Liste der evtl. Formen, die diese Konstanten ergeben
  3056.   enclosing       ; lexikalisch nächste darüberliegende Funktion (oder NIL)
  3057.   gf-p            ; Flag, ob eine generische Funktion produziert wird
  3058.                   ; (impliziert Blocks-Offset = Tagbodys-Offset = Keyword-Offset = 0 oder 1)
  3059. )
  3060. #+CLISP (remprop 'fnode 'sys::defstruct-description)
  3061.  
  3062. ; die aktuelle Funktion, ein FNODE:
  3063. (defvar *func*)
  3064. ; das Label am Beginn des Codes der aktuellen Funktion:
  3065. (defvar *func-start-label*)
  3066.  
  3067. ; Anzahl der bisher in der aktuellen Funktion aufgetretenen anonymen
  3068. ; Funktionen (Lambda-Ausdrücke):
  3069. (defvar *anonymous-count*)
  3070.  
  3071. ; *no-code* = T besagt, daß kein Code produziert werden soll:
  3072. (defvar *no-code*)
  3073. ; Dies verhindert, daß Variablen unnötigerweise in die Closure gesteckt oder
  3074. ; Optimierungen unnötigerweise unterlassen werden.
  3075.  
  3076.  
  3077. ;                 F O R M E N - V E R W A L T U N G
  3078.  
  3079. ; Bei jeder Rekursion werden folgende Variablen dynamisch gebunden:
  3080. (defvar *form*)      ; die aktuelle Form
  3081. (defvar *for-value*) ; ob und welche Werte der Form von Belang sind:
  3082.                      ; NIL : Werte sind irrelevant
  3083.                      ; ONE : nur der erste Wert ist relevant
  3084.                      ; ALL : alle Werte sind relevant
  3085.  
  3086. ; Ein ANODE ist die Codierung der Information, die beim Compilieren einer Form
  3087. ; gebraucht wird.
  3088. (defstruct (anode
  3089.             (:constructor mk-anode (#+COMPILER-DEBUG source
  3090.                                     type
  3091.                                     #+COMPILER-DEBUG sub-anodes
  3092.                                     seclass
  3093.                                     code
  3094.                                     #+COMPILER-DEBUG stackz
  3095.             )                      )
  3096.             (:copier nil)
  3097.            )
  3098.   #+COMPILER-DEBUG
  3099.   source              ; die zu dieser Form gehörige Source, meist eine Form
  3100.                       ; (nur zu Debugzwecken erforderlich)
  3101.   type                ; Typ des ANODE (CALL, PRIMOP, VAR, LET, SETQ, ...)
  3102.   #+COMPILER-DEBUG
  3103.   sub-anodes          ; alle ANODEs der Unterformen
  3104.   seclass             ; Seiteneffekt-Klassifikation
  3105.   code                ; erzeuger LAP-Code, eine Liste aus LAP-Anweisungen
  3106.                       ; und ANODEs
  3107.   #+COMPILER-DEBUG
  3108.   stackz              ; Zustand der Stacks beim Eintritt in den zugehörigen
  3109.                       ; LAP-Code
  3110. )
  3111. #+CLISP (remprop 'anode 'sys::defstruct-description)
  3112. ; (make-anode ...) ist dasselbe wie mk-anode, nur daß dabei die Argumente
  3113. ; mit Keywords markiert werden und wegen #+COMPILER-DEBUG unnötige
  3114. ; Komponenten trotzdem dastehen dürfen.
  3115. (eval-when (compile eval)
  3116.   (defmacro make-anode (&key
  3117.                         (source `*form*)
  3118.                         type
  3119.                         (sub-anodes `'())
  3120.                         seclass
  3121.                         code
  3122.                         (stackz `*stackz*)
  3123.                        )
  3124.     `(mk-anode #+COMPILER-DEBUG ,source
  3125.                ,type
  3126.                #+COMPILER-DEBUG ,sub-anodes
  3127.                ,seclass
  3128.                ,code
  3129.                #+COMPILER-DEBUG ,stackz
  3130.      )
  3131. ) )
  3132.  
  3133. #|
  3134. ; Eine Seiteneffekt-Klasse (SECLASS) ist ein Indikator:
  3135. ; NIL : dieses ANODE produziert keine Seiteneffekte,
  3136. ;       sein Wert ist nicht von Seiteneffekten beeinflußbar.
  3137. ; VAL : dieses ANODE produziert keine Seiteneffekte,
  3138. ;       sein Wert ist aber von Seiteneffekten beeinflußbar.
  3139. ; T   : dieses ANODE kann Seiteneffekte produzieren.
  3140. ; Somit:
  3141. ;   Falls der Wert uninteressant ist, kann ein ANODE mit SECLASS = NIL/VAL
  3142. ;   weggelassen werden.
  3143. ;   In der Reihenfolge der Auswertung dürfen vertauscht werden ANODEs mit
  3144. ;   SECLASS     NIL-NIL, NIL-VAL, NIL-T, VAL-VAL.
  3145.  
  3146. ; (seclass-or class1 ... classk) bestimmt die Gesamtklasse der Ausführung
  3147. ; aller Klassen.
  3148. (defun seclass-or (&rest args)
  3149.   (cond ((member 'T args :test #'eq) 'T)
  3150.         ((member 'VAL args :test #'eq) 'VAL)
  3151.         (t 'NIL)
  3152. ) )
  3153. ; Dito, mit nur 2 Argumenten
  3154. (defun seclass-or-2 (seclass1 seclass2)
  3155.   (or (eq seclass1 'T) seclass2 seclass1)
  3156. )
  3157. ; Damit die Liste der sub-anodes nicht gebildet werden muß, aber dennoch
  3158. ; der zu dieser Liste gehörige Seiteneffektklasse berechnet werden kann:
  3159. (eval-when (compile eval)
  3160.   (defmacro anodes-seclass-or (&rest anodeforms)
  3161.     (reduce #'(lambda (form1 form2) `(SECLASS-OR-2 ,form1 ,form2))
  3162.             (mapcar #'(lambda (anodeform) `(ANODE-SECLASS ,anodeform))
  3163.                     anodeforms
  3164.   ) )       )
  3165.   (define-modify-macro seclass-or-f (anode) seclass-or-anode)
  3166.   (defmacro seclass-or-anode (seclass anode)
  3167.     `(SECLASS-OR-2 ,seclass (ANODE-SECLASS ,anode))
  3168.   )
  3169. )
  3170. (defun anodelist-seclass-or (anodelist)
  3171.   (apply #'seclass-or (mapcar #'anode-seclass anodelist))
  3172. )
  3173.  
  3174. ; Stellt fest, ob zwei Anodes in der Reihenfolge ihrer Auswertung vertauscht
  3175. ; werden können - vorausgesetzt, die Stackzustände lassen das zu.
  3176. (defun anodes-commute (anode1 anode2)
  3177.   (let ((seclass1 (anode-seclass anode1))
  3178.         (seclass2 (anode-seclass anode2)))
  3179.     (or (eq seclass1 'NIL) (eq seclass2 'NIL)
  3180.         (and (eq seclass1 'VAL) (eq seclass2 'VAL))
  3181. ) ) )
  3182. |#
  3183.  
  3184. ; Eine Seiteneffekt-Klasse (SECLASS) ist ein Indikator (uses . modifies):
  3185. ; uses = NIL : dieses Anode ist nicht von Seiteneffekten beeinflußbar,
  3186. ;        Liste : dieses Anode ist vom Wert der Variablen in der Liste abhängig,
  3187. ;        T : dieses Anode ist möglicherweise von jedem Seiteneffekt beeinflußbar.
  3188. ; modifies = NIL : dieses Anode produziert keine Seiteneffekte
  3189. ;            Liste : ... produziert Seiteneffekte nur auf die Werte der
  3190. ;                    Variablen in der Liste
  3191. ;            T : ... produziert Seiteneffekte unbekannten Ausmaßes.
  3192. ; (Variablen sind hier VAR-Structures für lexikalische und Symbole für
  3193. ; dynamische Variablen.)
  3194. ; Somit:
  3195. ;   Falls der Wert uninteressant ist, kann ein ANODE mit SECLASS-modifies=NIL
  3196. ;   weggelassen werden.
  3197. ;   In der Reihenfolge der Auswertung dürfen vertauscht werden ANODEs mit
  3198. ;   SECLASS, deren uses- und modifies-Teil über Kreuz disjunkt sind.
  3199.  
  3200. ; (seclass-or class1 ... classk) bestimmt die Gesamtklasse der Ausführung
  3201. ; aller Klassen.
  3202. (defun seclass-or (&rest args)
  3203.   (if (null args) '(NIL . NIL) (reduce #'seclass-or-2 args))
  3204. )
  3205. ; Dito, mit nur 2 Argumenten
  3206. (defun seclass-or-2 (seclass1 seclass2)
  3207.   (cons (if (or (eq (car seclass1) 'T) (eq (car seclass2) 'T))
  3208.           'T
  3209.           (union (car seclass1) (car seclass2))
  3210.         )
  3211.         (if (or (eq (cdr seclass1) 'T) (eq (cdr seclass2) 'T))
  3212.           'T
  3213.           (union (cdr seclass1) (cdr seclass2))
  3214. ) )     )
  3215.  
  3216. ; Damit die Liste der sub-anodes nicht gebildet werden muß, aber dennoch
  3217. ; der zu dieser Liste gehörige Seiteneffektklasse berechnet werden kann:
  3218. (eval-when (compile eval)
  3219.   (defmacro anodes-seclass-or (&rest anodeforms)
  3220.     (reduce #'(lambda (form1 form2) `(SECLASS-OR-2 ,form1 ,form2))
  3221.             (mapcar #'(lambda (anodeform) `(ANODE-SECLASS ,anodeform))
  3222.                     anodeforms
  3223.   ) )       )
  3224.   (define-modify-macro seclass-or-f (anode) seclass-or-anode)
  3225.   (defmacro seclass-or-anode (seclass anode)
  3226.     `(SECLASS-OR-2 ,seclass (ANODE-SECLASS ,anode))
  3227.   )
  3228. )
  3229. (defun anodelist-seclass-or (anodelist)
  3230.   (apply #'seclass-or (mapcar #'anode-seclass anodelist))
  3231. )
  3232.  
  3233. ; Seiteneffekte auf weiter innen gebundene lexikalische Variablen zählen
  3234. ; nicht und werden deshalb eliminiert:
  3235. (defun seclass-without (seclass varlist)
  3236.   (flet ((bound (var) (member var varlist))) ; testet, ob var gebunden wird
  3237.     ; (Dynamische Variablen werden nicht eliminiert; sie sind in varlist
  3238.     ; als VAR-Structures und in seclass als Symbole enthalten.)
  3239.     (cons (if (eq (car seclass) 'T) 'T (remove-if #'bound (car seclass)))
  3240.           (if (eq (cdr seclass) 'T) 'T (remove-if #'bound (cdr seclass)))
  3241. ) ) )
  3242.  
  3243. ; Stellt fest, ob zwei Anodes in der Reihenfolge ihrer Auswertung vertauscht
  3244. ; werden können - vorausgesetzt, die Stackzustände lassen das zu.
  3245. (defun anodes-commute (anode1 anode2)
  3246.   (seclasses-commute (anode-seclass anode1) (anode-seclass anode2))
  3247. )
  3248. (defun seclasses-commute (seclass1 seclass2)
  3249.   (flet ((disjoint-p (uses modifies)
  3250.            (or (null uses) (null modifies)
  3251.                (and (not (eq uses 'T)) (not (eq modifies 'T))
  3252.                     (null (intersection uses modifies))
  3253.         )) )   )
  3254.     (and (disjoint-p (car seclass1) (cdr seclass2))
  3255.          (disjoint-p (car seclass2) (cdr seclass1))
  3256. ) ) )
  3257.  
  3258.  
  3259. ;            H I L F S F U N K T I O N E N
  3260.  
  3261. ; Zerlegt einen Funktionsnamen in Package und String.
  3262. (defun get-funname-string+pack (funname)
  3263.   (if (atom funname)
  3264.     (values (symbol-name funname) (symbol-package funname))
  3265.     (values (string-concat "(" (symbol-name (first funname)) " "
  3266.                                (symbol-name (second funname)) ")"
  3267.             )
  3268.             (symbol-package (second funname))
  3269. ) ) )
  3270.  
  3271. ; Liefert einen Funktionsnamen, der sich aus der Package und dem Printname eines
  3272. ; gegebenen Funktionsnamen, einem Bindestrich und einem Suffix zusammensetzt.
  3273. (defun symbol-suffix (funname suffix)
  3274.   (if (and (symbolp funname) (null (symbol-package funname))
  3275.            (function-name-p suffix)
  3276.       )
  3277.     suffix
  3278.     (multiple-value-bind (name pack) (get-funname-string+pack funname)
  3279.       ; suffix in einen String umwandeln:
  3280.       (cond ((symbolp suffix) (setq suffix (symbol-name suffix)))
  3281.             ((not (stringp suffix))
  3282.              (setq suffix (write-to-string suffix :escape nil :base 10 :radix nil :readably nil))
  3283.       )     )
  3284.       ; neues Symbol bilden:
  3285.       (let ((new-name (string-concat name "-" suffix)))
  3286.         (if pack (intern new-name pack) (make-symbol new-name))
  3287. ) ) ) )
  3288.  
  3289. ; (C-COMMENT controlstring . args)
  3290. ; gibt eine Zusatzinformation des Compilers aus (mittels FORMAT).
  3291. (defun c-comment (cstring &rest args)
  3292.   (let ((dest (if *compile-verbose* *c-error-output* *c-listing-output*)))
  3293.     (when dest (apply #'format dest cstring args))
  3294. ) )
  3295.  
  3296. ; (C-SOURCE-LOCATION)
  3297. ; liefert eine Beschreibung, an welcher Source-Stelle man sich befindet.
  3298. (defun c-source-location ()
  3299.   (if (and *compiling-from-file* *compile-file-lineno1* *compile-file-lineno2*)
  3300.     (format nil
  3301.             (if (= *compile-file-lineno1* *compile-file-lineno2*)
  3302.                 #L{
  3303.                 DEUTSCH " in Zeile ~D"
  3304.                 ENGLISH " in line ~D"
  3305.                 FRANCAIS " dans la ligne ~D"
  3306.                 }
  3307.                 #L{
  3308.                 DEUTSCH " in Zeilen ~D..~D"
  3309.                 ENGLISH " in lines ~D..~D"
  3310.                 FRANCAIS " dans les lignes ~D..~D"
  3311.                 }
  3312.             )
  3313.             *compile-file-lineno1* *compile-file-lineno2*
  3314.     )
  3315.     ""
  3316. ) )
  3317.  
  3318. (defvar *warning-count*)
  3319. ; (C-WARN controlstring . args)
  3320. ; gibt eine Compiler-Warnung aus (mittels FORMAT).
  3321. (defun c-warn (cstring &rest args)
  3322.   (setq cstring
  3323.     (string-concat 
  3324.      #L{
  3325.      DEUTSCH "~%WARNUNG~@[ in Funktion ~S~]~A :~%"
  3326.      ENGLISH "~%WARNING~@[ in function ~S~]~A :~%"
  3327.      FRANCAIS "~%AVERTISSEMENT~@[ dans la fonction ~S~]~A :~%"
  3328.      }
  3329.      cstring
  3330.   ) )
  3331.   (incf *warning-count*)
  3332.   (let ((dest (if *compile-warnings* *c-error-output* *c-listing-output*)))
  3333.     (when dest
  3334.       (apply #'format dest cstring
  3335.              (and (boundp '*func*) (fnode-p *func*) (fnode-name *func*))
  3336.              (c-source-location)
  3337.              args
  3338. ) ) ) )
  3339.  
  3340. (defvar *error-count*)
  3341. ; (C-ERROR controlstring . args)
  3342. ; gibt einen Compiler-Error aus (mittels FORMAT) und beendet das laufende C-FORM.
  3343. (defun c-error (cstring &rest args)
  3344.   (incf *error-count*)
  3345.   (let ((in-function
  3346.           (and (boundp '*func*) (fnode-p *func*) (fnode-name *func*))
  3347.        ))
  3348.     (when in-function
  3349.       (when *compiling-from-file* (pushnew in-function *functions-with-errors*))
  3350.     )
  3351.     (format *c-error-output*
  3352.             #L{
  3353.             DEUTSCH "~%ERROR~@[ in Funktion ~S~]~A :~%~?"
  3354.             ENGLISH "~%ERROR~@[ in function ~S~]~A :~%~?"
  3355.             FRANCAIS "~%ERREUR~@[ dans la fonction ~S~]~A :~%~?"
  3356.             }
  3357.             in-function (c-source-location)
  3358.             cstring args
  3359.   ) )
  3360.   (throw 'c-error
  3361.     (make-anode :source NIL
  3362.                 :type 'ERROR
  3363.                 :sub-anodes '()
  3364.                 :seclass '(NIL . NIL)
  3365.                 :code '((NIL))
  3366. ) ) )
  3367.  
  3368. ; (c-eval-when-compile form) führt eine Form zur Compile-Zeit aus.
  3369. (defun c-eval-when-compile (form)
  3370.   (when (and *compiling-from-file* *liboutput-stream*)
  3371.     ; Form auf den Liboutput-Stream schreiben:
  3372.     (terpri *liboutput-stream*)
  3373.     (write form :stream *liboutput-stream* :pretty t
  3374.                 :readably t
  3375.                 ; :closure t :circle t :array t :gensym t
  3376.                 ; :escape t :level nil :length nil :radix t
  3377.   ) )
  3378.   ; Form evaluieren:
  3379.   (eval form)
  3380. )
  3381.  
  3382. ; (c-constantp form) stellt fest, ob form im Compiler als Konstante gehandhabt
  3383. ; wird.
  3384. (defun c-constantp (form)
  3385.   (if (atom form)
  3386.     (or (numberp form) (characterp form) (stringp form) (bit-vector-p form)
  3387.         (and (symbolp form)
  3388.              (cond ((keywordp form) t)
  3389.                    ((eq (symbol-package form) *lisp-package*)
  3390.                     (constantp form)
  3391.                    )
  3392.                    (t (not (null (assoc form *constant-special-vars*))))
  3393.     )   )    )
  3394.     (and (eq (first form) 'QUOTE) (consp (cdr form)) (null (cddr form)))
  3395. ) )
  3396.  
  3397. ; (c-constant-value form) liefert den Wert einer Konstanten
  3398. (defun c-constant-value (form)
  3399.   (if (atom form)
  3400.     (cond ((numberp form) form)
  3401.           ((characterp form) form)
  3402.           ((stringp form) form)
  3403.           ((bit-vector-p form) form)
  3404.           ((symbolp form)
  3405.            (cond ((keywordp form) form)
  3406.                  ((eq (symbol-package form) *lisp-package*)
  3407.                   (symbol-value form)
  3408.                  )
  3409.                  (t (cdr (assoc form *constant-special-vars*)))
  3410.     )     ))
  3411.     (second form)
  3412. ) )
  3413.  
  3414. ; (anode-constantp anode) stellt fest, ob der Anode einen konstanten (und
  3415. ; zur Compile-Zeit bekannten) Wert liefert.
  3416. (defun anode-constantp (anode)
  3417.   ; Anode liefert konstanten Wert jedenfalls dann, wenn sein Code
  3418.   ; (nach TRAVERSE-ANODE) genau aus ((CONST ...)) bestehen würde.
  3419.   (let ((code (anode-code anode)))
  3420.     (and (consp code) (null (cdr code)) ; Liste der Länge 1
  3421.          (let ((item (car code)))
  3422.             (cond ((consp item)
  3423.                    (and (eq (first item) 'CONST)
  3424.                         (not (eq (const-horizont (second item)) ':form))
  3425.                   ))
  3426.                   ((anode-p item) (anode-constantp item))
  3427. ) ) )    )  )
  3428.  
  3429. ; (anode-constant-value anode) liefert den Wert eines konstanten Anode.
  3430. (defun anode-constant (anode)
  3431.   (let ((item (car (anode-code anode))))
  3432.     (cond ((consp item) (second item))
  3433.           (t #|(anode-p item)|# (anode-constant item))
  3434. ) ) )
  3435. (defun anode-constant-value (anode)
  3436.   (const-value (anode-constant anode))
  3437. )
  3438.  
  3439. ; (new-const value) liefert eine Konstante in *func* mit dem Wert value
  3440. ; im 1. Pass
  3441. (defun new-const (value)
  3442.   (make-const :horizont ':value :value value)
  3443. )
  3444.  
  3445. ; (make-label for-value) liefert ein neues Label. for-value (NIL/ONE/ALL)
  3446. ; gibt an, welche der Werte nach dem Label gebraucht werden.
  3447. (defun make-label (for-value)
  3448.   (let ((label (gensym)))
  3449.     (setf (symbol-value label) '()) ; Referenzliste für 2. Pass := leer
  3450.     (setf (get label 'for-value) for-value)
  3451.     label
  3452. ) )
  3453.  
  3454. ; liefert eine Special-Variable
  3455. (defun make-special-var (symbol)
  3456.   (make-var :name symbol :specialp t
  3457.             :constantp (c-constantp symbol)
  3458.             :constant (if (c-constantp symbol)
  3459.                         (make-const :horizont ':all
  3460.                                     :value (c-constant-value symbol)
  3461.                                     :form symbol
  3462. ) )                   ) )
  3463.  
  3464.  
  3465. ;                     E R S T E R   P A S S
  3466.  
  3467. ; (test-list L) stellt fest, ob L eine echte Liste ist, die mit NIL endet
  3468. ; und mindestens l1, höchstens aber l2 Elemente hat. Sonst Error.
  3469. (defun test-list (L &optional (l1 0) (l2 nil))
  3470.   (unless (and (listp L) (null (cdr (last L))))
  3471.     (c-error 
  3472.      #L{
  3473.      DEUTSCH "Dotted list im Code: ~S"
  3474.      ENGLISH "Code contains dotted list ~S"
  3475.      FRANCAIS "Paire pointée dans le code en ~S"
  3476.      }
  3477.      L
  3478.   ) )
  3479.   (unless (>= (length L) l1)
  3480.     (c-error 
  3481.      #L{
  3482.      DEUTSCH "Form zu kurz (zu wenig Argumente): ~S"
  3483.      ENGLISH "Form too short, too few arguments: ~S"
  3484.      FRANCAIS "Forme trop courte (trop peu d'arguments) : ~S"
  3485.      }
  3486.      L
  3487.   ) )
  3488.   (when l2
  3489.     (unless (<= (length L) l2)
  3490.       (c-error 
  3491.        #L{
  3492.        DEUTSCH "Form zu lang (zu viele Argumente): ~S"
  3493.        ENGLISH "Form too long, too many arguments: ~S"
  3494.        FRANCAIS "Forme trop longue (trop d'arguments) : ~S"
  3495.        }
  3496.        L
  3497.   ) ) )
  3498. )
  3499.  
  3500. ; c-form-table enthält zu allen Funktionen/Specialforms/Macros, die speziell
  3501. ; behandelt werden müssen, die Behandlungsfunktion (ohne Argumente aufzurufen).
  3502. (defconstant c-form-table
  3503.   (let ((hashtable (make-hash-table :test #'eq)))
  3504.     (mapc
  3505.       #'(lambda (acons) (setf (gethash (car acons) hashtable) (cdr acons)))
  3506.       `(; Special forms:
  3507.           (QUOTE . c-QUOTE)
  3508.           (PROGN . c-PROGN)
  3509.           (LET . ,#'(lambda () (c-LET/LET* nil)))
  3510.           (LET* . ,#'(lambda () (c-LET/LET* t)))
  3511.           (IF . c-IF)
  3512.           (SETQ . c-SETQ)
  3513.           (BLOCK . c-BLOCK)
  3514.           (RETURN-FROM . c-RETURN-FROM)
  3515.           (TAGBODY . c-TAGBODY)
  3516.           (GO . c-GO)
  3517.           (FUNCTION . c-FUNCTION)
  3518.           (MULTIPLE-VALUE-BIND . c-MULTIPLE-VALUE-BIND)
  3519.           (MULTIPLE-VALUE-SETQ . c-MULTIPLE-VALUE-SETQ)
  3520.           (AND . c-AND)
  3521.           (OR . c-OR)
  3522.           (WHEN . c-WHEN)
  3523.           (UNLESS . c-UNLESS)
  3524.           (COND . c-COND)
  3525.           (PSETQ . c-PSETQ)
  3526.           (MULTIPLE-VALUE-CALL . c-MULTIPLE-VALUE-CALL)
  3527.           (PROG1 . c-PROG1)
  3528.           (PROG2 . c-PROG2)
  3529.           (THE . c-THE)
  3530.           (CATCH . c-CATCH)
  3531.           (THROW . c-THROW)
  3532.           (UNWIND-PROTECT . c-UNWIND-PROTECT)
  3533.           (PROGV . c-PROGV)
  3534.           (MULTIPLE-VALUE-LIST . c-MULTIPLE-VALUE-LIST)
  3535.           (MULTIPLE-VALUE-PROG1 . c-MULTIPLE-VALUE-PROG1)
  3536.           (FLET . c-FLET)
  3537.           (LABELS . c-LABELS)
  3538.           (MACROLET . c-MACROLET)
  3539.           (SYMBOL-MACROLET . c-SYMBOL-MACROLET)
  3540.           (COMPILER-LET . c-COMPILER-LET)
  3541.           (EVAL-WHEN . c-EVAL-WHEN)
  3542.           (DECLARE . c-DECLARE)
  3543.           (LOAD-TIME-VALUE . c-LOAD-TIME-VALUE)
  3544.           (LOCALLY . c-LOCALLY)
  3545.         ; Macros:
  3546.           (CASE . c-CASE)
  3547.           (%GENERIC-FUNCTION-LAMBDA . c-%GENERIC-FUNCTION-LAMBDA)
  3548.           (%OPTIMIZE-FUNCTION-LAMBDA . c-%OPTIMIZE-FUNCTION-LAMBDA)
  3549.           (CLOS:GENERIC-FLET . c-GENERIC-FLET)
  3550.           (CLOS:GENERIC-LABELS . c-GENERIC-LABELS)
  3551.           (HANDLER-BIND . c-HANDLER-BIND)
  3552.           (SYS::%HANDLER-BIND . c-HANDLER-BIND)
  3553.           (SYS::CONSTANT-EQL . c-CONSTANT-EQL)
  3554.         ; Inline-compilierte Funktionen:
  3555.           (FUNCALL . c-FUNCALL)
  3556.           (SYS::%FUNCALL . c-FUNCALL)
  3557.           (APPLY . c-APPLY)
  3558.           (+ . c-PLUS)
  3559.           (- . c-MINUS)
  3560.           (SYS::SVSTORE . c-SVSTORE)
  3561.           (EQ . c-EQ)
  3562.           (EQL . c-EQL)
  3563.           (EQUAL . c-EQUAL)
  3564.           (MAPCAR . c-MAPCAR)
  3565.           (MAPLIST . c-MAPLIST)
  3566.           (MAPC . c-MAPC)
  3567.           (MAPL . c-MAPL)
  3568.           (MAPCAN . c-MAPCAN)
  3569.           (MAPCON . c-MAPCON)
  3570.           (MAPCAP . c-MAPCAP)
  3571.           (MAPLAP . c-MAPLAP)
  3572.           (TYPEP . c-TYPEP)
  3573.           (FORMAT . c-FORMAT)
  3574.           (REMOVE-IF . c-REMOVE-IF)
  3575.           (REMOVE-IF-NOT . c-REMOVE-IF-NOT)
  3576.           (DELETE-IF . c-DELETE-IF)
  3577.           (DELETE-IF-NOT . c-DELETE-IF-NOT)
  3578.           (SUBSTITUTE-IF . c-SUBSTITUTE-IF)
  3579.           (SUBSTITUTE-IF-NOT . c-SUBSTITUTE-IF-NOT)
  3580.           (NSUBSTITUTE-IF . c-NSUBSTITUTE-IF)
  3581.           (NSUBSTITUTE-IF-NOT . c-NSUBSTITUTE-IF-NOT)
  3582.           (FIND-IF . c-FIND-IF)
  3583.           (FIND-IF-NOT . c-FIND-IF-NOT)
  3584.           (POSITION-IF . c-POSITION-IF)
  3585.           (POSITION-IF-NOT . c-POSITION-IF-NOT)
  3586.           (COUNT-IF . c-COUNT-IF)
  3587.           (COUNT-IF-NOT . c-COUNT-IF-NOT)
  3588.           (SUBST-IF . c-SUBST-IF)
  3589.           (SUBST-IF-NOT . c-SUBST-IF-NOT)
  3590.           (NSUBST-IF . c-NSUBST-IF)
  3591.           (NSUBST-IF-NOT . c-NSUBST-IF-NOT)
  3592.           (MEMBER-IF . c-MEMBER-IF)
  3593.           (MEMBER-IF-NOT . c-MEMBER-IF-NOT)
  3594.           (ASSOC-IF . c-ASSOC-IF)
  3595.           (ASSOC-IF-NOT . c-ASSOC-IF-NOT)
  3596.           (RASSOC-IF . c-RASSOC-IF)
  3597.           (RASSOC-IF-NOT . c-RASSOC-IF-NOT)
  3598.     )  )
  3599.     hashtable
  3600. ) )
  3601. ; Diese Tabelle muß alle Special-Forms enthalten:
  3602. (do-all-symbols (sym)
  3603.   (when (and (special-form-p sym) (not (gethash sym c-form-table)))
  3604.     (compiler-error 'c-form-table)
  3605. ) )
  3606.  
  3607. ; compiliert eine Form.
  3608. ; Dabei ergibt sich kein Code, falls keine Werte gebraucht werden und die Form
  3609. ; keine Seiteneffekte produziert.
  3610. (defun c-form (*form* &optional (*for-value* *for-value*))
  3611.  (let
  3612.   ((anode
  3613.     (catch 'c-error
  3614.       (if (atom *form*)
  3615.         (cond ((symbolp *form*)
  3616.                (multiple-value-bind (macrop expansion)
  3617.                    (venv-search-macro *form* *venv*)
  3618.                  (if macrop ; Symbol-Macro ?
  3619.                    (c-form expansion) ; -> expandieren
  3620.                    (c-VAR *form*)
  3621.               )) )
  3622.               (t
  3623.            (c-CONST)
  3624.           ) )
  3625.         (let ((fun (first *form*)))
  3626.           (if (function-name-p fun)
  3627.             (multiple-value-bind (a b c) (fenv-search fun)
  3628.               (declare (ignore b))
  3629.               (if (null a)
  3630.                 ; nicht lokal definiert
  3631.                 (let ((handler (gethash fun c-form-table)))
  3632.                   (if handler ; Behandlungsfunktion gefunden?
  3633.                     ; also (symbolp fun)
  3634.                     (if (or (special-form-p fun) (macro-function fun)
  3635.                             (not (declared-notinline fun))
  3636.                         )
  3637.                       (funcall handler) ; ja -> aufrufen
  3638.                       ; normaler Aufruf globaler Funktion
  3639.                       (c-GLOBAL-FUNCTION-CALL fun)
  3640.                     )
  3641.                     ; nein -> jedenfalls keine Special-Form (die sind ja
  3642.                     ; alle in der Tabelle).
  3643.                     (if (and (symbolp fun) (macro-function fun)) ; globaler Macro ?
  3644.                       (c-form (macroexpand-1 *form* (vector *venv* *fenv*))) ; -> expandieren
  3645.                       ; globale Funktion
  3646.                       (if (and (equal fun (fnode-name *func*))
  3647.                                (not (declared-notinline fun))
  3648.                                (member `(SYS::IN-DEFUN ,fun) *denv* :test #'equal)
  3649.                           )
  3650.                         ; rekursiver Aufruf der aktuellen globalen Funktion
  3651.                         (c-LOCAL-FUNCTION-CALL fun (cons *func* nil) (cdr *form*))
  3652.                         ; normaler Aufruf globaler Funktion
  3653.                         (c-GLOBAL-FUNCTION-CALL fun)
  3654.                 ) ) ) )
  3655.                 (case a
  3656.                   (SYSTEM::MACRO ; lokaler Macro
  3657.                     (c-form (macroexpand-1 *form* (vector *venv* *fenv*))) ; -> expandieren
  3658.                   )
  3659.                   (GLOBAL ; Funktion im Interpreter-Environment %fenv% gefunden
  3660.                     ; (c-form `(SYS::%FUNCALL (FUNCTION ,fun) ,@(cdr *form*)))
  3661.                     (c-FUNCALL-NOTINLINE `(FUNCTION ,fun) (cdr *form*))
  3662.                   )
  3663.                   (LOCAL ; lokale Funktion (in *fenv* gefunden)
  3664.                     ; (c-form `(SYS::%FUNCALL (FUNCTION ,fun) ,@(cdr *form*)))
  3665.                     (c-LOCAL-FUNCTION-CALL fun c (cdr *form*))
  3666.                   )
  3667.                   (t (compiler-error 'c-form))
  3668.             ) ) )
  3669.             (if (and (consp fun) (eq (car fun) 'LAMBDA))
  3670.               (c-form `(SYS::%FUNCALL (FUNCTION ,fun) ,@(cdr *form*)))
  3671.               #| nicht: (c-LAMBDA-FUNCTION-CALL fun (cdr *form*)) |#
  3672.               (c-error 
  3673.                #L{
  3674.                DEUTSCH "Das ist nicht der Name einer Funktion: ~S"
  3675.                ENGLISH "Not the name of a function: ~S"
  3676.                FRANCAIS "Ceci n'est pas le nom d'une fonction : ~S"
  3677.                }
  3678.                fun
  3679.     ) ) ) ) ) )
  3680.   ))
  3681.   #+COMPILER-DEBUG (setf (anode-source anode) *form*)
  3682.   ; Falls keine Werte gebraucht werden und keine Seiteneffekte produziert
  3683.   ; werden, kann der dazugehörige Code ganz gestrichen werden:
  3684.   (when (and (null *for-value*) (null (cdr (anode-seclass anode))))
  3685.     (setf (anode-code anode) '())
  3686.     (setf (anode-seclass anode) '(NIL . NIL))
  3687.   )
  3688.   anode
  3689. ))
  3690.  
  3691. ; compiliere NIL (eine Art Notausgang)
  3692. (defun c-NIL ()
  3693.   (make-anode :type 'NIL
  3694.               :sub-anodes '()
  3695.               :seclass '(NIL . NIL)
  3696.               :code '((NIL)) )
  3697. )
  3698.  
  3699. ; Konstante als Form:
  3700. (defun c-CONST ()
  3701.   (make-anode :type 'const
  3702.               :sub-anodes '()
  3703.               :seclass '(NIL . NIL)
  3704.               :code `((CONST ,(new-const *form*)))
  3705. ) )
  3706.  
  3707. ; Variable als Form:
  3708. (defun c-VAR (symbol)
  3709.   ; Suche die Variable in *venv* :
  3710.   (multiple-value-bind (a b c) (venv-search symbol)
  3711.     (when (eq a 'NIL)
  3712.       (c-warn 
  3713.        #L{
  3714.        DEUTSCH "~S ist weder deklariert noch gebunden, behandle es als SPECIAL-deklarierte Variable."
  3715.        ENGLISH "~S is neither declared nor bound, it will be treated as if it were declared SPECIAL."
  3716.        FRANCAIS "~S n'est ni déclaré ni lié, et va être traité comme étant déclaré SPECIAL."
  3717.        }
  3718.        symbol
  3719.       )
  3720.       (when *compiling-from-file*
  3721.         (pushnew symbol *unknown-free-vars* :test #'eq)
  3722.       )
  3723.       (setq a 'SPECIAL)
  3724.     )
  3725.     (case a
  3726.       (SPECIAL ; Special-Variable
  3727.         (let ((var (make-special-var symbol)))
  3728.           (make-anode
  3729.             :type 'VAR
  3730.             :sub-anodes '()
  3731.             :seclass (cons
  3732.                        (if (and *for-value* (not (var-constantp var))) (list symbol) 'NIL)
  3733.                        'NIL
  3734.                      )
  3735.             :code (if *for-value*
  3736.                     (if (var-constantp var)
  3737.                       `((CONST ,(make-const
  3738.                                   :horizont (if (keywordp symbol) ':value ':all) ; Keywords braucht man nicht in #.-Syntax
  3739.                                   :value (c-constant-value symbol)
  3740.                                   :form symbol
  3741.                        ))       )
  3742.                       `((GETVALUE ,symbol))
  3743.                     )
  3744.                     '()
  3745.       ) ) )       )
  3746.       (LOCAL ; interpretativ lexikalisch
  3747.         (make-anode
  3748.           :type 'VAR
  3749.           :sub-anodes '()
  3750.           :seclass (cons (if *for-value* 'T 'NIL) 'NIL)
  3751.           :code (if *for-value*
  3752.                   `((CONST ,(new-const b)) ; Vektor
  3753.                     (PUSH)
  3754.                     (CONST ,(new-const c)) ; Index
  3755.                     (SVREF)
  3756.                    )
  3757.                   '()
  3758.       ) )       )
  3759.       ((T) ; lexikalisch in Stack oder Closure
  3760.         (let* ((var b)
  3761.                (get-anode
  3762.                  (make-anode
  3763.                    :type 'VAR
  3764.                    :sub-anodes '()
  3765.                    :seclass (cons (if *for-value* (list var) 'NIL) 'NIL)
  3766.                    :code (if *for-value*
  3767.                            `((GET ,var ,*venvc* ,*stackz*))
  3768.                            '()
  3769.               )) )       )
  3770.           (push get-anode (var-usedp var))
  3771.           (when (and *for-value* (not *no-code*))
  3772.             (setf (var-really-usedp var) t)
  3773.             (unless (eq (stackz-fun (var-stackz var)) *func*)
  3774.               (setf (var-closurep var) t)
  3775.             )
  3776.             (when (var-closurep var)
  3777.               ; aktiviere Venvconst in allen dazwischenliegenden Funktionen
  3778.               (do ((venvc *venvc* (cdr venvc)))
  3779.                   ((null venvc) (compiler-error 'c-VAR "INVISIBLE"))
  3780.                 (when (eq venvc (var-venvc var)) (return))
  3781.                 (when (fnode-p (car venvc))
  3782.                   (setf (fnode-Venvconst (car venvc)) t)
  3783.           ) ) ) )
  3784.           get-anode
  3785.       ) )
  3786.       (t (compiler-error 'c-VAR 'venv-search))
  3787. ) ) )
  3788.  
  3789. ; Variablenzuweisung:
  3790. (defun c-VARSET (symbol value-anode for-value)
  3791.   ; Suche die Variable in *venv* :
  3792.   (multiple-value-bind (a b c) (venv-search symbol)
  3793.     (when (eq a 'NIL)
  3794.       (c-warn 
  3795.        #L{
  3796.        DEUTSCH "~S ist weder deklariert noch gebunden, behandle es als SPECIAL-deklarierte Variable."
  3797.        ENGLISH "~S is neither declared nor bound, it will be treated as if it were declared SPECIAL."
  3798.        FRANCAIS "~S n'est ni déclaré ni lié, et va être traité comme étant déclaré SPECIAL."
  3799.        }
  3800.        symbol
  3801.        )
  3802.       (setq a 'SPECIAL)
  3803.     )
  3804.     (case a
  3805.       (SPECIAL ; Special-Variable
  3806.         (let ((var (make-special-var symbol)))
  3807.           (make-anode :type 'VARSET
  3808.                       :sub-anodes '()
  3809.                       :seclass (cons
  3810.                                  'NIL
  3811.                                  (if (var-constantp var) 'NIL (list symbol))
  3812.                                )
  3813.                       :code (if (var-constantp var)
  3814.                               (progn
  3815.                                 (c-warn 
  3816.                                  #L{
  3817.                                  DEUTSCH "Der Konstante ~S kann nicht zugewiesen werden.  Die Zuweisung wird ignoriert."
  3818.                                  ENGLISH "The constant ~S may not be assigned to.  The assignment will be ignored."
  3819.                                  FRANCAIS "Rien ne peut être assigné à la constante ~S.  L'assignation est ignorée."
  3820.                                  }
  3821.                                  symbol
  3822.                                 )
  3823.                                 '((VALUES1))
  3824.                               )
  3825.                               `((SETVALUE , symbol))
  3826.       ) ) )                 )
  3827.       (LOCAL ; interpretativ lexikalisch
  3828.         (make-anode :type 'VARSET
  3829.                     :sub-anodes '()
  3830.                     :seclass (cons 'NIL 'T)
  3831.                     :code `((PUSH)
  3832.                             (CONST ,(new-const b)) ; Vektor
  3833.                             (PUSH)
  3834.                             (CONST ,(new-const c)) ; Index
  3835.                             (SVSET)
  3836.       ) )                  )
  3837.       ((T) ; lexikalisch in Stack oder Closure
  3838.         (let* ((var b)
  3839.                (set-anode
  3840.                  (make-anode :type 'VARSET
  3841.                              :sub-anodes '()
  3842.                              :seclass (cons 'NIL (list var))
  3843.                              :code `((SET ,var ,*venvc* ,*stackz*))
  3844.               )) )
  3845.           (unless (var-usedp var) (setf (var-usedp var) t)) ; Zuweisung "benutzt" die Variable
  3846.           (unless *no-code*
  3847.             (setf (var-constantp var) nil) ; nicht mehr konstant wegen Zuweisung
  3848.             (push (list* value-anode set-anode for-value) (var-modified-list var))
  3849.             (unless (eq (stackz-fun (var-stackz var)) *func*)
  3850.               (setf (var-closurep var) t)
  3851.               ; aktiviere Venvconst in allen dazwischenliegenden Funktionen
  3852.               (do ((venvc *venvc* (cdr venvc)))
  3853.                   ((null venvc) (compiler-error 'c-VARSET "INVISIBLE"))
  3854.                 (when (eq venvc (var-venvc var)) (return))
  3855.                 (when (fnode-p (car venvc))
  3856.                   (setf (fnode-Venvconst (car venvc)) t)
  3857.             ) ) )
  3858.             ; Das Ersetzen einer Variablen innervar durch var ist dann
  3859.             ; nicht erlaubt, wenn während der Existenzdauer von innervar
  3860.             ; an var ein Wert zugewiesen wird.
  3861.             (setf (var-replaceable-list var)
  3862.               (delete-if #'(lambda (innervar-info) ; innervar gerade aktiv?
  3863.                              (let ((innervar (first innervar-info)))
  3864.                                (tailp (var-stackz innervar) *stackz*)
  3865.                            ) )
  3866.                          (var-replaceable-list var)
  3867.             ) )
  3868.           )
  3869.           set-anode
  3870.       ) )
  3871.       (t (compiler-error 'c-VARSET 'venv-search))
  3872. ) ) )
  3873.  
  3874. ;; Funktionsaufrufe, bei denen die Funktion ein Symbol oder (SETF symbol) ist:
  3875.  
  3876. (defun make-funname-const (name)
  3877.   (if (atom name)
  3878.     (new-const name)
  3879.     (let ((symbol (second name)))
  3880.       (make-const :horizont ':all
  3881.                   :value (system::get-setf-symbol symbol)
  3882.                   :form `(SYSTEM::GET-SETF-SYMBOL ',symbol)
  3883. ) ) ) )
  3884.  
  3885. ; Global function call, normal (notinline): (fun {form}*)
  3886. (defun c-NORMAL-FUNCTION-CALL (fun) ; fun ist ein Symbol oder (SETF symbol)
  3887.   (test-list *form* 1)
  3888.   (let* ((n (length (cdr *form*)))
  3889.          #+COMPILER-DEBUG (oldstackz *stackz*)
  3890.          (*stackz* *stackz*))
  3891.     (do ((formlist (cdr *form*))
  3892.          #+COMPILER-DEBUG (anodelist '())
  3893.          (codelist (list '(CALLP))))
  3894.         ((null formlist)
  3895.          (push
  3896.            `(,@(case n
  3897.                  (0 `(CALL0)) (1 `(CALL1)) (2 `(CALL2)) (t `(CALL ,n))
  3898.                )
  3899.              ,(make-funname-const fun)
  3900.             )
  3901.            codelist
  3902.          )
  3903.          (make-anode
  3904.            :type 'CALL
  3905.            :sub-anodes (nreverse anodelist)
  3906.            :seclass '(T . T)
  3907.            :code (nreverse codelist)
  3908.            :stackz oldstackz
  3909.         ))
  3910.       (let* ((formi (pop formlist))
  3911.              (anodei (c-form formi 'ONE)))
  3912.         #+COMPILER-DEBUG (push anodei anodelist)
  3913.         (push anodei codelist)
  3914.         (push '(PUSH) codelist)
  3915.         (push 1 *stackz*)
  3916. ) ) ) )
  3917.  
  3918. ; Liefert die Signatur einer Funktion aus dem fdescr
  3919. (defun fdescr-signature (fdescr)
  3920.   (if (cdr fdescr)
  3921.     (if (eq (cadr fdescr) 'LABELS)
  3922.       ; bei LABELS: aus der Lambdalisten-Information
  3923.       (multiple-value-bind (reqvar  optvar optinit optsvar  restvar
  3924.                             keyflag keyword keyvar keyinit keysvar allow-other-keys
  3925.                             auxvar auxinit)
  3926.           (values-list (cddr fdescr))
  3927.         (declare (ignore optinit optsvar keyvar keyinit keysvar auxvar auxinit))
  3928.         (values (length reqvar) (length optvar)
  3929.                 (not (eql restvar 0)) keyflag
  3930.                 keyword allow-other-keys
  3931.       ) )
  3932.       ; bei GENERIC-FLET oder GENERIC-LABELS: aus der Signatur
  3933.       (values-list (cddr fdescr))
  3934.     )
  3935.     ; bei FLET oder IN-DEFUN: aus dem fnode
  3936.     (let ((fnode (car fdescr)))
  3937.       (values (fnode-req-anz fnode) (fnode-opt-anz fnode)
  3938.               (fnode-rest-flag fnode) (fnode-keyword-flag fnode)
  3939.               (fnode-keywords fnode) (fnode-allow-other-keys-flag fnode)
  3940. ) ) ) )
  3941.  
  3942. ; (test-argument-syntax args applyargs fun req opt rest-p key-p keylist allow-p)
  3943. ; überprüft, ob die Argumentliste args (und evtl. weitere Argumente applyargs)
  3944. ; als Argumentliste zu fun (Symbol) geeignet ist, d.h. ob sie der gegebenen
  3945. ; Spezifikation, gegeben durch req,opt,rest-p,keylist,allow-p, genügt.
  3946. ; Gegebenenfalls wird eine Warnung ausgegeben.
  3947. ; Liefert:
  3948. ;   NO-KEYS           bei korrekter Syntax, ohne Keywords,
  3949. ;   STATIC-KEYS       bei korrekter Syntax mit konstanten Keywords,
  3950. ;   DYNAMIC-KEYS      bei (vermutlich) korrekter Syntax,
  3951. ;                       mit nicht-konstanten Keywords.
  3952. ;   NIL               bei fehlerhafter Syntax,
  3953. ; In den ersten beiden Fällen ist
  3954. ; falls (not applyargs):
  3955. ;   req <= (length args) <= (req+opt oder, falls rest-p oder key-p, unendlich)
  3956. ; bzw. falls applyargs:
  3957. ;   (length args) <= (req+opt oder, falls rest-p oder key-p, unendlich).
  3958. (defun test-argument-syntax (args applyargs fun req opt rest-p key-p keylist allow-p)
  3959.   (unless (and (listp args) (null (cdr (last args))))
  3960.     (c-error 
  3961.      #L{
  3962.      DEUTSCH "Argumentliste zu Funktion ~S ist dotted: ~S"
  3963.      ENGLISH "argument list to function ~S is dotted: ~S"
  3964.      FRANCAIS "Liste pointée d'arguments pour la fonction ~S : ~S"
  3965.      }
  3966.      fun args
  3967.    ) )
  3968.   (let ((n (length args))
  3969.         (reqopt (+ req opt)))
  3970.     (unless (and (or applyargs (<= req n)) (or rest-p key-p (<= n reqopt)))
  3971.       (c-warn 
  3972.        #L{
  3973.        DEUTSCH "~S mit ~S~:[~; oder mehr~] Argumenten aufgerufen, braucht aber ~:[~:[~S bis ~S~;~S~]~;mindestens ~*~S~] Argumente."
  3974.        ENGLISH "~S called with ~S~:[~; or more~] arguments, but it requires ~:[~:[from ~S to ~S~;~S~]~;at least ~*~S~] arguments."
  3975.        FRANCAIS "~S est appelé avec ~S~[; ou plus~] d'arguments mais a besoin ~:[de ~:[~S à ~S~;~S~]~;d'au moins ~*~S~] arguments."
  3976.        }
  3977.        fun n applyargs
  3978.        (or rest-p key-p)  (eql req reqopt) req reqopt
  3979.       )
  3980.       (return-from test-argument-syntax 'NIL)
  3981.     )
  3982.     (unless key-p (return-from test-argument-syntax 'NO-KEYS))
  3983.     ; Mit Keywords.
  3984.     (when (<= n reqopt) (return-from test-argument-syntax 'STATIC-KEYS))
  3985.     (when rest-p (return-from test-argument-syntax 'DYNAMIC-KEYS))
  3986.     (setq n (- n reqopt) args (nthcdr reqopt args))
  3987.     (unless (evenp n)
  3988.       (c-warn 
  3989.        #L{
  3990.        DEUTSCH "Keyword-Argumente zu Funktion ~S sind nicht paarig: ~S"
  3991.        ENGLISH "keyword arguments to function ~S should occur pairwise: ~S"
  3992.        FRANCAIS "Les arguments de genre mot-clé pour la fonction ~S ne sont pas par paires : ~S"
  3993.        }
  3994.        fun args
  3995.       )
  3996.       (return-from test-argument-syntax 'NIL)
  3997.     )
  3998.     (do ((keyargs args (cddr keyargs))
  3999.          (allow-flag allow-p)
  4000.          (wrong-key nil)
  4001.         )
  4002.         ((null keyargs)
  4003.          (if wrong-key
  4004.            (c-error 
  4005.             #L{
  4006.             DEUTSCH "Keyword ~S ist bei Funktion ~S nicht erlaubt.~%Erlaubt ~:[sind nur ~{~S~#[~; und ~S~:;, ~]~}~;ist nur ~{~S~}~]."
  4007.             ENGLISH "keyword ~S is not allowed for function ~S.~%The only allowed keyword~:[s are ~{~S~#[~; and ~S~:;, ~]~}~; is ~{~S~}~]."
  4008.             FRANCAIS "L'argument mot-clé ~S n'est pas permis pour la fonction ~S.~%Seul~:[s sont permis ~{~S~#[~; et ~S~:;, ~]~}~; est permis ~{~S~}~]."
  4009.             }
  4010.             wrong-key fun (eql (length keylist) 1) keylist
  4011.            )
  4012.            'STATIC-KEYS
  4013.         ))
  4014.       (let ((key (first keyargs)))
  4015.         (unless (c-constantp key)
  4016.           (return-from test-argument-syntax 'DYNAMIC-KEYS)
  4017.         )
  4018.         (setq key (c-constant-value key))
  4019.         (unless (keywordp key)
  4020.           (c-warn 
  4021.            #L{
  4022.            DEUTSCH "Das Argument ~S zu Funktion ~S ist kein Keyword."
  4023.            ENGLISH "argument ~S to function ~S is not a keyword"
  4024.            FRANCAIS "L'argument ~S pour la fonction ~S n'est pas un mot-clé."
  4025.            }
  4026.            (first keyargs) fun
  4027.           )
  4028.           (return-from test-argument-syntax 'DYNAMIC-KEYS)
  4029.         )
  4030.         (when (eq key ':ALLOW-OTHER-KEYS)
  4031.           (unless (c-constantp (second keyargs))
  4032.             (return-from test-argument-syntax 'DYNAMIC-KEYS)
  4033.           )
  4034.           (when (c-constant-value (second keyargs)) (setq allow-flag t))
  4035.         )
  4036.         (unless (or allow-flag (member key keylist :test #'eq))
  4037.           (setq wrong-key key)
  4038.     ) ) )
  4039. ) )
  4040.  
  4041. ; (c-DIRECT-FUNCTION-CALL args applyargs fun req opt rest-p key-p keylist
  4042. ;                         subr-flag call-code-producer)
  4043. ; compiliert die Abarbeitung der Argumente für den Direktaufruf einer
  4044. ; Funktion (d.h. ohne Argument-Check zur Laufzeit).
  4045. ; (test-argument-syntax ...) muß die Argumente bereits erfolgreich (d.h.
  4046. ; mit Ergebnis NO-KEYS oder STATIC-KEYS) überprüft haben.
  4047. ; args : Liste der Argumentformen,
  4048. ; applyargs : falls angegeben, Liste einer Form für die weiteren Argumente,
  4049. ; fun : Name der aufzurufenden Funktion (Symbol),
  4050. ; req,opt,rest-p,key-p,keylist,allow-p : Information über die Lambdaliste von fun
  4051. ; subr-flag : Flag, ob fun ein SUBR oder aber eine compilierte Closure ist,
  4052. ;             (Obacht: applyargs nur bei compilierten Closures verwenden!),
  4053. ; call-code-producer : Funktion, die den Code liefert, der am Ende anzufügen
  4054. ;                      ist und den Aufruf ausführt.
  4055. (defun c-DIRECT-FUNCTION-CALL (args applyargs fun req opt rest-p key-p keylist
  4056.                                subr-flag call-code-producer)
  4057.   (let* ((foldable nil)
  4058.          (sideeffects ; Seiteneffektklasse des Funktionsaufrufs selbst
  4059.            (if (not subr-flag)
  4060.              '(T . T) ; kein SUBR -> kann nichts aussagen
  4061.              (case fun ; fun ein SUBR
  4062.                (; Seiteneffektklasse (NIL . NIL) haben diejenigen Funktionen,
  4063.                 ; die ihre Argumente nur anschauen (Pointer, Inhalt nur bei
  4064.                 ; Zahlen oder ähnlichen unmodifizierbaren Datenstrukturen)
  4065.                 ; und auf keine globalen Variablen zugreifen.
  4066.                 ; Eine Funktion, die, zweimal mit denselben Argumenten auf-
  4067.                 ; gerufen, stets dasselbe Ergebnis liefert (im EQL-Sinne),
  4068.                 ; erlaubt Constant-Folding: Sind alle Argumente Konstanten
  4069.                 ; und der Funktionsaufruf durchführbar, so darf der Funktions-
  4070.                 ; aufruf durch das konstante Funktionsergebnis ersetzt werden.
  4071.                 ;
  4072.                 ; This is the list of SUBRs which have no side effects,
  4073.                 ; don't depend on global variables or such, don't even look
  4074.                 ; "into" their arguments, and are "foldable" (two calls with
  4075.                 ; identical arguments give the same result, and calls with
  4076.                 ; constant arguments can be evaluated at compile time).
  4077.                 (SYSTEM::%FUNTABREF
  4078.                  ARRAY-ELEMENT-TYPE ARRAY-RANK ADJUSTABLE-ARRAY-P
  4079.                  STANDARD-CHAR-P GRAPHIC-CHAR-P STRING-CHAR-P ALPHA-CHAR-P UPPER-CASE-P
  4080.                  LOWER-CASE-P BOTH-CASE-P DIGIT-CHAR-P ALPHANUMERICP CHAR= CHAR/= CHAR< CHAR>
  4081.                  CHAR<= CHAR>= CHAR-EQUAL CHAR-NOT-EQUAL CHAR-LESSP CHAR-GREATERP
  4082.                  CHAR-NOT-GREATERP CHAR-NOT-LESSP CHAR-CODE CHAR-BITS CHAR-FONT CODE-CHAR
  4083.                  MAKE-CHAR CHAR-UPCASE CHAR-DOWNCASE DIGIT-CHAR CHAR-INT INT-CHAR
  4084.                  CHAR-NAME CHAR-BIT
  4085.                  SPECIAL-FORM-P
  4086.                  ENDP
  4087.                  IDENTITY
  4088.                  EQ EQL CONSP ATOM SYMBOLP STRINGP NUMBERP
  4089.                  NULL NOT SYSTEM::CLOSUREP LISTP INTEGERP SYSTEM::FIXNUMP RATIONALP FLOATP
  4090.                  SYSTEM::SHORT-FLOAT-P SYSTEM::SINGLE-FLOAT-P SYSTEM::DOUBLE-FLOAT-P SYSTEM::LONG-FLOAT-P
  4091.                  REALP COMPLEXP STREAMP SYSTEM::FILE-STREAM-P SYSTEM::SYNONYM-STREAM-P
  4092.                  SYSTEM::BROADCAST-STREAM-P SYSTEM::CONCATENATED-STREAM-P SYSTEM::TWO-WAY-STREAM-P
  4093.                  SYSTEM::ECHO-STREAM-P SYSTEM::STRING-STREAM-P
  4094.                  RANDOM-STATE-P READTABLEP HASH-TABLE-P PATHNAMEP
  4095.                  HASH-TABLE-TEST
  4096.                  SYSTEM::LOGICAL-PATHNAME-P CHARACTERP FUNCTIONP PACKAGEP ARRAYP SIMPLE-ARRAY-P
  4097.                  BIT-VECTOR-P VECTORP SIMPLE-VECTOR-P SIMPLE-STRING-P SIMPLE-BIT-VECTOR-P
  4098.                  SYSTEM::SYMBOL-MACRO-P CLOS::STD-INSTANCE-P
  4099.                  ZEROP PLUSP MINUSP ODDP EVENP = /= < > <= >= MAX MIN
  4100.                  + - * / 1+ 1- CONJUGATE GCD LCM ISQRT
  4101.                  RATIONAL RATIONALIZE NUMERATOR DENOMINATOR FLOOR CEILING TRUNCATE
  4102.                  ROUND MOD REM DECODE-FLOAT SCALE-FLOAT
  4103.                  FLOAT-RADIX FLOAT-SIGN FLOAT-DIGITS FLOAT-PRECISION INTEGER-DECODE-FLOAT
  4104.                  COMPLEX REALPART IMAGPART LOGIOR LOGXOR LOGAND LOGEQV LOGNAND LOGNOR
  4105.                  LOGANDC1 LOGANDC2 LOGORC1 LOGORC2 BOOLE LOGNOT LOGTEST LOGBITP ASH LOGCOUNT
  4106.                  INTEGER-LENGTH LDB LDB-TEST MASK-FIELD DPB DEPOSIT-FIELD ! EXQUO
  4107.                 ) ; alle diese sind SUBRs ohne Keyword-Parameter
  4108.                 (setq foldable t)
  4109.                 '(NIL . NIL)
  4110.                )
  4111.                (;
  4112.                 ; This is the list of SUBRs which have no side effects,
  4113.                 ; don't depend on global variables or such, don't even look
  4114.                 ; "into" their arguments, but are not "foldable".
  4115.                 (VECTOR MAKE-STRING
  4116.                  VALUES ; nicht foldable, um Endlosschleife zu verhindern!
  4117.                  CONS LIST LIST* MAKE-LIST ACONS
  4118.                  LISP-IMPLEMENTATION-TYPE LISP-IMPLEMENTATION-VERSION SOFTWARE-TYPE
  4119.                  SOFTWARE-VERSION
  4120.                  SYSTEM::MAKE-LOAD-TIME-EVAL SYSTEM::MAKE-SYMBOL-MACRO
  4121.                  SYMBOL-NAME
  4122.                  SYSTEM::DECIMAL-STRING
  4123.                 )
  4124.                 '(NIL . NIL)
  4125.                )
  4126.                (;
  4127.                 ; This is the list of SUBRs which have no side effects,
  4128.                 ; but depend on global variables or look "into" their arguments.
  4129.                 (SYSTEM::SUBR-INFO
  4130.                  AREF SVREF ROW-MAJOR-AREF ARRAY-DIMENSION ARRAY-DIMENSIONS ARRAY-TOTAL-SIZE
  4131.                  ARRAY-IN-BOUNDS-P ARRAY-ROW-MAJOR-INDEX BIT SBIT
  4132.                  ARRAY-HAS-FILL-POINTER-P FILL-POINTER MAKE-ARRAY
  4133.                  CHARACTER CHAR SCHAR STRING= STRING/= STRING< STRING> STRING<=
  4134.                  STRING>= STRING-EQUAL STRING-NOT-EQUAL STRING-LESSP STRING-GREATERP
  4135.                  STRING-NOT-GREATERP STRING-NOT-LESSP SYSTEM::SEARCH-STRING=
  4136.                  SYSTEM::SEARCH-STRING-EQUAL SYSTEM::STRING-BOTH-TRIM STRING-UPCASE
  4137.                  STRING-DOWNCASE STRING-CAPITALIZE STRING NAME-CHAR SUBSTRING STRING-CONCAT
  4138.                  MAKE-SYMBOL SYMBOL-VALUE SYMBOL-FUNCTION BOUNDP FBOUNDP
  4139.                  VALUES-LIST MACRO-FUNCTION CONSTANTP
  4140.                  MAKE-HASH-TABLE GETHASH HASH-TABLE-COUNT HASH-TABLE-REHASH-SIZE
  4141.                  HASH-TABLE-REHASH-THRESHOLD HASH-TABLE-SIZE SYSTEM::HASH-TABLE-ITERATOR SXHASH
  4142.                  GET-MACRO-CHARACTER GET-DISPATCH-MACRO-CHARACTER SYSTEM::LINE-POSITION
  4143.                  CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR
  4144.                  CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR
  4145.                  CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR
  4146.                  LIST-LENGTH NTH FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH
  4147.                  EIGHTH NINTH TENTH REST NTHCDR LAST APPEND COPY-LIST
  4148.                  COPY-ALIST COPY-TREE REVAPPEND BUTLAST LDIFF TAILP PAIRLIS
  4149.                  GET-UNIVERSAL-TIME GET-INTERNAL-RUN-TIME
  4150.                  GET-INTERNAL-REAL-TIME SYSTEM::%%TIME
  4151.                  FIND-PACKAGE PACKAGE-NAME PACKAGE-NICKNAMES PACKAGE-USE-LIST
  4152.                  PACKAGE-USED-BY-LIST PACKAGE-SHADOWING-SYMBOLS LIST-ALL-PACKAGES FIND-SYMBOL
  4153.                  FIND-ALL-SYMBOLS
  4154.                  PARSE-NAMESTRING PATHNAME PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY
  4155.                  PATHNAME-NAME PATHNAME-TYPE PATHNAME-VERSION FILE-NAMESTRING
  4156.                  DIRECTORY-NAMESTRING HOST-NAMESTRING MERGE-PATHNAMES ENOUGH-NAMESTRING
  4157.                  MAKE-PATHNAME NAMESTRING TRUENAME PROBE-FILE DIRECTORY FILE-WRITE-DATE
  4158.                  FILE-AUTHOR
  4159.                  EQUAL EQUALP COMPILED-FUNCTION-P CLOS::GENERIC-FUNCTION-P COMMONP
  4160.                  TYPE-OF CLOS::CLASS-P CLOS:CLASS-OF COERCE
  4161.                  SYSTEM::%RECORD-REF SYSTEM::%RECORD-LENGTH SYSTEM::%STRUCTURE-REF SYSTEM::%MAKE-STRUCTURE
  4162.                  SYSTEM::%COPY-STRUCTURE SYSTEM::%STRUCTURE-TYPE-P SYSTEM::CLOSURE-NAME
  4163.                  SYSTEM::CLOSURE-CODEVEC SYSTEM::CLOSURE-CONSTS SYSTEM::MAKE-CODE-VECTOR
  4164.                  SYSTEM::%MAKE-CLOSURE CLOS::ALLOCATE-STD-INSTANCE CLOS:SLOT-EXISTS-P
  4165.                  SYSTEM::SEQUENCEP ELT SUBSEQ COPY-SEQ LENGTH REVERSE CONCATENATE
  4166.                  MAKE-SYNONYM-STREAM SYNONYM-STREAM-SYMBOL MAKE-BROADCAST-STREAM
  4167.                  BROADCAST-STREAM-STREAMS MAKE-CONCATENATED-STREAM
  4168.                  CONCATENATED-STREAM-STREAMS MAKE-TWO-WAY-STREAM
  4169.                  TWO-WAY-STREAM-INPUT-STREAM TWO-WAY-STREAM-OUTPUT-STREAM
  4170.                  MAKE-ECHO-STREAM ECHO-STREAM-INPUT-STREAM
  4171.                  ECHO-STREAM-OUTPUT-STREAM MAKE-STRING-INPUT-STREAM
  4172.                  SYSTEM::STRING-INPUT-STREAM-INDEX MAKE-STRING-OUTPUT-STREAM
  4173.                  SYSTEM::MAKE-STRING-PUSH-STREAM MAKE-BUFFERED-INPUT-STREAM
  4174.                  MAKE-BUFFERED-OUTPUT-STREAM OPEN-STREAM-P INPUT-STREAM-P
  4175.                  OUTPUT-STREAM-P STREAM-ELEMENT-TYPE FILE-LENGTH
  4176.                  GET GETF GET-PROPERTIES SYMBOL-PACKAGE SYMBOL-PLIST KEYWORDP
  4177.                  SYSTEM::SPECIAL-VARIABLE-P GENSYM
  4178.                  FFLOOR FCEILING FTRUNCATE FROUND
  4179.                  EXP EXPT LOG SQRT ABS PHASE SIGNUM SIN COS TAN CIS ASIN ACOS ATAN
  4180.                  SINH COSH TANH ASINH ACOSH ATANH FLOAT BYTE BYTE-SIZE BYTE-POSITION
  4181.                  SYSTEM::LOG2 SYSTEM::LOG10
  4182.                 )
  4183.                 '(T . NIL)
  4184.                )
  4185.                ; All other SUBRs (which may have side effects) are subsumed here.
  4186.                (t '(T . T)) ; vielleicht Seiteneffekte
  4187.         )) ) )
  4188.     (if (and (null *for-value*) (null (cdr sideeffects)))
  4189.       ; Brauche die Funktion nicht aufzurufen, nur die Argumente auswerten
  4190.       (progn
  4191.         (let ((*no-code* t) (*for-value* 'NIL))
  4192.           (funcall call-code-producer)
  4193.         )
  4194.         (c-form `(PROGN ,@args ,@applyargs))
  4195.       )
  4196.       (let ((n (length args))
  4197.             (reqopt (+ req opt))
  4198.             (seclass sideeffects)
  4199.             (codelist '()))
  4200.         (let ((*stackz* *stackz*))
  4201.           ; required und angegebene optionale Parameter:
  4202.           (dotimes (i (min n reqopt))
  4203.             (let* ((formi (pop args))
  4204.                    (anodei (c-form formi 'ONE)))
  4205.               (seclass-or-f seclass anodei)
  4206.               (push anodei codelist)
  4207.             )
  4208.             (push '(PUSH) codelist)
  4209.             (push 1 *stackz*)
  4210.           )
  4211.           (if applyargs
  4212.             (progn
  4213.               (when subr-flag (compiler-error 'c-DIRECT-FUNCTION-CALL "APPLY-SUBR"))
  4214.               (when key-p (compiler-error 'c-DIRECT-FUNCTION-CALL "APPLY-KEY"))
  4215.               (if (>= reqopt n)
  4216.                 ; fehlende optionale Parameter werden aus der Liste initialisiert:
  4217.                 (let* ((anz (- reqopt n))
  4218.                        (anode1 (c-form (first applyargs) 'ONE))
  4219.                        (anode2 (progn
  4220.                                  (push (if rest-p (+ anz 1) anz) *stackz*)
  4221.                                  (c-unlist rest-p anz (min opt anz))
  4222.                       ))       )
  4223.                   (seclass-or-f seclass anode1)
  4224.                   (push anode1 codelist)
  4225.                   (seclass-or-f seclass anode2)
  4226.                   (push anode2 codelist)
  4227.                 )
  4228.                 ; n > reqopt, impliziert rest-p.
  4229.                 ; Übergabe von restlichen Argumenten an eine compilierte Closure:
  4230.                 ; als Liste.
  4231.                 ; Liste aus allen weiteren Argumenten:
  4232.                 (progn
  4233.                   (let ((*stackz* *stackz*)
  4234.                         (rest-args args))
  4235.                     (loop
  4236.                       (when (null rest-args) (return))
  4237.                       (let ((anode (c-form (pop rest-args) 'ONE)))
  4238.                         (seclass-or-f seclass anode)
  4239.                         (push anode codelist)
  4240.                       )
  4241.                       (push '(PUSH) codelist)
  4242.                       (push 1 *stackz*)
  4243.                     )
  4244.                     (let ((anode (c-form (first applyargs) 'ONE)))
  4245.                       (seclass-or-f seclass anode)
  4246.                       (push anode codelist)
  4247.                     )
  4248.                     (push `(LIST* ,(- n reqopt)) codelist)
  4249.                   )
  4250.                   (push '(PUSH) codelist)
  4251.                   (push 1 *stackz*)
  4252.             ) ) )
  4253.             (progn
  4254.               ; fehlende optionale Parameter werden mit #<UNBOUND> initialisiert:
  4255.               (when (> reqopt n)
  4256.                 (let ((anz (- reqopt n)))
  4257.                   (push `(PUSH-UNBOUND ,anz) codelist)
  4258.                   (push anz *stackz*)
  4259.               ) )
  4260.               ; &rest-Parameter:
  4261.               (when rest-p
  4262.                 (if subr-flag
  4263.                   ; Übergabe von restlichen Argumenten an ein SUBR: einzeln
  4264.                   (loop
  4265.                     (when (null args) (return))
  4266.                     (let ((anode (c-form (pop args) 'ONE)))
  4267.                       (seclass-or-f seclass anode)
  4268.                       (push anode codelist)
  4269.                     )
  4270.                     (push '(PUSH) codelist)
  4271.                     (push 1 *stackz*)
  4272.                   )
  4273.                   ; Übergabe von restlichen Argumenten an eine compilierte Closure:
  4274.                   ; als Liste
  4275.                   (if (null args)
  4276.                     ; leere Liste
  4277.                     (progn
  4278.                       (push '(NIL) codelist)
  4279.                       (push '(PUSH) codelist)
  4280.                       (push 1 *stackz*)
  4281.                     )
  4282.                     ; Liste aus allen weiteren Argumenten:
  4283.                     (progn
  4284.                       (let ((*stackz* *stackz*)
  4285.                             (rest-args args))
  4286.                         (loop
  4287.                           (when (null rest-args) (return))
  4288.                           (let ((anode (c-form (pop rest-args) 'ONE)))
  4289.                             (seclass-or-f seclass anode)
  4290.                             (push anode codelist)
  4291.                           )
  4292.                           (push '(PUSH) codelist)
  4293.                           (push 1 *stackz*)
  4294.                         )
  4295.                         (push `(LIST ,(- n reqopt)) codelist)
  4296.                       )
  4297.                       (push '(PUSH) codelist)
  4298.                       (push 1 *stackz*)
  4299.             ) ) ) ) )
  4300.           )
  4301.           ; &key-Parameter:
  4302.           (when key-p
  4303.             ; Nur dann gleichzeitig rest-p und key-p, wenn n <= reqopt, da
  4304.             ; test-argument-syntax (ergab STATIC-KEYS) den anderen Fall
  4305.             ; bereits ausgeschlossen hat.
  4306.             (let ((keyanz (length keylist)))
  4307.               ; Erst alle Keys mit #<UNBOUND> vorbelegen, dann die Argumente
  4308.               ; in der angegebenen Reihenfolge auswerten und zuordnen?
  4309.               ; Das ist uns zu einfach. Wir lassen die Argumente kommutieren,
  4310.               ; damit möglichst viele der (STORE ...) durch (PUSH) ersetzt
  4311.               ; werden können: Die Argumente zu den ersten Keys werden nach
  4312.               ; Möglichkeit zuerst ausgewertet, die zu den letzten Keys
  4313.               ; zuletzt. Wir lassen es allerdings bei einem einzigen
  4314.               ; (PUSH-UNBOUND ...).
  4315.               (let* ((key-positions ; Liste von Tripeln (key stack-depth free-p),
  4316.                                     ; wobei stack-depth = keyanz-1...0 läuft und
  4317.                                     ; free-p angibt, ob der Slot schon gefüllt ist.
  4318.                        (let ((i keyanz))
  4319.                          (mapcar #'(lambda (key) (list key (decf i) t)) keylist)
  4320.                      ) )
  4321.                      (anodes ; Liste von Quadrupeln
  4322.                              ; (needed key-position anode stackz), wobei
  4323.                              ; key-position die stack-depth des Keyword-Slots
  4324.                              ; oder NIL ist, anode der Anode zu diesem Argument.
  4325.                              ; Die Liste wird in derselben Reihenfolge gehalten,
  4326.                              ; wie sie die Argumentliste vorgibt.
  4327.                              ; Ausnahme: needed = NIL bei anodes, deren
  4328.                              ; Berechnung man vorgezogen oder verschoben hat.
  4329.                        (let ((L '()))
  4330.                          (loop
  4331.                            (when (null args) (return))
  4332.                            (let* ((key (c-constant-value (pop args)))
  4333.                                   (tripel (assoc key key-positions :test #'eq)) ; kann =NIL sein!
  4334.                                   (for-value (third tripel))
  4335.                                   (arg (pop args)))
  4336.                              ; for-value /= NIL: Existentes Keyword, und der Slot ist noch leer
  4337.                              ; for-value = NIL: ALLOW-erlaubtes Keyword oder Slot schon gefüllt
  4338.                              (let* ((*stackz* (cons 0 *stackz*)) ; 0 wird später ersetzt
  4339.                                     (anode (c-form arg (if for-value 'ONE 'NIL))))
  4340.                                (seclass-or-f seclass anode)
  4341.                                (push (list t (second tripel) anode *stackz*) L)
  4342.                              )
  4343.                              (setf (third tripel) nil)
  4344.                          ) )
  4345.                          (nreverse L)
  4346.                     )) )
  4347.                 (let ((depth1 0)
  4348.                       (depth2 0)
  4349.                       (codelist-from-end '()))
  4350.                   ; Möglichst viel nach vorne ziehen:
  4351.                   (do ((anodesr anodes (cdr anodesr)))
  4352.                       ((null anodesr))
  4353.                     (let ((anodeetc (car anodesr))) ; nächstes Quadrupel
  4354.                       (when (first anodeetc) ; noch was zu tun?
  4355.                         (if (and
  4356.                               (or ; kein Keyword, d.h. kein (STORE ...) nötig?
  4357.                                   (null (second anodeetc))
  4358.                                   ; oberstes Keyword?
  4359.                                   (= (second anodeetc) (- keyanz depth1 1))
  4360.                               )
  4361.                               ; kommutiert anodeetc mit allen vorigen anodes?
  4362.                               (let ((anode (third anodeetc)))
  4363.                                 (do ((anodesr2 anodes (cdr anodesr2)))
  4364.                                     ((eq anodesr2 anodesr) t)
  4365.                                   (unless (anodes-commute anode (third (car anodesr2)))
  4366.                                     (return nil)
  4367.                               ) ) )
  4368.                             )
  4369.                           ; vorziehen:
  4370.                           (progn
  4371.                             (setf (first (fourth anodeetc)) depth1) ; korrekte Stacktiefe
  4372.                             (push (third anodeetc) codelist) ; in die Codeliste
  4373.                             (when (second anodeetc)
  4374.                               (push '(PUSH) codelist)
  4375.                               (incf depth1)
  4376.                             )
  4377.                             (setf (first anodeetc) nil) ; diesen brauchen wir nicht mehr
  4378.                           )
  4379.                           ; sonst machen wir nichts.
  4380.                   ) ) ) )
  4381.                   ; Möglichst viel nach hinten ziehen:
  4382.                   (setq anodes (nreverse anodes))
  4383.                   (do ((anodesr anodes (cdr anodesr)))
  4384.                       ((null anodesr))
  4385.                     (let ((anodeetc (car anodesr))) ; nächstes Quadrupel
  4386.                       (when (first anodeetc) ; noch was zu tun?
  4387.                         (if (and
  4388.                               (or ; kein Keyword, d.h. kein (STORE ...) nötig?
  4389.                                   (null (second anodeetc))
  4390.                                   ; unterstes Keyword?
  4391.                                   (= (second anodeetc) depth2)
  4392.                               )
  4393.                               ; kommutiert anodeetc mit allen späteren anodes?
  4394.                               (let ((anode (third anodeetc)))
  4395.                                 (do ((anodesr2 anodes (cdr anodesr2)))
  4396.                                     ((eq anodesr2 anodesr) t)
  4397.                                   (unless (anodes-commute anode (third (car anodesr2)))
  4398.                                     (return nil)
  4399.                               ) ) )
  4400.                             )
  4401.                           ; ans Ende verschieben:
  4402.                           (progn
  4403.                             (when (second anodeetc)
  4404.                               (push '(PUSH) codelist-from-end)
  4405.                               (incf depth2)
  4406.                             )
  4407.                             (setf (first (fourth anodeetc)) (- keyanz depth2)) ; korrekte Stacktiefe
  4408.                             (push (third anodeetc) codelist-from-end) ; in die Codeliste
  4409.                             (setf (first anodeetc) nil) ; diesen brauchen wir nicht mehr
  4410.                           )
  4411.                           ; sonst machen wir nichts.
  4412.                   ) ) ) )
  4413.                   (setq anodes (nreverse anodes))
  4414.                   (let ((depth-now (- keyanz depth2))) ; codelist-from-end erniedrigt den Stack um depth2
  4415.                     (when (> depth-now depth1)
  4416.                       (push `(PUSH-UNBOUND ,(- depth-now depth1)) codelist)
  4417.                     )
  4418.                     ; In codelist herrscht jetzt Stacktiefe depth-now.
  4419.                     (dolist (anodeetc anodes)
  4420.                       (when (first anodeetc)
  4421.                         (setf (first (fourth anodeetc)) depth-now) ; korrekte Stacktiefe
  4422.                         (push (third anodeetc) codelist)
  4423.                         (when (second anodeetc)
  4424.                           (push `(STORE ,(- (second anodeetc) depth2)) codelist)
  4425.                   ) ) ) )
  4426.                   ; Nun codelist-from-end:
  4427.                   (setq codelist (nreconc codelist-from-end codelist))
  4428.               ) )
  4429.               ; Jetzt sind alle Key-Argumente auf dem Stack.
  4430.               (push keyanz *stackz*)
  4431.           ) )
  4432.           (setq codelist (nreconc codelist (funcall call-code-producer)))
  4433.         )
  4434.         ; Constant-Folding: Ist fun foldable (also subr-flag = T und
  4435.         ; key-flag = NIL) und besteht codelist außer den (PUSH)s und dem
  4436.         ; Call-Code am Schluß nur aus Anodes mit code = ((CONST ...)) ?
  4437.         (when (and foldable
  4438.                    (every #'(lambda (code)
  4439.                               (or (not (anode-p code)) (anode-constantp code))
  4440.                             )
  4441.                           codelist
  4442.               )    )
  4443.           ; Funktion aufzurufen versuchen:
  4444.           (let ((args (let ((L '())) ; Liste der (konstanten) Argumente
  4445.                         (dolist (code codelist)
  4446.                           (when (anode-p code)
  4447.                             (push (anode-constant-value code) L)
  4448.                         ) )
  4449.                         (nreverse L)
  4450.                 )     )
  4451.                 resulting-values)
  4452.             (when (block try-eval
  4453.                     (setq resulting-values
  4454.                       (let ((*error-handler*
  4455.                               #'(lambda (&rest error-args)
  4456.                                   (declare (ignore error-args))
  4457.                                   (return-from try-eval nil)
  4458.                            ))   )
  4459.                         (multiple-value-list (apply fun args))
  4460.                     ) )
  4461.                     t
  4462.                   )
  4463.               ; Funktion erfolgreich aufgerufen, Constant-Folding durchführen:
  4464.               (return-from c-DIRECT-FUNCTION-CALL
  4465.                 (c-GLOBAL-FUNCTION-CALL-form
  4466.                   `(VALUES ,@(mapcar #'(lambda (x) `(QUOTE ,x)) resulting-values))
  4467.         ) ) ) ) )
  4468.         (make-anode
  4469.           :type `(DIRECT-CALL ,fun)
  4470.           :sub-anodes (remove-if-not #'anode-p codelist)
  4471.           :seclass seclass
  4472.           :code codelist
  4473.         )
  4474. ) ) ) )
  4475. (defun c-unlist (rest-p n m)
  4476.   (if rest-p
  4477.     (if (eql n 0)
  4478.       (make-anode :type 'UNLIST*
  4479.                   :sub-anodes '()
  4480.                   :seclass '(NIL . NIL)
  4481.                   :code '((PUSH))
  4482.       )
  4483.       (make-anode :type 'UNLIST*
  4484.                   :sub-anodes '()
  4485.                   :seclass '(T . T) ; kann Error melden
  4486.                   :code `((UNLIST* ,n ,m))
  4487.     ) )
  4488.     (make-anode :type 'UNLIST
  4489.                 :sub-anodes '()
  4490.                 :seclass '(T . T) ; kann Error melden
  4491.                 :code `((UNLIST ,n ,m))
  4492. ) ) )
  4493. (defun cclosure-call-code-producer (fun fnode req opt rest-flag key-flag keylist)
  4494.   (if (eq fnode *func*)
  4495.     ; rekursiver Aufruf der eigenen Funktion
  4496.     (let ((call-code
  4497.             `((JSR ,(+ req opt (if rest-flag 1 0) (length keylist)) ; Zahl der Stack-Einträge
  4498.                    ,*func-start-label*
  4499.              ))
  4500.          ))
  4501.       #'(lambda () call-code)
  4502.     )
  4503.     ; eine andere Cclosure aufrufen
  4504.     #'(lambda ()
  4505.         (list
  4506.           (c-form `(FUNCTION ,fun) 'ONE)
  4507.           (if key-flag '(CALLCKEY) '(CALLC))
  4508.       ) )
  4509. ) )
  4510.  
  4511. ; Global function call: (fun {form}*)
  4512. (defun c-GLOBAL-FUNCTION-CALL-form (*form*)
  4513.   (c-GLOBAL-FUNCTION-CALL (first *form*))
  4514. )
  4515. (defun c-GLOBAL-FUNCTION-CALL (fun) ; fun ist ein Symbol oder (SETF symbol)
  4516.   (test-list *form* 1)
  4517.   (when *compiling-from-file* ; von COMPILE-FILE aufgerufen?
  4518.     (unless (or (fboundp fun) (member fun *known-functions* :test #'equal))
  4519.       (pushnew fun *unknown-functions* :test #'equal)
  4520.     )
  4521.     ; PROCLAIM-Deklarationen zur Kenntnis nehmen:
  4522.     (when (and (eq fun 'PROCLAIM) (= (length *form*) 2))
  4523.       (let ((h (second *form*)))
  4524.         (when (c-constantp h)
  4525.           (c-form
  4526.             `(EVAL-WHEN (COMPILE) (c-PROCLAIM ',(c-constant-value h)))
  4527.     ) ) ) )
  4528.     ; Modul-Anforderungen zur Kenntnis nehmen:
  4529.     (when (and (memq fun '(PROVIDE REQUIRE))
  4530.                (every #'c-constantp (rest *form*))
  4531.           )
  4532.       (c-form
  4533.         `(EVAL-WHEN (COMPILE)
  4534.            (,(case fun
  4535.                (PROVIDE 'c-PROVIDE) ; c-PROVIDE statt PROVIDE
  4536.                (REQUIRE 'c-REQUIRE) ; c-REQUIRE statt REQUIRE
  4537.              )
  4538.             ,@(mapcar
  4539.                 #'(lambda (x) (list 'QUOTE (c-constant-value x))) ; Argumente quotieren
  4540.                 (rest *form*)
  4541.          ) )  )
  4542.     ) )
  4543.     ; Package-Anforderungen zur Kenntnis nehmen:
  4544.     (when (and (memq fun '(MAKE-PACKAGE SYSTEM::%IN-PACKAGE IN-PACKAGE
  4545.                            SHADOW SHADOWING-IMPORT EXPORT UNEXPORT
  4546.                            USE-PACKAGE UNUSE-PACKAGE IMPORT
  4547.                )          )
  4548.                (every #'c-constantp (rest *form*))
  4549.           )
  4550.       (push
  4551.         `(,fun
  4552.           ,@(mapcar
  4553.               #'(lambda (x) (list 'QUOTE (c-constant-value x))) ; Argumente quotieren
  4554.               (rest *form*)
  4555.          )  )
  4556.         *package-tasks*
  4557.   ) ) )
  4558.   (let* ((args (cdr *form*)) ; Argumente
  4559.          (n (length args))) ; Anzahl der Argumente
  4560.     (if (not (declared-notinline fun)) ; darf fun INLINE genommen werden?
  4561.       (multiple-value-bind (name req opt rest-p keylist allow-p) (subr-info fun)
  4562.         ; Ist fun ein SUBR, so sollte name = fun sein, und das SUBR hat die
  4563.         ; Spezifikation req, opt, rest-p, key-p = (not (null keylist)), allow-p.
  4564.         ; Sonst ist name = NIL.
  4565.         (if (and name (eq fun name)) ; beschreibt fun ein gültiges SUBR?
  4566.           (case fun
  4567.             ((CAR CDR FIRST REST NOT NULL CONS SVREF VALUES
  4568.               CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR
  4569.               CDDAR CDDDR SECOND THIRD FOURTH CAAAAR CAAADR CAADAR CAADDR
  4570.               CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDADDR
  4571.               CDDAAR CDDADR CDDDAR CDDDDR ATOM CONSP
  4572.               VALUES-LIST SYS::%SVSTORE EQ SYMBOL-FUNCTION LIST LIST*
  4573.              )
  4574.              ; Diese hier haben keylist=NIL, allow-p=NIL und
  4575.              ; (was aber nicht verwendet wird) opt=0.
  4576.              (if (and (<= req n) (or rest-p (<= n (+ req opt))))
  4577.                ; Wir machen den Aufruf INLINE.
  4578.                (let ((sideeffects ; Seiteneffektklasse der Funktionsausführung
  4579.                        (case fun
  4580.                          ((NOT NULL CONS VALUES ATOM CONSP EQ LIST LIST*)
  4581.                            '(NIL . NIL)
  4582.                          )
  4583.                          ((CAR CDR FIRST REST CAAR CADR
  4584.                            CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR
  4585.                            CDDDR SECOND THIRD FOURTH CAAAAR CAAADR CAADAR CAADDR
  4586.                            CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDADDR
  4587.                            CDDAAR CDDADR CDDDAR CDDDDR VALUES-LIST
  4588.                            SVREF SYMBOL-FUNCTION
  4589.                           )
  4590.                            '(T . NIL)
  4591.                          )
  4592.                          (t '(T . T))
  4593.                     )) )
  4594.                  (if (and (null *for-value*) (null (cdr sideeffects)))
  4595.                    ; Brauche die Funktion nicht aufzurufen, nur die Argumente auswerten
  4596.                    (c-form `(PROGN ,@args))
  4597.                    (if (and (eq fun 'VALUES) (eq *for-value* 'ONE))
  4598.                      (if (= n 0) (c-NIL) (c-form `(PROG1 ,@args)))
  4599.                      (let ((seclass sideeffects)
  4600.                            (codelist '()))
  4601.                        (let ((*stackz* *stackz*))
  4602.                          ; Argumente auswerten und bis auf das letzte auf den Stack
  4603.                          ; (denn das letzte Argument wird in A0 erwartet):
  4604.                          (loop
  4605.                            (when (null args) (return))
  4606.                            (let ((anode (c-form (pop args) 'ONE)))
  4607.                              (seclass-or-f seclass anode)
  4608.                              (push anode codelist)
  4609.                            )
  4610.                            (when args ; nicht am Schluß
  4611.                              (push '(PUSH) codelist)
  4612.                              (push 1 *stackz*)
  4613.                          ) )
  4614.                          (setq codelist
  4615.                            (nreconc codelist
  4616.                              (case fun
  4617.                                ((CAR FIRST) '((CAR)))
  4618.                                ((CDR REST) '((CDR)))
  4619.                                (CAAR '((CAR) (CAR)))
  4620.                                ((CADR SECOND) '((CDR) (CAR)))
  4621.                                (CDAR '((CAR) (CDR)))
  4622.                                (CDDR '((CDR) (CDR)))
  4623.                                (CAAAR '((CAR) (CAR) (CAR)))
  4624.                                (CAADR '((CDR) (CAR) (CAR)))
  4625.                                (CADAR '((CAR) (CDR) (CAR)))
  4626.                                ((CADDR THIRD) '((CDR) (CDR) (CAR)))
  4627.                                (CDAAR '((CAR) (CAR) (CDR)))
  4628.                                (CDADR '((CDR) (CAR) (CDR)))
  4629.                                (CDDAR '((CAR) (CDR) (CDR)))
  4630.                                (CDDDR '((CDR) (CDR) (CDR)))
  4631.                                (CAAAAR '((CAR) (CAR) (CAR) (CAR)))
  4632.                                (CAAADR '((CDR) (CAR) (CAR) (CAR)))
  4633.                                (CAADAR '((CAR) (CDR) (CAR) (CAR)))
  4634.                                (CAADDR '((CDR) (CDR) (CAR) (CAR)))
  4635.                                (CADAAR '((CAR) (CAR) (CDR) (CAR)))
  4636.                                (CADADR '((CDR) (CAR) (CDR) (CAR)))
  4637.                                (CADDAR '((CAR) (CDR) (CDR) (CAR)))
  4638.                                ((CADDDR FOURTH) '((CDR) (CDR) (CDR) (CAR)))
  4639.                                (CDAAAR '((CAR) (CAR) (CAR) (CDR)))
  4640.                                (CDAADR '((CDR) (CAR) (CAR) (CDR)))
  4641.                                (CDADAR '((CAR) (CDR) (CAR) (CDR)))
  4642.                                (CDADDR '((CDR) (CDR) (CAR) (CDR)))
  4643.                                (CDDAAR '((CAR) (CAR) (CDR) (CDR)))
  4644.                                (CDDADR '((CDR) (CAR) (CDR) (CDR)))
  4645.                                (CDDDAR '((CAR) (CDR) (CDR) (CDR)))
  4646.                                (CDDDDR '((CDR) (CDR) (CDR) (CDR)))
  4647.                                (ATOM '((ATOM)))
  4648.                                (CONSP '((CONSP)))
  4649.                                ((NOT NULL) '((NOT)))
  4650.                                (CONS '((CONS)))
  4651.                                (SVREF '((SVREF)))
  4652.                                (SYS::%SVSTORE '((SVSET)))
  4653.                                (EQ '((EQ)))
  4654.                                (VALUES (case n
  4655.                                          (0 '((VALUES0)) )
  4656.                                          (1 '((VALUES1)) )
  4657.                                          (t `((PUSH) ; letztes Argument auch noch in den Stack
  4658.                                               (STACK-TO-MV ,n)
  4659.                                              )
  4660.                                )       ) )
  4661.                                (VALUES-LIST '((LIST-TO-MV)))
  4662.                                (SYMBOL-FUNCTION '((SYMBOL-FUNCTION)))
  4663.                                (LIST (if (plusp n)
  4664.                                        `((PUSH) (LIST ,n))
  4665.                                        '((NIL))
  4666.                                )     )
  4667.                                (LIST* (case n
  4668.                                         (1 '((VALUES1)) )
  4669.                                         (t `((LIST* ,(1- n))) )
  4670.                                )      )
  4671.                                (t (compiler-error 'c-GLOBAL-FUNCTION-CALL))
  4672.                        ) ) ) )
  4673.                        (make-anode
  4674.                          :type `(PRIMOP ,fun)
  4675.                          :sub-anodes (remove-if-not #'anode-p codelist)
  4676.                          :seclass seclass
  4677.                          :code codelist
  4678.                        )
  4679.                ) ) ) )
  4680.                ; falsche Argumentezahl -> doch nicht INLINE:
  4681.                (progn
  4682.                  (c-warn 
  4683.                   #L{
  4684.                   DEUTSCH "~S mit ~S Argumenten aufgerufen, braucht aber ~:[~:[~S bis ~S~;~S~]~;mindestens ~*~S~] Argumente."
  4685.                   ENGLISH "~S called with ~S arguments, but it requires ~:[~:[from ~S to ~S~;~S~]~;at least ~*~S~] arguments."
  4686.                   FRANCAIS "~S est appelé avec ~S arguments mais a besoin ~:[de ~:[~S à ~S~;~S~]~;d'au moins ~*~S~] arguments."
  4687.                   }
  4688.                   fun n
  4689.                   rest-p  (eql opt 0) req (+ req opt)
  4690.                  )
  4691.                  (c-NORMAL-FUNCTION-CALL fun)
  4692.             )) )
  4693.             (t ; Ist das SUBR fun in der FUNTAB enthalten?
  4694.              (let ((index (gethash fun function-codes)))
  4695.                (if index
  4696.                  (case (test-argument-syntax args nil
  4697.                                     fun req opt rest-p keylist keylist allow-p
  4698.                        )
  4699.                    ((NO-KEYS STATIC-KEYS)
  4700.                     ; korrekte Syntax, Stack-Layout zur Compilezeit vorhersehbar
  4701.                     ; -> INLINE
  4702.                     (c-DIRECT-FUNCTION-CALL
  4703.                       args nil fun req opt rest-p keylist keylist
  4704.                       t ; es handelt sich um ein SUBR
  4705.                       (let ((call-code
  4706.                               ; Aufruf mit Hilfe der FUNTAB:
  4707.                               (cons
  4708.                                 (if (not rest-p)
  4709.                                   (CALLS-code index)
  4710.                                   `(CALLSR ,(max 0 (- n req opt)) ; Bei n<req+opt kommt noch ein (PUSH-UNBOUND ...)
  4711.                                            ,(- index funtabR-index)
  4712.                                    )
  4713.                                 )
  4714.                                 (case fun
  4715.                                   (; Funktionen, die nicht zurückkehren:
  4716.                                    (; control.d:
  4717.                                     SYS::DRIVER SYS::UNWIND-TO-DRIVER
  4718.                                     ; debug.d:
  4719.                                     ; SYS::REDO-EVAL-FRAME SYS::RETURN-FROM-EVAL-FRAME
  4720.                                     ; error.d:
  4721.                                     ERROR SYSTEM::ERROR-OF-TYPE INVOKE-DEBUGGER
  4722.                                    )
  4723.                                    '((BARRIER))
  4724.                                   )
  4725.                                   (t '())
  4726.                            )) ) )
  4727.                         #'(lambda () call-code)
  4728.                    )) )
  4729.                    (t (c-NORMAL-FUNCTION-CALL fun))
  4730.                  )
  4731.                  (c-NORMAL-FUNCTION-CALL fun)
  4732.           ) )) )
  4733.           (let ((inline-lambdabody
  4734.                   (or (and *compiling-from-file*
  4735.                            (cdr (assoc fun *inline-definitions* :test #'equal))
  4736.                       )
  4737.                       (get (sys::get-funname-symbol fun) 'sys::inline-expansion)
  4738.                )) )
  4739.             (if (and #| inline-lambdabody |#
  4740.                      (consp inline-lambdabody)
  4741.                      (inline-callable-function-p `(FUNCTION (LAMBDA ,@inline-lambdabody)) n)
  4742.                 )
  4743.               ; Aufruf einer globalen Funktion INLINE möglich
  4744.               (c-FUNCALL-INLINE fun args nil inline-lambdabody nil)
  4745.               (c-NORMAL-FUNCTION-CALL fun)
  4746.       ) ) ) )
  4747.       (c-NORMAL-FUNCTION-CALL fun)
  4748. ) ) )
  4749.  
  4750. ; Hilfsfunktion: PROCLAIM beim Compilieren vom File, vgl. Funktion PROCLAIM
  4751. (defun c-PROCLAIM (declspec)
  4752.   (when (consp declspec)
  4753.     (case (car declspec)
  4754.       (SPECIAL
  4755.         (dolist (var (cdr declspec))
  4756.           (when (symbolp var) (pushnew var *known-special-vars* :test #'eq))
  4757.       ) )
  4758.       (INLINE
  4759.         (dolist (var (cdr declspec))
  4760.           (when (function-name-p var)
  4761.             (pushnew var *inline-functions* :test #'equal)
  4762.             (setq *notinline-functions* (delete var *notinline-functions* :test #'equal))
  4763.       ) ) )
  4764.       (NOTINLINE
  4765.         (dolist (var (cdr declspec))
  4766.           (when (function-name-p var)
  4767.             (pushnew var *notinline-functions* :test #'equal)
  4768.             (setq *inline-functions* (delete var *inline-functions* :test #'equal))
  4769.       ) ) )
  4770.       (DECLARATION
  4771.         (dolist (var (cdr declspec))
  4772.           (when (symbolp var) (pushnew var *user-declaration-types* :test #'eq))
  4773.       ) )
  4774. ) ) )
  4775.  
  4776. ; Hilfsfunktion: DEFCONSTANT beim Compilieren
  4777. (defun c-PROCLAIM-CONSTANT (symbol initial-value-form)
  4778.   (when *compiling-from-file*
  4779.     (pushnew symbol *known-special-vars* :test #'eq)
  4780.     (when (c-constantp initial-value-form)
  4781.       (push (cons symbol (c-constant-value initial-value-form))
  4782.             *constant-special-vars*
  4783. ) ) ) )
  4784.  
  4785. ; Hilfsfunktion: DEFUN beim Compilieren
  4786. (defun c-DEFUN (symbol &optional lambdabody)
  4787.   (when *compiling* ; c-DEFUN kann auch vom Expander aus aufgerufen werden!
  4788.     (when *compiling-from-file*
  4789.       (pushnew symbol *known-functions* :test #'equal)
  4790.       (when lambdabody ; Lambdabody angegeben ->
  4791.         ; Funktionsdefinition erfolgt im Top-Level-Environment und ist inlinebar.
  4792.         (push (cons symbol lambdabody) *inline-definitions*)
  4793. ) ) ) )
  4794.  
  4795. ; Hilfsfunktion: PROVIDE beim Compilieren vom File, vgl. Funktion PROVIDE
  4796. (defun c-PROVIDE (module-name)
  4797.   (pushnew (string module-name) *compiled-modules* :test #'string=)
  4798. )
  4799.  
  4800. ; Hilfsfunktion: REQUIRE beim Compilieren vom File, vgl. Funktion REQUIRE
  4801. (defun c-REQUIRE (module-name &optional (pathname nil p-given))
  4802.   (unless (member (string module-name) *compiled-modules* :test #'string-equal)
  4803.     (unless p-given (setq pathname (pathname module-name)))
  4804.     (flet ((load-lib (file)
  4805.              (let* ((present-files
  4806.                       (search-file file (append sys::*source-file-types* '(#".lib")))
  4807.                     )
  4808.                     (newest-file (first present-files)))
  4809.                ; Falls das libfile unter den gefundenen Files vorkommt
  4810.                ; und das neueste ist:
  4811.                (if (and (consp present-files)
  4812.                         (string= (pathname-type newest-file)
  4813.                                  '#,(pathname-type '#".lib")
  4814.                    )    )
  4815.                  (load newest-file :verbose nil :print nil :echo nil) ; libfile laden
  4816.                  (compile-file (or newest-file file)) ; file compilieren
  4817.           )) ) )
  4818.       (if (atom pathname) (load-lib pathname) (mapcar #'load-lib pathname))
  4819. ) ) )
  4820.  
  4821. ;;; Hilfsfunktionen für
  4822. ;;; LET/LET*/MULTIPLE-VALUE-BIND/Lambda-Ausdruck/FLET/LABELS:
  4823.  
  4824. ;; Syntaxanalyse:
  4825.  
  4826. ; analysiert eine Parameterliste von LET/LET*, liefert:
  4827. ; die Liste der Symbole,
  4828. ; die Liste der Formen.
  4829. (defun analyze-letlist (parameters)
  4830.   (do ((L parameters (cdr L))
  4831.        (symbols nil)
  4832.        (forms nil))
  4833.       ((null L) (values (nreverse symbols) (nreverse forms)))
  4834.     (cond ((symbolp (car L)) (push (car L) symbols) (push nil forms))
  4835.           ((and (consp (car L)) (symbolp (caar L))
  4836.                 (consp (cdar L)) (null (cddar L))
  4837.            )
  4838.            (push (caar L) symbols) (push (cadar L) forms)
  4839.           )
  4840.           (t (catch 'c-error
  4841.                (c-error 
  4842.                 #L{
  4843.                 DEUTSCH "Falsche Syntax in LET/LET*: ~S"
  4844.                 ENGLISH "Illegal syntax in LET/LET*: ~S"
  4845.                 FRANCAIS "Mauvaise syntaxe pour LET/LET* : ~S"
  4846.                 }
  4847.                 (car L)
  4848.     )     )  ) )
  4849. ) )
  4850.  
  4851. ; analysiert eine Lambdaliste einer Funktion (CLTL S. 60), liefert 13 Werte:
  4852. ; 1. Liste der required Parameter
  4853. ; 2. Liste der optionalen Parameter
  4854. ; 3. Liste der Initformen der optionalen Parameter
  4855. ; 4. Liste der Svars zu den optionalen Parametern (0 für die fehlenden)
  4856. ; 5. Rest-Parameter oder 0
  4857. ; 6. Flag, ob Keywords erlaubt sind
  4858. ; 7. Liste der Keywords
  4859. ; 8. Liste der Keyword-Parameter
  4860. ; 9. Liste der Initformen der Keyword-Parameter
  4861. ; 10. Liste der Svars zu den Keyword-Parametern (0 für die fehlenden)
  4862. ; 11. Flag, ob andere Keywords erlaubt sind
  4863. ; 12. Liste der Aux-Variablen
  4864. ; 13. Liste der Initformen der Aux-Variablen
  4865. (defun analyze-lambdalist (lambdalist)
  4866.   (let ((L lambdalist) ; Rest der Lambdaliste
  4867.         (req nil)
  4868.         (optvar nil)
  4869.         (optinit nil)
  4870.         (optsvar nil)
  4871.         (rest 0)
  4872.         (keyflag nil)
  4873.         (keyword nil)
  4874.         (keyvar nil)
  4875.         (keyinit nil)
  4876.         (keysvar nil)
  4877.         (allow-other-keys nil)
  4878.         (auxvar nil)
  4879.         (auxinit nil))
  4880.        ; alle in umgedrehter Reihenfolge
  4881.     (macrolet ((err-illegal (item)
  4882.                  `(catch 'c-error
  4883.                     (c-error 
  4884.                      #L{
  4885.                      DEUTSCH "Dieser Lambdalistenmarker ist an dieser Stelle nicht erlaubt: ~S"
  4886.                      ENGLISH "Lambda list marker ~S not allowed here."
  4887.                      FRANCAIS "Le marqueur de liste lambda ~S n'est pas permis ici."
  4888.                      }
  4889.                      ,item
  4890.                   ) )
  4891.                )
  4892.                (err-norest ()
  4893.                  `(catch 'c-error
  4894.                     (c-error 
  4895.                      #L{
  4896.                      DEUTSCH "Fehlender &REST-Parameter in der Lambdaliste: ~S"
  4897.                      ENGLISH "Missing &REST parameter in lambda list ~S"
  4898.                      FRANCAIS "Il manque le paramètre &REST dans la liste lambda ~S"
  4899.                      }
  4900.                      lambdalist
  4901.                   ) )
  4902.                )
  4903.                (err-superflu (item)
  4904.                  `(catch 'c-error
  4905.                     (c-error 
  4906.                      #L{
  4907.                      DEUTSCH "Überflüssiges Lambdalisten-Element: ~S"
  4908.                      ENGLISH "Lambda list element ~S is superfluous."
  4909.                      FRANCAIS "L'élément de liste lambda est superflu : ~S"
  4910.                      }
  4911.                      ,item
  4912.                   ) )
  4913.               ))
  4914.       ; Required Parameter:
  4915.       (loop
  4916.         (if (atom L) (return))
  4917.         (let ((item (car L)))
  4918.           (if (symbolp item)
  4919.             (if (memq item lambda-list-keywords)
  4920.               (if (memq item '(&optional &rest &key &aux))
  4921.                 (return)
  4922.                 (err-illegal item)
  4923.               )
  4924.               (push item req)
  4925.             )
  4926.             (lambdalist-error item)
  4927.         ) )
  4928.         (setq L (cdr L))
  4929.       )
  4930.       ; Hier gilt (or (atom L) (member (car L) '(&optional &rest &key &aux))).
  4931.       ; Optionale Parameter:
  4932.       (when (and (consp L) (eq (car L) '&optional))
  4933.         (setq L (cdr L))
  4934.         (loop
  4935.           (if (atom L) (return))
  4936.           (let ((item (car L)))
  4937.             (if (symbolp item)
  4938.               (if (memq item lambda-list-keywords)
  4939.                 (if (memq item '(&rest &key &aux))
  4940.                   (return)
  4941.                   (err-illegal item)
  4942.                 )
  4943.                 (progn (push item optvar) (push nil optinit) (push 0 optsvar))
  4944.               )
  4945.               (if (and (consp item) (symbolp (car item)))
  4946.                 (if (null (cdr item))
  4947.                   (progn (push (car item) optvar) (push nil optinit) (push 0 optsvar))
  4948.                   (if (consp (cdr item))
  4949.                     (if (null (cddr item))
  4950.                       (progn (push (car item) optvar) (push (cadr item) optinit) (push 0 optsvar))
  4951.                       (if (and (consp (cddr item)) (symbolp (caddr item)) (null (cdddr item)))
  4952.                         (progn (push (car item) optvar) (push (cadr item) optinit) (push (caddr item) optsvar))
  4953.                         (lambdalist-error item)
  4954.                     ) )
  4955.                     (lambdalist-error item)
  4956.                 ) )
  4957.                 (lambdalist-error item)
  4958.           ) ) )
  4959.           (setq L (cdr L))
  4960.       ) )
  4961.       ; Hier gilt (or (atom L) (member (car L) '(&rest &key &aux))).
  4962.       ; Rest-Parameter:
  4963.       (when (and (consp L) (eq (car L) '&rest))
  4964.         (setq L (cdr L))
  4965.         (if (atom L)
  4966.           (err-norest)
  4967.           (prog ((item (car L)))
  4968.             (if (symbolp item)
  4969.               (if (memq item lambda-list-keywords)
  4970.                 (progn (err-norest) (return))
  4971.                 (setq rest item)
  4972.               )
  4973.               (lambdalist-error item)
  4974.             )
  4975.             (setq L (cdr L))
  4976.       ) ) )
  4977.       ; Vorrücken bis zum nächsten &key oder &aux :
  4978.       (loop
  4979.         (when (atom L) (return))
  4980.         (let ((item (car L)))
  4981.           (if (memq item lambda-list-keywords)
  4982.             (if (memq item '(&key &aux))
  4983.               (return)
  4984.               (err-illegal item)
  4985.             )
  4986.             (err-superflu item)
  4987.         ) )
  4988.         (setq L (cdr L))
  4989.       )
  4990.       ; Hier gilt (or (atom L) (member (car L) '(&key &aux))).
  4991.       ; Keyword-Parameter:
  4992.       (when (and (consp L) (eq (car L) '&key))
  4993.         (setq L (cdr L))
  4994.         (setq keyflag t)
  4995.         (loop
  4996.           (if (atom L) (return))
  4997.           (let ((item (car L)))
  4998.             (if (symbolp item)
  4999.               (if (memq item lambda-list-keywords)
  5000.                 (if (memq item '(&allow-other-keys &aux))
  5001.                   (return)
  5002.                   (err-illegal item)
  5003.                 )
  5004.                 (progn
  5005.                   (push (intern (symbol-name item) *keyword-package*) keyword)
  5006.                   (push item keyvar) (push nil keyinit) (push 0 keysvar)
  5007.               ) )
  5008.               (if (and
  5009.                     (consp item)
  5010.                     (or
  5011.                       (symbolp (car item))
  5012.                       (and (consp (car item))
  5013.                            (keywordp (caar item))
  5014.                            (consp (cdar item))
  5015.                            (symbolp (cadar item))
  5016.                            (null (cddar item))
  5017.                     ) )
  5018.                     (or (null (cdr item))
  5019.                         (and (consp (cdr item))
  5020.                              (or (null (cddr item))
  5021.                                  (and (consp (cddr item)) (symbolp (caddr item)) (null (cdddr item)))
  5022.                   ) )   )    )
  5023.                 (progn
  5024.                   (if (consp (car item))
  5025.                     (progn (push (caar item) keyword) (push (cadar item) keyvar))
  5026.                     (progn (push (intern (symbol-name (car item)) *keyword-package*) keyword) (push (car item) keyvar))
  5027.                   )
  5028.                   (if (consp (cdr item))
  5029.                     (progn
  5030.                       (push (cadr item) keyinit)
  5031.                       (if (consp (cddr item))
  5032.                         (push (caddr item) keysvar)
  5033.                         (push 0 keysvar)
  5034.                     ) )
  5035.                     (progn (push nil keyinit) (push 0 keysvar))
  5036.                 ) )
  5037.                 (lambdalist-error item)
  5038.           ) ) )
  5039.           (setq L (cdr L))
  5040.         )
  5041.         ; Hier gilt (or (atom L) (member (car L) '(&allow-other-keys &aux))).
  5042.         (when (and (consp L) (eq (car L) '&allow-other-keys))
  5043.           (setq allow-other-keys t)
  5044.           (setq L (cdr L))
  5045.       ) )
  5046.       ; Vorrücken bis zum nächsten &AUX :
  5047.       (loop
  5048.         (when (atom L) (return))
  5049.         (let ((item (car L)))
  5050.           (if (memq item lambda-list-keywords)
  5051.             (if (memq item '(&aux))
  5052.               (return)
  5053.               (err-illegal item)
  5054.             )
  5055.             (err-superflu item)
  5056.         ) )
  5057.         (setq L (cdr L))
  5058.       )
  5059.       ; Hier gilt (or (atom L) (member (car L) '(&aux))).
  5060.       ; &AUX-Variablen:
  5061.       (when (and (consp L) (eq (car L) '&aux))
  5062.         (setq L (cdr L))
  5063.         (loop
  5064.           (if (atom L) (return))
  5065.           (let ((item (car L)))
  5066.             (if (symbolp item)
  5067.               (if (memq item lambda-list-keywords)
  5068.                 (err-illegal item)
  5069.                 (progn (push item auxvar) (push nil auxinit))
  5070.               )
  5071.               (if (and (consp item) (symbolp (car item)))
  5072.                 (if (null (cdr item))
  5073.                   (progn (push (car item) auxvar) (push nil auxinit))
  5074.                   (if (and (consp (cdr item)) (null (cddr item)))
  5075.                     (progn (push (car item) auxvar) (push (cadr item) auxinit))
  5076.                     (lambdalist-error item)
  5077.                 ) )
  5078.                 (lambdalist-error item)
  5079.           ) ) )
  5080.           (setq L (cdr L))
  5081.       ) )
  5082.       ; Hier gilt (atom L).
  5083.       (if L
  5084.         (catch 'c-error
  5085.           (c-error 
  5086.            #L{
  5087.            DEUTSCH "Eine Lambdaliste, die einen Punkt enthält, ist nur bei Macros erlaubt, nicht hier: ~S"
  5088.            ENGLISH "Lambda lists with dots are only allowed in macros, not here: ~S"
  5089.            FRANCAIS "Les listes lambdas contenant une paire pointée ne sont permises qu'avec des macros et non ici : ~S"
  5090.            }
  5091.            lambdalist
  5092.       ) ) )
  5093.     )
  5094.     (values
  5095.       (nreverse req)
  5096.       (nreverse optvar) (nreverse optinit) (nreverse optsvar)
  5097.       rest
  5098.       keyflag
  5099.       (nreverse keyword) (nreverse keyvar) (nreverse keyinit) (nreverse keysvar)
  5100.       allow-other-keys
  5101.       (nreverse auxvar) (nreverse auxinit)
  5102. ) ) )
  5103.  
  5104. (defun lambdalist-error (item)
  5105.   (catch 'c-error
  5106.     (c-error 
  5107.      #L{
  5108.      DEUTSCH "Unzulässiges Lambdalistenelement: ~S"
  5109.      ENGLISH "Illegal lambda list element ~S"
  5110.      FRANCAIS "N'est pas permis dans une liste lambda : ~S"
  5111.      }
  5112.      item
  5113. ) ) )
  5114.  
  5115. ; (inline-callable-function-p form n) stellt fest, ob form eine Form ist, die
  5116. ; eine Funktion liefert, die mit n (und evtl. mehr) Argumenten Inline
  5117. ; aufgerufen werden kann. (vorbehaltlich Syntax-Errors in der Lambdaliste)
  5118. (defun inline-callable-function-p (form n &optional (more nil))
  5119.   ; muß von der Bauart (FUNCTION funname) sein
  5120.   (and (consp form) (eq (first form) 'FUNCTION)
  5121.        (consp (cdr form)) (null (cddr form))
  5122.        (let ((funname (second form)))
  5123.          ; funname muß von der Bauart (LAMBDA lambdalist ...) sein
  5124.          (and (consp funname) (eq (first funname) 'LAMBDA) (consp (cdr funname))
  5125.               (let ((lambdalist (second funname)))
  5126.                 ; lambdalist muß eine Liste sein, die kein &KEY enthält
  5127.                 ; (Funktionen mit &KEY werden nicht INLINE-expandiert, weil die
  5128.                 ; Zuordnung von den Argumenten zu den Variablen nur dynamisch,
  5129.                 ; mit GETF, möglich ist, und das kann die in Assembler
  5130.                 ; geschriebene APPLY-Routine schneller.)
  5131.                 (and (listp lambdalist)
  5132.                      (not (position '&KEY lambdalist))
  5133.                      (not (position '&ALLOW-OTHER-KEYS lambdalist))
  5134.                      (let ((&opt-pos (position '&OPTIONAL lambdalist))
  5135.                            (&rest-pos (position '&REST lambdalist))
  5136.                            (&aux-pos (or (position '&AUX lambdalist)
  5137.                                          (length lambdalist)
  5138.                           ))         )
  5139.                        (if &rest-pos
  5140.                          ; &rest angegeben
  5141.                          (or more (>= n (or &opt-pos &rest-pos)))
  5142.                          ; &rest nicht angegeben
  5143.                          (if more
  5144.                            (<= n (if &opt-pos (- &aux-pos 1) &aux-pos))
  5145.                            (if &opt-pos
  5146.                              (<= &opt-pos n (- &aux-pos 1))
  5147.                              (= n &aux-pos)
  5148.                      ) ) ) )
  5149.               ) )
  5150.        ) )
  5151. ) )
  5152.  
  5153.  
  5154. ;; Special-deklarierte Symbole:
  5155.  
  5156. (defvar *specials*) ; Liste aller zuletzt special deklarierten Symbole
  5157. (defvar *ignores*) ; Liste aller zuletzt ignore deklarierten Symbole
  5158. (defvar *ignorables*) ; Liste aller zuletzt ignorable deklarierten Symbole
  5159.  
  5160. ; pusht alle Symbole von specials als Variablen auf *venv* :
  5161. (defun push-specials ()
  5162.   (apply #'push-*venv* (mapcar #'make-special-var *specials*))
  5163. )
  5164.  
  5165. ; Überprüft eine Variable, ob sie zu Recht ignore-deklariert ist oder nicht...
  5166. (defun ignore-check (var)
  5167.   (let ((sym (var-name var)))
  5168.     (if (member sym *ignores* :test #'eq)
  5169.       ; var ignore-deklariert
  5170.       (if (var-specialp var)
  5171.         (c-warn 
  5172.          #L{
  5173.          DEUTSCH "Binden der Variablen ~S kann trotz IGNORE-Deklaration~%Seiteneffekte haben, weil sie SPECIAL deklariert ist."
  5174.          ENGLISH "Binding variable ~S can cause side effects despite of IGNORE declaration~%since it is declared SPECIAL."
  5175.          FRANCAIS "Lier la variable ~S peut avoir des effets de bord malgré la déclaration IGNORE~%car elle a été déclarée SPECIAL."
  5176.          }
  5177.          sym
  5178.         )
  5179.         (if (var-usedp var)
  5180.           (c-warn 
  5181.            #L{
  5182.            DEUTSCH "Variable ~S wird trotz IGNORE-Deklaration benutzt."
  5183.            ENGLISH "variable ~S is used despite of IGNORE declaration."
  5184.            FRANCAIS "La variable ~S est utilisée malgré la déclaration IGNORE."
  5185.            }
  5186.            sym
  5187.       ) ) )
  5188.       ; var nicht ignore-deklariert
  5189.       (unless (member sym *ignorables* :test #'eq)
  5190.         ; var auch nicht ignorable-deklariert
  5191.         (unless (or (var-specialp var) (var-usedp var))
  5192.           ; var lexikalisch und unbenutzt
  5193.           (unless (null (symbol-package sym)) ; sym ein (gensym) ?
  5194.             ; (Symbole ohne Home-Package kommen nicht vom Benutzer, die Warnung
  5195.             ; würde nur verwirren).
  5196.             (c-warn 
  5197.              #L{
  5198.              DEUTSCH "Variable ~S wird nicht benutzt.~%Schreibfehler oder fehlende IGNORE-Deklaration?"
  5199.              ENGLISH "variable ~S is not used.~%Misspelled or missing IGNORE declaration?"
  5200.              FRANCAIS "La variable ~S n'est pas utilisée.~%Mauvaise orthographe ou déclaration IGNORE manquante?"
  5201.              }
  5202.              sym
  5203. ) ) ) ) ) ) )
  5204.  
  5205. ; liefert den Code, der zum neuen Aufbau einer Closure und ihrer Unterbringung
  5206. ; im Stack nötig ist:
  5207. ; Dieser Code erweitert das von (cdr venvc) beschriebene Venv um closurevars,
  5208. ; (cdr stackz) ist der aktuelle Stackzustand.
  5209. ; Nach Aufbau der Closure sind venvc bzw. stackz die aktuellen Zustände.
  5210. (defun c-MAKE-CLOSURE (closurevars venvc stackz)
  5211.   (if closurevars
  5212.     `((VENV ,(cdr venvc) ,(cdr stackz))
  5213.       (MAKE-VECTOR1&PUSH ,(length closurevars))
  5214.      )
  5215.     '()
  5216. ) )
  5217.  
  5218. ;; Es gibt zwei Arten von Variablen-Bindungs-Vorgehensweisen:
  5219. ; 1. fixed-var: die Variable hat eine Position im Stack, darf nicht wegoptimiert
  5220. ;               werden. Ist die Variable dann doch in der Closure, so muß ihr
  5221. ;               Wert dorthin übertragen werden; ist die Variable dynamisch, so
  5222. ;               muß ein Bindungsframe aufgemacht werden.
  5223. ;               Auftreten: MULTIPLE-VALUE-BIND, Lambda-Ausdruck (required,
  5224. ;               optional, rest, keyword - Parameter)
  5225. ; 2. movable-var: die Variable darf wegoptimiert werden, falls sie konstant ist
  5226. ;                 (sie entweder dynamisch und konstant ist oder lexikalisch
  5227. ;                  und an eine Konstante gebunden und nie geSETQed wird). Hier
  5228. ;                 spielt also der Init-Wert eine Rolle.
  5229. ;                 Auftreten: LET, LET*, Lambda-Ausdruck (optional-svar,
  5230. ;                 keyword-svar, aux-Variablen)
  5231.  
  5232. ;; 1. fixed-var
  5233.  
  5234. ; Bindung einer fixed-var:
  5235. ; symbol --> Variable
  5236. ; Läßt *stackz* unverändert.
  5237. (defun bind-fixed-var-1 (symbol)
  5238.   (if (or (constantp symbol)
  5239.           (proclaimed-special-p symbol)
  5240.           (member symbol *specials* :test #'eq)
  5241.       )
  5242.     ; muß symbol dynamisch binden:
  5243.     (progn
  5244.       (when (c-constantp symbol)
  5245.         (catch 'c-error
  5246.           (c-error 
  5247.            #L{
  5248.            DEUTSCH "Konstante ~S kann nicht gebunden werden."
  5249.            ENGLISH "Constant ~S cannot be bound."
  5250.            FRANCAIS "La constante ~S ne peut pas être liée."
  5251.            }
  5252.            symbol
  5253.       ) ) )
  5254.       (make-special-var symbol)
  5255.     )
  5256.     ; muß symbol lexikalisch binden:
  5257.     (make-var :name symbol :specialp nil :constantp nil
  5258.               :usedp nil :really-usedp nil :closurep nil
  5259.               :stackz *stackz* :venvc *venvc*
  5260.     )
  5261. ) )
  5262.  
  5263. ; registriert in *stackz*, daß eine fixed-var gebunden wird
  5264. (defun bind-fixed-var-2 (var)
  5265.   (when (and (var-specialp var) (not (var-constantp var)))
  5266.     (push '(BIND 1) *stackz*)
  5267. ) )
  5268.  
  5269. ; liefert den Code, der die Variable var an den Inhalt von stackdummyvar
  5270. ; bindet. stackz ist der Stackzustand vor dem Binden dieser Variablen.
  5271. (defun c-bind-fixed-var (var stackdummyvar stackz)
  5272.   (if (var-specialp var)
  5273.     (if (var-constantp var)
  5274.       '() ; Konstante kann nicht gebunden werden
  5275.       `((GET ,stackdummyvar ,*venvc* ,stackz)
  5276.         (BIND ,(new-const (var-name var)))
  5277.        )
  5278.     )
  5279.     ; var lexikalisch, nach Definition nicht konstant
  5280.     (if (var-closurep var)
  5281.       `((GET ,stackdummyvar ,*venvc* ,stackz)
  5282.         (SET ,var ,*venvc* ,stackz)
  5283.        )
  5284.       '() ; var und stackdummyvar identisch
  5285. ) ) )
  5286.  
  5287. ; Kreiert je eine Stackvariable und eine Fixed-Variable zu jedem Symbol aus der
  5288. ; Variablenliste symbols und liefert beide Listen als Werte.
  5289. (defun process-fixed-var-list (symbols &optional optimflags)
  5290.   (do ((symbolsr symbols (cdr symbolsr))
  5291.        (optimflagsr optimflags (cdr optimflagsr))
  5292.        (varlist nil) ; Liste der Variablen
  5293.        (stackvarlist nil)) ; Liste der Stackvariablen (teils Dummys)
  5294.       ((null symbolsr) (values (nreverse varlist) (nreverse stackvarlist)))
  5295.     (push 1 *stackz*)
  5296.     ; (mit constantp=nil und really-usedp=t, um eine Wegoptimierung zu vermeiden)
  5297.     (push (make-var :name (gensym) :specialp nil :constantp nil
  5298.                     :usedp nil :really-usedp (null (car optimflagsr))
  5299.                     :closurep nil :stackz *stackz* :venvc *venvc*
  5300.           )
  5301.           stackvarlist
  5302.     )
  5303.     (push (bind-fixed-var-1 (car symbolsr)) varlist)
  5304. ) )
  5305.  
  5306. ; Eliminiert alle Zuweisungen auf eine unbenutzte Variable.
  5307. (defun unmodify-unused-var (var)
  5308.   (dolist (modified (var-modified-list var))
  5309.     (if (cddr modified)
  5310.       ; Wert der Zuweisung wird gebraucht
  5311.       (let ((set-anode (second modified))) ; Anode der Zuweisung selbst
  5312.         (setf (anode-code set-anode) '((VALUES1))) ; Zuweisung entfernen
  5313.       )
  5314.       ; Wert der Zuweisung wird nicht gebraucht
  5315.       (progn
  5316.         (let ((value-anode (first modified))) ; Anode für zugewiesenen Wert
  5317.           (when (null (cdr (anode-seclass value-anode)))
  5318.             (setf (anode-code value-anode) '()) ; evtl. Wert-Form entfernen
  5319.         ) )
  5320.         (let ((set-anode (second modified))) ; Anode der Zuweisung selbst
  5321.           (setf (anode-code set-anode) '()) ; Zuweisung entfernen
  5322. ) ) ) ) )
  5323.  
  5324. ; Überprüft und optimiert die Variablen
  5325. ; und liefert die Liste der Closure-Variablen (in der richtigen Reihenfolge).
  5326. (defun checking-fixed-var-list (varlist &optional optimflaglist)
  5327.   (let ((closurevarlist '()))
  5328.     (dolist (var varlist (nreverse closurevarlist))
  5329.       ; 1. Schritt: eventuelle Warnungen ausgeben
  5330.       (ignore-check var)
  5331.       ; 2. Schritt: Variablen-Ort (Stack oder Closure) endgültig bestimmen,
  5332.       ; evtl. optimieren
  5333.       (unless (var-specialp var)
  5334.         ; nur lexikalische Variablen können in der Closure liegen,
  5335.         ; nur bei lexikalischen Variablen kann optimiert werden
  5336.         (if (not (var-really-usedp var))
  5337.           ; Variable lexikalisch und unbenutzt
  5338.           (progn ; Variable eliminieren
  5339.             (setf (var-closurep var) nil)
  5340.             (when (car optimflaglist) ; optimierbare fixed-var?
  5341.               (setf (first (var-stackz var)) 0) ; aus dem Stack entfernen
  5342.               (setf (car optimflaglist) 'GONE) ; als gestrichen vermerken
  5343.             )
  5344.             (unmodify-unused-var var) ; Zuweisungen auf var eliminieren
  5345.           )
  5346.           (when (var-closurep var)
  5347.             ; Variable muß in der Closure liegen
  5348.             (push var closurevarlist)
  5349.       ) ) )
  5350.       (setq optimflaglist (cdr optimflaglist))
  5351. ) ) )
  5352.  
  5353. ;; 2. movable-var
  5354.  
  5355. ; Beim Binden einer Variablen var an einen Anode anode:
  5356. ; Wird eine lexikalische Variable an den Wert an einer lexikalischen Variablen
  5357. ; gebunden? Wenn ja, an welche Variable?
  5358. (defun bound-to-var-p (var anode)
  5359.   (if (var-specialp var)
  5360.     nil
  5361.     ; var lexikalisch
  5362.     (loop
  5363.       (unless (eql (length (anode-code anode)) 1) (return nil))
  5364.       (setq anode (first (anode-code anode)))
  5365.       (unless (anode-p anode)
  5366.         (if (and (consp anode) (eq (first anode) 'GET))
  5367.           ; Code zum Anode besteht genau aus ((GET outervar ...)).
  5368.           (return (second anode))
  5369.           (return nil)
  5370.     ) ) )
  5371. ) )
  5372.  
  5373. ; Bindung einer movable-var:
  5374. ; symbol form-anode --> Variable
  5375. ; erweitert *stackz* um genau einen Eintrag
  5376. (defun bind-movable-var (symbol form-anode)
  5377.   (if (or (constantp symbol)
  5378.           (proclaimed-special-p symbol)
  5379.           (member symbol *specials* :test #'eq)
  5380.       )
  5381.     ; muß symbol dynamisch binden:
  5382.     (progn
  5383.       (if (c-constantp symbol)
  5384.         (progn
  5385.           (catch 'c-error
  5386.             (c-error 
  5387.              #L{
  5388.              DEUTSCH "Konstante ~S kann nicht gebunden werden."
  5389.              ENGLISH "Constant ~S cannot be bound."
  5390.              FRANCAIS "La constante ~S ne peut pas être liée."
  5391.              }
  5392.              symbol
  5393.           ) )
  5394.           (push 0 *stackz*)
  5395.         )
  5396.         (push '(BIND 1) *stackz*)
  5397.       )
  5398.       (make-special-var symbol)
  5399.     )
  5400.     ; muß symbol lexikalisch binden:
  5401.     (let ((var
  5402.             (progn
  5403.               (push 1 *stackz*) ; vorläufig: 1 Platz auf dem Stack
  5404.               (make-var :name symbol :specialp nil
  5405.                 :constantp (anode-constantp form-anode) ; wird bei Zuweisungen auf NIL gesetzt
  5406.                 :constant (if (anode-constantp form-anode) (anode-constant form-anode))
  5407.                 :usedp nil :really-usedp nil :closurep nil ; wird evtl. auf T gesetzt
  5408.                 :stackz *stackz* :venvc *venvc*
  5409.          )) ) )
  5410.       (let ((outervar (bound-to-var-p var form-anode)))
  5411.         (when outervar ; Wird var an eine Variable outervar gebunden, so
  5412.                        ; darf später evtl. jede Referenz zu var in eine
  5413.                        ; Referenz zu outervar umgewandelt werden.
  5414.           (push (list var form-anode) (var-replaceable-list outervar))
  5415.       ) )
  5416.       var
  5417. ) ) )
  5418.  
  5419. ; liefert den Code, der die Variable var an A0 bindet:
  5420. (defun c-bind-movable-var (var)
  5421.   (if (var-specialp var)
  5422.     (if (var-constantp var)
  5423.       '() ; dynamische Konstanten können nicht gebunden werden
  5424.       `((BIND ,(new-const (var-name var))))
  5425.     )
  5426.     (if (var-closurep var)
  5427.       ; Closure-Variable schreiben:
  5428.       ; (var-stackz var) = (0 . ...) ist der aktuelle Stackzustand.
  5429.       `((SET ,var ,*venvc* ,(var-stackz var)))
  5430.       ; lexikalische Variable: wurde eventuell aus dem Stack eliminiert
  5431.       (if (zerop (first (var-stackz var)))
  5432.         '()
  5433.         `((PUSH)) ; im Stack: in die nächstuntere Stacklocation schreiben
  5434. ) ) ) )
  5435.  
  5436. ; liefert den Code, der die Variable var an das Ergebnis des ANODEs anode bindet
  5437. (defun c-bind-movable-var-anode (var anode)
  5438.   (let ((binding-anode
  5439.           (make-anode :type 'BIND-MOVABLE
  5440.                       :sub-anodes '()
  5441.                       :seclass '(NIL . NIL)
  5442.                       :code (c-bind-movable-var var)
  5443.        )) )
  5444.     (let ((outervar (bound-to-var-p var anode)))
  5445.       (when outervar ; Wird var an eine Variable outervar gebunden, so
  5446.                      ; darf später evtl. jede Referenz zu var in eine
  5447.                      ; Referenz zu outervar umgewandelt werden.
  5448.         (dolist (innervar-info (var-replaceable-list outervar))
  5449.           (when (eq (first innervar-info) var)
  5450.             (setf (cddr innervar-info) binding-anode) ; binding-anode nachtragen
  5451.     ) ) ) )
  5452.     (list anode binding-anode)
  5453. ) )
  5454.  
  5455. ; (process-movable-var-list symbols initforms *-flag) compiliert die initforms
  5456. ; (wie bei LET/LET*) und assoziiert sie mit den Variablen zu symbols.
  5457. ; Verändert *venv* (bei *-flag : incrementell, sonst auf einmal).
  5458. ; Liefert drei Werte:
  5459. ; 1. Liste der Variablen,
  5460. ; 2. Liste der ANODEs zu den initforms,
  5461. ; 3. Liste der Stackzustände nach dem Binden der Variablen.
  5462. (defun process-movable-var-list (symbols initforms *-flag)
  5463.   (do ((symbolsr symbols (cdr symbolsr))
  5464.        (initformsr initforms (cdr initformsr))
  5465.        (varlist '())
  5466.        (anodelist '())
  5467.        (stackzlist '()))
  5468.       ((null symbolsr)
  5469.        (unless *-flag (apply #'push-*venv* varlist)) ; Binden bei LET
  5470.        (values (nreverse varlist) (nreverse anodelist) (nreverse stackzlist))
  5471.       )
  5472.     (let* ((initform (car initformsr))
  5473.            (anode (c-form initform 'ONE)) ; initform compilieren
  5474.            (var (bind-movable-var (car symbolsr) anode)))
  5475.       (push anode anodelist)
  5476.       (push var varlist)
  5477.       (push *stackz* stackzlist)
  5478.       (when *-flag (push-*venv* var)) ; Binden bei LET*
  5479. ) ) )
  5480.  
  5481. ; Überprüft und optimiert die Variablen (wie bei LET/LET*)
  5482. ; und liefert die Liste der Closure-Variablen (in der richtigen Reihenfolge).
  5483. (defun checking-movable-var-list (varlist anodelist)
  5484.   (do ((varlistr varlist (cdr varlistr))
  5485.        (anodelistr anodelist (cdr anodelistr))
  5486.        (closurevarlist '()))
  5487.       ((null varlistr) (nreverse closurevarlist))
  5488.     (let ((var (car varlistr)))
  5489.       (when var
  5490.         ; 1. Schritt: eventuelle Warnungen ausgeben
  5491.         (ignore-check var)
  5492.         ; 2. Schritt: Variablen-Ort (Stack oder Closure oder eliminiert)
  5493.         ; endgültig bestimmen
  5494.         (unless (var-specialp var)
  5495.           ; nur bei lexikalischen Variablen kann optimiert werden
  5496.           (if (var-constantp var)
  5497.             ; Variable lexikalisch und konstant
  5498.             (progn ; Variable eliminieren
  5499.               (setf (var-closurep var) nil)
  5500.               (setf (first (var-stackz var)) 0) ; aus dem Stack entfernen
  5501.               (when (null (cdr (anode-seclass (car anodelistr))))
  5502.                 (setf (anode-code (car anodelistr)) '()) ; evtl. initform entfernen
  5503.             ) )
  5504.             (if (not (var-really-usedp var))
  5505.               ; Variable lexikalisch und unbenutzt
  5506.               (progn ; Variable eliminieren
  5507.                 (setf (var-closurep var) nil)
  5508.                 (setf (first (var-stackz var)) 0) ; aus dem Stack entfernen
  5509.                 (when (null (cdr (anode-seclass (car anodelistr))))
  5510.                   (setf (anode-code (car anodelistr)) '()) ; evtl. initform entfernen
  5511.                 )
  5512.                 (unmodify-unused-var var) ; Zuweisungen auf var eliminieren
  5513.               )
  5514.               (when (var-closurep var)
  5515.                 ; Variable muß in der Closure liegen
  5516.                 (setf (first (var-stackz var)) 0) ; belegt 0 Stack-Einträge
  5517.                 (push var closurevarlist)
  5518.         ) ) ) )
  5519. ) ) ) )
  5520.  
  5521. ; Optimiert eine Liste von Variablen.
  5522. ; (In der Liste müssen die lexikalisch inneren Variablen zuletzt kommen.)
  5523. (defun optimize-var-list (vars)
  5524.   (unless *no-code*
  5525.     (dolist (var (reverse vars))
  5526.       (when var
  5527.         ; Optimierung (innere Variablen zuerst):
  5528.         ; Wird eine Variable innervar an den Wert von var gebunden, wird
  5529.         ; während der Lebensdauer von innervar weder innervar noch var verändert
  5530.         ; (um dies sicherstellen zu können, müssen beide lexikalisch und im Stack
  5531.         ; sein), so kann innervar durch var ersetzt werden.
  5532.         (unless (or (var-specialp var) (var-closurep var))
  5533.           ; var ist lexikalisch und im Stack
  5534.           (dolist (innervar-info (var-replaceable-list var))
  5535.             (let ((innervar (first innervar-info)))
  5536.               ; innervar ist eine movable-var, die mit var initialisiert wird.
  5537.               ; Während der Lebensdauer von innervar wird var nichts zugewiesen.
  5538.               (unless (or (var-specialp innervar) (var-closurep innervar))
  5539.                 ; innervar ist lexikalisch und im Stack
  5540.                 (when (null (var-modified-list innervar))
  5541.                   ; Während der Lebensdauer von innervar wird auch innervar
  5542.                   ; nichts zugewiesen.
  5543.                   (unless (eql (first (var-stackz innervar)) 0) ; innervar noch nicht wegoptimiert?
  5544.                     (when (cddr innervar-info) ; und innervar-info korrekt dreigliedrig?
  5545.                       ; Variable innervar eliminieren:
  5546.                       (setf (first (var-stackz innervar)) 0) ; aus dem Stack entfernen
  5547.                       ; Initialisierung und Binden von innervar eliminieren:
  5548.                       (setf (anode-code (second innervar-info)) '())
  5549.                       (setf (anode-code (cddr innervar-info)) '())
  5550.                       ; Die Referenzen auf die Variable innervar werden
  5551.                       ; in Referenzen auf die Variable var umgewandelt:
  5552.                       (let ((using-var (var-usedp var)))
  5553.                         (do ((using-innervar (var-usedp innervar) (cdr using-innervar)))
  5554.                             ((atom using-innervar))
  5555.                           (let* ((anode (car using-innervar)) ; ein Anode vom Typ VAR
  5556.                                  (code (anode-code anode))) ; sein Code, () oder ((GET ...))
  5557.                             (unless (null code)
  5558.                               ; (anode-code anode) ist von der Gestalt ((GET innervar ...))
  5559.                               (setf (second (car code)) var)
  5560.                               (push anode using-var)
  5561.                         ) ) )
  5562.                         (setf (var-usedp var) using-var)
  5563.                       )
  5564.         ) ) ) ) ) ) )
  5565. ) ) ) )
  5566.  
  5567. ; Bildet den Code, der eine Liste von Variablen, zusammen mit ihren svars,
  5568. ; bindet (wie bei Lambdabody- Optional/Key - Variablen).
  5569. (defun c-bind-with-svars (-vars -dummys s-vars -anodes s-anodes -stackzs)
  5570.   (do ((-varsr -vars (cdr -varsr)) ; fixed-vars
  5571.        (-dummysr -dummys (cdr -dummysr))
  5572.        (s-varsr s-vars (cdr s-varsr)) ; movable-vars
  5573.        (-anodesr -anodes (cdr -anodesr))
  5574.        (s-anodesr s-anodes (cdr s-anodesr))
  5575.        (-stackzsr -stackzs (cdr -stackzsr))
  5576.        (L '()))
  5577.       ((null -varsr) (nreverse L))
  5578.     (when (car s-varsr)
  5579.       (setq L
  5580.         (revappend
  5581.           (c-bind-movable-var-anode (car s-varsr) (car s-anodesr))
  5582.           L
  5583.     ) ) )
  5584.     (setq L
  5585.       (revappend
  5586.         (let* ((var (car -varsr))
  5587.                (stackdummyvar (car -dummysr))
  5588.                (anode (car -anodesr))
  5589.                (stackz (car -stackzsr))
  5590.                (label (make-label 'ONE)))
  5591.           (if (var-specialp var)
  5592.             `((JMPIFBOUNDP ,stackdummyvar ,*venvc* ,stackz ,label)
  5593.               ,anode
  5594.               ,label
  5595.               ,@(if (var-constantp var)
  5596.                   '() ; Konstante kann nicht gebunden werden
  5597.                   `((BIND ,(new-const (var-name var))))
  5598.                 )
  5599.              )
  5600.             ; var lexikalisch, nach Definition nicht konstant
  5601.             (if (var-closurep var)
  5602.               `((JMPIFBOUNDP ,stackdummyvar ,*venvc* ,stackz ,label)
  5603.                 ,anode
  5604.                 ,label
  5605.                 (SET ,var ,*venvc* ,stackz)
  5606.                )
  5607.               (if (not (var-really-usedp var))
  5608.                 ; Variable wurde in checking-fixed-var-list wegoptimiert
  5609.                 (if (cdr (anode-seclass anode))
  5610.                   `((JMPIFBOUNDP ,stackdummyvar ,*venvc* ,stackz ,label)
  5611.                     ,anode
  5612.                     ,label
  5613.                    )
  5614.                   '()
  5615.                 )
  5616.                 ; im Stack vorhandene Variable
  5617.                 `((JMPIFBOUNDP ,stackdummyvar ,*venvc* ,stackz ,label)
  5618.                   ,anode
  5619.                   (SET ,var ,*venvc* ,stackz)
  5620.                   ,label
  5621.                  )
  5622.         ) ) ) )
  5623.         L
  5624.     ) )
  5625. ) )
  5626.  
  5627. ; compiliere (name lambdalist {declaration|docstring}* {form}*), liefere FNODE
  5628. (defun c-LAMBDABODY (name lambdabody &optional fenv-cons gf-p reqoptimflags)
  5629.   (test-list lambdabody 1)
  5630.   (let* ((*func* (make-fnode :name name :enclosing *func* :venvc *venvc*))
  5631.          (*stackz* *func*) ; leerer Stack
  5632.          (*venvc* (cons *func* *venvc*))
  5633.          (*func-start-label* (make-label 'NIL))
  5634.          (*anonymous-count* 0)
  5635.          (anode (catch 'c-error
  5636.     ; ab hier wird's kompliziert
  5637.     (multiple-value-bind (reqvar  optvar optinit optsvar  restvar
  5638.                           keyflag keyword keyvar keyinit keysvar allow-other-keys
  5639.                           auxvar auxinit)
  5640.         (if fenv-cons
  5641.           (values-list (cddar fenv-cons)) ; Bei c-LABELS wurde analyze-lambdalist schon aufgerufen
  5642.           (analyze-lambdalist (car lambdabody))
  5643.         )
  5644.       (setf (fnode-req-anz *func*) (length reqvar)
  5645.             (fnode-opt-anz *func*) (length optvar)
  5646.             (fnode-rest-flag *func*) (not (eql restvar 0))
  5647.             (fnode-keyword-flag *func*) keyflag
  5648.             (fnode-keywords *func*) keyword
  5649.             (fnode-allow-other-keys-flag *func*) allow-other-keys
  5650.       )
  5651.       (when fenv-cons (setf (caar fenv-cons) *func*)) ; Fixup für c-LABELS
  5652.       (multiple-value-bind (body-rest declarations)
  5653.           (parse-body (cdr lambdabody) t (vector *venv* *fenv*))
  5654.         (let ((oldstackz *stackz*)
  5655.               (*stackz* *stackz*)
  5656.               (*denv* *denv*)
  5657.               (*venv* *venv*)
  5658.               (*venvc* *venvc*)
  5659.               *specials* *ignores* *ignorables*
  5660.               req-vars req-dummys req-stackzs
  5661.               opt-vars opt-dummys opt-anodes opts-vars opts-anodes opt-stackzs
  5662.               rest-vars rest-dummys rest-stackzs
  5663.               key-vars key-dummys key-anodes keys-vars keys-anodes key-stackzs
  5664.               aux-vars aux-anodes
  5665.               closuredummy-stackz closuredummy-venvc
  5666.              )
  5667.           (multiple-value-setq (*specials* *ignores* *ignorables*)
  5668.             (process-declarations declarations)
  5669.           )
  5670.           ; Special-Variable auf *venv* pushen:
  5671.           (push-specials)
  5672.           ; Sichtbarkeit von Closure-Dummyvar:
  5673.           (push nil *venvc*)
  5674.           (setq closuredummy-venvc *venvc*)
  5675.           ; Stack-Dummy-Variable für die reqvar,optvar,restvar,keyvar bilden:
  5676.           (multiple-value-setq (req-vars req-dummys)
  5677.             (process-fixed-var-list reqvar reqoptimflags)
  5678.           )
  5679.           (multiple-value-setq (opt-vars opt-dummys)
  5680.             (process-fixed-var-list optvar)
  5681.           )
  5682.           (multiple-value-setq (rest-vars rest-dummys)
  5683.             (if (eql restvar 0)
  5684.               (values '() '())
  5685.               (process-fixed-var-list (list restvar))
  5686.           ) )
  5687.           (multiple-value-setq (key-vars key-dummys)
  5688.             (process-fixed-var-list keyvar)
  5689.           )
  5690.           ; Platz für die Funktion selbst (unter den Argumenten):
  5691.           (push 1 *stackz*)
  5692.           ; Platz für Closure-Dummyvar:
  5693.           (push 0 *stackz*)
  5694.           (setq closuredummy-stackz *stackz*)
  5695.           ; Bindungen der required-Parameter aktivieren:
  5696.           (setq req-stackzs (bind-req-vars req-vars))
  5697.           ; Bindungen der optional-Parameter/svar aktivieren:
  5698.           (multiple-value-setq (opt-anodes opt-stackzs opts-vars opts-anodes)
  5699.             (bind-opt-vars opt-vars opt-dummys optinit optsvar)
  5700.           )
  5701.           ; Bindung des rest-Parameters aktivieren:
  5702.           (unless (eql restvar 0)
  5703.             (setq rest-stackzs (bind-rest-vars rest-vars))
  5704.           )
  5705.           ; Bindungen der keyword-Parameter/svar aktivieren:
  5706.           (multiple-value-setq (key-anodes key-stackzs keys-vars keys-anodes)
  5707.             (bind-opt-vars key-vars key-dummys keyinit keysvar)
  5708.           )
  5709.           ; Bindungen der Aux-Variablen aktivieren:
  5710.           (multiple-value-setq (aux-vars aux-anodes)
  5711.             (bind-aux-vars auxvar auxinit)
  5712.           )
  5713.           (let* ((body-anode (c-form `(PROGN ,@body-rest) 'ALL))
  5714.                  ; Überprüfen der Variablen:
  5715.                  (closurevars
  5716.                    (append
  5717.                      (checking-fixed-var-list req-vars reqoptimflags)
  5718.                      (checking-fixed-var-list opt-vars)
  5719.                      (checking-movable-var-list opts-vars opts-anodes)
  5720.                      (checking-fixed-var-list rest-vars)
  5721.                      (checking-fixed-var-list key-vars)
  5722.                      (checking-movable-var-list keys-vars keys-anodes)
  5723.                      (checking-movable-var-list aux-vars aux-anodes)
  5724.                  ) )
  5725.                  (codelist
  5726.                    `(,*func-start-label*
  5727.                      ,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  5728.                      ,@(mapcap #'c-bind-fixed-var req-vars req-dummys req-stackzs)
  5729.                      ,@(c-bind-with-svars opt-vars opt-dummys opts-vars opt-anodes opts-anodes opt-stackzs)
  5730.                      ,@(mapcap #'c-bind-fixed-var rest-vars rest-dummys rest-stackzs)
  5731.                      ,@(c-bind-with-svars key-vars key-dummys keys-vars key-anodes keys-anodes key-stackzs)
  5732.                      ,@(mapcap #'c-bind-movable-var-anode aux-vars aux-anodes)
  5733.                      ,body-anode
  5734.                      (UNWIND ,*stackz* ,oldstackz t)
  5735.                      (RET)
  5736.                  )  )
  5737.                  (anode
  5738.                    (make-anode
  5739.                      :type 'LAMBDABODY
  5740.                      :source lambdabody
  5741.                      :sub-anodes `(,@opt-anodes ,@(remove nil opts-anodes)
  5742.                                    ,@key-anodes ,@(remove nil keys-anodes)
  5743.                                    ,@aux-anodes ,body-anode
  5744.                                   )
  5745.                      :seclass '(T . T) ; die Seiteneffektklasse dieses Anode ist irrelevant
  5746.                      :stackz oldstackz
  5747.                      :code codelist
  5748.                 )) )
  5749.             (when closurevars
  5750.               (setf (first closuredummy-stackz) 1) ; 1 Stackplatz für Dummy
  5751.               (setf (first closuredummy-venvc)
  5752.                 (cons closurevars closuredummy-stackz)
  5753.             ) )
  5754.             (optimize-var-list (append req-vars opt-vars opts-vars rest-vars key-vars keys-vars aux-vars))
  5755.             anode
  5756.     ) ) ) )
  5757.     ; das war die Produktion des Anode
  5758.         ))      )
  5759.     (setf (fnode-code *func*) anode)
  5760.     (when reqoptimflags (decf (fnode-req-anz *func*) (count 'GONE reqoptimflags)))
  5761.     (when (eq (anode-type anode) 'ERROR)
  5762.       ; korrekte, aber nichtstuende Funktion daraus machen
  5763.       (setf (fnode-req-anz *func*) 0
  5764.             (fnode-opt-anz *func*) 0
  5765.             (fnode-rest-flag *func*) t
  5766.             (fnode-keyword-flag *func*) nil
  5767.             (fnode-keywords *func*) '()
  5768.             (fnode-allow-other-keys-flag *func*) nil
  5769.             (anode-code (fnode-code *func*)) `((NIL) (SKIP 2) (RET))
  5770.     ) )
  5771.     (setf (fnode-gf-p *func*) gf-p)
  5772.     (setf (fnode-Consts-Offset *func*)
  5773.       (+ (setf (fnode-Keyword-Offset *func*)
  5774.            (+ (setf (fnode-Tagbodys-Offset *func*)
  5775.                 (+ (setf (fnode-Blocks-Offset *func*)
  5776.                      (if (fnode-venvconst *func*) 1 0)
  5777.                    )
  5778.                    (length (fnode-Blocks *func*))
  5779.               ) )
  5780.               (length (fnode-Tagbodys *func*))
  5781.          ) )
  5782.          (length (fnode-Keywords *func*))
  5783.     ) )
  5784.     (when gf-p
  5785.       ; Der Dispatch generischer Funktionen kann nicht auf externe Blocks und
  5786.       ; Tagbodys verweisen. Die Keywords allerdings werden notgedrungen verlagert.
  5787.       (when (or (fnode-Blocks *func*) (fnode-Tagbodys *func*))
  5788.         (compiler-error 'c-LAMBDABODY "GF")
  5789.       )
  5790.       ; Nun ist (fnode-Keyword-Offset *func*) = (fnode-Tagbodys-Offset *func*) =
  5791.       ;       = (fnode-Blocks-Offset *func*) = (if (fnode-venvconst *func*) 1 0)
  5792.     )
  5793.     *func*
  5794. ) )
  5795. (defun bind-req-vars (req-vars)
  5796.   (let ((req-stackzs '()))
  5797.     (dolist (var req-vars)
  5798.       (push-*venv* var)
  5799.       (push *stackz* req-stackzs)
  5800.       (bind-fixed-var-2 var)
  5801.     )
  5802.     (nreverse req-stackzs)
  5803. ) )
  5804. (defun bind-opt-vars (opt-vars opt-dummys optinit optsvar)
  5805.   (let ((opt-anodes '())
  5806.         (opt-stackzs '())
  5807.         (opts-vars '())
  5808.         (opts-anodes '()))
  5809.     (do ((opt-varsr opt-vars (cdr opt-varsr))
  5810.          (opt-dummysr opt-dummys (cdr opt-dummysr))
  5811.          (optinitr optinit (cdr optinitr))
  5812.          (optsvarr optsvar (cdr optsvarr)))
  5813.         ((null opt-varsr))
  5814.       (if (eql (car optsvarr) 0)
  5815.         (progn (push nil opts-vars) (push nil opts-anodes))
  5816.         (let* ((anode
  5817.                  (make-anode
  5818.                    :type 'OPTIONAL-SVAR
  5819.                    :sub-anodes '()
  5820.                    :seclass (cons (list (car opt-dummysr)) 'NIL)
  5821.                    :code `((BOUNDP ,(car opt-dummysr) ,*venvc* ,*stackz*))
  5822.                ) )
  5823.                (var (bind-movable-var (car optsvarr) anode))
  5824.               )
  5825.           (push anode opts-anodes)
  5826.           (push var opts-vars)
  5827.       ) )
  5828.       (push (c-form (car optinitr) 'ONE) opt-anodes)
  5829.       (push-*venv* (car opt-varsr))
  5830.       (push *stackz* opt-stackzs) (bind-fixed-var-2 (car opt-varsr))
  5831.       (unless (eql (car optsvarr) 0) (push-*venv* (car opts-vars)))
  5832.     )
  5833.     (values
  5834.       (nreverse opt-anodes) (nreverse opt-stackzs)
  5835.       (nreverse opts-vars) (nreverse opts-anodes)
  5836.     )
  5837. ) )
  5838. (defun bind-rest-vars (rest-vars)
  5839.   (let ((rest-stackzs '()))
  5840.     (push-*venv* (car rest-vars))
  5841.     (push *stackz* rest-stackzs)
  5842.     (bind-fixed-var-2 (car rest-vars))
  5843.     rest-stackzs ; (nreverse rest-stackzs) unnötig
  5844. ) )
  5845. (defun bind-aux-vars (auxvar auxinit)
  5846.   (let ((aux-vars '())
  5847.         (aux-anodes '()))
  5848.     (do ((auxvarr auxvar (cdr auxvarr))
  5849.          (auxinitr auxinit (cdr auxinitr)))
  5850.         ((null auxvarr))
  5851.       (let* ((initform (car auxinitr))
  5852.              (anode (c-form initform 'ONE))
  5853.              (var (bind-movable-var (car auxvarr) anode)))
  5854.         (push anode aux-anodes)
  5855.         (push var aux-vars)
  5856.         (push-*venv* var)
  5857.     ) )
  5858.     (values (nreverse aux-vars) (nreverse aux-anodes))
  5859. ) )
  5860.  
  5861. ; liefert den ANODE, der (bei gegebenem aktuellem Stackzustand)
  5862. ; die zu einem FNODE gehörende Funktion als Wert liefert.
  5863. (defun c-FNODE-FUNCTION (fnode &optional (*stackz* *stackz*))
  5864.   (make-anode
  5865.     :type 'FUNCTION
  5866.     :sub-anodes '()
  5867.     :seclass '(NIL . NIL)
  5868.     :code (if (zerop (fnode-keyword-offset fnode))
  5869.             `((FCONST ,fnode))
  5870.             `(,@(if (fnode-Venvconst fnode)
  5871.                   (prog1 ; beim Aufbau mitzugebendes Venv
  5872.                     `((VENV ,(fnode-venvc fnode) ,*stackz*)
  5873.                       (PUSH)
  5874.                      )
  5875.                     (setq *stackz* (cons 1 *stackz*))
  5876.                 ) )
  5877.               ,@(mapcap ; beim Aufbau mitzugebende Block-Conses
  5878.                   #'(lambda (block)
  5879.                       (prog1
  5880.                         `(,(if (member block (fnode-Blocks *func*) :test #'eq)
  5881.                              `(BCONST ,block)
  5882.                              `(GET ,(block-consvar block) ,*venvc* ,*stackz*)
  5883.                            )
  5884.                            (PUSH)
  5885.                          )
  5886.                         (setq *stackz* (cons 1 *stackz*))
  5887.                     ) )
  5888.                   (fnode-Blocks fnode)
  5889.                 )
  5890.               ,@(mapcap ; beim Aufbau mitzugebende Tagbody-Conses
  5891.                   #'(lambda (tagbody)
  5892.                       (prog1
  5893.                         `(,(if (member tagbody (fnode-Tagbodys *func*) :test #'eq)
  5894.                              `(GCONST ,tagbody)
  5895.                              `(GET ,(tagbody-consvar tagbody) ,*venvc* ,*stackz*)
  5896.                            )
  5897.                            (PUSH)
  5898.                          )
  5899.                         (setq *stackz* (cons 1 *stackz*))
  5900.                     ) )
  5901.                   (fnode-Tagbodys fnode)
  5902.                 )
  5903.               (COPY-CLOSURE ,fnode ,(fnode-keyword-offset fnode))
  5904.              )
  5905.           )
  5906. ) )
  5907.  
  5908.  
  5909. ;        ERSTER PASS :   S P E C I A L   F O R M S
  5910.  
  5911. ; compiliere (PROGN {form}*)
  5912. ; keine Formen -> NIL, genau eine Form -> diese Form,
  5913. ; mindestens zwei Formen -> alle der Reihe nach, nur bei der letzten kommt es
  5914. ; auf die Werte an.
  5915. (defun c-PROGN ()
  5916.   (test-list *form* 1)
  5917.   (let ((L (cdr *form*))) ; Liste der Formen
  5918.     (cond ((null L) (c-NIL)) ; keine Form -> NIL
  5919.           ((null (cdr L)) (c-form (car L))) ; genau eine Form
  5920.           (t (do (#+COMPILER-DEBUG (anodelist '())
  5921.                   (seclass '(NIL . NIL))
  5922.                   (codelist '())
  5923.                   (Lr L)) ; restliche Formenliste
  5924.                  ((null Lr)
  5925.                   (make-anode
  5926.                     :type 'PROGN
  5927.                     :sub-anodes (nreverse anodelist)
  5928.                     :seclass seclass
  5929.                     :code (nreverse codelist)
  5930.                  ))
  5931.                (let* ((formi (pop Lr)) ; i-te Form
  5932.                       (anodei (c-form formi (if (null Lr) *for-value* 'NIL))))
  5933.                  #+COMPILER-DEBUG (push anodei anodelist)
  5934.                  (seclass-or-f seclass anodei)
  5935.                  (push anodei codelist)
  5936. ) ) )     )  ) )
  5937.  
  5938. ; compiliere (PROG1 form1 {form}*)
  5939. ; bei *for-value* muß der Wert von form1 im Stack gerettet werden
  5940. (defun c-PROG1 ()
  5941.   (test-list *form* 2)
  5942.   (if (or (null *for-value*) (and (eq *for-value* 'ONE) (null (cddr *form*))))
  5943.     (c-form `(PROGN ,@(cdr *form*)))
  5944.     (let ((anode1 (c-form (second *form*) 'ONE))
  5945.           (anode2 (let ((*stackz* (cons 1 *stackz*)))
  5946.                     (c-form `(PROGN ,@(cddr *form*)) 'NIL)
  5947.          ))       )
  5948.       (make-anode
  5949.         :type 'PROG1
  5950.         :sub-anodes (list anode1 anode2)
  5951.         :seclass (anodes-seclass-or anode1 anode2)
  5952.         :code `(,anode1 (PUSH) ,anode2 (POP))
  5953. ) ) ) )
  5954.  
  5955. ; compiliere (PROG2 form1 form2 {form}*)
  5956. (defun c-PROG2 ()
  5957.   (test-list *form* 3)
  5958.   (c-form `(PROGN ,(second *form*) (PROG1 ,(third *form*) ,@(cdddr *form*))))
  5959. )
  5960.  
  5961. ; compiliere (IF form1 form2 [form3])
  5962. ; ist form1 eine Konstante, so kann der Compiler die Fallunterscheidung treffen.
  5963. (defun c-IF ()
  5964.   (test-list *form* 3 4)
  5965.   (let ((form1 (second *form*))
  5966.         (form2 (third *form*))
  5967.         (form3 (fourth *form*))) ; = NIL, falls *form* nur 3 lang ist
  5968.     (let ((anode1 (c-form form1 'ONE)))
  5969.       (if (anode-constantp anode1)
  5970.         (if (anode-constant-value anode1)
  5971.           (prog1 (c-form form2) (let ((*no-code* t)) (c-form form3 'NIL)))
  5972.           (prog2 (let ((*no-code* t)) (c-form form2 'NIL)) (c-form form3))
  5973.         )
  5974.         (let ((anode2 (c-form form2))
  5975.               (anode3 (c-form form3))
  5976.               (label1 (make-label 'NIL))
  5977.               (label2 (make-label *for-value*)))
  5978.           (make-anode
  5979.             :type 'IF
  5980.             :sub-anodes (list anode1 anode2 anode3)
  5981.             :seclass (anodes-seclass-or anode1 anode2 anode3)
  5982.             :code
  5983.               `(,anode1
  5984.                 (JMPIFNOT ,label1)
  5985.                 ,anode2
  5986.                 (JMP ,label2)
  5987.                 ,label1
  5988.                 ,anode3
  5989.                 ,label2
  5990.                )
  5991. ) ) ) ) ) )
  5992.  
  5993. ; compiliere (WHEN form1 {form}*)
  5994. (defun c-WHEN ()
  5995.   (test-list *form* 2)
  5996.   (c-form `(IF ,(second *form*) (PROGN ,@(cddr *form*))))
  5997. )
  5998.  
  5999. ; compiliere (UNLESS form1 {form}*)
  6000. (defun c-UNLESS ()
  6001.   (test-list *form* 2)
  6002.   (c-form `(IF ,(second *form*) NIL (PROGN ,@(cddr *form*))))
  6003. )
  6004.  
  6005. ; compiliere (AND {form}*)
  6006. (defun c-AND ()
  6007.   (test-list *form* 1)
  6008.   (cond ((null (cdr *form*)) ; keine Formen
  6009.          (make-anode
  6010.            :type 'AND
  6011.            :sub-anodes '()
  6012.            :seclass '(NIL . NIL)
  6013.            :code '((T))
  6014.         ))
  6015.         ((null (cddr *form*)) (c-form (second *form*))) ; genau eine Form
  6016.         (t (do (#+COMPILER-DEBUG (anodelist '())
  6017.                 (seclass '(NIL . NIL))
  6018.                 (codelist '())
  6019.                 (Lr (cdr *form*))
  6020.                 (label (make-label *for-value*))) ; Label am Ende
  6021.                ((null Lr)
  6022.                 (push label codelist)
  6023.                 (make-anode
  6024.                   :type 'AND
  6025.                   :sub-anodes (nreverse anodelist)
  6026.                   :seclass seclass
  6027.                   :code (nreverse codelist)
  6028.                ))
  6029.              (let* ((formi (pop Lr))
  6030.                     (anodei (c-form formi (if (null Lr) *for-value* 'ONE))))
  6031.                #+COMPILER-DEBUG (push anodei anodelist)
  6032.                (seclass-or-f seclass anodei)
  6033.                (if (null Lr)
  6034.                  ; letzte Form -> direkt übernehmen
  6035.                  (push anodei codelist)
  6036.                  ; nicht letzte Form -> Test kreieren
  6037.                  (if (anode-constantp anodei)
  6038.                    ; Konstante /= NIL -> weglassen, Konstante NIL -> fertig
  6039.                    (unless (anode-constant-value anodei)
  6040.                      (if *for-value* (push '(NIL) codelist))
  6041.                      (let ((*no-code* t)) (dolist (form Lr) (c-form form 'NIL)))
  6042.                      (setq Lr nil)
  6043.                    )
  6044.                    (progn ; normaler Test
  6045.                      (push anodei codelist)
  6046.                      (push `(,(if *for-value* 'JMPIFNOT1 'JMPIFNOT) ,label)
  6047.                            codelist
  6048.              ) ) ) ) )
  6049. ) )     )  )
  6050.  
  6051. ; compiliere (OR {form}*)
  6052. (defun c-OR ()
  6053.   (test-list *form* 1)
  6054.   (cond ((null (cdr *form*)) ; keine Formen
  6055.          (make-anode
  6056.            :type 'OR
  6057.            :sub-anodes '()
  6058.            :seclass '(NIL . NIL)
  6059.            :code '((NIL))
  6060.         ))
  6061.         ((null (cddr *form*)) (c-form (second *form*))) ; genau eine Form
  6062.         (t (do (#+COMPILER-DEBUG (anodelist '())
  6063.                 (seclass '(NIL . NIL))
  6064.                 (codelist '())
  6065.                 (Lr (cdr *form*))
  6066.                 (label (make-label *for-value*))) ; Label am Ende
  6067.                ((null Lr)
  6068.                 (push label codelist)
  6069.                 (make-anode
  6070.                   :type 'OR
  6071.                   :sub-anodes (nreverse anodelist)
  6072.                   :seclass seclass
  6073.                   :code (nreverse codelist)
  6074.                ))
  6075.              (let* ((formi (pop Lr))
  6076.                     (anodei (c-form formi (if (null Lr) *for-value* 'ONE))))
  6077.                #+COMPILER-DEBUG (push anodei anodelist)
  6078.                (seclass-or-f seclass anodei)
  6079.                (if (null Lr)
  6080.                  ; letzte Form -> direkt übernehmen
  6081.                  (push anodei codelist)
  6082.                  ; nicht letzte Form -> Test kreieren
  6083.                  (if (anode-constantp anodei)
  6084.                    ; Konstante NIL -> weglassen, Konstante /= NIL -> fertig
  6085.                    (when (anode-constant-value anodei)
  6086.                      (if *for-value* (push anodei codelist))
  6087.                      (let ((*no-code* t)) (dolist (form Lr) (c-form form 'NIL)))
  6088.                      (setq Lr nil)
  6089.                    )
  6090.                    (progn ; normaler Test
  6091.                      (push anodei codelist)
  6092.                      (push `(,(if *for-value* 'JMPIF1 'JMPIF) ,label)
  6093.                            codelist
  6094.              ) ) ) ) )
  6095. ) )     )  )
  6096.  
  6097. ; compiliere (QUOTE object)
  6098. (defun c-QUOTE ()
  6099.   (test-list *form* 2 2)
  6100.   (let ((value (second *form*)))
  6101.     (make-anode :type 'QUOTE
  6102.                 :sub-anodes '()
  6103.                 :seclass '(NIL . NIL)
  6104.                 :code (if *for-value* `((CONST ,(new-const value))) '() )
  6105. ) ) )
  6106.  
  6107. ; compiliere (THE type form)
  6108. (defun c-THE ()
  6109.   (test-list *form* 3 3)
  6110.   (c-form (third *form*)) ; ignoriere einfach die Typdeklaration
  6111. )
  6112.  
  6113. ; compiliere (DECLARE {declspec}*)
  6114. (defun c-DECLARE ()
  6115.   (test-list *form* 1)
  6116.   (c-error 
  6117.    #L{
  6118.    DEUTSCH "Deklarationen sind an dieser Stelle nicht erlaubt: ~S"
  6119.    ENGLISH "Misplaced declaration: ~S"
  6120.    FRANCAIS "Une déclaration n'est pas permise ici : ~S"
  6121.    }
  6122.    *form*
  6123. ) )
  6124.  
  6125. ; compiliere (LOAD-TIME-VALUE form [read-only-p])
  6126. (defun c-LOAD-TIME-VALUE ()
  6127.   (test-list *form* 2 3)
  6128.   (let ((form (second *form*))) ; ignoriere read-only-p
  6129.     (make-anode :type 'LOAD-TIME-VALUE
  6130.                 :sub-anodes '()
  6131.                 :seclass '(NIL . NIL)
  6132.                 :code (if *for-value*
  6133.                         `((CONST ,(if *compiling-from-file*
  6134.                                     (if (and (symbolp form) (c-constantp form))
  6135.                                       (make-const :horizont ':all :value (c-constant-value form) :form form)
  6136.                                       (make-const :horizont ':form :form form)
  6137.                                     )
  6138.                                     (make-const :horizont ':all :value (eval form) :form form)
  6139.                                   )
  6140.                          ))
  6141.                         '()
  6142.                       )
  6143. ) ) )
  6144.  
  6145. ; compiliere (CATCH tag {form}*)
  6146. (defun c-CATCH ()
  6147.   (test-list *form* 2)
  6148.   (let* ((anode1 (c-form (second *form*) 'ONE))
  6149.          (anode2 (let ((*stackz* (cons 'CATCH *stackz*)))
  6150.                    (c-form `(PROGN ,@(cddr *form*)))
  6151.          )       )
  6152.          (label (make-label *for-value*)))
  6153.     (make-anode :type 'CATCH
  6154.                 :sub-anodes (list anode1 anode2)
  6155.                 :seclass (anodes-seclass-or anode1 anode2)
  6156.                 :code `(,anode1
  6157.                         (CATCH-OPEN ,label)
  6158.                         ,anode2
  6159.                         (CATCH-CLOSE)
  6160.                         ,label
  6161. ) ) )                  )
  6162.  
  6163. ; compiliere (THROW tag form)
  6164. (defun c-THROW ()
  6165.   (test-list *form* 3 3)
  6166.   (let* ((anode1 (c-form (second *form*) 'ONE))
  6167.          (anode2 (let ((*stackz* (cons 1 *stackz*)))
  6168.                    (c-form (third *form*) 'ALL)
  6169.         ))       )
  6170.     (make-anode :type 'THROW
  6171.                 :sub-anodes (list anode1 anode2)
  6172.                 :seclass (cons (car (anodes-seclass-or anode1 anode2)) 'T)
  6173.                 :code `(,anode1 (PUSH) ,anode2 (THROW))
  6174. ) ) )
  6175.  
  6176. ; compiliere (UNWIND-PROTECT form1 {form}*)
  6177. (defun c-UNWIND-PROTECT ()
  6178.   (test-list *form* 2)
  6179.   (let* ((anode1 (let ((*stackz* (cons 'UNWIND-PROTECT *stackz*)))
  6180.                    (c-form (second *form*))
  6181.          )       )
  6182.          (anode2 (let ((*stackz* (cons 'CLEANUP *stackz*)))
  6183.                    (c-form `(PROGN ,@(cddr *form*)) 'NIL)
  6184.          )       )
  6185.          (label (make-label 'NIL)))
  6186.     (make-anode :type 'UNWIND-PROTECT
  6187.                 :sub-anodes (list anode1 anode2)
  6188.                 :seclass (anodes-seclass-or anode1 anode2)
  6189.                 :code `((UNWIND-PROTECT-OPEN ,label)
  6190.                         ,anode1
  6191.                         ,@(case *for-value*
  6192.                             ((NIL) '((VALUES0)))
  6193.                             (ONE '((VALUES1)))
  6194.                             ((T) '())
  6195.                           )
  6196.                         (UNWIND-PROTECT-NORMAL-EXIT)
  6197.                         ,label
  6198.                         ,anode2
  6199.                         (UNWIND-PROTECT-CLOSE ,label)
  6200. ) ) )                  )
  6201.  
  6202. ; compiliere (PROGV form1 form2 {form}*)
  6203. (defun c-PROGV ()
  6204.   (test-list *form* 3)
  6205.   (let ((anode1 (c-form (second *form*) 'ONE)))
  6206.     ; falls form1 konstant=NIL ist, kann man sich das Binden sparen:
  6207.     (if (and (anode-constantp anode1) (null (anode-constant-value anode1)))
  6208.       (c-form `(PROGN ,(third *form*) (PROGN ,@(cdddr *form*))))
  6209.       (let* ((stackz2 (cons 1 *stackz*))
  6210.              (anode2 (let ((*stackz* stackz2))
  6211.                        (c-form (third *form*) 'ONE)
  6212.              )       )
  6213.              (stackz3 (cons 'PROGV *stackz*))
  6214.              (anode3 (let ((*stackz* stackz3))
  6215.                        (c-form `(PROGN ,@(cdddr *form*)))
  6216.              )       )
  6217.              (flag t))
  6218.         ; falls anode3 von keinen Seiteneffekten abhängig ist, kann man sich das
  6219.         ; Binden sparen:
  6220.         (when (null (car (anode-seclass anode3)))
  6221.           (setf (first stackz2) 0)
  6222.           (setf (first stackz3) 0)
  6223.           (setq flag nil)
  6224.         )
  6225.         (make-anode :type 'PROGV
  6226.                     :sub-anodes (list anode1 anode2 anode3)
  6227.                     :seclass (anodes-seclass-or anode1 anode2 anode3)
  6228.                     :code `(,anode1
  6229.                             ,@(if flag '((PUSH)))
  6230.                             ,anode2
  6231.                             ,@(if flag '((PROGV)))
  6232.                             ,anode3
  6233.                             ,@(if flag
  6234.                                 `((UNWIND ,stackz3 ,*stackz* ,*for-value*))
  6235.                                 ; wird expandiert zu '((UNBIND1) (SKIPSP 1))
  6236.                            )  )
  6237. ) ) ) ) )
  6238.  
  6239. ; compiliere (MULTIPLE-VALUE-PROG1 form1 {form}*)
  6240. ; falls Werte nicht gebraucht werden: einfaches PROGN. Sonst: falls {form}*
  6241. ; seiteneffektfrei, nur form1, sonst: Werte von form1 auf den Stack legen und
  6242. ; nachher mit Funktion VALUES wieder einsammeln.
  6243. (defun c-MULTIPLE-VALUE-PROG1 ()
  6244.   (test-list *form* 2)
  6245.   (case *for-value*
  6246.     (ALL
  6247.      (let* ((stackz1 (cons 'MVCALLP *stackz*))
  6248.             (anode1 (let ((*stackz* stackz1))
  6249.                       (c-form (second *form*))
  6250.             )       )
  6251.             (anode2 (let ((*stackz* (cons 'MVCALL *stackz*)))
  6252.                       (c-form `(PROGN ,@(cddr *form*)) 'NIL)
  6253.            ))       )
  6254.        (make-anode :type 'MULTIPLE-VALUE-PROG1
  6255.                    :sub-anodes (list anode1 anode2)
  6256.                    :seclass (anodes-seclass-or anode1 anode2)
  6257.                    :code
  6258.                       (if (cdr (anode-seclass anode2))
  6259.                         `((CONST , #+CLISP (make-const :horizont ':all
  6260.                                                        :value #'values
  6261.                                                        :form '(function values)
  6262.                                            )
  6263.                                    #-CLISP (new-const 'values)
  6264.                           )
  6265.                           (MVCALLP)
  6266.                           ,anode1
  6267.                           (MV-TO-STACK)
  6268.                           ,anode2
  6269.                           (MVCALL))
  6270.                         (prog2 (setf (first stackz1) 0) `(,anode1))
  6271.                       )
  6272.     )) )
  6273.     (ONE (c-form `(PROG1 ,@(cdr *form*))))
  6274.     ((NIL) (c-form `(PROGN ,@(cdr *form*))))
  6275. ) )
  6276.  
  6277. ; compiliere (MULTIPLE-VALUE-CALL form1 {form}*)
  6278. (defun c-MULTIPLE-VALUE-CALL ()
  6279.   (test-list *form* 2)
  6280.   (if (null (cddr *form*))
  6281.     ; (c-form `(SYS::%FUNCALL ,(second *form*))) ; 0 Argumente zu form1
  6282.     (c-FUNCTION-CALL (second *form*) '())
  6283.     (let* ((anode1 (c-form (second *form*) 'ONE))
  6284.            #+COMPILER-DEBUG (anodelist (list anode1))
  6285.            (codelist '()))
  6286.       (push anode1 codelist)
  6287.       (push '(MVCALLP) codelist)
  6288.       (do ((Lr (cddr *form*))
  6289.            (i 0 (1+ i)))
  6290.           ((null Lr))
  6291.         (let* ((formi (pop Lr))
  6292.                (anodei
  6293.                  (let ((*stackz* (cons (if (zerop i) 'MVCALLP 'MVCALL) *stackz*)))
  6294.                    (c-form formi 'ALL)
  6295.               )) )
  6296.           #+COMPILER-DEBUG (push anodei anodelist)
  6297.           (push anodei codelist)
  6298.           (push '(MV-TO-STACK) codelist)
  6299.       ) )
  6300.       (push '(MVCALL) codelist)
  6301.       (make-anode :type 'MULTIPLE-VALUE-CALL
  6302.                   :sub-anodes (nreverse anodelist)
  6303.                   :seclass '(T . T)
  6304.                   :code (nreverse codelist)
  6305. ) ) ) )
  6306.  
  6307. ; compiliere (MULTIPLE-VALUE-LIST form)
  6308. (defun c-MULTIPLE-VALUE-LIST ()
  6309.   (test-list *form* 2 2)
  6310.   (if *for-value*
  6311.     (let ((anode1 (c-form (second *form*) 'ALL)))
  6312.       (make-anode :type 'MULTIPLE-VALUE-LIST
  6313.                   :sub-anodes (list anode1)
  6314.                   :seclass (anodes-seclass-or anode1)
  6315.                   :code `(,anode1 (MV-TO-LIST))
  6316.     ) )
  6317.     (c-form (second *form*))
  6318. ) )
  6319.  
  6320. ; Stellt fest, ob eine SETQ-Argumentliste Symbol-Macros zuweist.
  6321. (defun setqlist-macrop (l)
  6322.   (do ((l l (cddr l)))
  6323.       ((null l) nil)
  6324.     (let ((s (car l)))
  6325.       (when (and (symbolp s) (venv-search-macro s)) (return t))
  6326. ) ) )
  6327.  
  6328. ; compiliere (SETQ {symbol form}*)
  6329. ; alle Zuweisungen nacheinander durchführen
  6330. (defun c-SETQ ()
  6331.   (test-list *form* 1)
  6332.   (when (evenp (length *form*))
  6333.     (c-error 
  6334.      #L{
  6335.      DEUTSCH "Ungerade viele Argumente zu SETQ: ~S"
  6336.      ENGLISH "Odd number of arguments to SETQ: ~S"
  6337.      FRANCAIS "Nombre impair d'arguments pour SETQ : ~S"
  6338.      }
  6339.      *form*
  6340.   ) )
  6341.   (if (null (cdr *form*))
  6342.     (c-NIL) ; (SETQ) == (PROGN) == NIL
  6343.     (if (setqlist-macrop (cdr *form*))
  6344.       (c-form ; (SETF ...) statt (SETQ ...), macroexpandieren
  6345.         (funcall (macro-function 'SETF) (cons 'SETF (cdr *form*))
  6346.                  (vector *venv* *fenv*)
  6347.       ) )
  6348.       (do ((L (cdr *form*) (cddr L))
  6349.            #+COMPILER-DEBUG (anodelist '())
  6350.            (seclass '(NIL . NIL))
  6351.            (codelist '()))
  6352.           ((null L)
  6353.            (make-anode
  6354.              :type 'SETQ
  6355.              :sub-anodes (nreverse anodelist)
  6356.              :seclass seclass
  6357.              :code (nreverse codelist)
  6358.           ))
  6359.         (let* ((symboli (first L))
  6360.                (formi (second L))
  6361.                (anodei (c-form formi 'ONE)))
  6362.           #+COMPILER-DEBUG (push anodei anodelist)
  6363.           (if (symbolp symboli)
  6364.             (progn
  6365.               (push anodei codelist)
  6366.               (seclass-or-f seclass anodei)
  6367.               (let ((setteri (c-VARSET symboli anodei
  6368.                                        (and *for-value* (null (cddr L)))
  6369.                    ))        )
  6370.                 (push setteri codelist)
  6371.                 (seclass-or-f seclass setteri)
  6372.             ) )
  6373.             (progn
  6374.               (catch 'c-error
  6375.                 (c-error 
  6376.                  #L{
  6377.                  DEUTSCH "Zuweisung auf ~S unmöglich, da kein Symbol."
  6378.                  ENGLISH "Cannot assign to non-symbol ~S."
  6379.                  FRANCAIS "Rien ne peut être assigné à ~S car ce n'est pas un symbole."
  6380.                  }
  6381.                  symboli
  6382.               ) )
  6383.               (push '(VALUES1) codelist)
  6384.       ) ) ) )
  6385. ) ) )
  6386.  
  6387. ; compiliere (PSETQ {symbol form}*)
  6388. ; alle Zwischenwerte auf dem Stack retten, erst dann zuweisen
  6389. (defun c-PSETQ ()
  6390.   (test-list *form* 1)
  6391.   (when (evenp (length *form*))
  6392.     (c-error 
  6393.      #L{
  6394.      DEUTSCH "Ungerade viele Argumente zu PSETQ: ~S"
  6395.      ENGLISH "Odd number of arguments to PSETQ: ~S"
  6396.      FRANCAIS "Nombre impair d'arguments pour PSETQ : ~S"
  6397.      }
  6398.      *form*
  6399.   ) )
  6400.   (if (null (cdr *form*))
  6401.     (c-NIL) ; (PSETQ) == (PROGN) == NIL
  6402.     (if (setqlist-macrop (cdr *form*))
  6403.       (c-form ; (PSETF ...) statt (PSETQ ...), macroexpandieren
  6404.         (funcall (macro-function 'PSETF) (cons 'PSETF (cdr *form*))
  6405.                  (vector *venv* *fenv*)
  6406.       ) )
  6407.       (let ((anodelist '())
  6408.             (setterlist '()))
  6409.         ; Formen und Zuweisungen compilieren:
  6410.         (do ((L (cdr *form*)))
  6411.             ((null L))
  6412.           (let* ((symboli (pop L))
  6413.                  (formi (pop L))
  6414.                  (anodei (c-form formi 'ONE)))
  6415.             (if (symbolp symboli)
  6416.               (progn
  6417.                 (push anodei anodelist)
  6418.                 (push (c-VARSET symboli anodei nil) setterlist)
  6419.                 (push 0 *stackz*)
  6420.               )
  6421.               (catch 'c-error
  6422.                 (c-error 
  6423.                  #L{
  6424.                  DEUTSCH "Zuweisung auf ~S unmöglich, da kein Symbol."
  6425.                  ENGLISH "Cannot assign to non-symbol ~S."
  6426.                  FRANCAIS "Rien ne peut être assigné à ~S car ce n'est pas un symbole."
  6427.                  }
  6428.                  symboli
  6429.         ) ) ) ) )
  6430.         ; Versuche, sie so zu reorganisieren, daß möglichst wenige (PUSH)
  6431.         ; und (POP) nötig werden:
  6432.         (let ((codelist1 '())
  6433.               (codelist2 '())
  6434.               ; baue codelist = (nconc codelist1 (nreverse codelist2)) zusammen
  6435.               (seclass '(NIL . NIL))) ; Seiteneffektklasse von codelist insgesamt
  6436.           (do ((anodelistr anodelist (cdr anodelistr))
  6437.                (setterlistr setterlist (cdr setterlistr)))
  6438.               ((null anodelistr))
  6439.             (let ((anode (car anodelistr))
  6440.                   (setter (car setterlistr)))
  6441.               ; Normalerweise wäre vor codelist der anode und ein (PUSH)
  6442.               ; und nach codelist ein (POP) und der setter anzuhängen.
  6443.               ; Dies versuchen wir zu vereinfachen:
  6444.               (cond ((seclasses-commute (anode-seclass setter) seclass)
  6445.                      ; Ziehe den setter nach vorne:
  6446.                      (push setter codelist1)
  6447.                      (push anode codelist1)
  6448.                     )
  6449.                     ((seclasses-commute (anode-seclass anode) seclass)
  6450.                      ; Ziehe den anode nach hinten:
  6451.                      (push anode codelist2)
  6452.                      (push setter codelist2)
  6453.                     )
  6454.                     (t ; keine Vereinfachung möglich
  6455.                      (push '(PUSH) codelist1)
  6456.                      (push anode codelist1)
  6457.                      (push '(POP) codelist2)
  6458.                      (push setter codelist2)
  6459.                      (setf (car *stackz*) 1) ; brauche eine Variable im Stack
  6460.               )     )
  6461.               (setq seclass
  6462.                 (seclass-or-2 seclass
  6463.                   (seclass-or-2 (anode-seclass anode) (anode-seclass setter))
  6464.               ) )
  6465.               (setf *stackz* (cdr *stackz*))
  6466.           ) )
  6467.           ; *stackz* ist nun wieder auf dem alten Niveau.
  6468.           (when *for-value* (push '(NIL) codelist2))
  6469.           (make-anode
  6470.             :type 'PSETQ
  6471.             :sub-anodes (nreverse anodelist)
  6472.             :seclass seclass
  6473.             :code (nconc codelist1 (nreverse codelist2))
  6474. ) ) ) ) ) )
  6475.  
  6476. ; compiliere (MULTIPLE-VALUE-SETQ ({symbol}*) form)
  6477. ; alle gewünschten Werte auf den Stack, dann einzeln herunternehmen und
  6478. ; zuweisen.
  6479. (defun c-MULTIPLE-VALUE-SETQ ()
  6480.   (test-list *form* 3 3)
  6481.   (test-list (second *form*) 0)
  6482.   (if (dolist (s (second *form*) nil)
  6483.         (when (and (symbolp s) (venv-search-macro s)) (return t))
  6484.       )
  6485.     (c-form `(SYSTEM::MULTIPLE-VALUE-SETF ,@(cdr *form*)))
  6486.     (let* ((n (length (second *form*)))
  6487.            (anode1 (c-form (third *form*) 'ALL))
  6488.            (*stackz* *stackz*))
  6489.       (if (zerop n)
  6490.         (make-anode :type 'MULTIPLE-VALUE-SETQ
  6491.                     :sub-anodes (list anode1)
  6492.                     :seclass (anodes-seclass-or anode1)
  6493.                     :code `(,anode1
  6494.                             ,@(if (eq *for-value* 'ALL) '((VALUES1)) '())
  6495.         )                  )
  6496.         (do ((L (second *form*) (cdr L))
  6497.              #+COMPILER-DEBUG (anodelist (list anode1))
  6498.              (seclass (anode-seclass anode1))
  6499.              (codelist '()))
  6500.             ((null L)
  6501.              (if (= n 1)
  6502.                (setq codelist (cdr codelist)) ; letztes (POP) streichen
  6503.                (setq codelist (cons `(NV-TO-STACK ,n) codelist))
  6504.              )
  6505.              (make-anode
  6506.                :type 'MULTIPLE-VALUE-SETQ
  6507.                :sub-anodes (nreverse anodelist)
  6508.                :seclass seclass
  6509.                :code (cons anode1 codelist)
  6510.             ))
  6511.           (let ((symbol (car L)))
  6512.             (if (symbolp symbol)
  6513.               (let ((setter (c-VARSET symbol
  6514.                               (make-anode :type 'NOP
  6515.                                           :sub-anodes '()
  6516.                                           :seclass '(NIL . NIL)
  6517.                                           :code '()
  6518.                               )
  6519.                               (and *for-value* (null codelist))
  6520.                    ))       )
  6521.                 (push setter codelist)
  6522.                 (seclass-or-f seclass setter)
  6523.               )
  6524.               (catch 'c-error
  6525.                 (c-error 
  6526.                  #L{
  6527.                  DEUTSCH "Zuweisung auf ~S unmöglich, da kein Symbol."
  6528.                  ENGLISH "Cannot assign to non-symbol ~S."
  6529.                  FRANCAIS "Rien ne peut être assigné à ~S car ce n'est pas un symbole."
  6530.                  }
  6531.                  symbol
  6532.           ) ) ) )
  6533.           (push '(POP) codelist)
  6534.           (push 1 *stackz*)
  6535. ) ) ) ) )
  6536.  
  6537. ; Liefert den Code für das parallele Binden von Variablen.
  6538. ; (car *stackz*) sollte = 0 sein, (cdr *stackz*) wird evtl. erweitert.
  6539. (defun c-parallel-bind-movable-var-anode (varlist anodelist stackzlist
  6540.                                           &optional (other-anodes '())
  6541.                                          )
  6542.   ; Variable darf erst am Schluß gebunden werden, falls sie SPECIAL ist
  6543.   ; und nachfolgende Anodes von ihrem Wert abhängen können.
  6544.   (let ((bind-afterwards nil))
  6545.     (append
  6546.       (maplap
  6547.         #'(lambda (varlistr anodelistr stackzlistr)
  6548.             (let ((var (car varlistr))
  6549.                   (anode (car anodelistr)))
  6550.               (if (and (var-specialp var)
  6551.                        (let ((symbol (var-name var)))
  6552.                          (some
  6553.                            #'(lambda (other-anode)
  6554.                                ; hängt der Wert von other-anode möglicherweise
  6555.                                ; vom Wert von var ab?
  6556.                                (let ((uses (car (anode-seclass other-anode))))
  6557.                                  (or (eq uses 'T) (member symbol uses))
  6558.                              ) )
  6559.                            (cdr anodelistr)
  6560.                   )    ) )
  6561.                 (let* ((stackz (car stackzlistr))
  6562.                        (dummyvar ; Hilfsvariable im Stack
  6563.                          (make-var :name (gensym) :specialp nil
  6564.                                    :closurep nil :stackz stackz
  6565.                       )) )
  6566.                   (push (list dummyvar var (cdr *stackz*)) bind-afterwards)
  6567.                   (push (car stackz) (cdr *stackz*)) ; Platz für 1 Schluß-Bindung mehr
  6568.                   (setf (car stackz) 1) ; Platz für Hilfsvariable im Stack merken
  6569.                   (c-bind-movable-var-anode dummyvar anode)
  6570.                 )
  6571.                 (c-bind-movable-var-anode var anode)
  6572.           ) ) )
  6573.         varlist (append anodelist other-anodes) stackzlist
  6574.       )
  6575.       other-anodes
  6576.       (mapcap
  6577.         #'(lambda (bind)
  6578.             (let ((dummyvar (first bind)) ; Hilfsvariable im Stack
  6579.                   (var (second bind)) ; SPECIAL-Variable
  6580.                   (stackz (third bind))) ; Stackzustand vor Aufbau der Schluß-Bindung
  6581.               `((GET ,dummyvar ,*venvc* ,stackz)
  6582.                 ,@(c-bind-movable-var var)
  6583.                )
  6584.           ) )
  6585.         (nreverse bind-afterwards)
  6586.       )
  6587.     )
  6588. ) )
  6589.  
  6590. ; compiliere (LET/LET* ({var|(var value)}*) {declaration}* {form}*)
  6591. (defun c-LET/LET* (*-flag)
  6592.   (test-list *form* 2)
  6593.   (test-list (second *form*) 0)
  6594.   (multiple-value-bind (body-rest declarations)
  6595.       (parse-body (cddr *form*) nil (vector *venv* *fenv*))
  6596.     (let ((oldstackz *stackz*)
  6597.           (*stackz* *stackz*)
  6598.           (*denv* *denv*)
  6599.           (*venv* *venv*)
  6600.           (*venvc* *venvc*))
  6601.       (multiple-value-bind (*specials* *ignores* *ignorables*)
  6602.           (process-declarations declarations)
  6603.         ; Special-Variable auf *venv* pushen:
  6604.         (push-specials)
  6605.         ; Syntaxtest der Parameterliste:
  6606.         (multiple-value-bind (symbols initforms) (analyze-letlist (second *form*))
  6607.           (push 0 *stackz*) (push nil *venvc*) ; Platz für Closure-Dummyvar
  6608.           (let ((closuredummy-stackz *stackz*)
  6609.                 (closuredummy-venvc *venvc*))
  6610.             (multiple-value-bind (varlist anodelist stackzlist)
  6611.                 (process-movable-var-list symbols initforms *-flag)
  6612.               (unless *-flag (push 0 *stackz*)) ; Platz für Schluß-Bindungen
  6613.               (let ((body-anode (c-form `(PROGN ,@body-rest)))) ; Body compilieren
  6614.                 ; Überprüfen der Variablen:
  6615.                 (let* ((closurevars (checking-movable-var-list varlist anodelist))
  6616.                        (codelist
  6617.                          `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  6618.                            ,@(if *-flag
  6619.                                ; sequentielles Binden der Variablen
  6620.                                (mapcap #'c-bind-movable-var-anode varlist anodelist)
  6621.                                ; paralleles Binden der Variablen
  6622.                                (c-parallel-bind-movable-var-anode varlist anodelist stackzlist)
  6623.                              )
  6624.                            ,body-anode
  6625.                            (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  6626.                        )  )
  6627.                        (anode
  6628.                          (make-anode
  6629.                            :type (if *-flag 'LET* 'LET)
  6630.                            :sub-anodes `(,@anodelist ,body-anode)
  6631.                            :seclass (seclass-without
  6632.                                       (anodelist-seclass-or `(,@anodelist ,body-anode))
  6633.                                       varlist
  6634.                                     )
  6635.                            :stackz oldstackz
  6636.                            :code codelist
  6637.                       )) )
  6638.                   (when closurevars
  6639.                     (setf (first closuredummy-stackz) 1) ; 1 Stackplatz für Dummy
  6640.                     (setf (first closuredummy-venvc)
  6641.                       (cons closurevars closuredummy-stackz)
  6642.                   ) )
  6643.                   (optimize-var-list varlist)
  6644.                   anode
  6645. ) ) ) ) ) ) ) ) )
  6646.  
  6647. ; compiliere (LOCALLY {declaration}* {form}*)
  6648. (defun c-LOCALLY (&optional (c #'c-form)) ; vgl. c-LET/LET*
  6649.   (test-list *form* 1)
  6650.   (multiple-value-bind (body-rest declarations)
  6651.       (parse-body (cdr *form*) nil (vector *venv* *fenv*))
  6652.     (let ((*venv* *venv*))
  6653.       (multiple-value-bind (*specials* ignores ignorables)
  6654.           (process-declarations declarations)
  6655.         (declare (ignore ignores ignorables))
  6656.         ; Special-Variable auf *venv* pushen:
  6657.         (push-specials)
  6658.         (funcall c `(PROGN ,@body-rest))
  6659. ) ) ) )
  6660.  
  6661. ; compiliere (MULTIPLE-VALUE-BIND ({var}*) form1 {declaration}* {form}*)
  6662. (defun c-MULTIPLE-VALUE-BIND ()
  6663.   (test-list *form* 3)
  6664.   (test-list (second *form*) 0)
  6665.   (let ((symbols (second *form*)))
  6666.     (dolist (sym symbols)
  6667.       (unless (symbolp sym)
  6668.         (c-error 
  6669.          #L{
  6670.          DEUTSCH "Nur Symbole können Variable sein, nicht ~S"
  6671.          ENGLISH "Only symbols may be used as variables, not ~S"
  6672.          FRANCAIS "Seuls les symboles peuvent servir de variable et non ~S"
  6673.          }
  6674.          sym
  6675.     ) ) )
  6676.     (if (= (length symbols) 1)
  6677.       (c-form `(LET ((,(first symbols) ,(third *form*))) ,@(cdddr *form*)))
  6678.       (multiple-value-bind (body-rest declarations)
  6679.           (parse-body (cdddr *form*) nil (vector *venv* *fenv*))
  6680.         (let ((oldstackz *stackz*)
  6681.               (*stackz* *stackz*)
  6682.               (*denv* *denv*)
  6683.               (*venv* *venv*)
  6684.               (*venvc* *venvc*))
  6685.           (multiple-value-bind (*specials* *ignores* *ignorables*)
  6686.               (process-declarations declarations)
  6687.             ; Special-Variable auf *venv* pushen:
  6688.             (push-specials)
  6689.             (if (null symbols) ; leere Variablenliste -> gar nichts binden
  6690.               (let* ((anode1 (c-form (third *form*) 'NIL))
  6691.                      (anode2 (c-form `(PROGN ,@(cdddr *form*)))))
  6692.                 (make-anode :type 'MULTIPLE-VALUE-BIND
  6693.                   :sub-anodes (list anode1 anode2)
  6694.                   :seclass (anodes-seclass-or anode1 anode2)
  6695.                   :code `(,anode1 ,anode2)
  6696.               ) )
  6697.               (let ((anode1 (c-form (third *form*) 'ALL)))
  6698.                 (push nil *venvc*) ; Sichtbarkeit von Closure-Dummyvar
  6699.                 (multiple-value-bind (varlist stackvarlist)
  6700.                     (process-fixed-var-list symbols)
  6701.                   (push 0 *stackz*) ; Platz für Closure-Dummyvar
  6702.                   (let* ((closuredummy-stackz *stackz*)
  6703.                          (closuredummy-venvc *venvc*)
  6704.                          (stackzlist
  6705.                            (do* ((varlistr varlist (cdr varlistr))
  6706.                                  (L '()))
  6707.                                 ((null varlistr) (nreverse L))
  6708.                              (let ((var (car varlistr)))
  6709.                                (push-*venv* var)
  6710.                                (push *stackz* L) (bind-fixed-var-2 var)
  6711.                          ) ) )
  6712.                          (body-anode ; Body compilieren
  6713.                            (c-form `(PROGN ,@body-rest))
  6714.                          )
  6715.                          ; Überprüfen der Variablen:
  6716.                          (closurevars (checking-fixed-var-list varlist))
  6717.                          (codelist ; Code generieren
  6718.                            `(,anode1
  6719.                              (NV-TO-STACK ,(length symbols))
  6720.                              ,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  6721.                              ,@ ; Binden von special- oder Closure-Variablen:
  6722.                                (do ((stackvarlistr stackvarlist (cdr stackvarlistr))
  6723.                                     (stackzlistr stackzlist (cdr stackzlistr))
  6724.                                     (varlistr varlist (cdr varlistr))
  6725.                                     (L '()))
  6726.                                    ((null varlistr) (nreverse L))
  6727.                                  (setq L
  6728.                                    (append
  6729.                                      (reverse
  6730.                                        (c-bind-fixed-var
  6731.                                          (car varlistr)
  6732.                                          (car stackvarlistr)
  6733.                                          (car stackzlistr)
  6734.                                      ) )
  6735.                                      L
  6736.                                ) ) )
  6737.                              ,body-anode
  6738.                              (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  6739.                          )  )
  6740.                          (anode
  6741.                            (make-anode
  6742.                              :type 'MULTIPLE-VALUE-BIND
  6743.                              :sub-anodes (list anode1 body-anode)
  6744.                              :seclass (seclass-without
  6745.                                         (anodes-seclass-or anode1 body-anode)
  6746.                                         varlist
  6747.                                       )
  6748.                              :stackz oldstackz
  6749.                              :code codelist
  6750.                         )) )
  6751.                     (when closurevars
  6752.                       (setf (first closuredummy-stackz) 1) ; 1 Stackplatz für Dummy
  6753.                       (setf (first closuredummy-venvc)
  6754.                         (cons closurevars closuredummy-stackz)
  6755.                     ) )
  6756.                     (optimize-var-list varlist)
  6757.                     anode
  6758. ) ) ) ) ) ) ) ) ) )
  6759.  
  6760. ; compiliere (COMPILER-LET ({var|(var value)}*) {form}*)
  6761. (defun c-COMPILER-LET (&optional (c #'c-form))
  6762.   (test-list *form* 2)
  6763.   (test-list (second *form*) 0)
  6764.   (do ((L (second *form*) (cdr L))
  6765.        (varlist '())
  6766.        (valueslist '()))
  6767.       ((null L)
  6768.        (progv (nreverse varlist) (nreverse valueslist)
  6769.          (funcall c `(PROGN ,@(cddr *form*)) )
  6770.       ))
  6771.     (cond ((symbolp (car L)) (push (car L) varlist) (push nil valueslist))
  6772.           ((and (consp (car L)) (symbolp (caar L)) (consp (cdar L)) (null (cddar L)))
  6773.            (push (caar L) varlist) (push (eval (cadar L)) valueslist))
  6774.           (t (catch 'c-error
  6775.                (c-error 
  6776.                 #L{
  6777.                 DEUTSCH "Falsche Syntax in COMPILER-LET: ~S"
  6778.                 ENGLISH "Illegal syntax in COMPILER-LET: ~S"
  6779.                 FRANCAIS "Mauvaise syntaxe pour COMPILER-LET : ~S"
  6780.                 }
  6781.                 (car L)
  6782.     )     )  ) )
  6783. ) )
  6784.  
  6785. (macrolet ((check-blockname (name)
  6786.              `(unless (symbolp ,name)
  6787.                 (catch 'c-error
  6788.                   (c-error 
  6789.                    #L{
  6790.                    DEUTSCH "Blockname muß ein Symbol sein, nicht ~S"
  6791.                    ENGLISH "Block name must be a symbol, not ~S"
  6792.                    FRANCAIS "Un nom de bloc doit être un symbole et non ~S"
  6793.                    }
  6794.                    ,name
  6795.                 ) )
  6796.                 (setq ,name NIL) ; Default-Blockname
  6797.               )
  6798.           ))
  6799.  
  6800. ; compiliere (BLOCK name {form}*)
  6801. (defun c-BLOCK ()
  6802.   (test-list *form* 2)
  6803.   (let ((name (second *form*)))
  6804.     (check-blockname name)
  6805.     (let* ((*stackz* (cons 'BLOCK *stackz*)) ; Block-Frame
  6806.            (label (make-label *for-value*))
  6807.            (block (make-block :fnode *func* :label label
  6808.                     :consvar (make-var :name (gensym) :specialp nil
  6809.                                        :closurep nil :stackz *stackz*
  6810.                              )
  6811.                     :stackz *stackz* :used-far nil :for-value *for-value*
  6812.            )      )
  6813.            (*benv* (cons (cons name block) *benv*)) ; Block aktivieren
  6814.            (anode (c-form `(PROGN ,@(cddr *form*))))
  6815.           )
  6816.       (if (block-used-far block)
  6817.         (make-anode :type 'BLOCK
  6818.                     :sub-anodes (list anode)
  6819.                     :seclass (anodes-seclass-or anode)
  6820.                     :code `((BLOCK-OPEN ,(new-const (and (symbol-package name) name)) ; (gensym) zu nil machen
  6821.                                         ,label
  6822.                             )
  6823.                             ,anode
  6824.                             (BLOCK-CLOSE)
  6825.                             ,label
  6826.         )                  )
  6827.         (progn
  6828.           (setf (first *stackz*) 0) ; brauche keinen Blockframe
  6829.           (make-anode :type 'BLOCK
  6830.                       :sub-anodes (list anode)
  6831.                       :seclass (anodes-seclass-or anode)
  6832.                       :code `(,anode ,label)
  6833. ) ) ) ) ) )
  6834.  
  6835. ; compiliere (RETURN-FROM name [form])
  6836. (defun c-RETURN-FROM ()
  6837.   (test-list *form* 2 3)
  6838.   (let ((name (second *form*)))
  6839.     (check-blockname name)
  6840.     (let ((a (benv-search name)))
  6841.       (cond ((null a) ; dieser Blockname ist unsichtbar
  6842.              (c-error 
  6843.               #L{
  6844.               DEUTSCH "RETURN-FROM auf Block ~S an dieser Stelle nicht möglich."
  6845.               ENGLISH "RETURN-FROM block ~S is impossible from here."
  6846.               FRANCAIS "RETURN-FROM bloc ~S est impossible à partir d'ici."
  6847.               }
  6848.               name
  6849.             ))
  6850.             ((block-p a) ; in *benv* ohne %benv% sichtbar
  6851.              (let ((anode (c-form (third *form*) (block-for-value a))))
  6852.                (if (and (eq (block-fnode a) *func*)
  6853.                         (may-UNWIND *stackz* (cdr (block-stackz a)))
  6854.                    )
  6855.                  ; selbe Funktionen
  6856.                  (make-anode
  6857.                    :type 'RETURN-FROM
  6858.                    :sub-anodes (list anode)
  6859.                    :seclass '(T . T)
  6860.                    :code `(,anode
  6861.                            (UNWIND ,*stackz* ,(cdr (block-stackz a)) ,(block-for-value a))
  6862.                            (JMP ,(block-label a))
  6863.                  )        )
  6864.                  ; verschiedene Funktionen oder unbekannte Frames auf dem Stack
  6865.                  (progn
  6866.                    (unless *no-code*
  6867.                      ; in alle dazwischenliegenden Funktionen diesen Block eintragen:
  6868.                      (do ((fnode *func* (fnode-enclosing fnode)))
  6869.                          ((eq fnode (block-fnode a)))
  6870.                        (pushnew a (fnode-blocks fnode))
  6871.                      )
  6872.                      (setf (block-used-far a) t)
  6873.                    )
  6874.                    (make-anode
  6875.                      :type 'RETURN-FROM
  6876.                      :sub-anodes (list anode)
  6877.                      :seclass '(T . T)
  6878.                      :code `(,anode
  6879.                              ,@(if (not (block-for-value a)) '((VALUES0)))
  6880.                              (RETURN-FROM ,a
  6881.                               ,@(if (eq (block-fnode a) *func*) `(,*stackz*) '())
  6882.                    )        ))
  6883.             )) ) )
  6884.             ((consp a) ; in %benv% sichtbar
  6885.              (let ((anode (c-form (third *form*) 'ALL)))
  6886.                (make-anode
  6887.                  :type 'RETURN-FROM
  6888.                  :sub-anodes (list anode)
  6889.                  :seclass '(T . T)
  6890.                  :code `(,anode
  6891.                          (RETURN-FROM ,(new-const a))
  6892.             )) )        )
  6893.             (t (compiler-error 'c-RETURN-FROM))
  6894. ) ) ) )
  6895.  
  6896. ) ; macrolet
  6897.  
  6898. ; compiliere (TAGBODY {tag|form}*)
  6899. (defun c-TAGBODY ()
  6900.   (test-list *form* 1)
  6901.   (multiple-value-bind (taglist labellist)
  6902.     (do ((L (cdr *form*) (cdr L))
  6903.          (taglist '())
  6904.          (labellist '()))
  6905.         ((null L) (values (nreverse taglist) (nreverse labellist)))
  6906.       (let ((item (car L)))
  6907.         (if (atom item)
  6908.           (if (or (and (symbolp item) (not (null item))) (numberp item))
  6909.             ; Symbol NIL wird ausgeschlossen, weil zweideutig (ist auch Liste!).
  6910.             ; Andere Zahlen werden zugelassen, damit - ebenso wie 3.3.2 - auch
  6911.             ; 3.3 ein zulässiges Sprungziel ist.
  6912.             (progn
  6913.               (push item taglist)
  6914.               (push (make-label 'NIL) labellist)
  6915.             )
  6916.             (catch 'c-error
  6917.               (c-error 
  6918.                #L{
  6919.                DEUTSCH "Nur Zahlen und Symbole sind zulässige Sprungziele, nicht aber ~S"
  6920.                ENGLISH "Only numbers and symbols are valid tags, not ~S"
  6921.                FRANCAIS "Seuls les symboles et les nombres peuvent servir de marqueur de saut et non ~S"
  6922.                }
  6923.                item
  6924.     ) ) ) ) ) )
  6925.     (let* ((*stackz* (cons 0 *stackz*)) ; evtl. TAGBODY-Frame
  6926.            (tagbody (make-tagbody :fnode *func* :labellist labellist
  6927.                       :consvar (make-var :name (gensym) :specialp nil
  6928.                                          :closurep nil :stackz *stackz*
  6929.                                )
  6930.                       :stackz *stackz*
  6931.                       :used-far (make-array (length taglist) :fill-pointer 0)
  6932.            )        )
  6933.            (*genv* (cons (cons (apply #'vector taglist) tagbody) *genv*))
  6934.              ; Tagbody aktivieren
  6935.            (codelist '())
  6936.            #+COMPILER-DEBUG (anodelist '())
  6937.            (seclass '(NIL . NIL)))
  6938.       ; Inneres des Tagbody compilieren:
  6939.       (do ((formlistr (cdr *form*) (cdr formlistr))
  6940.            (taglistr taglist)
  6941.            (labellistr labellist))
  6942.           ((null formlistr)
  6943.            #+COMPILER-DEBUG (setq anodelist (nreverse anodelist))
  6944.            (setq codelist (nreverse codelist))
  6945.           )
  6946.         (let ((formi (car formlistr)))
  6947.           (if (atom formi)
  6948.             (when (and (consp taglistr) (eql formi (car taglistr)))
  6949.               ; Tag wiedergefunden
  6950.               (pop taglistr) (push (pop labellistr) codelist)
  6951.             )
  6952.             (let ((anodei (c-form formi 'NIL)))
  6953.               #+COMPILER-DEBUG (push anodei anodelist)
  6954.               (seclass-or-f seclass anodei)
  6955.               (push anodei codelist)
  6956.       ) ) ) )
  6957.       (if (> (length (tagbody-used-far tagbody)) 0)
  6958.         (let* ((used-tags (tagbody-used-far tagbody))
  6959.                (l (length used-tags))
  6960.                (used-label-list
  6961.                  (do ((i 0 (1+ i))
  6962.                       (l1 '()))
  6963.                      ((= i l) (nreverse l1))
  6964.                    (push
  6965.                      (elt labellist (position (aref used-tags i) taglist :test #'eql))
  6966.                      l1
  6967.               )) ) )
  6968.           (setf (first *stackz*) `(TAGBODY ,l))
  6969.           (setq codelist
  6970.             `((TAGBODY-OPEN
  6971.                 ,(new-const (map 'simple-vector
  6972.                                  #'(lambda (tag) (and (symbol-package tag) tag)) ; (gensym)s zu nil machen
  6973.                                  used-tags
  6974.                  )          )
  6975.                 ,@used-label-list
  6976.               )
  6977.               ,@codelist
  6978.               (TAGBODY-CLOSE-NIL)
  6979.         ) )  )
  6980.         (when *for-value* (setq codelist `(,@codelist (NIL))))
  6981.       )
  6982.       (make-anode :type 'TAGBODY
  6983.                   :sub-anodes anodelist
  6984.                   :seclass seclass
  6985.                   :code codelist
  6986. ) ) ) )
  6987.  
  6988. ; compiliere (GO tag)
  6989. (defun c-GO ()
  6990.   (test-list *form* 2 2)
  6991.   (let ((tag (second *form*)))
  6992.     (unless (or (and (symbolp tag) (not (null tag))) (numberp tag))
  6993.       (c-error 
  6994.        #L{
  6995.        DEUTSCH "Sprungziel muß ein Symbol oder eine Zahl sein, nicht ~S"
  6996.        ENGLISH "Tag must be a symbol or a number, not ~S"
  6997.        FRANCAIS "Le marqueur de saut doit être un symbole ou un nombre et non ~S"
  6998.        }
  6999.        tag
  7000.     ) )
  7001.     (multiple-value-bind (a b) (genv-search tag)
  7002.       (cond ((null a) ; dieser Tag ist unsichtbar
  7003.              (c-error 
  7004.               #L{
  7005.               DEUTSCH "GO auf Tag ~S an dieser Stelle nicht möglich."
  7006.               ENGLISH "GO to tag ~S is impossible from here."
  7007.               FRANCAIS "GO vers le marqueur ~S n'est pas possible ici."
  7008.               }
  7009.               tag
  7010.             ))
  7011.             ((tagbody-p a) ; in *genv* ohne %genv% sichtbar
  7012.              (if (and (eq (tagbody-fnode a) *func*)
  7013.                       (may-UNWIND *stackz* (tagbody-stackz a))
  7014.                  )
  7015.                ; selbe Funktionen
  7016.                (make-anode
  7017.                  :type 'GO
  7018.                  :sub-anodes '()
  7019.                  :seclass '(T . T)
  7020.                  :code `((UNWIND ,*stackz* ,(tagbody-stackz a) nil)
  7021.                          (JMP ,(nth b (tagbody-labellist a)))
  7022.                )        )
  7023.                ; verschiedene Funktionen oder unbekannte Frames auf dem Stack
  7024.                (let ((index 0))
  7025.                  (unless *no-code*
  7026.                    (setq index
  7027.                      (do* ((v (tagbody-used-far a))
  7028.                            (l (length v))
  7029.                            (i 0 (1+ i)))
  7030.                           ((= i l) (vector-push tag v) l)
  7031.                        (if (eql (aref v i) tag) (return i))
  7032.                    ) )
  7033.                    ; (aref (tagbody-used-far a) index) = tag
  7034.                    ; in alle dazwischenliegenden Funktionen diesen Tagbody eintragen:
  7035.                    (do ((fnode *func* (fnode-enclosing fnode)))
  7036.                        ((eq fnode (tagbody-fnode a)))
  7037.                      (pushnew a (fnode-tagbodys fnode))
  7038.                  ) )
  7039.                  (make-anode
  7040.                    :type 'GO
  7041.                    :sub-anodes '()
  7042.                    :seclass '(T . T)
  7043.                    :code `((VALUES0)
  7044.                            (GO ,a ,index
  7045.                             ,@(if (eq (tagbody-fnode a) *func*) `(,*stackz*) '())
  7046.                           ))
  7047.                  )
  7048.             )) )
  7049.             ((consp a) ; in %genv% sichtbar
  7050.              (make-anode
  7051.                :type 'GO
  7052.                :sub-anodes '()
  7053.                :seclass '(T . T)
  7054.                :code `((GO ,(new-const a) ,b))
  7055.             ))
  7056.             (t (compiler-error 'c-GO))
  7057. ) ) ) )
  7058.  
  7059. ; compiliere (FUNCTION funname)
  7060. (defun c-FUNCTION ()
  7061.   (test-list *form* 2 3)
  7062.   (let* ((longp (cddr *form*)) ; Flag, ob Langform (FUNCTION name funname)
  7063.          (name (second *form*)))
  7064.     (if (and (not longp) (function-name-p name))
  7065.       (multiple-value-bind (a b c) (fenv-search name)
  7066.         (case a
  7067.           ((NIL)
  7068.            (when *compiling-from-file* ; von COMPILE-FILE aufgerufen?
  7069.              (unless (or (fboundp name) (member name *known-functions* :test #'equal))
  7070.                (pushnew name *unknown-functions* :test #'equal)
  7071.            ) )
  7072.            (make-anode
  7073.              :type 'FUNCTION
  7074.              :sub-anodes '()
  7075.              :seclass '(T . NIL)
  7076.              :code (if (and (subr-info name) (not (declared-notinline name)))
  7077.                      `((CONST ,(make-const :horizont ':all
  7078.                                            :value (symbol-function name)
  7079.                                            :form `(FUNCTION ,name)
  7080.                       ))       )
  7081.                      `((CONST ,(make-funname-const name)) (SYMBOL-FUNCTION))
  7082.           ))       )
  7083.           (SYSTEM::MACRO
  7084.            (c-error 
  7085.             #L{
  7086.             DEUTSCH "~S ist keine Funktion, sondern ein lokal definierter Macro."
  7087.             ENGLISH "~S is not a function. It is a locally defined macro."
  7088.             FRANCAIS "~S n'est pas une fonction mais une macro définie localement."
  7089.             }
  7090.             name
  7091.           ))
  7092.           (GLOBAL ; gefunden in %fenv%
  7093.            (make-anode
  7094.              :type 'FUNCTION
  7095.              :sub-anodes '()
  7096.              :seclass '(T . NIL)
  7097.              :code `((CONST ,(new-const b))
  7098.                      (PUSH)
  7099.                      (CONST ,(new-const c))
  7100.                      (SVREF)
  7101.           ))        )
  7102.           (LOCAL ; gefunden in *fenv* ohne %fenv%
  7103.            (if (const-p b)
  7104.              (make-anode
  7105.                :type 'FUNCTION
  7106.                :sub-anodes '()
  7107.                :seclass '(NIL . NIL)
  7108.                :code `((FCONST ,(const-value b)))
  7109.              )
  7110.              (c-VAR (var-name b))
  7111.           ))
  7112.           (t (compiler-error 'c-FUNCTION))
  7113.       ) )
  7114.       (let ((funname (car (last *form*))))
  7115.         (if (and (consp funname) (eq (car funname) 'LAMBDA) (consp (cdr funname)))
  7116.           (let ((*no-code* (or *no-code* (null *for-value*))))
  7117.             (c-fnode-function
  7118.               (c-lambdabody
  7119.                 (if (and longp (function-name-p name))
  7120.                   name ; angegebener Funktionsname
  7121.                   (symbol-suffix (fnode-name *func*) (incf *anonymous-count*))
  7122.                 )
  7123.                 (cdr funname)
  7124.           ) ) )
  7125.           (c-error 
  7126.            #L{
  7127.            DEUTSCH "Nur Symbole und Lambda-Ausdrücke sind Namen von Funktionen, nicht ~S"
  7128.            ENGLISH "Only symbols and lambda expressions are function names, not ~S"
  7129.            FRANCAIS "Seuls les symboles et les expressions lambda sont des noms de fonction et non ~S"
  7130.            }
  7131.            funname
  7132. ) ) ) ) ) )
  7133.  
  7134. ; compiliere (%GENERIC-FUNCTION-LAMBDA . lambdabody)
  7135. (defun c-%GENERIC-FUNCTION-LAMBDA ()
  7136.   (test-list *form* 1)
  7137.   (let ((*no-code* (or *no-code* (null *for-value*))))
  7138.     (c-fnode-function
  7139.       (c-lambdabody
  7140.         (symbol-suffix (fnode-name *func*) (incf *anonymous-count*))
  7141.         (cdr *form*)
  7142.         nil
  7143.         t ; gf-p = T, Code für generische Funktion bauen
  7144. ) ) ) )
  7145.  
  7146. ; compiliere (%OPTIMIZE-FUNCTION-LAMBDA reqoptimflags . lambdabody)
  7147. ; reqoptimflags ist eine Liste von Flags, welche Required-Parameter des
  7148. ; lambdabody wegoptimiert werden dürfen. Zu jedem Required-Parameter:
  7149. ; NIL: normal,
  7150. ; T: darf wegoptimiert werden, dann wird daraus GONE gemacht.
  7151. ; NILs am Schluß der Liste dürfen weggelassen werden.
  7152. ; Die Ausgabe enthält zusätzlich zur Funktion die Liste der Wegoptimierten.
  7153. (defmacro %OPTIMIZE-FUNCTION-LAMBDA (reqoptimflags &rest lambdabody)
  7154.   (declare (ignore reqoptimflags))
  7155.   `(CONS (FUNCTION (LAMBDA ,@lambdabody)) NIL) ; ohne Compiler: nicht optimieren
  7156. )
  7157. (defun c-%OPTIMIZE-FUNCTION-LAMBDA ()
  7158.   (test-list *form* 2)
  7159.   (let ((*no-code* (or *no-code* (null *for-value*))))
  7160.     (let* ((reqoptimflags (copy-list (second *form*)))
  7161.            (anode1
  7162.              (c-fnode-function
  7163.                (c-lambdabody
  7164.                  (symbol-suffix (fnode-name *func*) (incf *anonymous-count*))
  7165.                  (cddr *form*)
  7166.                  nil nil reqoptimflags
  7167.            ) ) )
  7168.            (resultflags (mapcar #'(lambda (x) (eq x 'GONE)) reqoptimflags))
  7169.            (anode2 (let ((*stackz* (cons 1 *stackz*))
  7170.                          (*form* `(QUOTE ,resultflags)))
  7171.                      (c-QUOTE)
  7172.           ))       )
  7173.       (make-anode :type '%OPTIMIZE-FUNCTION-LAMBDA
  7174.                   :sub-anodes (list anode1 anode2)
  7175.                   :seclass (anodes-seclass-or anode1 anode2)
  7176.                   :code `(,anode1 (PUSH) ,anode2 (CONS))
  7177. ) ) ) )
  7178.  
  7179. (macrolet ((err-syntax (specform fdef)
  7180.              `(catch 'c-error
  7181.                 (c-error 
  7182.                  #L{
  7183.                  DEUTSCH "Falsche Syntax einer Funktionsdefinition in ~S: ~S"
  7184.                  ENGLISH "Illegal function definition syntax in ~S: ~S"
  7185.                  FRANCAIS "Mauvaise syntaxe de définition de fonction dans ~S : ~S"
  7186.                  }
  7187.                  ,specform ,fdef
  7188.               ) )
  7189.           ))
  7190.  
  7191. ; compiliere (FLET ({fundef}*) {form}*)
  7192. (defun c-FLET ()
  7193.   (test-list *form* 2)
  7194.   (test-list (second *form*) 0)
  7195.   (multiple-value-bind (namelist fnodelist)
  7196.       (do ((fdefsr (second *form*) (cdr fdefsr))
  7197.            (L1 '())
  7198.            (L2 '()))
  7199.           ((null fdefsr) (values (nreverse L1) (nreverse L2)))
  7200.         (let ((fdef (car fdefsr)))
  7201.           (if (and (consp fdef) (function-name-p (car fdef)) (consp (cdr fdef)))
  7202.             (let ((fnode (c-lambdabody
  7203.                            (symbol-suffix (fnode-name *func*) (car fdef))
  7204.                            (cdr fdef)
  7205.                  ))      )
  7206.               (push (car fdef) L1)
  7207.               (push fnode L2)
  7208.             )
  7209.             (err-syntax 'FLET fdef)
  7210.       ) ) )
  7211.     ; namelist = Liste der Namen, fnodelist = Liste der fnodes der Funktionen
  7212.     (let ((oldstackz *stackz*)
  7213.           (*stackz* *stackz*)
  7214.           (*venvc* *venvc*)
  7215.           (*venv* *venv*))
  7216.       (push 0 *stackz*) (push nil *venvc*) ; Platz für Closure-Dummyvar
  7217.       (let ((closuredummy-stackz *stackz*)
  7218.             (closuredummy-venvc *venvc*))
  7219.         (multiple-value-bind (varlist anodelist *fenv*)
  7220.             (do ((namelistr namelist (cdr namelistr))
  7221.                  (fnodelistr fnodelist (cdr fnodelistr))
  7222.                  (varlist '())
  7223.                  (anodelist '())
  7224.                  (fenv '()))
  7225.                 ((null namelistr)
  7226.                  (values (nreverse varlist) (nreverse anodelist)
  7227.                          (apply #'vector (nreverse (cons *fenv* fenv)))
  7228.                 ))
  7229.               (push (car namelistr) fenv)
  7230.               (let ((fnode (car fnodelistr)))
  7231.                 (if (zerop (fnode-keyword-offset fnode))
  7232.                   ; Funktionsdefinition ist autonom
  7233.                   (push (cons (list fnode) (make-const :horizont ':value :value fnode)) fenv)
  7234.                   (progn
  7235.                     (push (c-fnode-function fnode) anodelist)
  7236.                     (push 1 *stackz*)
  7237.                     (let ((var (make-var :name (gensym) :specialp nil
  7238.                                  :constantp nil :usedp t :really-usedp nil
  7239.                                  :closurep nil ; später evtl. auf T gesetzt
  7240.                                  :stackz *stackz* :venvc *venvc*
  7241.                          ))    )
  7242.                       (push (cons (list fnode) var) fenv)
  7243.                       (push var varlist)
  7244.             ) ) ) ) )
  7245.           (apply #'push-*venv* varlist) ; Hilfsvariablen aktivieren
  7246.           (let* ((body-anode ; restliche Formen compilieren
  7247.                    (c-form `(PROGN ,@(cddr *form*)))
  7248.                  )
  7249.                  (closurevars (checking-movable-var-list varlist anodelist))
  7250.                  (anode
  7251.                    (make-anode
  7252.                      :type 'FLET
  7253.                      :sub-anodes `(,@anodelist ,body-anode)
  7254.                      :seclass (seclass-without
  7255.                                 (anodelist-seclass-or `(,@anodelist ,body-anode))
  7256.                                 varlist
  7257.                               )
  7258.                      :code `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7259.                              ,@(mapcap #'c-bind-movable-var-anode varlist anodelist)
  7260.                              ,body-anode
  7261.                              (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7262.                    )        )
  7263.                 ))
  7264.             (when closurevars
  7265.               (setf (first closuredummy-stackz) 1) ; 1 Stackplatz für Dummy
  7266.               (setf (first closuredummy-venvc)
  7267.                 (cons closurevars closuredummy-stackz)
  7268.             ) )
  7269.             (optimize-var-list varlist)
  7270.             anode
  7271. ) ) ) ) ) )
  7272.  
  7273. ; compiliere (LABELS ({fundef}*) {form}*)
  7274. (defun c-LABELS ()
  7275.   (test-list *form* 2)
  7276.   (test-list (second *form*) 0)
  7277.   (let ((oldstackz *stackz*)
  7278.         (*stackz* *stackz*)
  7279.         (*venvc* *venvc*)
  7280.         (*venv* *venv*))
  7281.     (push 0 *stackz*) (push nil *venvc*) ; Platz für Closure-Dummyvar
  7282.     (let ((closuredummy-stackz *stackz*)
  7283.           (closuredummy-venvc *venvc*))
  7284.       (multiple-value-bind (namelist varlist lambdanamelist lambdabodylist fenvconslist)
  7285.           (do ((fdefsr (second *form*) (cdr fdefsr))
  7286.                (L1 '())
  7287.                (L2 '())
  7288.                (L3 '())
  7289.                (L4 '())
  7290.                (L5 '()))
  7291.               ((null fdefsr)
  7292.                (values (nreverse L1) (nreverse L2) (nreverse L3) (nreverse L4) (nreverse L5))
  7293.               )
  7294.             (let ((fdef (car fdefsr)))
  7295.               (if (and (consp fdef) (function-name-p (car fdef)) (consp (cdr fdef)))
  7296.                 (progn
  7297.                   (push (car fdef) L1)
  7298.                   (push 1 *stackz*)
  7299.                   (push (make-var :name (gensym) :specialp nil
  7300.                                   :constantp nil :usedp t :really-usedp nil
  7301.                                   :closurep nil ; später evtl. auf T gesetzt
  7302.                                   :stackz *stackz* :venvc *venvc*
  7303.                         )
  7304.                         L2
  7305.                   )
  7306.                   (push (symbol-suffix (fnode-name *func*) (car fdef)) L3)
  7307.                   (push (cdr fdef) L4)
  7308.                   (push
  7309.                     (cons
  7310.                       ; fdescr, bestehend aus:
  7311.                       (cons nil ; Platz für den FNODE
  7312.                         (cons 'LABELS
  7313.                           (multiple-value-list ; Werten von analyze-lambdalist
  7314.                             (analyze-lambdalist (cadr fdef))
  7315.                       ) ) )
  7316.                       ; Variable
  7317.                       (car L2)
  7318.                     )
  7319.                     L5
  7320.                 ) )
  7321.                 (err-syntax 'LABELS fdef)
  7322.           ) ) )
  7323.         ; namelist = Liste der Namen, varlist = Liste der Variablen,
  7324.         ; lambdanamelist = Liste der Dummynamen der Funktionen,
  7325.         ; lambdabodylist = Liste der Lambdabodys der Funktionen,
  7326.         ; fenvconslist = Liste der Conses (fdescr . var) für *fenv*
  7327.         ; (jeweils fdescr noch ohne den fnode, der kommt erst später hinein).
  7328.         (let ((*fenv* ; Funktionsnamen aktivieren
  7329.                 (do ((namelistr namelist (cdr namelistr))
  7330.                      (fenvconslistr fenvconslist (cdr fenvconslistr))
  7331.                      (L nil))
  7332.                     ((null namelistr)
  7333.                      (push *fenv* L)
  7334.                      (apply #'vector (nreverse L))
  7335.                     )
  7336.                   (push (car namelistr) L)
  7337.                   (push (car fenvconslistr) L)
  7338.              )) )
  7339.           (apply #'push-*venv* varlist) ; Hilfsvariablen aktivieren
  7340.           (let* ((fnodelist ; Funktionen compilieren
  7341.                    (mapcar #'c-lambdabody lambdanamelist lambdabodylist fenvconslist)
  7342.                  )
  7343.                  (anodelist
  7344.                    (mapcar #'(lambda (fnode var)
  7345.                                (c-fnode-function fnode (cdr (var-stackz var)))
  7346.                              )
  7347.                            fnodelist varlist
  7348.                  ) )
  7349.                  (body-anode ; restliche Formen compilieren
  7350.                    (c-form `(PROGN ,@(cddr *form*)))
  7351.                 ))
  7352.             ; die Variablen, zu denen die Funktion autonom war, werden nach-
  7353.             ; träglich zu Konstanten erklärt:
  7354.             (do ((varlistr varlist (cdr varlistr))
  7355.                  (fnodelistr fnodelist (cdr fnodelistr)))
  7356.                 ((null varlistr))
  7357.               (let ((var (car varlistr))
  7358.                     (fnode (car fnodelistr)))
  7359.                 (when (zerop (fnode-keyword-offset fnode))
  7360.                   ; Funktionsdefinition ist autonom
  7361.                   (setf (var-constantp var) t)
  7362.                   (setf (var-constant var) (new-const fnode))
  7363.             ) ) )
  7364.             (let* ((closurevars (checking-movable-var-list varlist anodelist))
  7365.                    (anode
  7366.                      (make-anode
  7367.                        :type 'LABELS
  7368.                        :sub-anodes `(,@anodelist ,body-anode)
  7369.                        :seclass (seclass-without
  7370.                                   (anodelist-seclass-or `(,@anodelist ,body-anode))
  7371.                                   varlist
  7372.                                 )
  7373.                        :code `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7374.                                ,@(mapcap #'c-bind-movable-var-anode varlist anodelist)
  7375.                                ,body-anode
  7376.                                (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7377.                      )        )
  7378.                   ))
  7379.               (when closurevars
  7380.                 (setf (first closuredummy-stackz) 1) ; 1 Stackplatz für Dummy
  7381.                 (setf (first closuredummy-venvc)
  7382.                   (cons closurevars closuredummy-stackz)
  7383.               ) )
  7384.               (optimize-var-list varlist)
  7385.               anode
  7386. ) ) ) ) ) ) )
  7387.  
  7388. ; compiliere (CLOS:GENERIC-FLET ({genfundefs}*) {form}*)
  7389. (defun c-GENERIC-FLET ()
  7390.   (test-list *form* 2)
  7391.   (test-list (second *form*) 0)
  7392.   (multiple-value-bind (namelist signlist formlist)
  7393.       (do ((fdefsr (second *form*) (cdr fdefsr))
  7394.            (L1 '())
  7395.            (L2 '())
  7396.            (L3 '()))
  7397.           ((null fdefsr) (values (nreverse L1) (nreverse L2) (nreverse L3)))
  7398.         (let ((fdef (car fdefsr)))
  7399.           (if (and (consp fdef) (function-name-p (car fdef)) (consp (cdr fdef)))
  7400.             (let ((name (first fdef)))
  7401.               (push name L1)
  7402.               (push (clos::defgeneric-lambdalist-callinfo 'clos:generic-flet name (second fdef))
  7403.                     L2
  7404.               )
  7405.               (push (clos::make-generic-function-form 'clos:generic-flet
  7406.                       name (second fdef) (cddr fdef) (vector *venv* *fenv*)
  7407.                     )
  7408.                     L3
  7409.             ) )
  7410.             (err-syntax 'CLOS:GENERIC-FLET fdef)
  7411.       ) ) )
  7412.     ; namelist = Liste der Namen,
  7413.     ; signlist = Liste der Signaturen der generischen Funktionen,
  7414.     ; formlist = Liste der Konstruktor-Formen der generischen Funktionen.
  7415.     (let ((oldstackz *stackz*)
  7416.           (*stackz* *stackz*)
  7417.           (*venvc* *venvc*)
  7418.           (*venv* *venv*))
  7419.       (push 0 *stackz*) (push nil *venvc*) ; Platz für Closure-Dummyvar
  7420.       (let ((closuredummy-stackz *stackz*)
  7421.             (closuredummy-venvc *venvc*))
  7422.         (multiple-value-bind (varlist anodelist *fenv*)
  7423.             (do ((namelistr namelist (cdr namelistr))
  7424.                  (signlistr signlist (cdr signlistr))
  7425.                  (formlistr formlist (cdr formlistr))
  7426.                  (varlist '())
  7427.                  (anodelist '())
  7428.                  (fenv '()))
  7429.                 ((null namelistr)
  7430.                  (values (nreverse varlist) (nreverse anodelist)
  7431.                          (apply #'vector (nreverse (cons *fenv* fenv)))
  7432.                 ))
  7433.               (push (car namelistr) fenv)
  7434.               (push (c-form (car formlistr) 'ONE) anodelist)
  7435.               (push 1 *stackz*)
  7436.               (let ((var (make-var :name (gensym) :specialp nil
  7437.                            :constantp nil :usedp t :really-usedp nil
  7438.                            :closurep nil ; später evtl. auf T gesetzt
  7439.                            :stackz *stackz* :venvc *venvc*
  7440.                    ))    )
  7441.                 (push (cons (list* nil 'GENERIC (car signlistr)) var) fenv)
  7442.                 (push var varlist)
  7443.             ) )
  7444.           (apply #'push-*venv* varlist) ; Hilfsvariablen aktivieren
  7445.           (let* ((body-anode ; restliche Formen compilieren
  7446.                    (c-form `(PROGN ,@(cddr *form*)))
  7447.                  )
  7448.                  (closurevars (checking-movable-var-list varlist anodelist))
  7449.                  (anode
  7450.                    (make-anode
  7451.                      :type 'CLOS:GENERIC-FLET
  7452.                      :sub-anodes `(,@anodelist ,body-anode)
  7453.                      :seclass (seclass-without
  7454.                                 (anodelist-seclass-or `(,@anodelist ,body-anode))
  7455.                                 varlist
  7456.                               )
  7457.                      :code `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7458.                              ,@(mapcap #'c-bind-movable-var-anode varlist anodelist)
  7459.                              ,body-anode
  7460.                              (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7461.                    )        )
  7462.                 ))
  7463.             (when closurevars
  7464.               (setf (first closuredummy-stackz) 1) ; 1 Stackplatz für Dummy
  7465.               (setf (first closuredummy-venvc)
  7466.                 (cons closurevars closuredummy-stackz)
  7467.             ) )
  7468.             (optimize-var-list varlist)
  7469.             anode
  7470. ) ) ) ) ) )
  7471.  
  7472. ; compiliere (CLOS:GENERIC-LABELS ({genfundefs}*) {form}*)
  7473. (defun c-GENERIC-LABELS ()
  7474.   (test-list *form* 2)
  7475.   (test-list (second *form*) 0)
  7476.   (let ((oldstackz *stackz*)
  7477.         (*stackz* *stackz*)
  7478.         (*venvc* *venvc*)
  7479.         (*venv* *venv*))
  7480.     (push 0 *stackz*) (push nil *venvc*) ; Platz für Closure-Dummyvar
  7481.     (let ((closuredummy-stackz *stackz*)
  7482.           (closuredummy-venvc *venvc*))
  7483.       (multiple-value-bind (namelist varlist fenvconslist formlist)
  7484.           (do ((fdefsr (second *form*) (cdr fdefsr))
  7485.                (L1 '())
  7486.                (L2 '())
  7487.                (L3 '())
  7488.                (L4 '()))
  7489.               ((null fdefsr)
  7490.                (values (nreverse L1) (nreverse L2) (nreverse L3) (nreverse L4))
  7491.               )
  7492.             (let ((fdef (car fdefsr)))
  7493.               (if (and (consp fdef) (function-name-p (car fdef)) (consp (cdr fdef)))
  7494.                 (let ((name (first fdef)))
  7495.                   (push name L1)
  7496.                   (push 1 *stackz*)
  7497.                   (push (make-var :name (gensym) :specialp nil
  7498.                                   :constantp nil :usedp t :really-usedp nil
  7499.                                   :closurep nil ; später evtl. auf T gesetzt
  7500.                                   :stackz *stackz* :venvc *venvc*
  7501.                         )
  7502.                         L2
  7503.                   )
  7504.                   (push (cons
  7505.                           ; fdescr
  7506.                           (list* nil 'GENERIC
  7507.                                  (clos::defgeneric-lambdalist-callinfo 'clos:generic-labels name (second fdef))
  7508.                           )
  7509.                           ; Variable
  7510.                           (car L2)
  7511.                         )
  7512.                         L3
  7513.                   )
  7514.                   (push (clos::make-generic-function-form 'clos:generic-labels
  7515.                           name (second fdef) (cddr fdef) (vector *venv* *fenv*)
  7516.                         )
  7517.                         L4
  7518.                 ) )
  7519.                 (err-syntax 'CLOS:GENERIC-LABELS fdef)
  7520.           ) ) )
  7521.         ; namelist = Liste der Namen, varlist = Liste der Variablen,
  7522.         ; fenvconslist = Liste der Conses (fdescr . var) für *fenv*,
  7523.         ; formlist = Liste der Konstruktor-Formen der generischen Funktionen.
  7524.         (let ((*fenv* ; Funktionsnamen aktivieren
  7525.                 (do ((namelistr namelist (cdr namelistr))
  7526.                      (fenvconslistr fenvconslist (cdr fenvconslistr))
  7527.                      (L nil))
  7528.                     ((null namelistr)
  7529.                      (push *fenv* L)
  7530.                      (apply #'vector (nreverse L))
  7531.                     )
  7532.                   (push (car namelistr) L)
  7533.                   (push (car fenvconslistr) L)
  7534.              )) )
  7535.           (apply #'push-*venv* varlist) ; Hilfsvariablen aktivieren
  7536.           (let* ((anodelist
  7537.                    (mapcar #'(lambda (form) (c-form form 'ONE)) formlist)
  7538.                  )
  7539.                  (body-anode ; restliche Formen compilieren
  7540.                    (c-form `(PROGN ,@(cddr *form*)))
  7541.                  )
  7542.                  (closurevars (checking-movable-var-list varlist anodelist))
  7543.                  (anode
  7544.                    (make-anode
  7545.                      :type 'CLOS:GENERIC-LABELS
  7546.                      :sub-anodes `(,@anodelist ,body-anode)
  7547.                      :seclass (seclass-without
  7548.                                 (anodelist-seclass-or `(,@anodelist ,body-anode))
  7549.                                 varlist
  7550.                               )
  7551.                      :code `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  7552.                              ,@(mapcap #'c-bind-movable-var-anode varlist anodelist)
  7553.                              ,body-anode
  7554.                              (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7555.                    )        )
  7556.                 ))
  7557.             (when closurevars
  7558.               (setf (first closuredummy-stackz) 1) ; 1 Stackplatz für Dummy
  7559.               (setf (first closuredummy-venvc)
  7560.                 (cons closurevars closuredummy-stackz)
  7561.             ) )
  7562.             (optimize-var-list varlist)
  7563.             anode
  7564. ) ) ) ) ) )
  7565.  
  7566. ) ; macrolet
  7567.  
  7568. ; compiliere (MACROLET ({macrodef}*) {form}*)
  7569. (defun c-MACROLET (&optional (c #'c-form))
  7570.   (test-list *form* 2)
  7571.   (test-list (second *form*) 0)
  7572.   (do ((L1 (second *form*) (cdr L1))
  7573.        (L2 '()))
  7574.       ((null L1)
  7575.        (push *fenv* L2)
  7576.        (let ((*fenv* (apply #'vector (nreverse L2)))) ; *fenv* erweitern
  7577.          (funcall c `(PROGN ,@(cddr *form*))) ; restliche Formen compilieren
  7578.       ))
  7579.     (let* ((macrodef (car L1))
  7580.            (name (car macrodef)))
  7581.       (push name L2)
  7582.       (push #+CLISP (sys::make-macro-expandercons macrodef)
  7583.             #-CLISP (cons 'SYSTEM::MACRO (make-macro-expander macrodef))
  7584.             L2
  7585.   ) ) )
  7586. )
  7587.  
  7588. ; compiliere (SYMBOL-MACROLET ({symdef}*) {declaration}* {form}*)
  7589. (defun c-SYMBOL-MACROLET (&optional (c #'c-form))
  7590.   (test-list *form* 2)
  7591.   (test-list (second *form*) 0)
  7592.   (multiple-value-bind (body-rest declarations)
  7593.       (parse-body (cddr *form*) nil (vector *venv* *fenv*))
  7594.     (let ((*denv* *denv*)
  7595.           (*venv* *venv*))
  7596.       (multiple-value-bind (*specials* *ignores* *ignorables*)
  7597.           (process-declarations declarations)
  7598.         ; Special-Variable auf *venv* pushen:
  7599.         (push-specials)
  7600.         ; Syntaxtest der Parameterliste:
  7601.         (multiple-value-bind (symbols expansions)
  7602.             (do ((L (second *form*) (cdr L))
  7603.                  (symbols nil)
  7604.                  (expansions nil))
  7605.                 ((null L) (values (nreverse symbols) (nreverse expansions)))
  7606.               (let ((symdef (car L)))
  7607.                 (if (and (consp symdef) (symbolp (car symdef))
  7608.                          (consp (cdr symdef)) (null (cddr symdef))
  7609.                     )
  7610.                   (progn (push (first symdef) symbols) (push (second symdef) expansions))
  7611.                   (catch 'c-error
  7612.                     (c-error 
  7613.                      #L{
  7614.                      DEUTSCH "Falsche Syntax in SYMBOL-MACROLET: ~S"
  7615.                      ENGLISH "Illegal syntax in SYMBOL-MACROLET: ~S"
  7616.                      FRANCAIS "Mauvaise syntaxe pour SYMBOL-MACROLET : ~S"
  7617.                      }
  7618.                      symdef
  7619.             ) ) ) ) )
  7620.           (dolist (s (intersection *specials* symbols))
  7621.             (catch 'c-error
  7622.               (c-error 
  7623.                #L{
  7624.                DEUTSCH "~S: Symbol ~S darf nicht gleichzeitig SPECIAL und Makro deklariert werden."
  7625.                ENGLISH "~S: symbol ~S must not be declared SPECIAL and a macro at the same time"
  7626.                FRANCAIS "~S : Le symbole ~S ne peut être déclaré SPECIAL et macro en même temps."
  7627.                }
  7628.                'symbol-macrolet s
  7629.           ) ) )
  7630.           (setq *venv* ; *venv* erweitern
  7631.             (apply #'vector
  7632.               (nconc (mapcan #'(lambda (sym expansion) (list sym (make-symbol-macro expansion)))
  7633.                              symbols expansions
  7634.                      )
  7635.                      (list *venv*)
  7636.           ) ) )
  7637.           (funcall c `(PROGN ,@body-rest)) ; restliche Formen compilieren
  7638. ) ) ) ) )
  7639.  
  7640. ; compiliere (EVAL-WHEN ({situation}*) {form}*)
  7641. (defun c-EVAL-WHEN (&optional (c #'c-form))
  7642.   (test-list *form* 2)
  7643.   (test-list (second *form*) 0)
  7644.   (let ((load-flag nil)
  7645.         (compile-flag nil)
  7646.         (compile-once-only nil))
  7647.     (dolist (situation (second *form*))
  7648.       (case situation
  7649.         (LOAD (setq load-flag t))
  7650.         (COMPILE (setq compile-flag t))
  7651.         (EVAL)
  7652.         (COMPILE-ONCE-ONLY (setq compile-once-only t))
  7653.         (T (cond ((equal situation '(NOT EVAL)) (setq load-flag t compile-flag t))
  7654.                  ((equal situation '(NOT COMPILE)) (setq load-flag t))
  7655.                  (t (c-error 
  7656.                      #L{
  7657.                      DEUTSCH "Situation bei EVAL-WHEN muß EVAL, LOAD oder COMPILE sein, nicht ~S."
  7658.                      ENGLISH "EVAL-WHEN situation must be EVAL or LOAD or COMPILE, but not ~S"
  7659.                      FRANCAIS "EVAL-WHEN ne s'applique qu'aux situations EVAL, LOAD ou COMPILE et non ~S."
  7660.                      }
  7661.                      situation
  7662.     ) ) )  )     )  )
  7663.     (let ((form `(PROGN ,@(cddr *form*))))
  7664.       (if compile-flag
  7665.         (c-eval-when-compile form) ; ausführen und ins Lib-File schreiben
  7666.         (if compile-once-only
  7667.           (eval form) ; nur jetzt ausführen, nicht ins Lib-File schreiben
  7668.       ) )
  7669.       (funcall c (if load-flag form 'NIL))
  7670. ) ) )
  7671.  
  7672. ; compiliere (COND {clause}*)
  7673. (defun c-COND ()
  7674.   (test-list *form* 1)
  7675.   (c-form
  7676.     (let ((clauses (cdr *form*))) ; (COND . clauses) macroexpandieren
  7677.       (if (null clauses)
  7678.         'NIL
  7679.         (let ((clause (car clauses)))
  7680.           (if (atom clause)
  7681.             (c-error 
  7682.              #L{
  7683.              DEUTSCH "COND-Klausel ohne Test: ~S"
  7684.              ENGLISH "COND clause without test: ~S"
  7685.              FRANCAIS "Clause COND sans test : ~S"
  7686.              }
  7687.              clause
  7688.             )
  7689.             (let ((test (car clause)))
  7690.               (if (cdr clause)
  7691.                 `(IF ,test (PROGN ,@(cdr clause)) (COND ,@(cdr clauses)))
  7692.                 `(OR ,test (COND ,@(cdr clauses)))
  7693. ) ) ) ) ) ) ) )
  7694.  
  7695.  
  7696. ;               ERSTER PASS :   M A C R O S
  7697.  
  7698. ; compiliere (CASE keyform {clause}*)
  7699. (defun c-CASE ()
  7700.   (test-list *form* 1)
  7701.   (let ((keyform (second *form*))
  7702.         (clauses (cddr *form*))
  7703.         ; clauses vereinfachen:
  7704.         (newclauses '())
  7705.         (allkeys '()))
  7706.     (let ((default-passed nil))
  7707.       (do ((clauses clauses))
  7708.           ((endp clauses))
  7709.         (let ((clause (pop clauses)))
  7710.           (if (atom clause)
  7711.             (c-error 
  7712.              #L{
  7713.              DEUTSCH "CASE-Klausel ohne Objekte: ~S"
  7714.              ENGLISH "CASE clause without objects: ~S"
  7715.              FRANCAIS "Clause CASE sans objets LISP : ~S"
  7716.              }
  7717.              clause
  7718.             )
  7719.             (let ((keys (car clause)))
  7720.               (if default-passed ; war der Default schon da?
  7721.                 (setq keys nil)
  7722.                 (if (or (eq keys 'T) (eq keys 'OTHERWISE))
  7723.                   (progn
  7724.                     (when clauses
  7725.                       (catch 'c-error
  7726.                         (c-error 
  7727.                          #L{
  7728.                          DEUTSCH "~S: Die ~S-Klausel muß die letzte sein: ~S"
  7729.                          ENGLISH "~S: the ~S clause must be the last one: ~S"
  7730.                          FRANCAIS "~S : La clause ~S doit être la dernière: ~S"
  7731.                          }
  7732.                          'case keys *form*
  7733.                     ) ) )
  7734.                     (setq keys 'T)
  7735.                     (setq default-passed t)
  7736.                   )
  7737.                   (let ((newkeys '()))
  7738.                     (dolist (key (if (listp keys) keys (list keys)))
  7739.                       (if (not (member key allkeys :test #'eql)) ; remove-duplicates
  7740.                         (progn (push key allkeys) (push key newkeys))
  7741.                         (c-warn 
  7742.                          #L{
  7743.                          DEUTSCH "Doppelt aufgeführter ~S-Fall ~S : ~S"
  7744.                          ENGLISH "Duplicate ~S label ~S : ~S"
  7745.                          FRANCAIS "~S : Le choix ~S se répète: ~S"
  7746.                          }
  7747.                          'case key *form*
  7748.                     ) ) )
  7749.                     (setq keys (nreverse newkeys))
  7750.               ) ) )
  7751.               (push (cons keys (cdr clause)) newclauses)
  7752.       ) ) ) )
  7753.       (unless default-passed (push '(T NIL) newclauses))
  7754.       (setq newclauses (nreverse newclauses))
  7755.       (setq allkeys (nreverse allkeys))
  7756.     )
  7757.     ; newclauses enthält jetzt keine doppelten keys, genau einmal T als keys,
  7758.     ; und allkeys ist die Menge aller Keys.
  7759.     (if (<= (length allkeys) 2) ; wenige Keys -> direkt EQL verwenden
  7760.       (let ((keyvar (gensym)))
  7761.         (labels ((ifify (clauses)
  7762.                    (if (null clauses)
  7763.                      'NIL
  7764.                      `(IF ,(let ((keys (caar clauses)))
  7765.                              (if (listp keys)
  7766.                                `(OR ,@(mapcar
  7767.                                         #'(lambda (key) `(EQL ,keyvar ',key))
  7768.                                         keys
  7769.                                 )     )
  7770.                                'T ; keys = T, der Default-Fall
  7771.                            ) )
  7772.                         (PROGN ,@(cdar clauses))
  7773.                         ,(ifify (cdr clauses))
  7774.                       )
  7775.                 )) )
  7776.           (c-form
  7777.             `(LET ((,keyvar ,keyform)) (PROGN ,keyvar ,(ifify newclauses)))
  7778.       ) ) )
  7779.       (let ((keyform-anode (c-form keyform 'ONE))
  7780.             (default-anode nil)
  7781.             (cases '())) ; Liste von Tripeln (keylist label anode)
  7782.         (dolist (clause newclauses)
  7783.           (if (car clause)
  7784.             (let ((anode (c-form `(PROGN ,@(cdr clause)))))
  7785.               (if (atom (car clause))
  7786.                 (setq default-anode anode)
  7787.                 (push (list (car clause) (make-label 'NIL) anode) cases)
  7788.             ) )
  7789.             (let ((*no-code* t)) (c-form `(PROGN ,@(cdr clause)) 'NIL))
  7790.         ) )
  7791.         (setq cases (nreverse cases))
  7792.         (if (anode-constantp keyform-anode)
  7793.           (let ((value (anode-constant-value keyform-anode)))
  7794.             (dolist (case cases default-anode)
  7795.               (when (member value (first case) :test #'eql)
  7796.                 (return (third case))
  7797.           ) ) )
  7798.           (let ((default-label (make-label 'NIL))
  7799.                 (end-label (make-label *for-value*))
  7800.                 (test (if (every #'EQL=EQ allkeys) 'EQ 'EQL)))
  7801.             (make-anode
  7802.               :type 'CASE
  7803.               :sub-anodes `(,keyform-anode ,@(mapcar #'third cases) ,default-anode)
  7804.               :seclass
  7805.                 (anodelist-seclass-or
  7806.                   `(,keyform-anode ,@(mapcar #'third cases) ,default-anode)
  7807.                 )
  7808.               :code
  7809.                 `(,keyform-anode
  7810.                   (JMPHASH
  7811.                     ,test
  7812.                     ,(mapcap ; Aliste (obji -> labeli)
  7813.                        #'(lambda (case)
  7814.                            (let ((label (second case)))
  7815.                              (mapcar #'(lambda (obj) (cons obj label))
  7816.                                      (first case)
  7817.                          ) ) )
  7818.                        cases
  7819.                      )
  7820.                     ,default-label
  7821.                     ,@(mapcar #'second cases) ; alle Labels, ohne Doppelte
  7822.                   )
  7823.                   ,@(mapcap
  7824.                       #'(lambda (case)
  7825.                           `(,(second case) ; Label
  7826.                             ,(third case) ; Anode
  7827.                             (JMP ,end-label)
  7828.                            )
  7829.                         )
  7830.                       cases
  7831.                     )
  7832.                   ,default-label
  7833.                   ,default-anode
  7834.                   ,end-label
  7835.                  )
  7836.           ) )
  7837. ) ) ) ) )
  7838.  
  7839. ; compiliere (HANDLER-BIND ({(typespec handler)}*) {form}*)
  7840. ; und  (SYS::%HANDLER-BIND ({(typespec handler)}*) {form}*)
  7841. (defun c-HANDLER-BIND ()
  7842.   (test-list *form* 2)
  7843.   (test-list (second *form*) 0)
  7844.   (let ((body (cddr *form*))
  7845.         (types '())
  7846.         (handler-labels '())
  7847.         (handler-anodes '()))
  7848.     (dolist (clause (second *form*))
  7849.       (test-list clause 2 2)
  7850.       (let ((type (first clause))
  7851.             (handler (second clause)))
  7852.         (if (block try-subtypep
  7853.               (let ((*error-handler*
  7854.                       #'(lambda (&rest error-args)
  7855.                           (declare (ignore error-args))
  7856.                           (return-from try-subtypep nil)
  7857.                    ))   )
  7858.                 (subtypep type `(OR ,@types))
  7859.             ) )
  7860.           ; Brauche diesen Handler nicht zu berücksichtigen
  7861.           (let ((*no-code* t) (*for-value* 'NIL)) (c-form handler))
  7862.           ; Der Handler ist eine Funktion mit dynamischem Extent.
  7863.           (let ((label (make-label 'ONE)))
  7864.             (push type types)
  7865.             (push label handler-labels)
  7866.             (push
  7867.               (let* ((*stackz* (cons 'ANYTHING *stackz*))
  7868.                      (oldstackz *stackz*)
  7869.                      (*venv* *venv*))
  7870.                 ; Platz für die Funktion selbst:
  7871.                 (push 1 *stackz*)
  7872.                 (let* ((condition-sym (gensym))
  7873.                        (condition-anode
  7874.                          (make-anode :type 'CONDITION
  7875.                                      :sub-anodes '()
  7876.                                      :seclass '(T . NIL)
  7877.                                      :code '() ; vorher kommt (HANDLER-BEGIN)
  7878.                        ) )
  7879.                        (condition-var (bind-movable-var condition-sym condition-anode)))
  7880.                   (push-*venv* condition-var)
  7881.                   (let ((body-anode
  7882.                           (c-form `(SYS::%FUNCALL ,handler ,condition-sym) 'NIL)
  7883.                        ))
  7884.                     ; Überprüfen der Variablen (muß nicht in die Closure):
  7885.                     (checking-movable-var-list (list condition-var) (list condition-anode))
  7886.                     (let* ((codelist
  7887.                              `(,label
  7888.                                (HANDLER-BEGIN)
  7889.                                ,@(c-bind-movable-var-anode condition-var condition-anode)
  7890.                                ,body-anode
  7891.                                (UNWINDSP ,*stackz* ,*func*) ; ein (SKIPSP k)
  7892.                                (UNWIND ,*stackz* ,oldstackz NIL) ; ein (SKIP 2)
  7893.                                (RET)
  7894.                               )
  7895.                            )
  7896.                            (anode
  7897.                              (make-anode
  7898.                                :type 'HANDLER
  7899.                                :sub-anodes `(,body-anode)
  7900.                                :seclass '(T . T) ; eigentlich irrelevant
  7901.                                :stackz oldstackz
  7902.                                :code codelist
  7903.                           )) )
  7904.                       (optimize-var-list (list condition-var))
  7905.                       anode
  7906.               ) ) ) )
  7907.               handler-anodes
  7908.             )
  7909.     ) ) ) )
  7910.     (if (null types)
  7911.       (c-form `(PROGN ,@body))
  7912.       (progn
  7913.         (setq types (nreverse types))
  7914.         (setq handler-labels (nreverse handler-labels))
  7915.         (setq handler-anodes (nreverse handler-anodes))
  7916.         (let* ((label (make-label 'NIL))
  7917.                (oldstackz *stackz*)
  7918.                (*stackz* (cons 4 *stackz*)) ; HANDLER-Frame
  7919.                (body-anode (c-form `(PROGN ,@body))))
  7920.           (make-anode
  7921.             :type 'HANDLER-BIND
  7922.             :sub-anodes `(,body-anode ,@handler-anodes)
  7923.             :seclass (anodelist-seclass-or `(,body-anode ,@handler-anodes))
  7924.             :stackz oldstackz
  7925.             :code `((HANDLER-OPEN ,(new-const (coerce types 'vector)) ,*stackz* ,@handler-labels)
  7926.                     (JMP ,label)
  7927.                     ,@handler-anodes
  7928.                     ,label
  7929.                     ,body-anode
  7930.                     (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  7931.                    )
  7932.     ) ) ) )
  7933. ) )
  7934.  
  7935. ; compiliere (SYS::CONSTANT-EQL form1 form2 form3)
  7936. (defun c-CONSTANT-EQL ()
  7937.   (test-list *form* 4 4)
  7938.   (let ((form1 (second *form*))
  7939.         (form23 (cddr *form*)))
  7940.     (if (and *compiling-from-file*
  7941.              (c-constantp form1)
  7942.              (let ((value (c-constant-value form1)))
  7943.                (or (stringp value) (bit-vector-p value))
  7944.         )    )
  7945.       (c-form `(SYS::LOOSE-CONSTANT-EQL ,@form23))
  7946.       (c-form `(EQL ,@form23))
  7947. ) ) )
  7948.  
  7949.  
  7950. ;   ERSTER PASS :   I N L I N E - F U N K T I O N E N   (PRIMOPS)
  7951.  
  7952. ; Funktionsaufrufe, die wie special forms behandelt werden:
  7953.  
  7954. ; Erst FUNCALL bzw. SYS::%FUNCALL.
  7955.  
  7956. ; (c-FUNCALL-NOTINLINE funform args) compiliert einen Funktionsaufruf
  7957. ; (SYS::%FUNCALL funform . args),
  7958. ; für den das STACK-Layout der Argumente nicht zur Compile-Zeit bestimmt
  7959. ; werden kann.
  7960. (defun c-FUNCALL-NOTINLINE (funform args)
  7961.   (test-list args 0)
  7962.   (let* ((anode1 (c-form funform 'ONE))
  7963.          (*stackz* (cons 1 *stackz*)))
  7964.     (do ((formlistr args (cdr formlistr))
  7965.          #+COMPILER-DEBUG (anodelist (list anode1))
  7966.          (codelist (list '(FUNCALLP) anode1)))
  7967.         ((null formlistr)
  7968.          (push `(FUNCALL ,(length args)) codelist)
  7969.          (make-anode
  7970.            :type 'FUNCALL
  7971.            :sub-anodes (nreverse anodelist)
  7972.            :seclass '(T . T)
  7973.            :code (nreverse codelist)
  7974.         ))
  7975.       (let ((anode (c-form (car formlistr) 'ONE)))
  7976.         #+COMPILER-DEBUG (push anode anodelist)
  7977.         (push anode codelist)
  7978.       )
  7979.       (push '(PUSH) codelist)
  7980.       (push 1 *stackz*)
  7981. ) ) )
  7982.  
  7983. ; (c-FUNCALL-INLINE funform args applyargs lambdabody sameenv) compiliert einen
  7984. ; Funktionsaufruf (SYS::%FUNCALL funform . args) bzw.
  7985. ; (APPLY funform . args applyargs) [applyargs eine Liste aus einer Form],
  7986. ; für den das STACK-Layout der Argumente zur Compile-Zeit bestimmt werden kann.
  7987. ; sameenv gibt an, ob lambdabody im selben Environment oder im
  7988. ; Top-Level-Environment zu betrachten ist.
  7989. (defun c-FUNCALL-INLINE (funform arglist applyarglist lambdabody sameenv)
  7990.   (test-list lambdabody 1)
  7991.   (multiple-value-bind (reqvar  optvar optinit optsvar  restvar
  7992.                         keyflag keyword keyvar keyinit keysvar allow-other-keys
  7993.                         auxvar auxinit)
  7994.       (analyze-lambdalist (pop lambdabody))
  7995.     (when (or keyflag keyword keyvar keyinit keysvar allow-other-keys)
  7996.       (compiler-error 'c-FUNCALL-INLINE)
  7997.     )
  7998.     (let ((r (length reqvar)) ; Anzahl der required-Argumente
  7999.           (s (length optvar)) ; Anzahl der optionalen Argumente
  8000.           (|t| (length arglist))) ; Anzahl der angegebenen Argumente
  8001.       (when (and (null restvar) (> |t| (+ r s)))
  8002.         ; zu viele Argumente angegeben. Wird beseitigt durch Einführung
  8003.         ; mehrerer zusätzlicher optionaler Argumente:
  8004.         (catch 'c-error
  8005.           (c-error 
  8006.            #L{
  8007.            DEUTSCH "Zuviele Argumente für ~S"
  8008.            ENGLISH "Too many arguments to ~S"
  8009.            FRANCAIS "Trop d'arguments pour ~S"
  8010.            }
  8011.            funform
  8012.         ) )
  8013.         (dotimes (i (- |t| (+ r s)))
  8014.           (let ((var (gensym)))
  8015.             (setq optvar (append optvar (list var)))
  8016.             (setq optinit (append optinit (list nil)))
  8017.             (setq optsvar (append optsvar (list nil)))
  8018.             (incf s)
  8019.             (push `(DECLARE (IGNORE ,var)) lambdabody)
  8020.       ) ) )
  8021.       (when (and (null applyarglist) (< |t| r))
  8022.         ; zu wenige Argumente angegeben. Wird beseitigt durch Einführung
  8023.         ; zusätzlicher Argumente:
  8024.         (catch 'c-error
  8025.           (c-error 
  8026.            #L{
  8027.            DEUTSCH "Zuwenig Argumente für ~S"
  8028.            ENGLISH "Too few arguments to ~S"
  8029.            FRANCAIS "Trop peu d'arguments pour ~S"
  8030.            }
  8031.            funform
  8032.         ) )
  8033.         (setq arglist (append arglist (make-list (- r |t|) :initial-element nil)))
  8034.         (setq |t| r)
  8035.       )
  8036.       ; Nun ist (t>=r oder apply-arg da) und (t<=r+s oder &rest-Parameter da).
  8037.       (let ((oldstackz *stackz*)
  8038.             (oldvenv *venv*)
  8039.             (oldfenv *fenv*)
  8040.             (oldbenv *benv*)
  8041.             (oldgenv *genv*)
  8042.             (olddenv *denv*)
  8043.             (*stackz* *stackz*)
  8044.             (*venv* (and sameenv *venv*))
  8045.             (*venvc* *venvc*)
  8046.             (*fenv* (and sameenv *fenv*))
  8047.             (*benv* (and sameenv *benv*))
  8048.             (*genv* (and sameenv *genv*))
  8049.             (*denv* (if sameenv
  8050.                       *denv*
  8051.                       (cons `(INLINING ,funform)
  8052.                             (remove-if-not #'(lambda (declspec)
  8053.                                                (case (car declspec)
  8054.                                                  ((DECLARATION SYS::IN-DEFUN INLINING) t)
  8055.                                                  (t nil)
  8056.                                              ) )
  8057.                                            *denv*
  8058.            ))       ) )     )
  8059.         (multiple-value-bind (body-rest declarations)
  8060.             (parse-body lambdabody t (vector *venv* *fenv*))
  8061.           (let (*specials* *ignores* *ignorables*
  8062.                 req-vars req-anodes req-stackzs
  8063.                 opt-vars opt-anodes opt-stackzs ; optionale und svar zusammen!
  8064.                 rest-vars rest-anodes rest-stackzs
  8065.                 fixed-anodes fixed-stackz
  8066.                 reqfixed-vars reqfixed-dummys reqfixed-stackzs
  8067.                 optfixed-vars optfixed-dummys optfixed-anodes
  8068.                 optsfixed-vars optsfixed-anodes optfixed-stackzs
  8069.                 restfixed-vars restfixed-dummys restfixed-stackzs
  8070.                 aux-vars aux-anodes
  8071.                 closuredummy-stackz closuredummy-venvc
  8072.                )
  8073.             (multiple-value-setq (*specials* *ignores* *ignorables*)
  8074.               (process-declarations declarations)
  8075.             )
  8076.             ; Special-Variable auf *venv* pushen:
  8077.             (push-specials)
  8078.             (push 0 *stackz*) (push nil *venvc*) ; Platz für Closure-Dummyvar
  8079.             (setq closuredummy-stackz *stackz* closuredummy-venvc *venvc*)
  8080.             (flet ((finish-using-applyarg (reqvar optvar optinit optsvar restvar)
  8081.                      ; reqvar und optvar/optinit/optsvar sowie arglist sind schon
  8082.                      ; teilweise verkürzt. Zerlegen der weiteren Argumentliste
  8083.                      ; mittels UNLIST bzw. UNLIST*. Daher ein Stackaufbau mit
  8084.                      ; festem Aussehen, vgl. c-LAMBDABODY.
  8085.                      (setq fixed-anodes
  8086.                            (list
  8087.                              (let ((anode1 (let ((*venv* oldvenv)
  8088.                                                  (*fenv* oldfenv)
  8089.                                                  (*benv* oldbenv)
  8090.                                                  (*genv* oldgenv)
  8091.                                                  (*denv* olddenv))
  8092.                                              (c-form (first applyarglist) 'ONE)
  8093.                                    )       )
  8094.                                    (anode2 (c-unlist (not (eql restvar 0))
  8095.                                                      (+ (length reqvar) (length optvar))
  8096.                                                      (length optvar)
  8097.                                   ))       )
  8098.                                (make-anode
  8099.                                  :type 'APPLY-UNLIST
  8100.                                  :sub-anodes (list anode1 anode2)
  8101.                                  :seclass (anodes-seclass-or anode1 anode2)
  8102.                                  :code `(,anode1 ,anode2)
  8103.                      )     ) ) )
  8104.                      ; Stack-Dummy-Variable für die reqvar,optvar,restvar bilden:
  8105.                      (multiple-value-setq (reqfixed-vars reqfixed-dummys)
  8106.                        (process-fixed-var-list reqvar)
  8107.                      )
  8108.                      (multiple-value-setq (optfixed-vars optfixed-dummys)
  8109.                        (process-fixed-var-list optvar)
  8110.                      )
  8111.                      (multiple-value-setq (restfixed-vars restfixed-dummys)
  8112.                        (if (eql restvar 0)
  8113.                          (values '() '())
  8114.                          (process-fixed-var-list (list restvar))
  8115.                      ) )
  8116.                      (push 0 *stackz*) (setq fixed-stackz *stackz*)
  8117.                      ; Bindungen der required-Parameter aktivieren:
  8118.                      (setq reqfixed-stackzs (bind-req-vars reqfixed-vars))
  8119.                      ; Bindungen der optional-Parameter/svar aktivieren:
  8120.                      (multiple-value-setq (optfixed-anodes optfixed-stackzs optsfixed-vars optsfixed-anodes)
  8121.                        (bind-opt-vars optfixed-vars optfixed-dummys optinit optsvar)
  8122.                      )
  8123.                      ; Bindung des rest-Parameters aktivieren:
  8124.                      (unless (eql restvar 0)
  8125.                        (setq restfixed-stackzs (bind-rest-vars restfixed-vars))
  8126.                      )
  8127.                   ))
  8128.               (block main-args
  8129.                 ; required-Parameter binden:
  8130.                 (do ((reqvarr reqvar (cdr reqvarr)))
  8131.                     ((null reqvarr))
  8132.                   (if (null arglist) ; impliziert, daß apply-arg da
  8133.                     (return-from main-args
  8134.                       (finish-using-applyarg reqvarr optvar optinit optsvar restvar)
  8135.                     )
  8136.                     (let* ((form (pop arglist))
  8137.                            (anode (let ((*venv* oldvenv)
  8138.                                         (*fenv* oldfenv)
  8139.                                         (*benv* oldbenv)
  8140.                                         (*genv* oldgenv)
  8141.                                         (*denv* olddenv))
  8142.                                     (c-form form 'ONE)
  8143.                            )      )
  8144.                            (var (bind-movable-var (car reqvarr) anode)))
  8145.                       (push anode req-anodes)
  8146.                       (push var req-vars)
  8147.                       (push *stackz* req-stackzs)
  8148.                       (push-*venv* var)
  8149.                 ) ) )
  8150.                 ; optionale Parameter und Svars binden:
  8151.                 (do ((optvarr optvar (cdr optvarr))
  8152.                      (optinitr optinit (cdr optinitr))
  8153.                      (optsvarr optsvar (cdr optsvarr)))
  8154.                     ((null optvarr))
  8155.                   (if (and applyarglist (null arglist))
  8156.                     (return-from main-args
  8157.                       (finish-using-applyarg '() optvarr optinitr optsvarr restvar)
  8158.                     )
  8159.                     (let* ((svar-init (not (null arglist))) ; = NIL oder T
  8160.                            (anode (if svar-init
  8161.                                     (progn
  8162.                                       (let ((*no-code* t))
  8163.                                         (c-form (car optinitr) 'NIL)
  8164.                                       )
  8165.                                       (let ((*venv* oldvenv)
  8166.                                             (*fenv* oldfenv)
  8167.                                             (*benv* oldbenv)
  8168.                                             (*genv* oldgenv)
  8169.                                             (*denv* olddenv))
  8170.                                         (c-form (pop arglist) 'ONE)
  8171.                                     ) )
  8172.                                     (c-form (car optinitr) 'ONE)
  8173.                            )      )
  8174.                            (var (bind-movable-var (car optvarr) anode)))
  8175.                       (push anode opt-anodes)
  8176.                       (push var opt-vars)
  8177.                       (push *stackz* opt-stackzs)
  8178.                       (push-*venv* var)
  8179.                       (unless (eql (car optsvarr) 0)
  8180.                         (let* ((anode (c-form svar-init 'ONE))
  8181.                                (var (bind-movable-var (car optsvarr) anode)))
  8182.                           (push anode opt-anodes)
  8183.                           (push var opt-vars)
  8184.                           (push *stackz* opt-stackzs)
  8185.                           (push-*venv* var)
  8186.                       ) )
  8187.                 ) ) )
  8188.                 (if (eql restvar 0)
  8189.                   ; weitere Argumente verbrauchen:
  8190.                   (when applyarglist
  8191.                     (return-from main-args
  8192.                       (finish-using-applyarg '() '() '() '() restvar)
  8193.                   ) )
  8194.                   ; Rest-Parameter binden:
  8195.                   (let* ((form (if applyarglist
  8196.                                  (if arglist `(LIST* ,@arglist ,@applyarglist) (first applyarglist))
  8197.                                  (if arglist `(LIST ,@arglist) 'NIL)
  8198.                          )     )
  8199.                          (anode (let ((*venv* oldvenv)
  8200.                                       (*fenv* oldfenv)
  8201.                                       (*benv* oldbenv)
  8202.                                       (*genv* oldgenv)
  8203.                                       (*denv* olddenv))
  8204.                                   (c-form form 'ONE)
  8205.                          )      )
  8206.                          (var (bind-movable-var restvar anode)))
  8207.                     (push anode rest-anodes)
  8208.                     (push var rest-vars)
  8209.                     (push *stackz* rest-stackzs)
  8210.                     (push-*venv* var)
  8211.                 ) )
  8212.                 (push 0 *stackz*) (setq fixed-stackz *stackz*)
  8213.             ) )
  8214.             (setq req-vars (nreverse req-vars))
  8215.             (setq req-anodes (nreverse req-anodes))
  8216.             (setq req-stackzs (nreverse req-stackzs))
  8217.             (setq opt-vars (nreverse opt-vars))
  8218.             (setq opt-anodes (nreverse opt-anodes))
  8219.             (setq opt-stackzs (nreverse opt-stackzs))
  8220.             ; Bindungen der Aux-Variablen aktivieren:
  8221.             (multiple-value-setq (aux-vars aux-anodes)
  8222.               (bind-aux-vars auxvar auxinit)
  8223.             )
  8224.             (let* ((body-anode (c-form `(PROGN ,@body-rest)))
  8225.                    ; Überprüfen der Variablen:
  8226.                    (varlist
  8227.                      (append req-vars opt-vars rest-vars
  8228.                              reqfixed-vars optfixed-vars optsfixed-vars restfixed-vars
  8229.                              aux-vars
  8230.                    ) )
  8231.                    (closurevars
  8232.                      (append
  8233.                        (checking-movable-var-list req-vars req-anodes)
  8234.                        (checking-movable-var-list opt-vars opt-anodes)
  8235.                        (checking-movable-var-list rest-vars rest-anodes)
  8236.                        (checking-fixed-var-list reqfixed-vars)
  8237.                        (checking-fixed-var-list optfixed-vars)
  8238.                        (checking-movable-var-list optsfixed-vars optsfixed-anodes)
  8239.                        (checking-fixed-var-list restfixed-vars)
  8240.                        (checking-movable-var-list aux-vars aux-anodes)
  8241.                    ) )
  8242.                    (codelist
  8243.                      `(,@(c-make-closure closurevars closuredummy-venvc closuredummy-stackz)
  8244.                        ,@(let ((*stackz* fixed-stackz))
  8245.                            (c-parallel-bind-movable-var-anode
  8246.                              (append req-vars    opt-vars    rest-vars   )
  8247.                              (append req-anodes  opt-anodes  rest-anodes )
  8248.                              (append req-stackzs opt-stackzs rest-stackzs)
  8249.                              fixed-anodes
  8250.                          ) )
  8251.                        ,@(mapcap #'c-bind-fixed-var reqfixed-vars reqfixed-dummys reqfixed-stackzs)
  8252.                        ,@(c-bind-with-svars optfixed-vars optfixed-dummys optsfixed-vars optfixed-anodes optsfixed-anodes optfixed-stackzs)
  8253.                        ,@(mapcap #'c-bind-fixed-var restfixed-vars restfixed-dummys restfixed-stackzs)
  8254.                        ,@(mapcap #'c-bind-movable-var-anode aux-vars aux-anodes)
  8255.                        ,body-anode
  8256.                        (UNWIND ,*stackz* ,oldstackz ,*for-value*)
  8257.                    )  )
  8258.                    (anode
  8259.                      (make-anode
  8260.                        :type 'FUNCALL
  8261.                        :sub-anodes
  8262.                          `(,@req-anodes ,@opt-anodes ,@rest-anodes
  8263.                            ,@fixed-anodes ,@optfixed-anodes ,@(remove nil optsfixed-anodes)
  8264.                            ,@aux-anodes ,body-anode
  8265.                           )
  8266.                        :seclass
  8267.                          (seclass-without
  8268.                            (anodelist-seclass-or
  8269.                              `(,@req-anodes ,@opt-anodes ,@rest-anodes
  8270.                                ,@fixed-anodes ,@optfixed-anodes ,@(remove nil optsfixed-anodes)
  8271.                                ,@aux-anodes ,body-anode
  8272.                            )  )
  8273.                            varlist
  8274.                          )
  8275.                        :stackz oldstackz
  8276.                        :code codelist
  8277.                   )) )
  8278.               (when closurevars
  8279.                 (setf (first closuredummy-stackz) 1) ; 1 Stackplatz für Dummy
  8280.                 (setf (first closuredummy-venvc)
  8281.                   (cons closurevars closuredummy-stackz)
  8282.               ) )
  8283.               (optimize-var-list varlist)
  8284.               anode
  8285. ) ) ) ) ) ) )
  8286.  
  8287. ; compiliert (fun {form}*), wobei fun eine lokale Funktion ist.
  8288. ; fdescr die zugehörige Information aus *fenv*.
  8289. (defun c-LOCAL-FUNCTION-CALL (fun fdescr args)
  8290.   ; (test-list args 0) ; das erledigt gleich (test-argument-syntax ...)
  8291.   ; Aufruf-Spezifikation holen:
  8292.   (multiple-value-bind (req opt rest-flag key-flag keylist allow-flag)
  8293.       (fdescr-signature fdescr)
  8294.     (case (test-argument-syntax
  8295.             args nil fun req opt rest-flag key-flag keylist allow-flag
  8296.           )
  8297.       ((NO-KEYS STATIC-KEYS)
  8298.        ; Aufruf INLINE
  8299.        (c-DIRECT-FUNCTION-CALL
  8300.          args nil fun req opt rest-flag key-flag keylist
  8301.          nil ; kein SUBR-, sondern Cclosure-Aufruf
  8302.          (cclosure-call-code-producer fun (car fdescr) req opt rest-flag key-flag keylist)
  8303.       ))
  8304.       (t (c-FUNCALL-NOTINLINE `(FUNCTION ,fun) args))
  8305. ) ) )
  8306.  
  8307. ; (c-FUNCTION-CALL funform arglist) compiliert einen Funktionsaufruf
  8308. ; (SYS::%FUNCALL funform . arglist).
  8309. (defun c-FUNCTION-CALL (funform arglist)
  8310.   (when (inline-callable-function-p funform (length arglist))
  8311.     ; Aufruf eines Lambda-Ausdrucks INLINE möglich
  8312.     (return-from c-FUNCTION-CALL
  8313.       (c-FUNCALL-INLINE funform arglist nil (cdr (second funform)) t)
  8314.   ) )
  8315.   (when (and (consp funform) (eq (first funform) 'COMPLEMENT)
  8316.              (consp (rest funform)) (null (cddr funform))
  8317.              (not (fenv-search 'COMPLEMENT)) (not (declared-notinline 'COMPLEMENT))
  8318.              (not (fenv-search 'NOT))
  8319.         )
  8320.     ; (complement fn) --> (let ((f fn)) ... #'(lambda (&rest args) (not (apply f args))) ...)
  8321.     (return-from c-FUNCTION-CALL
  8322.       (c-form `(NOT (SYS::%FUNCALL ,(second funform) ,@arglist)))
  8323.   ) )
  8324.   (when (and (consp funform) (eq (first funform) 'FUNCTION)
  8325.              ; Ausdrücke der Form (FUNCTION ...) dürfen zu beliebigem
  8326.              ; Zeitpunkt ausgewertet werden, also ist
  8327.              ; (SYS::%FUNCALL (FUNCTION fun) . arglist)  äquivalent zu
  8328.              ; (fun . arglist).
  8329.              (consp (rest funform)) (function-name-p (second funform)) ; vorerst nur #'sym, sonst Endlosschleife!
  8330.         )
  8331.     (return-from c-FUNCTION-CALL
  8332.       (progn
  8333.         (test-list funform 2 2)
  8334.         (c-form `(,(second funform) ,@arglist)) ; genauer aufschlüsseln, vgl. c-FUNCTION ??
  8335.   ) ) )
  8336.   ; Aufruf NOTINLINE
  8337.   (c-FUNCALL-NOTINLINE funform arglist)
  8338. )
  8339.  
  8340. (defun c-FUNCALL ()
  8341.   (test-list *form* 2)
  8342.   (c-FUNCTION-CALL (second *form*) (cddr *form*))
  8343. )
  8344.  
  8345. (defun c-APPLY ()
  8346.   (test-list *form* 3)
  8347.   (let* ((funform (second *form*))
  8348.          (arglist (cddr *form*))
  8349.          (n (1- (length arglist)))) ; Mindestanzahl Argumente
  8350.     (when (inline-callable-function-p funform n t)
  8351.       ; Aufruf eines Lambda-Ausdrucks INLINE möglich
  8352.       (return-from c-APPLY
  8353.         (c-FUNCALL-INLINE funform (butlast arglist) (last arglist) (cdr (second funform)) t)
  8354.     ) )
  8355.     (when (and (consp funform) (eq (first funform) 'COMPLEMENT)
  8356.                (consp (rest funform)) (null (cddr funform))
  8357.                (not (fenv-search 'COMPLEMENT)) (not (declared-notinline 'COMPLEMENT))
  8358.                (not (fenv-search 'NOT))
  8359.           )
  8360.       ; (complement fn) --> (let ((f fn)) ... #'(lambda (&rest args) (not (apply f args))) ...)
  8361.       (return-from c-APPLY
  8362.         (c-form `(NOT (APPLY ,(second funform) ,@arglist)))
  8363.     ) )
  8364.     (when (and (consp funform) (eq (first funform) 'FUNCTION)
  8365.                ; Ausdrücke der Form (FUNCTION ...) dürfen zu beliebigem
  8366.                ; Zeitpunkt ausgewertet werden.
  8367.                (consp (rest funform)) (function-name-p (second funform))
  8368.           )
  8369.       (let ((fun (second funform)))
  8370.         (test-list funform 2 2)
  8371.         (unless (declared-notinline fun) ; darf fun INLINE genommen werden?
  8372.           (flet ((c-LOCAL-APPLY (fdescr)
  8373.                    (multiple-value-bind (req opt rest-flag key-flag keylist allow-flag)
  8374.                        (fdescr-signature fdescr)
  8375.                      (unless key-flag
  8376.                        ; ohne Keyword-Argumente
  8377.                        (when (eq (test-argument-syntax (butlast arglist) (last arglist)
  8378.                                    fun req opt rest-flag key-flag keylist allow-flag
  8379.                                  )
  8380.                                'NO-KEYS
  8381.                              )
  8382.                          ; Syntax stimmt -> Aufruf INLINE
  8383.                          (return-from c-APPLY
  8384.                            (c-DIRECT-FUNCTION-CALL (butlast arglist) (last arglist)
  8385.                              fun req opt rest-flag key-flag keylist
  8386.                              nil ; kein SUBR-, sondern Cclosure-Aufruf
  8387.                              (cclosure-call-code-producer fun (car fdescr) req opt rest-flag key-flag keylist)
  8388.                 )) ) ) ) ) )
  8389.             (multiple-value-bind (a b c) (fenv-search fun)
  8390.               (declare (ignore b))
  8391.               ; (APPLY #'fun . args) kann evtl. vereinfacht werden
  8392.               (case a
  8393.                 ((NIL) ; globale Funktion
  8394.                   (unless (and (symbolp fun) (or (special-form-p fun) (macro-function fun))) ; Special-Form oder globaler Macro ?
  8395.                     (when (and (equal fun (fnode-name *func*))
  8396.                                (member `(SYS::IN-DEFUN ,fun) *denv* :test #'equal)
  8397.                           )
  8398.                       ; rekursiver Aufruf der aktuellen globalen Funktion
  8399.                       (c-LOCAL-APPLY (cons *func* nil))
  8400.                     )
  8401.                     (let ((inline-lambdabody
  8402.                             (or (and *compiling-from-file*
  8403.                                      (cdr (assoc fun *inline-definitions* :test #'equal))
  8404.                                 )
  8405.                                 (get (sys::get-funname-symbol fun) 'sys::inline-expansion)
  8406.                          )) )
  8407.                       (if (and #| inline-lambdabody |#
  8408.                                (consp inline-lambdabody)
  8409.                                (inline-callable-function-p `(FUNCTION (LAMBDA ,@inline-lambdabody)) n t)
  8410.                           )
  8411.                         ; Aufruf einer globalen Funktion INLINE möglich
  8412.                         (return-from c-APPLY
  8413.                           (c-FUNCALL-INLINE fun (butlast arglist) (last arglist) inline-lambdabody nil)
  8414.                 ) ) ) ) )
  8415.                 (LOCAL ; lokale Funktion
  8416.                   (c-LOCAL-APPLY c)
  8417.               ) )
  8418.     ) ) ) ) )
  8419.     ; Wenn keine der Optimierungen möglich war:
  8420.     (let* ((anode1 (c-form funform 'ONE))
  8421.            (*stackz* (cons 1 *stackz*)))
  8422.       (do ((formlistr arglist (cdr formlistr))
  8423.            #+COMPILER-DEBUG (anodelist (list anode1))
  8424.            (codelist (list '(APPLYP) anode1)))
  8425.           ((null formlistr)
  8426.            (push `(APPLY ,n) codelist)
  8427.            (make-anode
  8428.              :type 'APPLY
  8429.              :sub-anodes (nreverse anodelist)
  8430.              :seclass '(T . T)
  8431.              :code (nreverse codelist)
  8432.           ))
  8433.         (let ((anode (c-form (car formlistr) 'ONE)))
  8434.           #+COMPILER-DEBUG (push anode anodelist)
  8435.           (push anode codelist)
  8436.           (when (cdr formlistr)
  8437.             (push 1 *stackz*) (push '(PUSH) codelist)
  8438.     ) ) ) )
  8439. ) )
  8440.  
  8441. (defun c-PLUS ()
  8442.   (test-list *form* 1)
  8443.   ; bilde Teilsumme der konstanten Argumente, Rest dann dazu:
  8444.   (let ((const-sum 0)
  8445.         (other-parts '())
  8446.         val
  8447.        )
  8448.     (dolist (form (cdr *form*))
  8449.       (if (and (c-constantp form) (numberp (setq val (c-constant-value form))))
  8450.         (setq const-sum (+ const-sum val))
  8451.         (push form other-parts)
  8452.     ) )
  8453.     (case (length other-parts)
  8454.       (0 ; nur konstante Summanden
  8455.          (c-form const-sum) ; Zahl const-sum wertet zu sich selbst aus
  8456.       )
  8457.       (1 ; nur ein variabler Summand
  8458.          (case const-sum
  8459.            (0 (c-form (first other-parts))) ; keine Addition nötig
  8460.            (+1 (c-form `(1+ ,(first other-parts))))
  8461.            (-1 (c-form `(1- ,(first other-parts))))
  8462.            (t (c-GLOBAL-FUNCTION-CALL-form `(+ ,const-sum ,@other-parts)))
  8463.       )  )
  8464.       (t (setq other-parts (nreverse other-parts))
  8465.          (unless (eql const-sum 0) (push const-sum other-parts))
  8466.          (c-GLOBAL-FUNCTION-CALL-form `(+ ,@other-parts))
  8467. ) ) ) )
  8468.  
  8469. (defun c-MINUS ()
  8470.   (test-list *form* 2)
  8471.   (let ((unary-p (= (length *form*) 2)) ; unäres Minus oder nicht?
  8472.         (const-sum 0) ; Summe der konstanten Teile
  8473.         (first-part 0) ; zu addierende Form
  8474.         (other-parts '()) ; abzuziehende Formen
  8475.         val
  8476.        )
  8477.     (unless unary-p
  8478.       (let ((form (second *form*)))
  8479.         (if (and (c-constantp form) (numberp (setq val (c-constant-value form))))
  8480.           (setq const-sum val)
  8481.           (setq first-part form)
  8482.     ) ) )
  8483.     (dolist (form (if unary-p (cdr *form*) (cddr *form*)))
  8484.       (if (and (c-constantp form) (numberp (setq val (c-constant-value form))))
  8485.         (setq const-sum (- const-sum val))
  8486.         (push form other-parts)
  8487.     ) )
  8488.     (if (null other-parts)
  8489.       ; nichts zu subtrahieren
  8490.       (let ((*form* `(+ ,const-sum ,first-part))) (c-PLUS))
  8491.       ; etwas zu subtrahieren
  8492.       (c-GLOBAL-FUNCTION-CALL-form
  8493.         `(-
  8494.           ,@(if (eql first-part 0) ; variable zu addierende Form?
  8495.               (if (and (eql const-sum 0) (null (cdr other-parts)))
  8496.                 '()
  8497.                 `(,const-sum)
  8498.               )
  8499.               (if (eql const-sum 0)
  8500.                 `(,first-part)
  8501.                 `(,first-part ,(- const-sum))
  8502.             ) )
  8503.           ,@(nreverse other-parts)
  8504.          )
  8505. ) ) ) )
  8506.  
  8507. (defun c-SVSTORE ()
  8508.   (test-list *form* 4 4)
  8509.   ; (sys::svstore arg1 arg2 arg3) -> (sys::%svstore arg3 arg1 arg2)
  8510.   (let ((arg1 (second *form*)) (arg2 (third *form*)) (arg3 (fourth *form*))
  8511.         (argvar1 (gensym)) (argvar2 (gensym)))
  8512.     (c-form
  8513.       `(LET* ((,argvar1 ,arg1) (,argvar2 ,arg2))
  8514.          (sys::%svstore ,arg3 ,argvar1 ,argvar2)
  8515.        )
  8516. ) ) )
  8517.  
  8518. (defun c-EQ ()
  8519.   (test-list *form* 3 3)
  8520.   (let ((arg1 (second *form*)) (arg2 (third *form*)))
  8521.     (if (and (c-constantp arg1) (c-constantp arg2))
  8522.       (c-form `(QUOTE ,(eq (c-constant-value arg1) (c-constant-value arg2))))
  8523.       (progn
  8524.         (when (c-constantp arg1)
  8525.           (rotatef arg1 arg2) ; Besser arg2 konstant, damit JMPIFEQTO geht
  8526.         )
  8527.         (if (and (c-constantp arg2) (eq (c-constant-value arg2) 'NIL))
  8528.           (c-GLOBAL-FUNCTION-CALL-form `(NULL ,arg1))
  8529.           (c-GLOBAL-FUNCTION-CALL-form `(EQ ,arg1 ,arg2))
  8530. ) ) ) ) )
  8531.  
  8532. ; bei Symbolen, Fixnums und Characters ist EQL mit EQ gleichbedeutend
  8533. (defun EQL=EQ (x) (or (symbolp x) (fixnump x) (characterp x)))
  8534.  
  8535. (defun c-EQL ()
  8536.   (test-list *form* 3 3)
  8537.   (let ((arg1 (second *form*)) (arg2 (third *form*)))
  8538.     (cond ((and (c-constantp arg1) (c-constantp arg2))
  8539.            (c-form `(QUOTE ,(eql (c-constant-value arg1) (c-constant-value arg2))))
  8540.           )
  8541.           ((or (and (c-constantp arg1) (EQL=EQ (c-constant-value arg1)))
  8542.                (and (c-constantp arg2) (EQL=EQ (c-constant-value arg2)))
  8543.            )
  8544.            (let ((*form* `(EQ ,arg1 ,arg2))) (c-EQ))
  8545.           )
  8546.           (t (c-GLOBAL-FUNCTION-CALL 'EQL))
  8547. ) ) )
  8548.  
  8549. ; bei Symbolen, Zahlen und Characters ist EQUAL mit EQL gleichbedeutend
  8550. (defun EQUAL=EQL (x) (or (symbolp x) (numberp x) (characterp x)))
  8551.  
  8552. (defun c-EQUAL ()
  8553.   (test-list *form* 3 3)
  8554.   (let ((arg1 (second *form*)) (arg2 (third *form*)))
  8555.     (cond ((or (and (c-constantp arg1) (EQUAL=EQL (c-constant-value arg1)))
  8556.                (and (c-constantp arg2) (EQUAL=EQL (c-constant-value arg2)))
  8557.            )
  8558.            (let ((*form* `(EQL ,arg1 ,arg2))) (c-EQL))
  8559.           )
  8560.           (t (c-GLOBAL-FUNCTION-CALL 'EQUAL))
  8561. ) ) )
  8562.  
  8563. ; Bildet den inneren Teil einer MAPCAR/MAPC/MAPCAN/MAPCAP-Expansion
  8564. (defun c-MAP-on-CARs-inner (innerst-fun blockname restvars &optional (itemvars '()))
  8565.   (if (null restvars)
  8566.     (funcall innerst-fun (nreverse itemvars))
  8567.     (let ((restvar (car restvars))
  8568.           (itemvar (gensym)))
  8569.       `(IF (CONSP ,restvar)
  8570.          (LET ((,itemvar (CAR ,restvar)))
  8571.            ,(c-MAP-on-CARs-inner innerst-fun blockname (cdr restvars) (cons itemvar itemvars))
  8572.          )
  8573.          (RETURN-FROM ,blockname)
  8574. ) ) )  )
  8575.  
  8576. ; Bildet eine MAPCAR/MAPCAN/MAPCAP-Expansion
  8577. (defun c-MAP-on-CARs (adjoin-fun funform forms)
  8578.   (let ((erg (gensym))
  8579.         (blockname (gensym))
  8580.         (restvars
  8581.           (mapcar #'(lambda (form) (declare (ignore form)) (gensym)) forms)
  8582.         )
  8583.         (tag (gensym)))
  8584.     `(LET ((,erg NIL))
  8585.        (BLOCK ,blockname
  8586.          (LET* ,(mapcar #'list restvars forms)
  8587.            (TAGBODY ,tag
  8588.              ,(c-MAP-on-CARs-inner
  8589.                 #'(lambda (itemvars)
  8590.                     `(SETQ ,erg (,adjoin-fun (SYS::%FUNCALL ,funform ,@itemvars) ,erg))
  8591.                   )
  8592.                 blockname
  8593.                 restvars
  8594.               )
  8595.              (SETQ ,@(mapcap #'(lambda (restvar)
  8596.                                  `(,restvar (CDR ,restvar))
  8597.                                )
  8598.                              restvars
  8599.              )       )
  8600.              (GO ,tag)
  8601.        ) ) )
  8602.        (SYS::LIST-NREVERSE ,erg)
  8603. ) )  )
  8604.  
  8605. ; Bildet eine MAPLIST/MAPCON/MAPLAP-Expansion
  8606. (defun c-MAP-on-LISTs (adjoin-fun funform forms)
  8607.   (let ((erg (gensym))
  8608.         (blockname (gensym))
  8609.         (restvars
  8610.           (mapcar #'(lambda (form) (declare (ignore form)) (gensym)) forms)
  8611.         )
  8612.         (tag (gensym)))
  8613.     `(LET ((,erg NIL))
  8614.        (BLOCK ,blockname
  8615.          (LET* ,(mapcar #'list restvars forms)
  8616.            (TAGBODY ,tag
  8617.              (IF (OR ,@(mapcar #'(lambda (restvar) `(ATOM ,restvar)) restvars))
  8618.                (RETURN-FROM ,blockname)
  8619.              )
  8620.              (SETQ ,erg (,adjoin-fun (SYS::%FUNCALL ,funform ,@restvars) ,erg))
  8621.              (SETQ ,@(mapcap #'(lambda (restvar)
  8622.                                  `(,restvar (CDR ,restvar))
  8623.                                )
  8624.                              restvars
  8625.              )       )
  8626.              (GO ,tag)
  8627.        ) ) )
  8628.        (SYS::LIST-NREVERSE ,erg)
  8629. ) )  )
  8630.  
  8631. (defun c-MAPC ()
  8632.   (test-list *form* 3)
  8633.   (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8634.     (c-form
  8635.       (let* ((tempvar (gensym))
  8636.              (forms (cons tempvar (cdddr *form*)))
  8637.              (blockname (gensym))
  8638.              (restvars
  8639.                (mapcar #'(lambda (form) (declare (ignore form)) (gensym)) forms)
  8640.              )
  8641.              (tag (gensym)))
  8642.         `(LET ((,tempvar ,(third *form*)))
  8643.            (BLOCK ,blockname
  8644.              (LET* ,(mapcar #'list restvars forms)
  8645.                (TAGBODY ,tag
  8646.                  ,(c-MAP-on-CARs-inner
  8647.                     #'(lambda (itemvars) `(SYS::%FUNCALL ,(second *form*) ,@itemvars))
  8648.                     blockname
  8649.                     restvars
  8650.                   )
  8651.                  (SETQ ,@(mapcap #'(lambda (restvar)
  8652.                                      `(,restvar (CDR ,restvar))
  8653.                                    )
  8654.                                  restvars
  8655.                  )       )
  8656.                  (GO ,tag)
  8657.            ) ) )
  8658.            ,tempvar
  8659.     ) )  )
  8660.     (c-GLOBAL-FUNCTION-CALL 'MAPC)
  8661. ) )
  8662.  
  8663. (defun c-MAPL ()
  8664.   (test-list *form* 3)
  8665.   (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8666.     (c-form
  8667.       (let* ((tempvar (gensym))
  8668.              (forms (cons tempvar (cdddr *form*)))
  8669.              (blockname (gensym))
  8670.              (restvars
  8671.                (mapcar #'(lambda (form) (declare (ignore form)) (gensym)) forms)
  8672.              )
  8673.              (tag (gensym)))
  8674.         `(LET ((,tempvar ,(third *form*)))
  8675.            (BLOCK ,blockname
  8676.              (LET* ,(mapcar #'list restvars forms)
  8677.                (TAGBODY ,tag
  8678.                  (IF (OR ,@(mapcar #'(lambda (restvar) `(ATOM ,restvar)) restvars))
  8679.                    (RETURN-FROM ,blockname)
  8680.                  )
  8681.                  (SYS::%FUNCALL ,(second *form*) ,@restvars)
  8682.                  (SETQ ,@(mapcap #'(lambda (restvar)
  8683.                                      `(,restvar (CDR ,restvar))
  8684.                                    )
  8685.                                  restvars
  8686.                  )       )
  8687.                  (GO ,tag)
  8688.            ) ) )
  8689.            ,tempvar
  8690.     ) )  )
  8691.     (c-GLOBAL-FUNCTION-CALL 'MAPL)
  8692. ) )
  8693.  
  8694. (defun c-MAPCAR ()
  8695.   (test-list *form* 3)
  8696.   (if (null *for-value*)
  8697.     (let ((*form* `(MAPC ,@(cdr *form*)))) (c-MAPC))
  8698.     (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8699.       (c-form (c-MAP-on-CARs 'CONS (second *form*) (cddr *form*)))
  8700.       (c-GLOBAL-FUNCTION-CALL 'MAPCAR)
  8701. ) ) )
  8702.  
  8703. (defun c-MAPLIST ()
  8704.   (test-list *form* 3)
  8705.   (if (null *for-value*)
  8706.     (let ((*form* `(MAPL ,@(cdr *form*)))) (c-MAPL))
  8707.     (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8708.       (c-form (c-MAP-on-LISTs 'CONS (second *form*) (cddr *form*)))
  8709.       (c-GLOBAL-FUNCTION-CALL 'MAPLIST)
  8710. ) ) )
  8711.  
  8712. (defun c-MAPCAN ()
  8713.   (test-list *form* 3)
  8714.   (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8715.     (c-form (c-MAP-on-CARs 'NRECONC (second *form*) (cddr *form*)))
  8716.     (c-GLOBAL-FUNCTION-CALL 'MAPCAN)
  8717. ) )
  8718.  
  8719. (defun c-MAPCON ()
  8720.   (test-list *form* 3)
  8721.   (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8722.     (c-form (c-MAP-on-LISTs 'NRECONC (second *form*) (cddr *form*)))
  8723.     (c-GLOBAL-FUNCTION-CALL 'MAPCON)
  8724. ) )
  8725.  
  8726. (defun c-MAPCAP ()
  8727.   (test-list *form* 3)
  8728.   (if (null *for-value*)
  8729.     (let ((*form* `(MAPC ,@(cdr *form*)))) (c-MAPC))
  8730.     (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8731.       (c-form (c-MAP-on-CARs 'REVAPPEND (second *form*) (cddr *form*)))
  8732.       (c-GLOBAL-FUNCTION-CALL 'MAPCAP)
  8733. ) ) )
  8734.  
  8735. (defun c-MAPLAP ()
  8736.   (test-list *form* 3)
  8737.   (if (null *for-value*)
  8738.     (let ((*form* `(MAPL ,@(cdr *form*)))) (c-MAPL))
  8739.     (if (inline-callable-function-p (second *form*) (length (cddr *form*)))
  8740.       (c-form (c-MAP-on-LISTs 'REVAPPEND (second *form*) (cddr *form*)))
  8741.       (c-GLOBAL-FUNCTION-CALL 'MAPLAP)
  8742. ) ) )
  8743.  
  8744. ;; c-TYPEP vgl. TYPEP in type.lsp
  8745. ; Symbole mit Property TYPE-SYMBOL:
  8746. (defconstant c-typep-alist1
  8747.   '((ARRAY . arrayp)
  8748.     (ATOM . atom)
  8749.     (BIT-VECTOR . bit-vector-p)
  8750.     (CHARACTER . characterp)
  8751.     (COMMON . commonp)
  8752.     (COMPILED-FUNCTION . compiled-function-p)
  8753.     (COMPLEX . complexp)
  8754.     (CONS . consp)
  8755.     (DOUBLE-FLOAT . double-float-p)
  8756.     (FIXNUM . fixnump)
  8757.     (FLOAT . floatp)
  8758.     (FUNCTION . functionp)
  8759.     (HASH-TABLE . hash-table-p)
  8760.     (INTEGER . integerp)
  8761.     (KEYWORD . keywordp)
  8762.     (LIST . listp)
  8763.     #+LOGICAL-PATHNAMES
  8764.     (LOGICAL-PATHNAME . sys::logical-pathname-p)
  8765.     (LONG-FLOAT . long-float-p)
  8766.     (NULL . null)
  8767.     (NUMBER . numberp)
  8768.     (PACKAGE . packagep)
  8769.     (PATHNAME . pathnamep)
  8770.     (RANDOM-STATE . random-state-p)
  8771.     (RATIONAL . rationalp)
  8772.     (READTABLE . readtablep)
  8773.     (REAL . realp)
  8774.     (SEQUENCE . sys::sequencep)
  8775.     (SHORT-FLOAT . short-float-p)
  8776.     (SIMPLE-ARRAY . sys::simple-array-p)
  8777.     (SIMPLE-BIT-VECTOR . simple-bit-vector-p)
  8778.     (SIMPLE-STRING . simple-string-p)
  8779.     (SIMPLE-VECTOR . simple-vector-p)
  8780.     (SINGLE-FLOAT . single-float-p)
  8781.     (CLOS:STANDARD-GENERIC-FUNCTION . clos::generic-function-p)
  8782.     (CLOS:STANDARD-OBJECT . clos::std-instance-p)
  8783.     (STREAM . streamp)
  8784.     (FILE-STREAM . sys::file-stream-p)
  8785.     (SYNONYM-STREAM . sys::synonym-stream-p)
  8786.     (BROADCAST-STREAM . sys::broadcast-stream-p)
  8787.     (CONCATENATED-STREAM . sys::concatenated-stream-p)
  8788.     (TWO-WAY-STREAM . sys::two-way-stream-p)
  8789.     (ECHO-STREAM . sys::echo-stream-p)
  8790.     (STRING-STREAM . sys::string-stream-p)
  8791.     (STRING . stringp)
  8792.     (SYMBOL . symbolp)
  8793.     (VECTOR . vectorp)
  8794. )  )
  8795. (defconstant c-typep-alist2
  8796.   '((BIGNUM . ((x) (and (integerp x) (not (fixnump x)))))
  8797.     (BIT . ((x) (or (eql x 0) (eql x 1))))
  8798.     (NIL . ((x) (declare (ignore x)) nil))
  8799.     (RATIO . ((x) (and (rationalp x) (not (integerp x)))))
  8800.     (STANDARD-CHAR . ((x) (and (characterp x) (standard-char-p x))))
  8801.     (STRING-CHAR . ((x) (and (characterp x) (string-char-p x))))
  8802.     (STRUCTURE .
  8803.       ((x)
  8804.         (let ((y (type-of x)))
  8805.           (and (symbolp y) (get y 'SYS::DEFSTRUCT-DESCRIPTION)
  8806.                (SYS::%STRUCTURE-TYPE-P y x)
  8807.     ) ) ) )
  8808.     (T . ((x) (declare (ignore x)) t))
  8809. )  )
  8810. (defun c-typep-array (tester)
  8811.   #'(lambda (x &optional (el-type '*) (dims '*) &rest illegal-args)
  8812.       (declare (ignore illegal-args))
  8813.       `(AND (,tester ,x)
  8814.             ,@(if (eq el-type '*)
  8815.                 '()
  8816.                 `((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type)))
  8817.               )
  8818.             ,@(if (eq dims '*)
  8819.                 '()
  8820.                 (if (numberp dims)
  8821.                   `((EQL ,dims (ARRAY-RANK ,x)))
  8822.                   `((EQL ,(length dims) (ARRAY-RANK ,x))
  8823.                     ,@(let ((i 0))
  8824.                         (mapcap #'(lambda (dim)
  8825.                                     (prog1
  8826.                                       (if (eq dim '*)
  8827.                                         '()
  8828.                                         `((EQL ',dim (ARRAY-DIMENSION ,x ,i)))
  8829.                                       )
  8830.                                       (incf i)
  8831.                                   ) )
  8832.                                 dims
  8833.                       ) )
  8834.                    )
  8835.               ) )
  8836.        )
  8837. )   )
  8838. (defun c-typep-vector (tester)
  8839.   #'(lambda (x &optional (size '*) &rest illegal-args)
  8840.       (declare (ignore illegal-args))
  8841.       `(AND (,tester ,x)
  8842.             ,@(if (eq size '*)
  8843.                 '()
  8844.                 `((EQL (ARRAY-DIMENSION ,x 0) ',size))
  8845.               )
  8846.        )
  8847.     )
  8848. )
  8849. (defun c-typep-number (caller tester)
  8850.   #'(lambda (x &optional (low '*) (high '*) &rest illegal-args)
  8851.       (declare (ignore illegal-args))
  8852.       `(AND (,tester ,x)
  8853.             ,@(cond ((eq low '*) '())
  8854.                     ((funcall tester low) `((<= ,low ,x)))
  8855.                     ((and (consp low) (null (rest low)) (funcall tester (first low)))
  8856.                      `((< ,(first low) ,x))
  8857.                     )
  8858.                     (t (c-warn 
  8859.                         #L{
  8860.                         DEUTSCH "~S: Argument zu ~S muß *, ~S oder eine Liste von ~S sein: ~S"
  8861.                         ENGLISH "~S: argument to ~S must be *, ~S or a list of ~S: ~S"
  8862.                         FRANCAIS "~S : L'argument de ~S doit être *, ~S ou une liste de ~S: ~S"
  8863.                         }
  8864.                         'typep caller caller caller low
  8865.                        )
  8866.                        (throw 'c-TYPEP nil)
  8867.               )     )
  8868.             ,@(cond ((eq high '*) '())
  8869.                     ((funcall tester high) `((>= ,high ,x)))
  8870.                     ((and (consp high) (null (rest high)) (funcall tester (first high)))
  8871.                      `((> ,(first high) ,x))
  8872.                     )
  8873.                     (t (c-warn 
  8874.                         #L{
  8875.                         DEUTSCH "~S: Argument zu ~S muß *, ~S oder eine Liste von ~S sein: ~S"
  8876.                         ENGLISH "~S: argument to ~S must be *, ~S or a list of ~S: ~S"
  8877.                         FRANCAIS "~S : L'argument de ~S doit être *, ~S ou une liste de ~S: ~S"
  8878.                         }
  8879.                         'typep caller caller caller high
  8880.                        )
  8881.                        (throw 'c-TYPEP nil)
  8882.               )     )
  8883.        )
  8884.     )
  8885. )
  8886. (defconstant c-typep-alist3
  8887.   `((ARRAY . ,(c-typep-array 'ARRAYP))
  8888.     (SIMPLE-ARRAY . ,(c-typep-array 'SIMPLE-ARRAY-P))
  8889.     (VECTOR .
  8890.       ,#'(lambda (x &optional (el-type '*) (size '*) &rest illegal-args)
  8891.            (declare (ignore illegal-args))
  8892.            `(AND (VECTORP ,x)
  8893.                  ,@(if (eq el-type '*)
  8894.                      '()
  8895.                      `((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type)))
  8896.                    )
  8897.                  ,@(if (eq size '*)
  8898.                      '()
  8899.                      `((EQL (ARRAY-DIMENSION ,x 0) ',size))
  8900.                    )
  8901.             )
  8902.          )
  8903.     )
  8904.     (SIMPLE-VECTOR . ,(c-typep-vector 'SIMPLE-VECTOR-P))
  8905.     (COMPLEX .
  8906.       ,#'(lambda (x &optional (rtype '*) (itype rtype) &rest illegal-args)
  8907.            (declare (ignore illegal-args))
  8908.            `(AND (COMPLEXP ,x)
  8909.                  ,@(if (eq rtype '*)
  8910.                      '()
  8911.                      `((TYPEP (REALPART ,x) ',rtype))
  8912.                    )
  8913.                  ,@(if (eq itype '*)
  8914.                      '()
  8915.                      `((TYPEP (IMAGPART ,x) ',itype))
  8916.                    )
  8917.             )
  8918.          )
  8919.     )
  8920.     (INTEGER . ,(c-typep-number 'INTEGER 'INTEGERP))
  8921.     (MOD .
  8922.       ,#'(lambda (x &optional n &rest illegal-args)
  8923.            (declare (ignore illegal-args))
  8924.            (unless (integerp n)
  8925.              (c-warn 
  8926.               #L{
  8927.               DEUTSCH "~S: Argument zu MOD muß ganze Zahl sein: ~S"
  8928.               ENGLISH "~S: argument to MOD must be an integer: ~S"
  8929.               FRANCAIS "~S : L'argument de MOD doit être un entier: ~S"
  8930.               }
  8931.               'typep n
  8932.              )
  8933.              (throw 'c-TYPEP nil)
  8934.            )
  8935.            `(AND (INTEGERP ,x) (NOT (MINUSP ,x)) (< ,x ,n))
  8936.          )
  8937.     )
  8938.     (SIGNED-BYTE .
  8939.       ,#'(lambda (x &optional (n '*) &rest illegal-args)
  8940.            (declare (ignore illegal-args))
  8941.            (unless (or (eq n '*) (integerp n))
  8942.              (c-warn 
  8943.               #L{
  8944.               DEUTSCH "~S: Argument zu SIGNED-BYTE muß ganze Zahl oder * sein: ~S"
  8945.               ENGLISH "~S: argument to SIGNED-BYTE must be an integer or * : ~S"
  8946.               FRANCAIS "~S : L'argument de SIGNED-BYTE doit être un entier ou bien * : ~S"
  8947.               }
  8948.               'typep n
  8949.              )
  8950.              (throw 'c-TYPEP nil)
  8951.            )
  8952.            `(AND (INTEGERP ,x)
  8953.                  ,@(if (eq n '*) '() `((< (INTEGER-LENGTH ,x) ,n)))
  8954.             )
  8955.          )
  8956.     )
  8957.     (UNSIGNED-BYTE .
  8958.       ,#'(lambda (x &optional (n '*) &rest illegal-args)
  8959.            (declare (ignore illegal-args))
  8960.            (unless (or (eq n '*) (integerp n))
  8961.              (c-warn 
  8962.               #L{
  8963.               DEUTSCH "~S: Argument zu UNSIGNED-BYTE muß ganze Zahl oder * sein: ~S"
  8964.               ENGLISH "~S: argument to UNSIGNED-BYTE must be an integer or * : ~S"
  8965.               FRANCAIS "~S : L'argument de UNSIGNED-BYTE doit être un entier ou bien * : ~S"
  8966.               }
  8967.               'typep n
  8968.              )
  8969.              (throw 'c-TYPEP nil)
  8970.            )
  8971.            `(AND (INTEGERP ,x) (NOT (MINUSP ,x))
  8972.                  ,@(if (eq n '*) '() `((<= (INTEGER-LENGTH ,x) ,n)))
  8973.             )
  8974.          )
  8975.     )
  8976.     (REAL . ,(c-typep-number 'REAL 'REALP))
  8977.     (RATIONAL . ,(c-typep-number 'RATIONAL 'RATIONALP))
  8978.     (FLOAT . ,(c-typep-number 'FLOAT 'FLOATP))
  8979.     (SHORT-FLOAT . ,(c-typep-number 'SHORT-FLOAT 'SHORT-FLOAT-P))
  8980.     (SINGLE-FLOAT . ,(c-typep-number 'SINGLE-FLOAT 'SINGLE-FLOAT-P))
  8981.     (DOUBLE-FLOAT . ,(c-typep-number 'DOUBLE-FLOAT 'DOUBLE-FLOAT-P))
  8982.     (LONG-FLOAT . ,(c-typep-number 'LONG-FLOAT 'LONG-FLOAT-P))
  8983.     (STRING . ,(c-typep-vector 'STRINGP))
  8984.     (SIMPLE-STRING . ,(c-typep-vector 'SIMPLE-STRING-P))
  8985.     (BIT-VECTOR . ,(c-typep-vector 'BIT-VECTOR-P))
  8986.     (SIMPLE-BIT-VECTOR . ,(c-typep-vector 'SIMPLE-BIT-VECTOR-P))
  8987. )  )
  8988. (defun c-TYPEP () ; vgl. TYPEP in type.lsp
  8989.   (test-list *form* 3 3)
  8990.   (let ((objform (second *form*))
  8991.         (typeform (third *form*)))
  8992.     (when (c-constantp typeform)
  8993.       (let ((type (c-constant-value typeform)) h)
  8994.         (cond ((symbolp type)
  8995.                 (cond ; Test auf Property TYPE-SYMBOL:
  8996.                       ((setq h (assoc type c-typep-alist1))
  8997.                         (setq h (cdr h))
  8998.                         (return-from c-TYPEP
  8999.                           (c-GLOBAL-FUNCTION-CALL-form `(,h ,objform))
  9000.                       ) )
  9001.                       ((setq h (assoc type c-typep-alist2))
  9002.                         (setq h (cdr h))
  9003.                         (return-from c-TYPEP
  9004.                           (let ((*form* `(,h ,objform)))
  9005.                             (c-FUNCALL-INLINE
  9006.                               (symbol-suffix '#:TYPEP (symbol-name type))
  9007.                               (list objform)
  9008.                               nil
  9009.                               h
  9010.                               nil
  9011.                       ) ) ) )
  9012.                       ; Test auf Property TYPE-LIST:
  9013.                       ((setq h (assoc type c-typep-alist3))
  9014.                         (setq h (cdr h))
  9015.                         (let* ((objvar (gensym))
  9016.                                (testform (funcall h objvar))
  9017.                                (lambdabody `((,objvar) ,testform)))
  9018.                           (return-from c-TYPEP
  9019.                             (let ((*form* `((lambda ,@lambdabody) ,objform)))
  9020.                               (c-FUNCALL-INLINE
  9021.                                 (symbol-suffix '#:TYPEP (symbol-name type))
  9022.                                 (list objform)
  9023.                                 nil
  9024.                                 lambdabody
  9025.                                 nil
  9026.                       ) ) ) ) )
  9027.                       #+CLISP ; Test auf Property DEFTYPE-EXPANDER:
  9028.                       ((setq h (get type 'SYS::DEFTYPE-EXPANDER))
  9029.                         (return-from c-TYPEP
  9030.                           (c-form `(TYPEP ,objform ',(funcall h (list type))))
  9031.                       ) )
  9032.                       #+CLISP ; Test auf Property DEFSTRUCT-DESCRIPTION:
  9033.                       ((get type 'SYS::DEFSTRUCT-DESCRIPTION)
  9034.                         (return-from c-TYPEP
  9035.                           (c-form `(SYS::%STRUCTURE-TYPE-P ',type ,objform))
  9036.                       ) )
  9037.                       #+CLISP ; Test auf Property CLOS::CLASS:
  9038.                       ((and (setq h (get type 'CLOS::CLASS)) (clos::class-p h)
  9039.                             (eq (clos:class-name h) type)
  9040.                        )
  9041.                         (return-from c-TYPEP
  9042.                           (c-form `(CLOS::SUBCLASSP (CLOS:CLASS-OF ,objform)
  9043.                                      (LOAD-TIME-VALUE (CLOS:FIND-CLASS ',type))
  9044.                                    )
  9045.                       ) ) )
  9046.               ) )
  9047.               ((and (consp type) (symbolp (first type)))
  9048.                 (catch 'c-TYPEP
  9049.                   (cond ((and (eq (first type) 'SATISFIES) (eql (length type) 2))
  9050.                           (let ((fun (second type)))
  9051.                             (unless (symbolp (second type))
  9052.                               (c-warn 
  9053.                                #L{
  9054.                                DEUTSCH "~S: Argument zu SATISFIES muß Symbol sein: ~S"
  9055.                                ENGLISH "~S: argument to SATISFIES must be a symbol: ~S"
  9056.                                FRANCAIS "~S : L'argument de SATISFIES doit être un symbole: ~S"
  9057.                                }
  9058.                                'typep (second type)
  9059.                               )
  9060.                               (throw 'c-TYPEP nil)
  9061.                             )
  9062.                             (return-from c-TYPEP
  9063.                               (c-GLOBAL-FUNCTION-CALL-form `(,fun ,objform))
  9064.                         ) ) )
  9065.                         ((eq (first type) 'MEMBER)
  9066.                           (return-from c-TYPEP
  9067.                             (let ((*form* `(CASE ,objform (,(rest type) T) (t NIL))))
  9068.                               (c-CASE)
  9069.                         ) ) )
  9070.                         ((and (eq (first type) 'EQL) (eql (length type) 2))
  9071.                           (return-from c-TYPEP
  9072.                             (let ((*form* `(EQL ,objform ',(second type))))
  9073.                               (c-EQL)
  9074.                         ) ) )
  9075.                         ((and (eq (first type) 'NOT) (eql (length type) 2))
  9076.                           (return-from c-TYPEP
  9077.                             (c-GLOBAL-FUNCTION-CALL-form
  9078.                               `(NOT (TYPEP ,objform ',(second type)))
  9079.                         ) ) )
  9080.                         ((or (eq (first type) 'AND) (eq (first type) 'OR))
  9081.                           (return-from c-TYPEP
  9082.                             (c-form
  9083.                               (let ((objvar (gensym)))
  9084.                                 `(LET ((,objvar ,objform))
  9085.                                    (,(first type) ; AND oder OR
  9086.                                     ,@(mapcar #'(lambda (typei) `(TYPEP ,objvar ',typei)) (rest type))
  9087.                                  ) )
  9088.                         ) ) ) )
  9089.                         ((setq h (assoc (first type) c-typep-alist3))
  9090.                           (setq h (cdr h))
  9091.                           (let* ((objvar (gensym))
  9092.                                  (testform (apply h objvar (rest type)))
  9093.                                  (lambdabody `((,objvar) ,testform)))
  9094.                             (return-from c-TYPEP
  9095.                               (let ((*form* `((lambda ,@lambdabody) ,objform)))
  9096.                                 (c-FUNCALL-INLINE
  9097.                                   (symbol-suffix '#:TYPEP (symbol-name (first type)))
  9098.                                   (list objform)
  9099.                                   nil
  9100.                                   lambdabody
  9101.                                   nil
  9102.                         ) ) ) ) )
  9103.               ) ) )
  9104.               ((and (clos::class-p type) (eq (get (clos:class-name type) 'CLOS::CLASS) type))
  9105.                 (return-from c-TYPEP
  9106.                   (c-form `(CLOS::SUBCLASSP (CLOS:CLASS-OF ,objform)
  9107.                              (LOAD-TIME-VALUE (CLOS:FIND-CLASS ',(clos:class-name type)))
  9108.                            )
  9109.               ) ) )
  9110.     ) ) )
  9111.     (c-GLOBAL-FUNCTION-CALL 'TYPEP)
  9112. ) )
  9113.  
  9114. ;; c-FORMAT vgl. FORMAT in format.lsp
  9115. (defun c-FORMAT ()
  9116.   (test-list *form* 3)
  9117.   (if (stringp (third *form*))
  9118.     ; Format-String zur Compile-Zeit vorkompilieren.
  9119.     (let ((*form* `(FORMAT ,(second *form*) (FORMATTER ,(third *form*)) ,@(cdddr *form*))))
  9120.       (c-GLOBAL-FUNCTION-CALL 'FORMAT)
  9121.     )
  9122.     (c-GLOBAL-FUNCTION-CALL 'FORMAT)
  9123. ) )
  9124.  
  9125. ;; c-REMOVE-IF, c-REMOVE-IF-NOT usw.
  9126. (macrolet ((c-seqop (op n)
  9127.              (let ((op-if (intern (string-concat (string op) "-IF") *lisp-package*))
  9128.                    (op-if-not (intern (string-concat (string op) "-IF-NOT") *lisp-package*))
  9129.                    (c-op-if (intern (string-concat "C-" (string op) "-IF")))
  9130.                    (c-op-if-not (intern (string-concat "C-" (string op) "-IF-NOT"))))
  9131.                `(progn
  9132.                   (defun ,c-op-if ()
  9133.                     (test-list *form* ,(+ 1 n))
  9134.                     (let ((pred-arg ,(case n (2 `(second *form*))
  9135.                                              (3 `(third *form*))
  9136.                                      )
  9137.                          ))
  9138.                       (if (and (consp pred-arg) (eq (first pred-arg) 'COMPLEMENT)
  9139.                                (consp (rest pred-arg)) (null (cddr pred-arg))
  9140.                                ; (op-if (complement fn) ...) --> (op-if-not fn ...)
  9141.                                (not (fenv-search 'COMPLEMENT)) (not (declared-notinline 'COMPLEMENT))
  9142.                                (not (fenv-search 'NOT))
  9143.                           )
  9144.                         (c-form ,(case n (2 `(list* ',op-if-not (second pred-arg) (cddr *form*)))
  9145.                                          (3 `(list* ',op-if-not (second *form*) (second pred-arg) (cdddr *form*)))
  9146.                                  )
  9147.                         )
  9148.                         (c-GLOBAL-FUNCTION-CALL ',op-if)
  9149.                   ) ) )
  9150.                   (defun ,c-op-if-not ()
  9151.                     (test-list *form* ,(+ 1 n))
  9152.                     (let ((pred-arg ,(case n (2 `(second *form*))
  9153.                                              (3 `(third *form*))
  9154.                                      )
  9155.                          ))
  9156.                       (if (and (consp pred-arg) (eq (first pred-arg) 'COMPLEMENT)
  9157.                                (consp (rest pred-arg)) (null (cddr pred-arg))
  9158.                                ; (op-if-not (complement fn) ...) --> (op-if fn ...)
  9159.                                (not (fenv-search 'COMPLEMENT))
  9160.                                (not (fenv-search 'NOT))
  9161.                           )
  9162.                         (c-form ,(case n (2 `(list* ',op-if (second pred-arg) (cddr *form*)))
  9163.                                          (3 `(list* ',op-if (second *form*) (second pred-arg) (cdddr *form*)))
  9164.                                  )
  9165.                         )
  9166.                         (c-GLOBAL-FUNCTION-CALL ',op-if-not)
  9167.                   ) ) )
  9168.                )
  9169.           )) )
  9170.   (c-seqop REMOVE 2)
  9171.   (c-seqop DELETE 2)
  9172.   (c-seqop SUBSTITUTE 3)
  9173.   (c-seqop NSUBSTITUTE 3)
  9174.   (c-seqop FIND 2)
  9175.   (c-seqop POSITION 2)
  9176.   (c-seqop COUNT 2)
  9177.   (c-seqop SUBST 3)
  9178.   (c-seqop NSUBST 3)
  9179.   (c-seqop MEMBER 2)
  9180.   (c-seqop ASSOC 2)
  9181.   (c-seqop RASSOC 2)
  9182. )
  9183.  
  9184.  
  9185.  
  9186. ;                     Z W E I T E R   P A S S
  9187.  
  9188. ; eine Tabelle von Paaren (fnode n).
  9189. ; Jedes Paar zeigt an, daß im 3. Pass in der Konstanten Nummer n des
  9190. ; funktionalen Objektes von fnode der dort stehende fnode durch das durch ihn
  9191. ; erzeugte funktionale Objekt zu ersetzen ist.
  9192. (defvar *fnode-fixup-table*)
  9193.  
  9194. ; macht aus dem ANODE-Baum zum fnode *func* ein funktionales Objekt:
  9195. (defun pass2 (*func*)
  9196.   (when (anode-p (fnode-code *func*)) ; falls 2. Pass noch nicht durchgeführt:
  9197.     ; erst den Code flachklopfen, optimieren und assemblieren:
  9198.     (let ((code-list (compile-to-LAP))) ; Code flachklopfen und in Stücke zerteilen,
  9199.                                         ; optimieren und zu einer Liste machen
  9200.       (when (fnode-gf-p *func*) (setq code-list (CONST-to-LOADV code-list))) ; evtl. CONSTs umwandeln
  9201.       (let (#+CLISP3 (SPdepth (SP-depth code-list))) ; Stackbedarf bestimmen
  9202.         (setq code-list (insert-combined-LAPs code-list)) ; kombinierte Operationen einführen
  9203.         (create-fun-obj *func* (assemble-LAP code-list) #+CLISP3 SPdepth) ; assemblieren und funkt. Objekt
  9204.     ) )
  9205.     ; dann die Sub-Funktionen durch den 2. Pass jagen
  9206.     (dolist (x (fnode-Consts *func*)) (if (fnode-p x) (pass2 x)))
  9207. ) )
  9208.  
  9209. #|
  9210.  
  9211. pass2 ruft den 1. Schritt auf.
  9212.  
  9213. Nach dem 1. Schritt ist der Code in kleine Stücke aufgeteilt, jeweils von
  9214. einem Label bis zu einem Wegsprung (JMP, JMPCASE, JMPCASE1-TRUE, JMPCASE1-FALSE,
  9215. JMPHASH, RETURN-FROM, GO, RET, THROW, BARRIER). Die Teile stecken (jeweils als
  9216. Liste in umgekehrter Reihenfolge, mit dem Label als letztem CDR) im Vektor
  9217. *code-parts*.
  9218. (symbol-value label) enthält eine Liste der Referenzen von label, und zwar in
  9219. der Form:
  9220.  - Index in *code-parts*, wenn die Referenz der entsprechende Wegsprung ist;
  9221.  - opcode sonst, wobei opcode der Befehl ist, in dem label auftritt.
  9222. Nach dem 1. Schritt enthält der Code nur noch Tags (Symbole) und Listen aus
  9223. Symbolen und Zahlen. Es darf daher mit SUBST und EQUAL gearbeitet werden.
  9224.  
  9225. Der 1. Schritt ruft, sobald er mit einem Stück fertig ist, den 2. Schritt
  9226. auf.
  9227.  
  9228. Dann ruft pass2 den 3. Schritt auf. Es handelt sich hier um Optimierungen,
  9229. die, wenn sie erfolgreich waren, weitere dieser Optimierungen aufrufen.
  9230.  
  9231. |#
  9232.  
  9233. #|
  9234.                              1. Schritt:
  9235.           Expansion von Code-Teilen, Aufteilen des Codes in Stücke
  9236.  
  9237. Verändert werden:
  9238.  
  9239. vorher                           nachher
  9240.  
  9241. (CONST const)                    (CONST n const)
  9242. (FCONST fnode)                   (CONST n), Fixup für 3. Pass merken
  9243. (BCONST block)                   (CONST n)
  9244. (GCONST tagbody)                 (CONST n)
  9245. (GET var venvc stackz)           (LOAD n) oder (LOADI k n) oder (LOADC n m)
  9246.                                  oder (LOADIC k n m) oder (LOADV k m)
  9247.                                  oder (GETVALUE n) oder (CONST n)
  9248.                                  oder (CONST n const)
  9249. (SET var venvc stackz)           (STORE n) oder (STOREI k n) oder (STOREC n m)
  9250.                                  oder (STOREIC k n m) oder (STOREV k m)
  9251.                                  oder (SETVALUE n)
  9252. (SETVALUE symbol)                (SETVALUE n)
  9253. (GETVALUE symbol)                (GETVALUE n)
  9254. (BIND const)                     (BIND n)
  9255. (UNWIND stackz1 stackz2 for-value) eine Folge von
  9256.                                  (SKIP n), (SKIPI k n), (SKIPSP k), (VALUES0),
  9257.                                  (UNWIND-PROTECT-CLEANUP), (UNBIND1),
  9258.                                  (BLOCK-CLOSE), (TAGBODY-CLOSE)
  9259. (UNWINDSP stackz1 stackz2)       eine Folge von (SKIPSP k)
  9260. (JMPIF label)                    (JMPCASE label new-label) new-label
  9261. (JMPIFNOT label)                 (JMPCASE new-label label) new-label
  9262. (JMPIF1 label)                   (JMPCASE1-TRUE label new-label) new-label
  9263. (JMPIFNOT1 label)                (JMPCASE1-FALSE new-label label) new-label
  9264. (JMPHASH test ((obj1 . label1) ... (objm . labelm)) label . labels)
  9265.                                  (JMPHASH n ht label . labels)
  9266.                                  wobei ht = Hash-Tabelle (obji -> labeli) ist
  9267. (VENV venvc stackz)              (VENV) oder (NIL)
  9268.                                  oder (LOAD n) oder (LOADI k n)
  9269. (COPY-CLOSURE fnode n)           (COPY-CLOSURE m n), Fixup für 3. Pass merken
  9270. (CALLP)                          gestrichen
  9271. (CALL k fun)                     (CALL k n)
  9272. (CALL0 fun)                      (CALL0 n)
  9273. (CALL1 fun)                      (CALL1 n)
  9274. (CALL2 fun)                      (CALL2 n)
  9275. (FUNCALLP)                       (PUSH)
  9276. (APPLYP)                         (PUSH)
  9277. (JMPIFBOUNDP var venvc stackz label)
  9278.                                  (JMPIFBOUNDP n label)
  9279. (BOUNDP var venvc stackz)        (BOUNDP n)
  9280. (BLOCK-OPEN const label)         (BLOCK-OPEN n label)
  9281. (RETURN-FROM const)              (RETURN-FROM n)
  9282. (RETURN-FROM block)              (RETURN-FROM n)
  9283. (RETURN-FROM block stackz)       (RETURN-FROM-I k n)
  9284. (TAGBODY-OPEN const label1 ... labelm)
  9285.                                  (TAGBODY-OPEN n label1 ... labelm)
  9286. (GO const l)                     (GO n l)
  9287. (GO tagbody l)                   (GO n l)
  9288. (GO tagbody l stackz)            (GO-I k n l)
  9289. (HANDLER-OPEN const stackz label1 ... labelm)
  9290.                                  (HANDLER-OPEN n v k label1 ... labelm)
  9291.  
  9292.  
  9293. unverändert bleiben:
  9294. (NIL)
  9295. (PUSH-NIL n)
  9296. (T)
  9297. (STORE n)
  9298. (UNBIND1)
  9299. (PROGV)
  9300. (PUSH)
  9301. (POP)
  9302. (RET)
  9303. (JMP label)
  9304. (JSR m label)
  9305. (BARRIER)
  9306. (MAKE-VECTOR1&PUSH n)
  9307. (CALLS1 n)
  9308. (CALLS2 n)
  9309. (CALLSR m n)
  9310. (CALLC)
  9311. (CALLCKEY)
  9312. (FUNCALL n)
  9313. (APPLY n)
  9314. (PUSH-UNBOUND n)
  9315. (UNLIST n m)
  9316. (UNLIST* n m)
  9317. (VALUES0)
  9318. (VALUES1)
  9319. (STACK-TO-MV n)
  9320. (MV-TO-STACK)
  9321. (NV-TO-STACK n)
  9322. (MV-TO-LIST)
  9323. (LIST-TO-MV)
  9324. (MVCALLP)
  9325. (MVCALL)
  9326. (BLOCK-CLOSE)
  9327. (TAGBODY-CLOSE-NIL)
  9328. (TAGBODY-CLOSE)
  9329. (CATCH-OPEN label)
  9330. (CATCH-CLOSE)
  9331. (THROW)
  9332. (UNWIND-PROTECT-OPEN label)
  9333. (UNWIND-PROTECT-NORMAL-EXIT)
  9334. (UNWIND-PROTECT-CLOSE label)
  9335. (UNWIND-PROTECT-CLEANUP)
  9336. (HANDLER-BEGIN)
  9337. (NOT)
  9338. (EQ)
  9339. (CAR)
  9340. (CDR)
  9341. (CONS)
  9342. (ATOM)
  9343. (CONSP)
  9344. (SYMBOL-FUNCTION)
  9345. (SVREF)
  9346. (SVSET)
  9347. (LIST n)
  9348. (LIST* n)
  9349.  
  9350. Neue Operationen:
  9351.  
  9352. (JMP label boolvalue)            Sprung zu label, boolvalue beschreibt den 1.
  9353.                                  Wert: FALSE falls =NIL, TRUE falls /=NIL,
  9354.                                  NIL falls unbekannt.
  9355.  
  9356. (JMPCASE label1 label2)          Sprung zu label1, falls A0 /= NIL,
  9357.                                  bzw. zu label2, falls A0 = NIL.
  9358.  
  9359. (JMPCASE1-TRUE label1 label2)    Falls A0 /= NIL: Sprung nach label1, 1 Wert.
  9360.                                  Falls A0 = NIL: Sprung nach label2.
  9361.  
  9362. (JMPCASE1-FALSE label1 label2)   Falls A0 /= NIL: Sprung nach label1.
  9363.                                  Falls A0 = NIL: Sprung nach label2, 1 Wert.
  9364.  
  9365. (JMPTAIL m n label)              Verkleinerung des Stack-Frames von n auf m,
  9366.                                  dann Sprung zu label mit undefinierten Werten.
  9367.  
  9368. |#
  9369.  
  9370. ; Ein Vektor mit Fill-Pointer, der die Codestücke enthält:
  9371. (defvar *code-parts*)
  9372.  
  9373. ; Ein gleichlanger Vektor mit Fill-Pointer, der zu jedem Codestück eine
  9374. ; "Position" enthält, wo das Stück am Ende landen soll (0 = ganz am Anfang,
  9375. ; je höher, desto weiter hinten).
  9376. (defvar *code-positions*)
  9377.  
  9378. ; Trägt eine Konstante in (fnode-consts *func*) ein und liefert deren Index n.
  9379. ; value ist der Wert der Konstanten,
  9380. ; form eine Form mit diesem Wert oder NIL,
  9381. ; horizont = :value (dann ist form = NIL) oder :all oder :form.
  9382. (defun value-form-index (value form horizont &optional (func *func*))
  9383.   (let ((const-list (fnode-consts func))
  9384.         (forms-list (fnode-consts-forms func))
  9385.         (n (fnode-Consts-Offset func)))
  9386.     (if (null const-list)
  9387.       (progn
  9388.         (setf (fnode-consts func) (list value))
  9389.         (setf (fnode-consts-forms func) (list form))
  9390.         n
  9391.       )
  9392.       (loop
  9393.         (when (if (eq horizont ':form)
  9394.                 (eql (car forms-list) form)
  9395.                 ; Bei horizont = :value oder :all vergleichen wir nur value.
  9396.                 (eql (car const-list) value)
  9397.               )
  9398.           (return n)
  9399.         )
  9400.         (incf n)
  9401.         (when (null (cdr const-list))
  9402.           (setf (cdr const-list) (list value))
  9403.           (setf (cdr forms-list) (list form))
  9404.           (return n)
  9405.         )
  9406.         (setq const-list (cdr const-list))
  9407.         (setq forms-list (cdr forms-list))
  9408. ) ) ) )
  9409. (defun constvalue-index (value)
  9410.   (value-form-index value nil ':value)
  9411. )
  9412.  
  9413. ; sucht eine Konstante in (fnode-Keywords *func*) und in (fnode-Consts *func*),
  9414. ; trägt sie eventuell in (fnode-Consts *func*) ein. Liefert ihren Index n.
  9415. (defun kvalue-form-index (value form horizont &optional (func *func*))
  9416.   (when (and (not (eq horizont ':form)) (keywordp value)) ; nur bei Keywords lohnt sich die Suche
  9417.     (do ((n (fnode-Keyword-Offset func) (1+ n))
  9418.          (L (fnode-Keywords func) (cdr L)))
  9419.         ((null L))
  9420.       (if (eq (car L) value) (return-from kvalue-form-index n))
  9421.   ) )
  9422.   (value-form-index value form horizont func)
  9423. )
  9424. (defun kconstvalue-index (value)
  9425.   (kvalue-form-index value nil ':value)
  9426. )
  9427. (defun const-index (const)
  9428.   (if (and *compiling-from-file* (not (eq (const-horizont const) ':value)))
  9429.     (kvalue-form-index (const-value const) (const-form const) (const-horizont const))
  9430.     (kvalue-form-index (const-value const) nil ':value)
  9431. ) )
  9432.  
  9433. ; (make-const-code const) liefert den Code, der den Wert der Konstanten
  9434. ; als 1 Wert nach A0 bringt.
  9435. (defun make-const-code (const)
  9436.   (unless (eq (const-horizont const) ':form)
  9437.     (let ((value (const-value const)))
  9438.       (cond ((eq value 'nil) (return-from make-const-code '(NIL) ))
  9439.             ((eq value 't) (return-from make-const-code '(T) ))
  9440.   ) ) )
  9441.   `(CONST ,(const-index const) ,const)
  9442. )
  9443.  
  9444. ; (bconst-index block) liefert den Index in FUNC, an dem dieser Block steht.
  9445. (defun bconst-index (block &optional (func *func*))
  9446. ; (+ (fnode-Blocks-Offset func)
  9447. ;    (position block (fnode-Blocks func) :test #'eq)
  9448. ; )
  9449.   (do ((n (fnode-Blocks-Offset func) (1+ n))
  9450.        (L (fnode-Blocks func) (cdr L)))
  9451.       ((eq (car L) block) n)
  9452. ) )
  9453.  
  9454. ; (gconst-index tagbody) liefert den Index in FUNC, an dem dieser Tagbody steht.
  9455. (defun gconst-index (tagbody &optional (func *func*))
  9456. ; (+ (fnode-Tagbodys-Offset func)
  9457. ;    (position tagbody (fnode-Tagbodys func) :test #'eq)
  9458. ; )
  9459.   (do ((n (fnode-Tagbodys-Offset func) (1+ n))
  9460.        (L (fnode-Tagbodys func) (cdr L)))
  9461.       ((eq (car L) tagbody) n)
  9462. ) )
  9463.  
  9464. ; (fconst-index fnode) liefert den Index in FUNC, an dem dieser fnode in den
  9465. ; Konstanten steht. Wenn nötig, wird er eingefügt und in *fnode-fixup-table*
  9466. ; vermerkt.
  9467. (defun fconst-index (fnode &optional (func *func*))
  9468.   (if (member fnode (fnode-Consts func))
  9469.     (constvalue-index fnode)
  9470.     (let ((n (constvalue-index fnode)))
  9471.       (push (list func n) *fnode-fixup-table*)
  9472.       n
  9473. ) ) )
  9474.  
  9475. ; Hilfsvariablen beim rekursiven Aufruf von traverse-anode:
  9476.  
  9477. ; Das aktuelle Codestück, eine umgedrehte Liste von Instruktionen, die
  9478. ; mit dem Start-Label als letztem nthcdr endet.
  9479. (defvar *code-part*)
  9480.  
  9481. ; und seine Nummer (Index in *code-parts*)
  9482. (defvar *code-index*)
  9483.  
  9484. ; Flag, ob "toter Code" (d.h. Code, der nicht erreichbar ist) vorliegt
  9485. (defvar *dead-code*)
  9486.  
  9487. ; Für Sprungkettenverkürzung in traverse-anode: Liste aller bereits
  9488. ; durchgeführten Label-Substitutionen ((old-label . new-label) ...)
  9489. (defvar *label-subst*)
  9490.  
  9491. ; Der aktuelle Wert, interpretiert als boolescher Wert:
  9492. ; FALSE falls =NIL, TRUE falls /=NIL, NIL falls unbekannt.
  9493. ; (Keine Einschränkung an die Anzahl der Werte!)
  9494. (defvar *current-value*)
  9495.  
  9496. ; Liste der Variablen/Konstanten, deren Wert mit dem aktuellen übereinstimmt
  9497. ; (lexikalische Variablen als VARIABLE-Structures, dynamische Variablen als
  9498. ; Symbole, Konstanten als CONST-Structures mit horizont = :value oder :all).
  9499. ; Ist diese Liste nichtleer, so liegt auch genau 1 Wert vor.
  9500. (defvar *current-vars*)
  9501.  
  9502. ; Jedes Label (ein Gensym-Symbol) hat als Wert eine Liste aller Referenzen
  9503. ; auf label, und zwar jeweils entweder als Index i in *code-parts*, wenn es
  9504. ; sich um den Wegsprung (das Ende) von (aref *code-parts* i) handelt, oder
  9505. ; als Instruktion (einer Liste) in allen anderen Fällen. Falls das Label
  9506. ; ein Codestück beginnt, steht unter (get label 'code-part) der Index in
  9507. ; *code-part* des Codestücks, das mit diesem Label anfängt. Unter
  9508. ; (get label 'for-value) steht, wieviele Werte bei einem möglichen Sprung
  9509. ; auf das Label von Bedeutung sind (NIL/ONE/ALL).
  9510. ; Eine Ausnahme stellt das "Label" NIL dar, das den Einsprungpunkt darstellt.
  9511.  
  9512. ; Ersetzt alle Referenzen auf old-label durch Referenzen auf new-label.
  9513. (defun label-subst (old-label new-label)
  9514.   ; alle Referenzen auf old-label verändern:
  9515.   (dolist (ref (symbol-value old-label))
  9516.     (nsubst new-label old-label
  9517.             (rest (if (integerp ref) (first (aref *code-parts* ref)) ref))
  9518.   ) )
  9519.   ; und als Referenzen auf new-label eintragen:
  9520.   (setf (symbol-value new-label)
  9521.     (nconc (symbol-value old-label) (symbol-value new-label))
  9522.   )
  9523.   (setf (symbol-value old-label) '())
  9524.   ; Mit old-label fängt kein Codestück mehr an:
  9525.   (remprop old-label 'code-part)
  9526. )
  9527.  
  9528. ; Aktuelles Codestück beenden und ein neues Codestück anfangen:
  9529. (defun finish-code-part ()
  9530.   ; das aktuelle Codestück vereinfachen:
  9531.   (simplify *code-part*)
  9532.   ; *code-part* in *code-parts* unterbringen:
  9533.   (vector-push-extend *code-part* *code-parts*)
  9534.   (vector-push-extend (incf *code-index*) *code-positions*)
  9535. )
  9536.  
  9537. ; Einen Wegsprung auf Label label emittieren.
  9538. ; Dadurch wird ein neues Codestück angefangen.
  9539. (defun emit-jmp (label)
  9540.   ; mit einem Wegsprung:
  9541.   (push `(JMP ,label ,*current-value*) *code-part*)
  9542.   (push *code-index* (symbol-value label))
  9543.   (finish-code-part)
  9544. )
  9545.  
  9546. ; Läuft durch den Code eines Anode durch, expandiert den Code und baut dabei
  9547. ; *code-part* weiter. Adjustiert die Variablen *current-value* usw. passend.
  9548. (defun traverse-anode (code)
  9549.   (dolist (item code)
  9550.     (if (atom item)
  9551.       (cond ((symbolp item) ; Label
  9552.              (if *dead-code*
  9553.                ; Code kann angesprungen werden, ist ab jetzt nicht mehr tot
  9554.                (setq *dead-code* nil)
  9555.                (if (symbolp *code-part*)
  9556.                  ; Label item sofort nach Label *code-part*
  9557.                  ; -> können identifiziert werden
  9558.                  (let ((old-label *code-part*) (new-label item))
  9559.                    ; substituiere *code-parts* -> item
  9560.                    (label-subst old-label new-label)
  9561.                    (setq *label-subst*
  9562.                      (acons old-label new-label
  9563.                        (nsubst new-label old-label *label-subst*)
  9564.                  ) ) )
  9565.                  ; Label mitten im Codestück -> aktuelles Codestück beenden
  9566.                  (emit-jmp item)
  9567.              ) )
  9568.              ; jetzt geht das aktuelle Codestück erst richtig los,
  9569.              ; mit dem Label item:
  9570.              (setq *code-part* item)
  9571.              (setf (get item 'code-part) (fill-pointer *code-parts*))
  9572.              ; Da noch Sprünge auf dieses Label kommen können, wissen wir
  9573.              ; nicht, was A0 enthält:
  9574.              (setq *current-value* nil *current-vars* '())
  9575.             )
  9576.             ((anode-p item) (traverse-anode (anode-code item))) ; Anode -> rekursiv
  9577.             (t (compiler-error 'traverse-anode "ITEM"))
  9578.       )
  9579.       ; item ist eine normale Instruktion
  9580.       (unless *dead-code* ; nur erreichbarer Code braucht verarbeitet zu werden
  9581.         (nsublis *label-subst* (rest item)) ; bisherige Substitutionen durchführen
  9582.         (case (first item)
  9583.           (CONST
  9584.             (let ((const (second item)))
  9585.               (if (eq (const-horizont const) ':form)
  9586.                 (progn
  9587.                   (push (make-const-code const) *code-part*)
  9588.                   (setq *current-value* nil *current-vars* '())
  9589.                 )
  9590.                 (let ((cv (const-value const)))
  9591.                   (unless ; ein (CONST cv) schon in *current-vars* enthalten?
  9592.                       (dolist (v *current-vars* nil)
  9593.                         (when (and (const-p v) (eq (const-value v) cv)) (return t))
  9594.                       )
  9595.                     (push (make-const-code const) *code-part*)
  9596.                     (setq *current-value* (if (null cv) 'FALSE 'TRUE)
  9597.                           *current-vars* (list const)
  9598.           ) ) ) ) ) )
  9599.           (FCONST
  9600.             (push `(CONST ,(fconst-index (second item))) *code-part*)
  9601.             (setq *current-value* 'TRUE *current-vars* '())
  9602.           )
  9603.           (BCONST
  9604.             (push `(CONST ,(bconst-index (second item))) *code-part*)
  9605.             (setq *current-value* 'TRUE *current-vars* '())
  9606.           )
  9607.           (GCONST
  9608.             (push `(CONST ,(gconst-index (second item))) *code-part*)
  9609.             (setq *current-value* 'TRUE *current-vars* '())
  9610.           )
  9611.           (GET
  9612.             (let ((var (second item))
  9613.                   (venvc (third item))
  9614.                   (stackz (fourth item)))
  9615.               (unless (member var *current-vars* :test #'eq) ; Ist bereits der aktuelle Wert = var ?
  9616.                 (push
  9617.                   (if (var-constantp var)
  9618.                     (let* ((const (var-constant var))
  9619.                            (val (const-value const)))
  9620.                       (setq *current-value* (if (null val) 'FALSE 'TRUE))
  9621.                       (if (fnode-p val)
  9622.                         ; FNODEs als Werte können (fast) nur von LABELS stammen
  9623.                         `(CONST ,(fconst-index val))
  9624.                         (make-const-code const)
  9625.                     ) )
  9626.                     (progn
  9627.                       (setq *current-value* nil)
  9628.                       (if (var-specialp var)
  9629.                         `(GETVALUE ,(kconstvalue-index (setq var (var-name var))))
  9630.                         (if (var-closurep var)
  9631.                           (multiple-value-bind (k n m)
  9632.                               (zugriff-in-closure var venvc stackz)
  9633.                             (if n
  9634.                               (if k `(LOADIC ,k ,n ,m) `(LOADC ,n ,m))
  9635.                               `(LOADV ,k ,(1+ m))
  9636.                           ) )
  9637.                           ; lexikalisch und im Stack, also in derselben Funktion
  9638.                           (multiple-value-bind (k n)
  9639.                               (zugriff-in-stack stackz (var-stackz var))
  9640.                             (if k `(LOADI ,k ,n) `(LOAD ,n) )
  9641.                   ) ) ) ) )
  9642.                   *code-part*
  9643.                 )
  9644.                 (setq *current-vars* (list var))
  9645.           ) ) )
  9646.           (SET
  9647.             (let ((var (second item))
  9648.                   (venvc (third item))
  9649.                   (stackz (fourth item)))
  9650.               (unless (member var *current-vars* :test #'eq) ; Ist bereits der aktuelle Wert = var ?
  9651.                 (push
  9652.                   (if (var-specialp var)
  9653.                     `(SETVALUE ,(kconstvalue-index (setq var (var-name var))))
  9654.                     (if (var-closurep var)
  9655.                       (multiple-value-bind (k n m)
  9656.                           (zugriff-in-closure var venvc stackz)
  9657.                         (if n
  9658.                           (if k `(STOREIC ,k ,n ,m) `(STOREC ,n ,m))
  9659.                           `(STOREV ,k ,(1+ m))
  9660.                       ) )
  9661.                       ; lexikalisch und im Stack, also in derselben Funktion
  9662.                       (multiple-value-bind (k n)
  9663.                           (zugriff-in-stack stackz (var-stackz var))
  9664.                         (if k `(STOREI ,k ,n) `(STORE ,n) )
  9665.                   ) ) )
  9666.                   *code-part*
  9667.                 )
  9668.                 (push var *current-vars*) ; *current-value* bleibt unverändert
  9669.           ) ) )
  9670.           (GETVALUE
  9671.             (let ((symbol (second item)))
  9672.               (unless (member symbol *current-vars* :test #'eq)
  9673.                 (push `(GETVALUE ,(kconstvalue-index symbol)) *code-part*)
  9674.                 (setq *current-value* nil *current-vars* (list symbol))
  9675.           ) ) )
  9676.           (SETVALUE
  9677.             (let ((symbol (second item)))
  9678.               (unless (member symbol *current-vars* :test #'eq)
  9679.                 (push `(SETVALUE ,(kconstvalue-index symbol)) *code-part*)
  9680.                 (push symbol *current-vars*) ; *current-value* bleibt unverändert
  9681.           ) ) )
  9682.           (BIND
  9683.             (push `(BIND ,(const-index (second item))) *code-part*)
  9684.             (setq *current-value* nil *current-vars* '()) ; undefinierte Werte
  9685.           )
  9686.           (UNWIND ; mehrzeilige Umwandlung
  9687.             (traverse-anode
  9688.               (expand-UNWIND (second item) (third item) (fourth item))
  9689.           ) )
  9690.           (UNWINDSP ; mehrzeilige Umwandlung
  9691.             (let ((k (spdepth-difference (second item) (third item))))
  9692.               (when (> k 0)
  9693.                 (push `(SKIPSP ,k) *code-part*)
  9694.           ) ) )
  9695.           ((JMPIF JMPIFNOT JMPIF1 JMPIFNOT1)
  9696.             (if (null *current-value*)
  9697.               (let ((label (second item))
  9698.                     (new-label (make-label 'NIL)))
  9699.                 (push
  9700.                   (case (first item)
  9701.                     (JMPIF `(JMPCASE ,label ,new-label))
  9702.                     (JMPIFNOT `(JMPCASE ,new-label ,label))
  9703.                     (JMPIF1 `(JMPCASE1-TRUE ,label ,new-label))
  9704.                     (JMPIFNOT1 `(JMPCASE1-FALSE ,new-label ,label))
  9705.                   )
  9706.                   *code-part*
  9707.                 )
  9708.                 (push *code-index* (symbol-value (second item)))
  9709.                 (push *code-index* (symbol-value new-label))
  9710.                 (finish-code-part)
  9711.                 (setf (get new-label 'code-part) (fill-pointer *code-parts*))
  9712.                 (setq *code-part* new-label)
  9713.                 ; *current-value* und *current-vars* bleiben unverändert.
  9714.               )
  9715.               ; boolescher Wert beim Wegsprung bekannt
  9716.               (if (if (eq *current-value* 'FALSE)
  9717.                     (memq (first item) '(JMPIF JMPIF1)) ; Wert=NIL -> JMPIF weglassen
  9718.                     (memq (first item) '(JMPIFNOT JMPIFNOT1)) ; Wert/=NIL -> JMPIFNOT weglassen
  9719.                   )
  9720.                 ; Sprung weglassen
  9721.                 nil
  9722.                 ; in JMP umwandeln:
  9723.                 (progn
  9724.                   (when (memq (first item) '(JMPIF1 JMPIFNOT1))
  9725.                     (push '(VALUES1) *code-part*) ; genau 1 Wert erzwingen
  9726.                   )
  9727.                   (emit-jmp (second item))
  9728.                   (setq *dead-code* t)
  9729.           ) ) ) )
  9730.           (JMPHASH
  9731.             (let ((hashtable (make-hash-table :test (second item)))
  9732.                   (labels (cddddr item)))
  9733.               (dolist (acons (third item))
  9734.                 (setf (gethash (car acons) hashtable)
  9735.                       (position (cdr acons) labels)
  9736.               ) )
  9737.               (push `(JMPHASH ,(constvalue-index hashtable) ,hashtable
  9738.                               ,@(cdddr item)
  9739.                      )
  9740.                     *code-part*
  9741.             ) )
  9742.             ; Referenzen vermerken:
  9743.             (dolist (label (cdddr item))
  9744.               (push *code-index* (symbol-value label))
  9745.             )
  9746.             (finish-code-part)
  9747.             (setq *dead-code* t)
  9748.           )
  9749.           (VENV
  9750.             (let ((venvc (second item))
  9751.                   (stackz (third item)))
  9752.               (loop ; in venvc die NILs übergehen
  9753.                 (when (car venvc) (return))
  9754.                 (setq venvc (cdr venvc))
  9755.               )
  9756.               (push
  9757.                 (if (consp (car venvc)) ; aus dem Stack holen
  9758.                   (multiple-value-bind (k n)
  9759.                       (zugriff-in-stack stackz (cdr (car venvc)))
  9760.                     (if k `(LOADI ,k ,n) `(LOAD ,n) )
  9761.                   )
  9762.                   (if (eq (car venvc) *func*)
  9763.                     (if (fnode-Venvconst *func*) '(VENV) '(NIL))
  9764.                     (compiler-error 'traverse-anode 'VENV)
  9765.                 ) )
  9766.                 *code-part*
  9767.               )
  9768.               (if (equal (car *code-part*) '(NIL))
  9769.                 (setq *current-value* 'FALSE *current-vars* (list (make-const :horizont ':value :value 'NIL)))
  9770.                 (setq *current-value* nil *current-vars* '())
  9771.               )
  9772.           ) )
  9773.           (COPY-CLOSURE
  9774.             (push `(COPY-CLOSURE ,(fconst-index (second item)) ,(third item))
  9775.                    *code-part*
  9776.             )
  9777.             (setq *current-value* 'TRUE *current-vars* '())
  9778.           )
  9779.           (CALLP) ; wird gestrichen
  9780.           (CALL
  9781.             (push `(CALL ,(second item) ,(const-index (third item)))
  9782.                    *code-part*
  9783.             )
  9784.             (setq *current-value* nil *current-vars* '())
  9785.           )
  9786.           ((CALL0 CALL1 CALL2)
  9787.             (push `(,(first item) ,(const-index (second item)))
  9788.                   *code-part*
  9789.             )
  9790.             (setq *current-value* nil *current-vars* '())
  9791.           )
  9792.           ((FUNCALLP APPLYP)
  9793.             (push '(PUSH) *code-part*)
  9794.             (setq *current-value* nil *current-vars* '())
  9795.           )
  9796.           ((JMPIFBOUNDP BOUNDP)
  9797.             (let ((var (second item))
  9798.                   (stackz (fourth item))
  9799.                  )
  9800.               (when (var-closurep var)
  9801.                 (compiler-error 'traverse-anode 'var-closurep)
  9802.               )
  9803.               (multiple-value-bind (k n)
  9804.                   (zugriff-in-stack stackz (var-stackz var))
  9805.                 (when k (compiler-error 'traverse-anode 'var-stackz))
  9806.                 (push `(,(first item) ,n ,@(cddddr item)) *code-part*)
  9807.                 (when (eq (first item) 'JMPIFBOUNDP)
  9808.                   (push (first *code-part*) (symbol-value (fifth item)))
  9809.                 )
  9810.                 (setq *current-value* nil *current-vars* '()) ; undefinierte Werte
  9811.           ) ) )
  9812.           (BLOCK-OPEN
  9813.             (let ((label (third item)))
  9814.               (push `(BLOCK-OPEN ,(const-index (second item)) ,label)
  9815.                      *code-part*
  9816.               )
  9817.               (push (first *code-part*) (symbol-value label))
  9818.           ) )
  9819.           (RETURN-FROM
  9820.             (push
  9821.               (if (cddr item)
  9822.                 (multiple-value-bind (k n)
  9823.                     (zugriff-in-stack (third item) (block-stackz (second item)))
  9824.                   `(RETURN-FROM-I ,k ,n)
  9825.                 )
  9826.                 (if (block-p (second item))
  9827.                   `(RETURN-FROM ,(bconst-index (second item)))
  9828.                   `(RETURN-FROM ,(const-index (second item)))
  9829.               ) )
  9830.               *code-part*
  9831.             )
  9832.             (finish-code-part)
  9833.             (setq *dead-code* t)
  9834.           )
  9835.           (TAGBODY-OPEN
  9836.             (push `(TAGBODY-OPEN ,(const-index (second item)) ,@(cddr item))
  9837.                   *code-part*
  9838.             )
  9839.             (dolist (label (cddr item)) (push item (symbol-value label)))
  9840.           )
  9841.           (GO
  9842.             (push
  9843.               (if (cdddr item)
  9844.                 (multiple-value-bind (k n)
  9845.                     (zugriff-in-stack (fourth item) (tagbody-stackz (second item)))
  9846.                   `(GO-I ,k ,n ,(third item))
  9847.                 )
  9848.                 (if (tagbody-p (second item))
  9849.                   `(GO ,(gconst-index (second item)) ,(third item))
  9850.                   `(GO ,(const-index (second item)) ,(third item))
  9851.               ) )
  9852.               *code-part*
  9853.             )
  9854.             (finish-code-part)
  9855.             (setq *dead-code* t)
  9856.           )
  9857.           ((NIL TAGBODY-CLOSE-NIL)
  9858.             (push item *code-part*)
  9859.             (setq *current-value* 'FALSE *current-vars* (list (make-const :horizont ':value :value 'NIL)))
  9860.           )
  9861.           (HANDLER-OPEN
  9862.             (setq item
  9863.               (let ((v (const-value (second item)))
  9864.                     (k (spdepth-difference (third item) *func*)))
  9865.                 ; Aus v = #(type1 ... typem) mache v = #(type1 nil ... typem nil)
  9866.                 (setq v (coerce (mapcap #'(lambda (x) (list x nil)) (coerce v 'list)) 'vector))
  9867.                 `(HANDLER-OPEN ,(constvalue-index (cons v k)) ,v ,k ,@(cdddr item))
  9868.             ) )
  9869.             (push item *code-part*)
  9870.             (dolist (label (cddddr item)) (push item (symbol-value label)))
  9871.           )
  9872.           (VALUES0
  9873.             (push item *code-part*)
  9874.             (setq *current-value* 'FALSE *current-vars* '())
  9875.           )
  9876.           ((SKIP SKIPI SKIPSP VALUES1 MVCALLP BLOCK-CLOSE TAGBODY-CLOSE
  9877.             CATCH-CLOSE UNWIND-PROTECT-NORMAL-EXIT HANDLER-BEGIN
  9878.             STORE ; STORE nur auf Funktionsargumente innerhalb eines
  9879.                   ; Funktionsaufrufs, vgl. c-DIRECT-FUNCTION-CALL
  9880.            )
  9881.             (push item *code-part*)
  9882.           )
  9883.           ((T)
  9884.             (push item *code-part*)
  9885.             (setq *current-value* 'TRUE *current-vars* (list (make-const :horizont ':value :value 'T)))
  9886.           )
  9887.           ((RET BARRIER THROW)
  9888.             (push item *code-part*)
  9889.             (finish-code-part)
  9890.             (setq *dead-code* t)
  9891.           )
  9892.           (JMP
  9893.             (emit-jmp (second item))
  9894.             (setq *dead-code* t)
  9895.           )
  9896.           (JSR
  9897.             (push item *code-part*)
  9898.             (push item (symbol-value (third item)))
  9899.             (setq *current-value* nil *current-vars* '())
  9900.           )
  9901.           ((CATCH-OPEN UNWIND-PROTECT-OPEN)
  9902.             (push item *code-part*)
  9903.             (push item (symbol-value (second item)))
  9904.           )
  9905.           (UNWIND-PROTECT-CLOSE
  9906.             (push item *code-part*)
  9907.             (push item (symbol-value (second item)))
  9908.             (setq *current-value* nil *current-vars* '()) ; Werte werden weggeworfen
  9909.           )
  9910.           ((PUSH-NIL PROGV PUSH POP MAKE-VECTOR1&PUSH CALLS1 CALLS2 CALLSR
  9911.             CALLC CALLCKEY FUNCALL APPLY PUSH-UNBOUND UNLIST UNLIST*
  9912.             STACK-TO-MV MV-TO-STACK NV-TO-STACK MV-TO-LIST LIST-TO-MV MVCALL
  9913.             NOT EQ CAR CDR ATOM CONSP SYMBOL-FUNCTION SVREF SVSET
  9914.            )
  9915.             (push item *code-part*)
  9916.             (setq *current-value* nil *current-vars* '())
  9917.           )
  9918.           ((CONS LIST LIST*)
  9919.             (push item *code-part*)
  9920.             (setq *current-value* 'TRUE *current-vars* '())
  9921.           )
  9922.           ((UNWIND-PROTECT-CLEANUP)
  9923.             (push item *code-part*)
  9924.             (setq *current-vars* '()) ; Kann Variablenwerte zerstören
  9925.           )
  9926.           ((UNBIND1)
  9927.             (push item *code-part*)
  9928.             (setq *current-vars* (delete-if #'symbolp *current-vars*)) ; Kann Werte dynamischer Variablen zerstören
  9929.           )
  9930.           (t (compiler-error 'traverse-anode "LISTITEM"))
  9931. ) ) ) ) )
  9932.  
  9933. ; Hilfsfunktionen nach dem 1. Schritt:
  9934.  
  9935. ; Kommt eine Instruktion item dazu, die vielleicht Label-Referenzen enthält,
  9936. ; so ist note-references aufzurufen. Dieses notiert die Label-Referenzen in
  9937. ; item. item gehöre zu (aref *code-parts* index).
  9938. ; Wird eine Instruktion item entfernt, die vielleicht Label-Referenzen enthält,
  9939. ; so ist remove-references aufzurufen. Dieses notiert das Wegfallen der
  9940. ; Label-Referenzen in item. item gehöre zu (aref *code-parts* index).
  9941. ; Liefert auch die Liste der in item enthaltenen Labels.
  9942. (macrolet ((references ()
  9943.              `(case (first item)
  9944.                 (JMP (end-ref (second item)))
  9945.                 ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  9946.                  (end-ref (second item)) (end-ref (third item))
  9947.                 )
  9948.                 (JMPHASH (dolist (label (cdddr item)) (end-ref label)))
  9949.                 ((JMPIFBOUNDP CATCH-OPEN UNWIND-PROTECT-OPEN UNWIND-PROTECT-CLOSE)
  9950.                  (mid-ref (second item))
  9951.                 )
  9952.                 ((BLOCK-OPEN JSR) (mid-ref (third item)))
  9953.                 (JMPTAIL (mid-ref (fourth item)))
  9954.                 (TAGBODY-OPEN (dolist (label (cddr item)) (mid-ref label)))
  9955.                 (HANDLER-OPEN (dolist (label (cddddr item)) (mid-ref label)))
  9956.               )
  9957.           ))
  9958.   (defun note-references (item &optional index)
  9959.     (macrolet ((end-ref (label) `(push index (symbol-value ,label)))
  9960.                (mid-ref (label) `(push item (symbol-value ,label))))
  9961.       (references)
  9962.   ) )
  9963.   (defun remove-references (item &optional index &aux (labellist '()))
  9964.     (macrolet ((end-ref (label)
  9965.                  (let ((labelvar (gensym)))
  9966.                    `(let ((,labelvar ,label))
  9967.                       (setf (symbol-value ,labelvar) (delete index (symbol-value ,labelvar)))
  9968.                       (pushnew ,labelvar labellist)
  9969.                     )
  9970.                ) )
  9971.                (mid-ref (label)
  9972.                  (let ((labelvar (gensym)))
  9973.                    `(let ((,labelvar ,label))
  9974.                       (setf (symbol-value ,labelvar) (delete item (symbol-value ,labelvar)))
  9975.                       (pushnew ,labelvar labellist)
  9976.                     )
  9977.               )) )
  9978.       (references)
  9979.       labellist
  9980.   ) )
  9981. )
  9982.  
  9983. #|
  9984.                               2. Schritt
  9985.                 Vereinfachung von Folgen von Operationen
  9986.  
  9987. Dieses spielt sich auf umgedrehten Codestücken ab; sie werden dabei destruktiv
  9988. verändert.
  9989.  
  9990. Vereinfachungsregeln für Operationen:
  9991.  
  9992. 1. (VALUES1) darf nach allen Instruktionen gestrichen werden, die sowieso nur
  9993.    einen Wert produzieren, und vor allen, die sowieso nur einen verwenden.
  9994.  
  9995. 2. (SKIP n1) (SKIP n2)               --> (SKIP n1+n2)
  9996.    (SKIPI k n1) (SKIP n2)            --> (SKIPI k n1+n2)
  9997.    (SKIP n1) (SKIPI k n2)            --> (SKIPI k n2)
  9998.    (SKIPI k1 n1) (SKIPI k2 n2)       --> (SKIPI k1+k2+1 n2)
  9999.    (SKIPSP k1) (SKIPI k2 n)          --> (SKIPI k1+k2 n)
  10000.    (SKIPSP k1) (SKIPSP k2)           --> (SKIPSP k1+k2)
  10001.  
  10002. 3. (NOT) (NOT) (NOT)                 --> (NOT)
  10003.    (ATOM) (NOT)                      --> (CONSP)
  10004.    (CONSP) (NOT)                     --> (ATOM)
  10005.  
  10006. 4. (LOAD 0) (SKIP n)                 --> (POP) (SKIP n-1)  für n>1
  10007.    (LOAD 0) (SKIP 1)                 --> (POP)             für n=1
  10008.    (PUSH) (SKIP n)                   --> (SKIP n-1)  für n>1
  10009.    (PUSH) (SKIP 1)                   -->             für n=1
  10010.    (NV-TO-STACK n) (SKIP n)          -->
  10011.    (NV-TO-STACK n+m) (SKIP n)        --> (NV-TO-STACK m)
  10012.    (NV-TO-STACK n) (SKIP n+m)        --> (SKIP m)
  10013.    (STORE m) (SKIP n)                --> (VALUES1) (SKIP n) für n>m
  10014.    (STORE 0) (POP)                   --> (VALUES1) (SKIP 1)
  10015.    (PUSH) (POP)                      --> (VALUES1)
  10016.    (POP) (PUSH)                      -->
  10017.    (SKIP n) (PUSH)                   --> (SKIP n-1) (STORE 0) für n>1
  10018.    (SKIP 1) (PUSH)                   --> (STORE 0)            für n=1
  10019.  
  10020. 5. (VALUES1)/... (MV-TO-STACK)       --> (VALUES1)/... (PUSH)
  10021.    (VALUES0) (MV-TO-STACK)           -->
  10022.    (STACK-TO-MV n) (MV-TO-STACK)     -->
  10023.    (STACK-TO-MV m) (NV-TO-STACK n)   --> (PUSH-NIL n-m)  für m<n
  10024.                                      -->                 für m=n
  10025.                                      --> (SKIP m-n)      für m>n
  10026.    (NIL)/(VALUES0) (NV-TO-STACK n)   --> (PUSH-NIL n)
  10027.    (VALUES1)/... (NV-TO-STACK n)     --> (VALUES1)/... (PUSH) (PUSH-NIL n-1)
  10028.  
  10029. 6. (PUSH-UNBOUND n) (PUSH-UNBOUND m) --> (PUSH-UNBOUND n+m)
  10030.  
  10031. 7. (LIST* 1)                         --> (CONS)
  10032.  
  10033. |#
  10034.  
  10035. ; Die Hash-Tabelle one-value-ops enthält diejenigen Befehle,
  10036. ; die genau einen Wert erzeugen.
  10037. (defconstant one-value-ops
  10038.   (let ((ht (make-hash-table :test #'eq)))
  10039.     (dolist (op '(NIL T CONST LOAD LOADI LOADC LOADV LOADIC STORE STOREI
  10040.                   STOREC STOREV STOREIC GETVALUE SETVALUE POP VENV
  10041.                   COPY-CLOSURE BOUNDP VALUES1 MV-TO-LIST TAGBODY-CLOSE-NIL
  10042.                   NOT EQ CAR CDR CONS ATOM CONSP SYMBOL-FUNCTION SVREF SVSET
  10043.                   LIST LIST*
  10044.             )    )
  10045.       (setf (gethash op ht) t)
  10046.     )
  10047.     ht
  10048. ) )
  10049.  
  10050. ; Der Wert zu einem Key in dieser Hash-Tabelle gibt an, wieviele Werte bei
  10051. ; der Ausführung der entsprechenden Operation benötigt werden
  10052. ; (vgl. *for-value*):
  10053. ; NIL : Werte werden weggeworfen.
  10054. ; ONE : Ein Wert wird verwendet, die übrigen weggeworfen.
  10055. ; ALL : Alle Werte werden verwendet.
  10056. ; Operationen, die ihre Werte nicht verändern, werden hierin nicht
  10057. ; aufgeführt.
  10058. (defconstant for-value-table
  10059.   (let ((ht (make-hash-table :test #'eq)))
  10060.     (dolist (op '(NIL PUSH-NIL T CONST LOAD LOADI LOADC LOADV LOADIC
  10061.                   GETVALUE POP JSR JMPTAIL BARRIER VENV COPY-CLOSURE CALL
  10062.                   CALL0 CALLS1 CALLS2 CALLSR FUNCALL PUSH-UNBOUND JMPIFBOUNDP
  10063.                   BOUNDP VALUES0 STACK-TO-MV MVCALL
  10064.                   BLOCK-OPEN TAGBODY-OPEN TAGBODY-CLOSE-NIL GO GO-I
  10065.                   UNWIND-PROTECT-OPEN UNWIND-PROTECT-CLOSE
  10066.                   HANDLER-OPEN HANDLER-BEGIN
  10067.                   LIST
  10068.             )    )
  10069.       (setf (gethash op ht) 'NIL)
  10070.     )
  10071.     (dolist (op '(STORE STOREI STOREC STOREV STOREIC SETVALUE BIND PROGV PUSH
  10072.                   MAKE-VECTOR1&PUSH CALL1 CALL2 CALLC CALLCKEY APPLY UNLIST
  10073.                   UNLIST* VALUES1 LIST-TO-MV MVCALLP CATCH-OPEN
  10074.                   NOT EQ CAR CDR CONS ATOM CONSP SYMBOL-FUNCTION SVREF SVSET
  10075.                   LIST*
  10076.             )    )
  10077.       (setf (gethash op ht) 'ONE)
  10078.     )
  10079.     (dolist (op '(MV-TO-STACK NV-TO-STACK MV-TO-LIST RETURN-FROM RETURN-FROM-I
  10080.                   THROW UNWIND-PROTECT-NORMAL-EXIT
  10081.             )    )
  10082.       (setf (gethash op ht) 'ALL)
  10083.     )
  10084.     ; Nicht in der Tabelle, weil sie die Werte unverändert lassen:
  10085.     ;           '(UNBIND1 SKIP SKIPI SKIPSP BLOCK-CLOSE TAGBODY-CLOSE
  10086.     ;             CATCH-CLOSE UNWIND-PROTECT-CLEANUP
  10087.     ;            )
  10088.     ; Nicht in der Tabelle, weil es Wegsprünge sind:
  10089.     ;   ONE:    '(JMPHASH)
  10090.     ;   ALL:    '(RET JMP JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10091.     ht
  10092. ) )
  10093.  
  10094. ; Vereinfacht ein Codestück (in umgedrehter Reihenfolge!).
  10095. ; Obige Vereinfachungsregeln werden durchgeführt, solange es geht.
  10096. ; Ergebnis ist meist NIL, oder aber (um anzuzeigen, daß weitere Optimierungen
  10097. ; möglich sind) das Anfangslabel, falls sich dessen Property for-value
  10098. ; abgeschwächt hat.
  10099. (defun simplify (codelist)
  10100.   (let ((for-value-at-end
  10101.           (let ((item (car codelist)))
  10102.             (case (first item)
  10103.               (JMP (get (second item) 'for-value))
  10104.               ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10105.                 (if (or (and (not (eq (first item) 'JMPCASE1-TRUE))
  10106.                              (eq (get (second item) 'for-value) 'ALL)
  10107.                         )
  10108.                         (and (not (eq (first item) 'JMPCASE1-FALSE))
  10109.                              (eq (get (third item) 'for-value) 'ALL)
  10110.                     )   )
  10111.                   'ALL
  10112.                   'ONE
  10113.               ) )
  10114.               (JMPHASH 'ONE)
  10115.               ((BARRIER GO GO-I JMPTAIL) 'NIL)
  10116.               ((RETURN-FROM RETURN-FROM-I RET THROW) 'ALL)
  10117.               (t (compiler-error 'simplify "AT-END"))
  10118.         ) ) )
  10119.         (result nil)) ; evtl. das Anfangslabel
  10120.     ; for-value-at-end zeigt an, welche Werte vor dem Wegsprung benötigt werden.
  10121.     (loop
  10122.       (let ((modified nil))
  10123.         (let* ((links codelist) (mitte (cdr links)) rechts (for-value for-value-at-end))
  10124.           ; Es wandern drei Pointer durch die Codeliste: ...links.mitte.rechts...
  10125.           ; for-value zeigt an, was für Werte nach Ausführung von (car mitte),
  10126.           ; vor Ausführung von (car links), gebraucht werden.
  10127.           (loop
  10128.             nochmal
  10129.             (when (atom mitte) (return))
  10130.             (setq rechts (cdr mitte))
  10131.             (macrolet ((ersetze1 (new) ; ersetze (car mitte) durch new
  10132.                          `(progn
  10133.                             (setf (car mitte) ,new)
  10134.                             (setq modified t) (go nochmal)
  10135.                           )
  10136.                        )
  10137.                        (ersetze2 (new) ; ersetze (car mitte) und (car rechts) durch new
  10138.                          `(progn
  10139.                             ,@(unless (equal new '(car mitte))
  10140.                                 `((setf (car mitte) ,new))
  10141.                               )
  10142.                             (setf (cdr mitte) (cdr rechts))
  10143.                             (setq modified t) (go nochmal)
  10144.                           )
  10145.                        )
  10146.                        (streiche1 () ; streiche (car mitte) ersatzlos
  10147.                          `(progn
  10148.                             (setf (cdr links) (setq mitte rechts))
  10149.                             (setq modified t) (go nochmal)
  10150.                           )
  10151.                        )
  10152.                        (streiche2 () ; streiche (car mitte) und (car rechts) ersatzlos
  10153.                          `(progn
  10154.                             (setf (cdr links) (setq mitte (cdr rechts)))
  10155.                             (setq modified t) (go nochmal)
  10156.                           )
  10157.                        )
  10158.                        (erweitere2 (new1 new2) ; ersetze (car mitte) durch new1 und new2
  10159.                          `(progn
  10160.                             (setf (car mitte) ,new1)
  10161.                             (setf (cdr mitte) (cons ,new2 rechts))
  10162.                             (setq modified t) (go nochmal)
  10163.                           )
  10164.                       ))
  10165.               (when (eq for-value 'NIL)
  10166.                 ; vor einer Operation, die keine Werte braucht:
  10167.                 (case (first (car mitte))
  10168.                   ((NIL T CONST LOAD LOADI LOADC LOADV LOADIC GETVALUE VENV
  10169.                     BOUNDP VALUES0 VALUES1 MV-TO-LIST LIST-TO-MV NOT CAR CDR
  10170.                     SYMBOL-FUNCTION ATOM CONSP
  10171.                    )
  10172.                     (streiche1)
  10173.                   )
  10174.                   ((LIST LIST* STACK-TO-MV) ; (LIST n) --> (SKIP n), n>0
  10175.                                             ; (LIST* n) --> (SKIP n), n>0
  10176.                                             ; (STACK-TO-MV n) --> (SKIP n), n>0
  10177.                     (ersetze1 `(SKIP ,(second (car mitte))))
  10178.                   )
  10179.                   ((POP EQ CONS SVREF) (ersetze1 '(SKIP 1)))
  10180.               ) )
  10181.               (when (eq for-value 'ONE)
  10182.                 ; vor einer Operation, die nur einen Wert braucht:
  10183.                 (case (first (car mitte))
  10184.                   (VALUES1 (streiche1))
  10185.                   (VALUES0 (ersetze1 '(NIL)))
  10186.                   (LIST-TO-MV (ersetze1 '(CAR)))
  10187.                   (STACK-TO-MV ; (STACK-TO-MV n) --> (SKIP n-1) (POP) für n>1
  10188.                     (let ((n (second (car mitte))))
  10189.                       (erweitere2 '(POP) `(SKIP ,(- n 1)))
  10190.               ) ) ) )
  10191.               (when (consp rechts)
  10192.                 ; Gucklock umfaßt (car mitte) und (car rechts), evtl. auch mehr.
  10193.                 (case (first (car mitte))
  10194.                   (VALUES1 ; Regel 1
  10195.                     (when (gethash (first (car rechts)) one-value-ops nil)
  10196.                       ; (op ...) (VALUES1) --> (op ...)
  10197.                       (streiche1)
  10198.                   ) )
  10199.                   (NOT ; Regel 3
  10200.                     (case (first (car rechts))
  10201.                       (NOT
  10202.                         (when (and (consp (cdr rechts))
  10203.                                    (equal (cadr rechts) '(NOT))
  10204.                               )
  10205.                           ; (NOT) (NOT) (NOT) --> (NOT)
  10206.                           (streiche2)
  10207.                       ) )
  10208.                       (ATOM (ersetze2 '(CONSP))) ; (ATOM) (NOT) --> (CONSP)
  10209.                       (CONSP (ersetze2 '(ATOM))) ; (CONSP) (NOT) --> (ATOM)
  10210.                   ) )
  10211.                   (SKIP
  10212.                     (let ((n2 (second (car mitte)))) ; n2 > 0
  10213.                       (case (first (car rechts))
  10214.                         ; Regel 2
  10215.                         (SKIP ; (SKIP n1) (SKIP n2) --> (SKIP n1+n2)
  10216.                           (let ((n1 (second (car rechts))))
  10217.                             (ersetze2 `(SKIP ,(+ n1 n2)))
  10218.                         ) )
  10219.                         (SKIPI ; (SKIPI k n1) (SKIP n2) --> (SKIPI k n1+n2)
  10220.                           (let ((k (second (car rechts)))
  10221.                                 (n1 (third (car rechts))))
  10222.                             (ersetze2 `(SKIPI ,k ,(+ n1 n2)))
  10223.                         ) )
  10224.                         ; Regel 4
  10225.                         (LOAD ; (LOAD 0) (SKIP n) --> (POP) [(SKIP n-1)]
  10226.                           (when (eql (second (car rechts)) 0)
  10227.                             (if (eql n2 1)
  10228.                               (ersetze2 '(POP))
  10229.                               (progn (setf (car rechts) '(POP))
  10230.                                      (ersetze1 `(SKIP ,(- n2 1)))
  10231.                         ) ) ) )
  10232.                         (PUSH ; (PUSH) (SKIP n) --> [(SKIP n-1)]
  10233.                           (if (eql n2 1)
  10234.                             (streiche2)
  10235.                             (ersetze2 `(SKIP ,(- n2 1)))
  10236.                         ) )
  10237.                         (NV-TO-STACK
  10238.                           (let ((n1 (second (car rechts))))
  10239.                             (cond ((> n1 n2) (ersetze2 `(NV-TO-STACK ,(- n1 n2))))
  10240.                                   ((< n1 n2) (ersetze2 `(SKIP ,(- n2 n1))))
  10241.                                   (t (streiche2))
  10242.                         ) ) )
  10243.                         (STORE ; (STORE m) (SKIP n) --> (VALUES1) (SKIP n) für n>m
  10244.                           (let ((m (second (car rechts))))
  10245.                             (when (> n2 m)
  10246.                               (setf (car rechts) '(VALUES1))
  10247.                               (setq modified t) (go nochmal)
  10248.                   ) ) ) ) ) )
  10249.                   (SKIPI ; Regel 2
  10250.                     (case (first (car rechts))
  10251.                       (SKIP ; (SKIP n1) (SKIPI k n2) --> (SKIPI k n2)
  10252.                         (ersetze2 (car mitte))
  10253.                       )
  10254.                       (SKIPI ; (SKIPI k1 n1) (SKIPI k2 n2) --> (SKIPI k1+k2+1 n2)
  10255.                         (let ((k1 (second (car rechts)))
  10256.                               (k2 (second (car mitte)))
  10257.                               (n2 (third (car mitte))))
  10258.                           (ersetze2 `(SKIPI ,(+ k1 k2 1) ,n2))
  10259.                       ) )
  10260.                       (SKIPSP ; (SKIPSP k1) (SKIPI k2 n) --> (SKIPI k1+k2 n)
  10261.                         (let ((k1 (second (car rechts)))
  10262.                               (k2 (second (car mitte)))
  10263.                               (n2 (third (car mitte))))
  10264.                           (ersetze2 `(SKIPI ,(+ k1 k2) ,n2))
  10265.                   ) ) ) )
  10266.                   (SKIPSP ; Regel 2
  10267.                     (case (first (car rechts))
  10268.                       (SKIPSP ; (SKIPSP k1) (SKIPSP k2) --> (SKIPSP k1+k2)
  10269.                         (let ((k1 (second (car rechts)))
  10270.                               (k2 (second (car mitte))))
  10271.                           (ersetze2 `(SKIPSP ,(+ k1 k2)))
  10272.                   ) ) ) )
  10273.                   (POP ; Regel 4
  10274.                     (cond ((equal (car rechts) '(STORE 0))
  10275.                             ; (STORE 0) (POP) --> (VALUES1) (SKIP 1)
  10276.                             (setf (car rechts) '(VALUES1))
  10277.                             (ersetze1 '(SKIP 1))
  10278.                           )
  10279.                           ((equal (car rechts) '(PUSH))
  10280.                             ; (PUSH) (POP) --> (VALUES1)
  10281.                             (ersetze2 '(VALUES1))
  10282.                   ) )     )
  10283.                   (PUSH ; Regel 4
  10284.                     (case (first (car rechts))
  10285.                       (POP (streiche2)) ; (POP) (PUSH) streichen
  10286.                       (SKIP ; (SKIP n) (PUSH) --> [(SKIP n-1)] (STORE 0)
  10287.                         (let ((n (second (car rechts))))
  10288.                           (if (eql n 1)
  10289.                             (unless (and (consp (cdr rechts)) (equal (cadr rechts) '(LOAD 0)))
  10290.                               ; (LOAD 0) (SKIP 1) (PUSH) wird anders behandelt
  10291.                               (ersetze2 '(STORE 0))
  10292.                             )
  10293.                             (progn (setf (car rechts) `(SKIP ,(- n 1)))
  10294.                                    (ersetze1 '(STORE 0))
  10295.                   ) ) ) ) ) )
  10296.                   (MV-TO-STACK ; Regel 5
  10297.                     (when (gethash (first (car rechts)) one-value-ops nil)
  10298.                       ; (car rechts) liefert nur einen Wert -->
  10299.                       ; (MV-TO-STACK) durch (PUSH) ersetzen:
  10300.                       (ersetze1 '(PUSH))
  10301.                     )
  10302.                     (case (first (car rechts))
  10303.                       ((VALUES0 STACK-TO-MV) (streiche2))
  10304.                   ) )
  10305.                   (NV-TO-STACK ; Regel 5
  10306.                     (let ((n (second (car mitte))))
  10307.                       (case (first (car rechts))
  10308.                         (STACK-TO-MV
  10309.                           (let ((m (second (car rechts))))
  10310.                             (cond ((> n m) (ersetze2 `(PUSH-NIL ,(- n m))))
  10311.                                   ((< n m) (ersetze2 `(SKIP ,(- m n))))
  10312.                                   (t (streiche2))
  10313.                         ) ) )
  10314.                         ((VALUES0 NIL) (ersetze2 `(PUSH-NIL ,n)))
  10315.                         (t (when (gethash (first (car rechts)) one-value-ops nil)
  10316.                              (erweitere2 `(PUSH-NIL ,(- n 1)) `(PUSH))
  10317.                   ) ) ) )  )
  10318.                   (PUSH-UNBOUND ; Regel 6
  10319.                     (case (first (car rechts))
  10320.                       (PUSH-UNBOUND ; (PUSH-UNBOUND n) (PUSH-UNBOUND m) --> (PUSH-UNBOUND n+m)
  10321.                         (let ((n (second (car rechts)))
  10322.                               (m (second (car mitte))))
  10323.                           (ersetze2 `(PUSH-UNBOUND ,(+ n m)))
  10324.                   ) ) ) )
  10325.                   (LIST* ; Regel 7
  10326.                     (when (equal (rest (car mitte)) '(1))
  10327.                       (ersetze1 '(CONS))
  10328.                   ) )
  10329.             ) ) )
  10330.             (when (atom mitte) (return))
  10331.             ; Neues for-value berechnen, in Abhängigkeit von (car mitte):
  10332.             (setq for-value
  10333.               (gethash (first (car mitte)) for-value-table for-value)
  10334.             )
  10335.             ; weiterrücken:
  10336.             (setq links mitte mitte rechts)
  10337.           )
  10338.           ; Codestück zu Ende: (atom mitte)
  10339.           (when mitte
  10340.             ; mitte ist das Anfangslabel
  10341.             (let ((old-for-value (get mitte 'for-value)))
  10342.               ; Ist for-value besser als old-for-value ?
  10343.               (when (and (not (eq for-value old-for-value))
  10344.                          (or (eq old-for-value 'ALL) (eq for-value 'NIL))
  10345.                     )
  10346.                 ; ja -> Anfangslabel nachher als Ergebnis bringen:
  10347.                 (setf (get mitte 'for-value) for-value result mitte)
  10348.           ) ) )
  10349.         ) ; end let*
  10350.         (unless modified (return))
  10351.     ) ) ; end let, loop
  10352.     (let (codelistr)
  10353.       (when (and (eq (first (first codelist)) 'RET)
  10354.                  (consp (setq codelistr (cdr codelist)))
  10355.                  (or (eq (first (first codelistr)) 'JSR)
  10356.                      (and (eq (first (second codelist)) 'SKIP)
  10357.                           (consp (setq codelistr (cddr codelist)))
  10358.                           (eq (first (first codelistr)) 'JSR)
  10359.             )    )   )
  10360.         ; (JSR n label) [(SKIP m)] (RET) --> (JMPTAIL n n+m label)
  10361.         (let ((n (second (first codelistr)))
  10362.               (label (third (first codelistr)))
  10363.               (m (if (eq codelistr (cdr codelist)) 0 (second (second codelist)))))
  10364.           (setf (first codelist) `(JMPTAIL ,n ,(+ n m) ,label))
  10365.         )
  10366.         (remove-references (first codelistr)) ; (JSR ...) wird gestrichen
  10367.         (note-references (first codelist)) ; (JMPTAIL ...) wird eingefügt
  10368.         (setf (cdr codelist) (cdr codelistr)) ; ein bzw. zwei Listenelemente streichen
  10369.         (setq for-value-at-end 'NIL) ; JMPTAIL braucht keine Werte
  10370.     ) )
  10371.     result
  10372. ) )
  10373.  
  10374. #|
  10375.                             3. Schritt:
  10376.                       Allgemeine Optimierungen
  10377.  
  10378. Wird eine Optimierung erfolgreich durchgeführt, so werden alle weiteren
  10379. Optimierungen nochmal probiert, die sich deswegen ergeben könnten.
  10380.  
  10381. optimize-part    - ruft den 2. Schritt auf:
  10382.                    Peephole-Optimierung normaler Operationen.
  10383.  
  10384. optimize-label   - Codestücke zu Labels, die nicht (mehr) referenziert werden,
  10385.                    werden entfernt.
  10386.                  - Wird ein Label nur von einem einzigen JMP referenziert,
  10387.                    der nicht vom selben Codestück kommt, können die beiden
  10388.                    betroffenen Stücke aneinandergehängt werden.
  10389.  
  10390. optimize-short   - Liegt ein Codestück vor, wo auf das Anfangslabel label1
  10391.                    sofort ein (JMP label2) folgt, so werden alle Referenzen
  10392.                    von label1 durch label2 ersetzt und das Codestück entfernt.
  10393.                  - Liegt ein Codestück vor, wo auf das Anfangslabel label
  10394.                    sofort ein
  10395.                    (JMPCASE/JMPCASE1-TRUE/JMPCASE1-FALSE label_true label_false)
  10396.                    folgt, so können Referenzen (JMPCASE1-TRUE label l) und
  10397.                    (JMPCASE1-FALSE l label) vereinfacht werden.
  10398.                  - Ein kurzes Codestück wird direkt an zugehörige JMPs auf
  10399.                    sein Anfangslabel angehängt. (Ein Codestück heißt "kurz",
  10400.                    wenn es höchstens 2 Befehle umfaßt und nicht mit einem
  10401.                    JMPHASH (den man nicht duplizieren sollte) abgeschlossen
  10402.                    ist. Auch HANDLER-OPEN sollte man nicht duplizieren.)
  10403.  
  10404. optimize-jmpcase - (JMPCASE label label) wird vereinfacht zu (JMP label).
  10405.                  - (NOT) [...] (JMPCASE label_true label_false) wird
  10406.                    vereinfacht zu [...] (JMPCASE label_false label_true),
  10407.                    wobei [...] nur Befehle enthalten darf, die den 1. Wert
  10408.                    nicht verändern, und bei label_true und label_false keine
  10409.                    Werte gebraucht werden.
  10410.  
  10411. optimize-value   - Ein Wegsprung JMPCASE1-TRUE/JMPCASE1-FALSE kann durch
  10412.                    JMPCASE ersetzt werden, wenn am Ziel-Label der Wert
  10413.                    nicht gebraucht oder nur der 1. Wert gebraucht wird.
  10414.                  - Ein Wegsprung JMPCASE/JMPCASE1-TRUE/JMPCASE1-FALSE kann
  10415.                    durch ein JMP ersetzt werden, wenn der aktuelle Wert an
  10416.                    dieser Stelle als =NIL oder als /=NIL nachgewiesen werden
  10417.                    kann.
  10418.                  - Ein JMP kann die Information, welcher Wert gerade vorliegt,
  10419.                    zu seinem Ziel-Label weitertragen.
  10420.  
  10421. coalesce         - Lege Codeteile mit gleichem Ende (mind. 3 Befehle) zusammen.
  10422.  
  10423. |#
  10424.  
  10425. (defun optimize-part (code)
  10426.   (let ((label (simplify code)))
  10427.     (when label
  10428.       ; Die Property for-value von label wurde verbessert.
  10429.       (dolist (ref (symbol-value label))
  10430.         (when (integerp ref) (optimize-value ref))
  10431. ) ) ) )
  10432.  
  10433. (defun optimize-label (label &optional (index (get label 'code-part))
  10434.                                        (code (aref *code-parts* index))
  10435.                                        (lastc (last code))
  10436.                       )
  10437.   (unless (eq label (cdr lastc)) (compiler-error 'optimize-label))
  10438.   (when label
  10439.     ; label ist ein Label, es beginnt den Code
  10440.     ; code = (aref *code-parts* index), und es ist lastc = (last code).
  10441.     (let ((refs (symbol-value label))) ; Liste der Referenzen darauf
  10442.       (cond ((null refs)
  10443.               ; nicht referenziertes Label: Codestück entfernen,
  10444.               ; Referenzen aus diesem Codestück heraus eliminieren.
  10445.               (let ((labellist '())) ; Liste von Labels, die Referenzen
  10446.                                      ; verloren haben
  10447.                 (loop
  10448.                   (when (atom code) (return))
  10449.                   (setq labellist
  10450.                     (nreconc labellist (remove-references (pop code) index))
  10451.                 ) )
  10452.                 (setf (aref *code-parts* index) nil) ; Codestück entfernen
  10453.                 ; Bei Labels mit weniger Referenzen weiteroptimieren:
  10454.                 ; (Vorsicht: Hierdurch kann sich *code-parts* verändern.)
  10455.                 (dolist (olabel labellist)
  10456.                   (let* ((oindex (get olabel 'code-part))
  10457.                          (ocode (aref *code-parts* oindex)))
  10458.                     (when ocode
  10459.                       (optimize-label olabel oindex ocode)
  10460.                 ) ) )
  10461.             ) )
  10462.             ((null (cdr refs))
  10463.               ; Label mit nur einer Referenz, und zwar durch JMP ?
  10464.               (let ((ref (first refs)))
  10465.                 (when (and (integerp ref) ; Ein JMP ist ein Wegsprung
  10466.                            (eq (first (car (aref *code-parts* ref))) 'JMP)
  10467.                            (not (eql index ref)) ; aus anderem Codestück
  10468.                       )
  10469.                   ; Anhängen:
  10470.                   ; (aref *code-parts* ref) wird in die Schublade
  10471.                   ; (aref *code-parts* index) gesteckt.
  10472.                   (setf (cdr lastc) (rest (aref *code-parts* ref)))
  10473.                   (setf (aref *code-parts* ref) nil)
  10474.                   (let ((new-startlabel (cdr (last lastc)))) ; neues Startlabel von (aref *code-parts* index)
  10475.                     (when new-startlabel
  10476.                       (setf (get new-startlabel 'code-part) index)
  10477.                   ) )
  10478.                   (setf (symbol-value label) '()) ; altes Startlabel von (aref *code-parts* index) deaktivieren
  10479.                   ; neues Codestück vereinfachen:
  10480.                   (optimize-part code)
  10481. ) ) ) )     ) ) )
  10482.  
  10483. (defun optimize-short (index &optional (code (aref *code-parts* index))
  10484.                              &aux      (lastc (last code))
  10485.                                        (label (cdr lastc))
  10486.                       )
  10487.   (when label
  10488.     ; label ist ein Label, es beginnt den Code
  10489.     ; code = (aref *code-parts* index), und es ist lastc = (last code).
  10490.     (when (eq code lastc)
  10491.       ; Eine einzige Operation nach dem Label.
  10492.       (let ((item (car code)))
  10493.         (case (first item)
  10494.           (JMP ; (JMP ...) sofort nach dem Label
  10495.             (let ((to-label (second item)))
  10496.               (unless (eq label to-label)
  10497.                 (label-subst label to-label) ; Referenzen umbiegen
  10498.                 (setf (aref *code-parts* index) nil) ; Codestück entfernen
  10499.                 (setf (symbol-value to-label)
  10500.                       (delete index (symbol-value to-label)) ; Referenz fällt weg
  10501.                 )
  10502.                 (optimize-label to-label) ; mögliche Optimierung
  10503.             ) )
  10504.             (return-from optimize-short)
  10505.           )
  10506.           ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10507.             (let ((true-label (second item))
  10508.                   (false-label (third item)))
  10509.               (unless (or (eq label true-label) (eq label false-label))
  10510.                 (macrolet ((err () `(compiler-error 'optimize-short)))
  10511.                   ; JMPCASE1-Referenzen auf label vereinfachen:
  10512.                   (let ((modified-indices '())) ; Indizes von modifizierten Codestücken
  10513.                     (dolist (refindex (symbol-value label))
  10514.                       (when (integerp refindex)
  10515.                         (let* ((refcode (aref *code-parts* refindex))
  10516.                                (ref (car refcode)))
  10517.                           (case (first ref)
  10518.                             (JMP
  10519.                               ; (JMP label) --> (JMPCASE/... true-label false-label)
  10520.                               (setf (car refcode) item)
  10521.                               ; neue Verweise auf true-label und false-label:
  10522.                               (push refindex (symbol-value true-label))
  10523.                               (push refindex (symbol-value false-label))
  10524.                               (push refindex modified-indices)
  10525.                             )
  10526.                             ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10527.                               ; (JMPCASE/... label1 label2)
  10528.                               (let ((label1 (second ref)) ; im TRUE-Fall: wohin springen
  10529.                                     (label2 (third ref)) ; im FALSE-Fall: wohin springen
  10530.                                     (1-true (eq (first ref) 'JMPCASE1-TRUE)) ; im TRUE-Fall: mit (VALUES1) ?
  10531.                                     (1-false (eq (first ref) 'JMPCASE1-FALSE))) ; im FALSE-Fall: mit (VALUES1) ?
  10532.                                 (when (eq label label1)
  10533.                                   ; Der (JMPCASE/... label ...) wird vereinfacht zu
  10534.                                   ; (JMPCASE/... true-label ...).
  10535.                                   (setq label1 true-label)
  10536.                                   ; neuer Verweis auf true-label:
  10537.                                   (push refindex (symbol-value true-label))
  10538.                                   (push refindex modified-indices)
  10539.                                   (when (eq (first item) 'JMPCASE1-TRUE)
  10540.                                     (setq 1-true t)
  10541.                                 ) )
  10542.                                 (when (eq label label2)
  10543.                                   ; Der (JMPCASE/... ... label) wird vereinfacht zu
  10544.                                   ; (JMPCASE/... ... false-label).
  10545.                                   (setq label2 false-label)
  10546.                                   ; neuer Verweis auf false-label:
  10547.                                   (push refindex (symbol-value false-label))
  10548.                                   (push refindex modified-indices)
  10549.                                   (when (eq (first item) 'JMPCASE1-FALSE)
  10550.                                     (setq 1-false t)
  10551.                                 ) )
  10552.                                 (unless (eq (get label1 'for-value) 'ALL)
  10553.                                   (setq 1-true nil)
  10554.                                 )
  10555.                                 (unless (eq (get label2 'for-value) 'ALL)
  10556.                                   (setq 1-false nil)
  10557.                                 )
  10558.                                 (when (and 1-true 1-false)
  10559.                                   (push '(VALUES1) (cdr refcode))
  10560.                                   (setq 1-true nil 1-false nil)
  10561.                                 )
  10562.                                 (setf (car refcode)
  10563.                                   `(,(cond (1-true 'JMPCASE1-TRUE)
  10564.                                            (1-false 'JMPCASE1-FALSE)
  10565.                                            (t 'JMPCASE)
  10566.                                      )
  10567.                                     ,label1
  10568.                                     ,label2
  10569.                                    )
  10570.                             ) ) )
  10571.                             (JMPHASH (err)) ; JMPHASH hat undefinierte Werte
  10572.                         ) )
  10573.                         ; später:
  10574.                         ; (setf (symbol-value label) (delete refindex (symbol-value label)))
  10575.                     ) )
  10576.                     (setf (symbol-value label)
  10577.                           (delete-if #'integerp (symbol-value label))
  10578.                     )
  10579.                     ; evtl. Optimierung wegen verringerter Referenzen möglich:
  10580.                     (optimize-label label)
  10581.                     ; evtl. weitere Optimierung in veränderten Codeteilen:
  10582.                     (dolist (refindex modified-indices)
  10583.                       (simplify (aref *code-parts* refindex))
  10584.                       (optimize-value refindex)
  10585.                       (optimize-jmpcase refindex (aref *code-parts* refindex))
  10586.                     )
  10587.           ) ) ) ) )
  10588.     ) ) )
  10589.     ; Sonstige "kurze" Codestücke, maximal 2 Operationen lang:
  10590.     (when (and (or (eq code lastc) (eq (cdr code) lastc))
  10591.                (not (eq (first (car code)) 'JMPHASH))
  10592.                (or (eq code lastc) (not (eq (first (cadr code)) 'HANDLER-OPEN)))
  10593.           )
  10594.       (let ((indices '())) ; Liste der Indizes der Codestücke, an die wir code anhängen
  10595.         (setf (cdr lastc) '()) ; code vorläufig ohne das Label am Schluß
  10596.         (dolist (refindex (symbol-value label))
  10597.           (when (and (integerp refindex) (not (eql refindex index)))
  10598.             (let ((refcode (aref *code-parts* refindex)))
  10599.               (when (eq (first (car refcode)) 'JMP)
  10600.                 ; anhängen:
  10601.                 (let ((new-code (mapcar #'copy-list code)))
  10602.                   (dolist (op new-code) (note-references op refindex))
  10603.                   (setf (aref *code-parts* refindex) (nconc new-code (cdr refcode)))
  10604.                 )
  10605.                 (setf (symbol-value label) (delete refindex (symbol-value label)))
  10606.                 (push refindex indices)
  10607.         ) ) ) )
  10608.         (setf (cdr lastc) label) ; wieder das Label ans Listenende setzen
  10609.         (when indices
  10610.           ; mögliche weitere Optimierungen:
  10611.           (dolist (refindex indices)
  10612.             (optimize-part (aref *code-parts* refindex))
  10613.           )
  10614.           (optimize-label label) ; label hat weniger Referenzen -> optimieren
  10615.     ) ) )
  10616. ) )
  10617.  
  10618. ; get-boolean-value versucht zu einem Anfangsstück eines Codestücks
  10619. ; (einem (nthcdr n codelist) mit n>=1) zu bestimmen, welcher boolesche Wert
  10620. ; nach seiner Ausführung vorliegt:
  10621. ; FALSE     sicher A0 = NIL,
  10622. ; TRUE      sicher A0 /= NIL,
  10623. ; NIL       keine Aussage.
  10624. (defun get-boolean-value (code)
  10625.   (macrolet ((err () `(compiler-error 'get-boolean-value)))
  10626.     (let ((invert nil)) ; ob von hier bis zum Ende der boolesche Wert invertiert wird
  10627.       ((lambda (value)
  10628.          (if invert
  10629.            (case value (TRUE 'FALSE) (FALSE 'TRUE) (t NIL))
  10630.            value
  10631.        ) )
  10632.        (block value
  10633.          (loop ; Codeliste durchlaufen
  10634.            (when (atom code) (return))
  10635.            (case (first (car code))
  10636.              ((NIL VALUES0 TAGBODY-CLOSE-NIL) ; produzieren Wert NIL
  10637.                (return-from value 'FALSE) ; Damit können wir die Schleife abbrechen
  10638.              )
  10639.              ((T CONS LIST LIST*) ; produzieren Wert /= NIL
  10640.                ; (LIST n) und (LIST* n) wegen n>0.
  10641.                (return-from value 'TRUE) ; Damit können wir die Schleife abbrechen
  10642.              )
  10643.              (CONST
  10644.                (unless (and (cddr (car code)) (eq (const-horizont (third (car code))) ':form))
  10645.                  ; (CONST n) produziert Wert /= NIL, weil der Wert schon zur
  10646.                  ; Compile-Zeit bekannt ist und die Konstante NIL in make-const-code
  10647.                  ; bereits speziell behandelt wurde.
  10648.                  (return-from value 'TRUE) ; Damit können wir die Schleife abbrechen
  10649.                )
  10650.                (return-from value nil)
  10651.              )
  10652.              (NOT (setq invert (not invert))) ; invertiere später den booleschen Wert
  10653.              ((UNBIND1 SKIP SKIPI SKIPSP STORE STOREI STOREV STOREC STOREIC SETVALUE
  10654.                VALUES1 BLOCK-CLOSE TAGBODY-CLOSE CATCH-CLOSE UNWIND-PROTECT-CLEANUP
  10655.              )) ; keine Änderung des 1. Werts -> weiter in der Codeliste
  10656.              (t (return-from value nil))
  10657.            )
  10658.            (setq code (cdr code))
  10659.          )
  10660.          (when code
  10661.            ; code ist das Anfangslabel.
  10662.            ; Inspiziere alle Sprünge auf das Label code:
  10663.            (let ((bisher nil))
  10664.              ; bisher = FALSE, falls bisher alle Sprünge den booleschen Wert
  10665.              ;                 FALSE mitbringen,
  10666.              ; bisher = TRUE, falls bisher alle Sprünge den booleschen Wert
  10667.              ;                TRUE mitbringen,
  10668.              ; bisher = NIL am Anfang.
  10669.              ; Falls ein Sprung einen unbekannten booleschen Wert mitbringt,
  10670.              ; kann man die Schleife gleich verlassen.
  10671.              (flet ((neu (value)
  10672.                       (cond ((null bisher) (setq bisher value))
  10673.                             ((not (eq value bisher)) (return-from value nil))
  10674.                    )) )
  10675.                (dolist (ref (symbol-value code))
  10676.                  (if (integerp ref)
  10677.                    (let ((refcode (first (aref *code-parts* ref)))) ; der Wegsprung hierher
  10678.                      ; Ein Wegsprung mit undefinierten Werten kann das nicht sein.
  10679.                      (case (first refcode)
  10680.                        (JMP
  10681.                          (if (third refcode)
  10682.                            ; Wert vor dem Sprung bekannt
  10683.                            (neu (third refcode))
  10684.                            ; Wert vor dem Sprung unbekannt
  10685.                            (return-from value nil)
  10686.                        ) )
  10687.                        ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10688.                          (when (eq code (second refcode)) (neu 'TRUE))
  10689.                          (when (eq code (third refcode)) (neu 'FALSE))
  10690.                        )
  10691.                        (t (err)) ; JMPHASH hat undefinierte Werte, und die
  10692.                                  ; anderen Wegsprünge enthalten keine Labels.
  10693.                    ) )
  10694.                    (case (first ref)
  10695.                      ((JMPIFBOUNDP BLOCK-OPEN CATCH-OPEN)
  10696.                        (return-from value nil) ; Da können wir nichts aussagen
  10697.                      )
  10698.                      (t (err)) ; An den Labels in TAGBODY-OPEN, JSR,
  10699.                                ; UNWIND-PROTECT-OPEN, UNWIND-PROTECT-CLOSE
  10700.                                ; liegen undefinierte Werte vor.
  10701.          ) ) ) ) ) )
  10702.          nil ; Default: nichts aussagbar
  10703.       ))
  10704. ) ) )
  10705.  
  10706. (defun optimize-jmpcase (index code)
  10707.   (when (eq (first (car code)) 'JMPCASE)
  10708.     ; Code endet mit (JMPCASE ...)
  10709.     (let ((true-label (second (car code)))
  10710.           (false-label (third (car code))))
  10711.       (if (eq true-label false-label)
  10712.         ; (JMPCASE label label) --> (JMP label ..)
  10713.         (progn
  10714.           (setf (car code) `(JMP ,true-label ,(get-boolean-value (cdr code))))
  10715.           ; doppelte Referenz wird zu einer einfachen:
  10716.           (setf (symbol-value true-label)
  10717.                 (delete index (symbol-value true-label) :count 1)
  10718.           )
  10719.           ; und weiter optimieren:
  10720.           (optimize-part code)
  10721.           (optimize-short (get true-label 'code-part))
  10722.         )
  10723.         (when (and (null (get true-label 'for-value))
  10724.                    (null (get false-label 'for-value))
  10725.               )
  10726.           ; Versuche NOTs zu eliminieren:
  10727.           (let ((invert 0)
  10728.                 (cr1 code)
  10729.                 (cr2 (cdr code))) ; stets cr2 = (cdr cr1)
  10730.             (loop
  10731.               (when (atom cr2) (return))
  10732.               (case (first (car cr2))
  10733.                 ((UNBIND1 SKIP SKIPI SKIPSP VALUES1 BLOCK-CLOSE TAGBODY-CLOSE
  10734.                   CATCH-CLOSE UNWIND-PROTECT-CLEANUP
  10735.                  ) ; diese Operationen brauchen keine Werte und lassen
  10736.                    ; den 1. Wert unverändert
  10737.                  (shiftf cr1 cr2 (cdr cr2))
  10738.                 )
  10739.                 (NOT
  10740.                   (setf (cdr cr1) (setq cr2 (cdr cr2))) ; (NOT) streichen
  10741.                   (incf invert)
  10742.                 )
  10743.                 (t (return))
  10744.             ) )
  10745.             ; invert = Anzahl, wie oft (NOT) gestrichen wurde
  10746.             (when (oddp invert)
  10747.               ; true-label und false-label vertauschen:
  10748.               (setf (car code) `(JMPCASE ,false-label ,true-label))
  10749.             )
  10750.             (when (plusp invert)
  10751.               ; und weiter optimieren:
  10752.               (optimize-part code)
  10753.               (optimize-short index)
  10754.         ) ) )
  10755. ) ) ) )
  10756.  
  10757. (defun optimize-value (index &optional (code (aref *code-parts* index)))
  10758.   (let ((item (car code)))
  10759.     (case (first item)
  10760.       ((JMPCASE JMPCASE1-TRUE JMPCASE1-FALSE)
  10761.         ; (JMPCASE/... true-label false-label)
  10762.         (let ((true-label (second item))
  10763.               (false-label (third item)))
  10764.           (when (or (and (eq (first item) 'JMPCASE1-TRUE)
  10765.                          (not (eq (get true-label 'for-value) 'ALL))
  10766.                          ; Wertezahl 1 wird bei true-label nicht gebraucht
  10767.                          ; (JMPCASE1-TRUE ...) --> (JMPCASE ...)
  10768.                     )
  10769.                     (and (eq (first item) 'JMPCASE1-FALSE)
  10770.                          (not (eq (get false-label 'for-value) 'ALL))
  10771.                          ; Wertezahl 1 wird bei false-label nicht gebraucht
  10772.                          ; (JMPCASE1-FALSE ...) --> (JMPCASE ...)
  10773.                 )   )
  10774.             (setq item (setf (car code) `(JMPCASE ,@(rest item))))
  10775.             ; Weitere mögliche Optimierungen:
  10776.             (optimize-jmpcase index code)
  10777.           )
  10778.           ; Versuche, den booleschen Wert an dieser Stelle zu ermitteln
  10779.           ; und vereinfache gegebenenfalls:
  10780.           (case (get-boolean-value (cdr code))
  10781.             (TRUE ; Sprung geht immer auf true-label
  10782.               ; Referenz auf false-label streichen:
  10783.               (setf (symbol-value false-label)
  10784.                 (delete index (symbol-value false-label))
  10785.               )
  10786.               (setf (car code) `(JMP ,true-label TRUE))
  10787.               (when (eq (first item) 'JMPCASE1-TRUE)
  10788.                 (push '(VALUES1) (cdr code))
  10789.                 (simplify code)
  10790.               )
  10791.               (optimize-part code) ; weitere mögliche Optimierung
  10792.               ; weitere mögliche Optimierungen:
  10793.               (optimize-label false-label) ; wegen verringerter Referenzen
  10794.               (optimize-short index) ; wegen obigem optimize-part
  10795.             )
  10796.             (FALSE
  10797.               ; Referenz auf true-label streichen
  10798.               (setf (symbol-value true-label)
  10799.                 (delete index (symbol-value true-label))
  10800.               )
  10801.               (setf (car code) `(JMP ,false-label FALSE))
  10802.               (when (eq (first item) 'JMPCASE1-FALSE)
  10803.                 (push '(VALUES1) (cdr code))
  10804.                 (simplify code)
  10805.               )
  10806.               (optimize-part code) ; weitere mögliche Optimierung
  10807.               ; weitere mögliche Optimierungen:
  10808.               (optimize-label true-label) ; wegen verringerter Referenzen
  10809.               (optimize-short index) ; wegen obigem optimize-part
  10810.       ) ) ) )
  10811.       (JMP
  10812.         (let ((label (second item)))
  10813.           (when (get label 'for-value)
  10814.             ; Wert wird benötigt
  10815.             (when (null (third item))
  10816.               ; aber er ist unbekannt.
  10817.               ; Vielleicht läßt sich der Wert herausbekommen ?
  10818.               (let ((value (get-boolean-value (cdr code))))
  10819.                 (when value
  10820.                   (setf (car code) `(JMP ,label ,value))
  10821.                   ; Wert jetzt bekannt, läßt sich vielleicht verwenden:
  10822.                   (optimize-value (get label 'code-part))
  10823. ) ) ) ) ) ) ) ) )
  10824.  
  10825. ; coalesce legt gleiche Codeteile in den gegebenen Codestücken soweit wie
  10826. ; möglich zusammen und liefert als Ergebnis ein Flag, ob etwas geändert wurde.
  10827. (defun coalesce (&optional (indexlist
  10828.                              ; Liste aller möglichen Indizes
  10829.                              (let ((L '()))
  10830.                                (dotimes (i (fill-pointer *code-parts*)) (push i L))
  10831.                                (nreverse L)
  10832.                 )          ) )
  10833.   (let ((parts-ht ; Eine Hashtabelle, die eine Abbildung realisiert:
  10834.                   ; Codeende --> Liste aller Indizes von Codestücken,
  10835.                   ;              die damit enden
  10836.           (let ((ht (make-hash-table :test #'equal :size (length indexlist))))
  10837.             (dolist (index indexlist)
  10838.               (let ((code (aref *code-parts* index))) ; ein Codestück
  10839.                 ; Wegen der Vereinfachungsregel für "kurze" Codestücke werden
  10840.                 ; nur Teile zusammengelegt, die in mindestens den letzten 3
  10841.                 ; Operationen übereinstimmen.
  10842.                 (when (and (consp code) (consp (cdr code)) (consp (cddr code)))
  10843.                   (push index
  10844.                     (gethash (list* (first code) (second code) (third code))
  10845.                              ht '()
  10846.                   ) )
  10847.             ) ) )
  10848.             ht
  10849.         ) )
  10850.         (modified nil))
  10851.     ; Dann über die möglichen Codeenden iterieren:
  10852.     (maphash
  10853.       #'(lambda (code-beginning indices)
  10854.           (declare (ignore code-beginning))
  10855.           (when (cdr indices) ; mindestens zwei Indizes mit diesem Codeende?
  10856.             ; Versuche, möglichst langes Codestück zusammenzulegen:
  10857.             (let ((codes ; Liste der zusammenzulegenden Codestücke
  10858.                     (mapcar #'(lambda (i) (aref *code-parts* i)) indices)
  10859.                   )
  10860.                   (new-code '()) ; hier wird der gemeinsame Code gesammelt
  10861.                   (new-index (fill-pointer *code-parts*)) ; Index dafür
  10862.                   (new-order ; das gemeinsame Stück wird beim letzten Teil einzusortiert
  10863.                     (reduce #'max (mapcar #'(lambda (i) (aref *code-positions* i)) indices))
  10864.                  ))
  10865.               (loop
  10866.                 ; stimmen noch alle überein?
  10867.                 (unless (every #'consp codes) (return))
  10868.                 (let* ((code1 (first codes)) ; ein beliebiges der Codestücke
  10869.                        (code11 (car code1))) ; dessen letzte Operation
  10870.                   (unless (every #'(lambda (code) (equal (car code) code11))
  10871.                                  (rest codes)
  10872.                           )
  10873.                     (return)
  10874.                   )
  10875.                   ; ja. Alle Codestücke aus codes um eine Operation verkürzen:
  10876.                   (mapc #'(lambda (code index) ; Referenzen löschen
  10877.                             (remove-references (car code) index)
  10878.                           )
  10879.                         codes indices
  10880.                   )
  10881.                   ; verkürzen: (setq codes (mapcar #'cdr codes)), oder:
  10882.                   (mapl #'(lambda (codesr)
  10883.                             (setf (car codesr) (cdr (car codesr)))
  10884.                           )
  10885.                         codes
  10886.                   )
  10887.                   (push code11 new-code) ; new-code verlängern
  10888.                   (note-references code11 new-index)
  10889.               ) )
  10890.               (let* ((new-label (make-label 'ALL))
  10891.                      ; Alle Codestücke aus codes wurden verkürzt, sie werden
  10892.                      ; jetzt verlängert um ein (JMP new-label NIL).
  10893.                      (jmpop `(JMP ,new-label NIL)))
  10894.                 (mapc #'(lambda (code index)
  10895.                           (setf (aref *code-parts* index) (cons jmpop code))
  10896.                         )
  10897.                       codes indices
  10898.                 )
  10899.                 (setf (symbol-value new-label) indices) ; Referenzen auf new-label
  10900.                 (setf (get new-label 'code-part) new-index)
  10901.                 (vector-push-extend (nreconc new-code new-label) *code-parts*)
  10902.                 (vector-push-extend new-order *code-positions*)
  10903.               )
  10904.               ; weitere mögliche Optimierungen:
  10905.               (optimize-part (aref *code-parts* new-index))
  10906.               (coalesce indices)
  10907.               (setq modified t) ; Veränderung hat stattgefunden
  10908.         ) ) )
  10909.       parts-ht
  10910.     )
  10911.     modified
  10912. ) )
  10913.  
  10914. ; Die Hauptfunktion des 3. Schritts:
  10915. ; Führt alle Optimierungen durch, und faßt dann alle Codestücke wieder zu
  10916. ; einer einzigen Codeliste zusammen und liefert diese.
  10917. (defun optimize-all ()
  10918.   ; Optimierungen:
  10919.   (loop
  10920.     ; Optimierungen aufrufen:
  10921.     ; Wird eine fündig, so ruft sie auch gleich die Optimierungs-
  10922.     ; schritte auf, die sich dadurch ergeben könnten. Daher brauchen
  10923.     ; sie hier nur einmal aufgeführt zu werden.
  10924.     ; Vorsicht hier: durch die Optimierungen können *code-parts* und sein
  10925.     ; Inhalt sich völlig verändern.
  10926.     (do ((index 0 (1+ index)))
  10927.         ((eql index (fill-pointer *code-parts*)))
  10928.       (let ((code (aref *code-parts* index)))
  10929.         (when code
  10930.           (let* ((lastc (last code))
  10931.                  (label (cdr lastc)))
  10932.             (when label
  10933.               (unless (eql index (get label 'code-part))
  10934.                 (compiler-error 'optimize-all 'code-part)
  10935.             ) )
  10936.             (optimize-label label index code lastc)
  10937.       ) ) )
  10938.       (let ((code (aref *code-parts* index)))
  10939.         (when code
  10940.           (optimize-jmpcase index code)
  10941.       ) )
  10942.       (let ((code (aref *code-parts* index)))
  10943.         (when code
  10944.           (optimize-value index code)
  10945.       ) )
  10946.       (let ((code (aref *code-parts* index)))
  10947.         (when code
  10948.           (optimize-short index code)
  10949.     ) ) )
  10950.     (unless (coalesce) (return)) ; (coalesce) tat nichts -> fertig
  10951.   )
  10952.   ; Zu einer einzigen Codeliste zusammenfassen:
  10953.   ; (Dabei werden die Labels nun Listenelemente im Code statt nur NTHCDRs.)
  10954.   (let ((start-index 0)) ; Start-"Label" NIL beginnt Codestück Nr. 0
  10955.     ; Erst jeweils ein Codestück, das mit label anfängt, wenn möglich an ein
  10956.     ; Codestück anhängen, das mit einem JMP oder JMPCASE/... zu label endet.
  10957.     (do ((index (fill-pointer *code-parts*)))
  10958.         ((eql (decf index) 0)) ; index durchläuft die Indizes von *code-parts*
  10959.                                ; von oben nach unten, ausgenommen start-index=0.
  10960.       (let ((code (aref *code-parts* index)))
  10961.         (when code
  10962.           (loop
  10963.             ; Betrachte das Label am Ende von code, im Codestück Nr. index:
  10964.             (let* ((lastc (last code)) ; letztes Cons von code
  10965.                    (label (cdr lastc)) ; Label am Ende von code
  10966.                    (refs (symbol-value label)) ; Referenzen darauf
  10967.                    (pos (aref *code-positions* index)) ; Position von code
  10968.                    (jmp-ref nil) ; bisher beste gefundene JMP-Referenz auf label
  10969.                    (jmpcase-ref nil) ; bisher beste gefundene JMPCASE-Referenz auf label
  10970.                    (jmpcase1-ref nil)) ; bisher beste gefundene JMPCASE1-...-Referenz auf label
  10971.               (if (null label)
  10972.                 ; Das Start-Code-Stück wurde umgehängt!
  10973.                 (progn
  10974.                   (setq start-index index)
  10975.                   (return) ; zum nächsten Index
  10976.                 )
  10977.                 (flet ((better (new-ref old-ref)
  10978.                          ; Eine Referenz new-ref ist "besser" als eine andere
  10979.                          ; old-ref, wenn sie näher dran ist. Dabei haben
  10980.                          ; Vorwärtsreferenzen generell Priorität gegenüber
  10981.                          ; Rückwärtsreferenzen.
  10982.                          (or (null old-ref) ; noch gar kein old-ref?
  10983.                              (let ((old-pos (aref *code-positions* old-ref))
  10984.                                    (new-pos (aref *code-positions* new-ref)))
  10985.                                (if (> old-pos pos) ; Habe bisher nur Rückwärtssprung?
  10986.                                  ; ja: new-pos ist besser, falls es
  10987.                                  ; < pos (Vorwärtssprung) oder
  10988.                                  ; >=pos, <=old-pos (kürzerer Rückwärtssprung) ist.
  10989.                                  (<= new-pos old-pos)
  10990.                                  ; nein: new-pos ist besser, falls es
  10991.                                  ; <=pos, >=old-pos (kürzerer Vorwärtssprung) ist.
  10992.                                  (<= old-pos new-pos pos)
  10993.                       )) )   ) )
  10994.                   (macrolet ((update (old-ref new-ref) ; zur Bestimmung des bisher Besten
  10995.                                `(when (better ,new-ref ,old-ref)
  10996.                                   (setq ,old-ref ,new-ref)
  10997.                                 )
  10998.                             ))
  10999.                     ; Bestimme die beste Referenz, an die das Codestück
  11000.                     ; gehängt werden kann:
  11001.                     (dolist (refindex refs)
  11002.                       (when (and (integerp refindex)
  11003.                                  (not (eql refindex index)) ; nicht an sich selber hängen!
  11004.                             )
  11005.                         (let ((refcode1 (car (aref *code-parts* refindex))))
  11006.                           (case (first refcode1)
  11007.                             (JMP ; mögliches Anhängen an (JMP label ...)
  11008.                               (update jmp-ref refindex)
  11009.                             )
  11010.                             (JMPCASE ; mögliches Anhängen an (JMPCASE ... label ...)
  11011.                               (update jmpcase-ref refindex)
  11012.                             )
  11013.                             (JMPCASE1-TRUE ; mögliches Anhängen an (JMPCASE1-TRUE ... label)
  11014.                               (when (eq label (third refcode1))
  11015.                                 (update jmpcase1-ref refindex)
  11016.                             ) )
  11017.                             (JMPCASE1-FALSE ; mögliches Anhängen an (JMPCASE1-FALSE label ...)
  11018.                               (when (eq label (second refcode1))
  11019.                                 (update jmpcase1-ref refindex)
  11020.                             ) )
  11021.                     ) ) ) )
  11022.                     (cond (jmp-ref ; an (JMP label) anhängen
  11023.                             (setf (cdr lastc)
  11024.                                   (cons label (cdr (aref *code-parts* jmp-ref)))
  11025.                             )
  11026.                             (setf (aref *code-parts* jmp-ref) nil)
  11027.                             (setq code lastc)
  11028.                           )
  11029.                           (jmpcase1-ref
  11030.                             (let* ((refcode (aref *code-parts* jmpcase1-ref))
  11031.                                    (refcode1 (car refcode))
  11032.                                    (jmpop
  11033.                                      (if (eq label (second refcode1))
  11034.                                        `(JMPIFNOT1 ,(third refcode1))
  11035.                                        `(JMPIF1 ,(second refcode1))
  11036.                                   )) )
  11037.                               (setf (cdr lastc) (list* label jmpop (cdr refcode)))
  11038.                               (setf (aref *code-parts* jmpcase1-ref) nil)
  11039.                               (setq code lastc)
  11040.                           ) )
  11041.                           (jmpcase-ref
  11042.                             (let* ((refcode (aref *code-parts* jmpcase-ref))
  11043.                                    (refcode1 (car refcode))
  11044.                                    (for-value (or (get (second refcode1) 'for-value)
  11045.                                                   (get (third refcode1) 'for-value)
  11046.                                    )          )
  11047.                                    (jmpop
  11048.                                      (if (eq label (second refcode1))
  11049.                                        `(JMPIFNOT ,(third refcode1) ,for-value)
  11050.                                        `(JMPIF ,(second refcode1) ,for-value)
  11051.                                   )) )
  11052.                               (setf (cdr lastc) (list* label jmpop (cdr refcode)))
  11053.                               (setf (aref *code-parts* jmpcase-ref) nil)
  11054.                               (setq code lastc)
  11055.                           ) )
  11056.                           (t ; kein Anhängen möglich
  11057.                             (return) ; zum nächsten Index
  11058.           ) ) ) ) ) )     )
  11059.     ) ) )
  11060.     ; Sicherstellen, daß das Anfangs-Stück auch an den Anfang kommt:
  11061.     ; (Das würde auch gehen, indem bei jeder der obigen Anhängungen
  11062.     ; ein (setf (aref *code-positions* index) (aref *code-positions* jmp..-ref))
  11063.     ; gemacht würde. Wieso tun wir das nicht??)
  11064.     (setf (aref *code-positions* start-index) 0)
  11065.     ; Codeliste zusammensetzen:
  11066.     (let ((code-parts (map 'list #'cons *code-parts* *code-positions*)))
  11067.       (setq code-parts (delete-if-not #'car code-parts)) ; code=nil bedeutet: gestrichen
  11068.       (setq code-parts (sort code-parts #'> :key #'cdr)) ; nach Reihenfolge sortieren
  11069.       ; Die Teile sind jetzt in der richtigen Ordnung, nur umgekehrt.
  11070.       (let ((codelist '()))
  11071.         (dolist (code-part code-parts)
  11072.           (let ((code (car code-part)))
  11073.             ; code an codelist anhängen, dabei aber den Wegsprung umwandeln:
  11074.             (let ((item (car code)))
  11075.               (case (first item)
  11076.                 (JMP (setf (car code) `(JMP ,(second item))))
  11077.                 (JMPCASE ; (JMPCASE true-label false-label)
  11078.                          ; --> (JMPIFNOT false-label fv) (JMP true-label)
  11079.                   (setq code
  11080.                     (list* `(JMP ,(second item))
  11081.                            `(JMPIFNOT ,(third item)
  11082.                                       ,(or (get (second item) 'for-value)
  11083.                                            (get (third item) 'for-value)
  11084.                                        )
  11085.                             )
  11086.                            (cdr code)
  11087.                 ) ) )
  11088.                 (JMPCASE1-TRUE ; (JMPCASE1-TRUE true-label false-label)
  11089.                                ; --> (JMPIF1 true-label) (JMP false-label)
  11090.                   (setq code
  11091.                     (list* `(JMP ,(third item))
  11092.                            `(JMPIF1 ,(second item))
  11093.                            (cdr code)
  11094.                 ) ) )
  11095.                 (JMPCASE1-FALSE ; (JMPCASE1-FALSE true-label false-label)
  11096.                                 ; --> (JMPIFNOT1 false-label) (JMP true-label)
  11097.                   (setq code
  11098.                     (list* `(JMP ,(second item))
  11099.                            `(JMPIFNOT1 ,(third item))
  11100.                            (cdr code)
  11101.             ) ) ) ) )
  11102.             ; Label zum Listenelement machen:
  11103.             (let ((lastc (last code)))
  11104.               (when (cdr lastc)
  11105.                 (setf (cdr lastc) (list (cdr lastc)))
  11106.             ) )
  11107.             ; Umdrehen und vor codelist hängen (deswegen wurde vorhin
  11108.             ; mit #'> statt #'< sortiert):
  11109.             (setq codelist (nreconc code codelist))
  11110.         ) )
  11111.         codelist
  11112. ) ) ) )
  11113.  
  11114. #|
  11115. ;; Debugging hints:
  11116. (in-package "SYSTEM")
  11117. (setq *print-circle* t)
  11118. (trace compile-to-lap)
  11119. (trace (traverse-anode :post-print *code-part*))
  11120. (trace (optimize-part    :pre-print *code-parts* :post-print *code-parts*)
  11121.        (optimize-label   :pre-print *code-parts* :post-print *code-parts*)
  11122.        (optimize-short   :pre-print *code-parts* :post-print *code-parts*)
  11123.        (optimize-jmpcase :pre-print *code-parts* :post-print *code-parts*)
  11124.        (optimize-value   :pre-print *code-parts* :post-print *code-parts*)
  11125.        (coalesce         :pre-print *code-parts* :post-print *code-parts*)
  11126.        (optimize-all     :pre-print *code-parts* :post-print *code-parts*)
  11127. )
  11128. (trace simplify)
  11129. ;; Move out suspect code to a separate file which you load interpreted.
  11130.  
  11131. ;; Special debugging checks:
  11132. (defun optimize-check ()
  11133.   (do ((index 0 (1+ index)))
  11134.       ((eql index (fill-pointer *code-parts*)))
  11135.     (let ((code (aref *code-parts* index)))
  11136.       (when code
  11137.         (let* ((lastc (last code))
  11138.                (label (cdr lastc)))
  11139.           (when label
  11140.             (unless (eql index (get label 'code-part))
  11141.               (compiler-error 'optimize-check 'code-part)
  11142. ) ) ) ) ) ) )
  11143. (trace
  11144.   (optimize-part    :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11145.   (optimize-label   :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11146.   (optimize-short   :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11147.   (optimize-jmpcase :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11148.   (optimize-value   :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11149.   (coalesce         :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11150.   (optimize-all     :pre (optimize-check) :post (optimize-check) :suppress-if t)
  11151. )
  11152. |#
  11153.  
  11154. #| Was ist mit den folgenden möglichen Optimierungen??
  11155.  
  11156. 10. Kommt vor einem (JMP label) ein (UNWIND-PROTECT-CLEANUP) und vor dem
  11157.    label ein (UNWIND-PROTECT-3 cleanup-label), so muß es sich um denselben
  11158.    UNWIND-PROTECT-Frame handeln, und man kann (UNWIND-PROTECT-CLEANUP)
  11159.    streichen und (JMP label) durch (JMP newlabel) ersetzen, wobei newlabel
  11160.    ein neues Label ist, das vor dem (evtl. zu ergänzenden) (UNWIND-PROTECT-2)
  11161.    vor cleanup-label sitzt:
  11162.    (UNWIND-PROTECT-CLEANUP) (JMP label) ...
  11163.    ... [(UNWIND-PROTECT-2)] cleanup-label ... (UNWIND-PROTECT-3 cleanup-label) label
  11164.    -->
  11165.    (JMP newlabel) ...
  11166.    ... newlabel (UNWIND-PROTECT-2) cleanup-label ... (UNWIND-PROTECT-3 cleanup-label) label
  11167.  
  11168. 11. Kommt nach einem Label label ein (NIL), so darf jeder (JMPIFNOT label)
  11169.    und jeder (JMPIFNOT1 label) durch ein (JMPIFNOT1 z) ersetzt werden,
  11170.    wo z ein neues Label nach dem (NIL) ist:
  11171.           (JMPIFNOT label) ... label (NIL) ...
  11172.    -->       (JMPIFNOT1 z) ... label (NIL) z ...
  11173.  
  11174. |#
  11175.  
  11176. ; Führt den 1. und 2.,3. Schritt aus:
  11177. (defun compile-to-LAP ()
  11178.   (let ((*code-parts* (make-array 10 :adjustable t :fill-pointer 0))
  11179.         (*code-positions* (make-array 10 :adjustable t :fill-pointer 0)))
  11180.     ; Expandiert den Code des Fnode *func* und teilt ihn in Stücke auf.
  11181.     ; Hinterläßt seine Werte in *code-parts* und *code-positions*.
  11182.     (let ((*code-part* (list '(START))) ; NIL als Start-"Label"
  11183.           (*code-index* 0)
  11184.           (*dead-code* nil)
  11185.           (*label-subst* '())
  11186.           (*current-value* nil)
  11187.           (*current-vars* '()))
  11188.       (traverse-anode (anode-code (fnode-code *func*)))
  11189.     )
  11190.     ; Optimiert in *code-parts* und *code-positions*, faßt dann den Code
  11191.     ; in einer Liste zusammen und liefert diese:
  11192.     (let ((code-list (optimize-all)))
  11193.       (unless (equal (pop code-list) '(START))
  11194.         (compiler-error 'compile-to-LAP 'start)
  11195.       )
  11196.       code-list
  11197. ) ) )
  11198.  
  11199.  
  11200. #|
  11201.                             4. Schritt:
  11202.                       Eliminieren von (CONST n)
  11203.  
  11204. Generische Funktionen haben eine feste Länge. Die Konstanten werden im
  11205. VENV-Const aufbewahrt. In diesem Schritt werden umgewandelt:
  11206.   (LOADV k m)    -->  (LOADV k+1 m)
  11207.   (STOREV k m)   -->  (STOREV k+1 m)
  11208.   (CONST n [c])  -->  (LOADV 0 n)
  11209.   (VENV)         -->  (LOADV 0 0)
  11210.   (JMPHASH n ht label . labels)  -->  (JMPHASHV n ht label . labels)
  11211.   (GETVALUE n)         -->  illegal
  11212.   (SETVALUE n)         -->  illegal
  11213.   (BIND n)             -->  illegal
  11214.   (COPY-CLOSURE m n)   -->  illegal
  11215.   (CALL k n)           -->  illegal
  11216.   (CALL0 n)            -->  illegal
  11217.   (CALL1 n)            -->  illegal
  11218.   (CALL2 n)            -->  illegal
  11219.   (BLOCK-OPEN n label) -->  illegal
  11220.   (RETURN-FROM n)      -->  illegal
  11221.   (TAGBODY-OPEN n ...) -->  illegal
  11222.   (GO n l)             -->  illegal
  11223. |#
  11224.  
  11225. (defun CONST-to-LOADV (code-list)
  11226.   (do ((codelistr code-list (cdr codelistr)))
  11227.       ((null codelistr))
  11228.     (let ((item (car codelistr)))
  11229.       (when (consp item)
  11230.         (case (first item)
  11231.           ((LOADV STOREV)
  11232.             (setf (car codelistr)
  11233.                   `(,(first item) ,(1+ (second item)) ,@(cddr item))
  11234.           ) )
  11235.           (CONST
  11236.             (setf (car codelistr) `(LOADV 0 ,(second item)))
  11237.           )
  11238.           (VENV
  11239.             (setf (car codelistr) `(LOADV 0 0))
  11240.           )
  11241.           (JMPHASH
  11242.             (setf (car codelistr) `(JMPHASHV ,@(cdr item)))
  11243.           )
  11244.           ((GETVALUE SETVALUE BIND COPY-CLOSURE CALL CALL0 CALL1 CALL2
  11245.             BLOCK-OPEN RETURN-FROM TAGBODY-OPEN GO)
  11246.             (compiler-error 'CONST-to-LOADV "Illegal-in-GF")
  11247.           )
  11248.   ) ) ) )
  11249.   code-list
  11250. )
  11251.  
  11252.  
  11253. #|
  11254.                             5. Schritt:
  11255.                    Bestimmung des Stackbedarfs
  11256.  
  11257. Dieser Schritt bestimmt, wieviel SP-Einträge die Funktion maximal braucht.
  11258. |#
  11259.  
  11260. #+CLISP3
  11261. (defun SP-depth (code-list)
  11262.   (let ((max-depth 0) ; bisherige Maximal-Tiefe
  11263.         (unseen-label-alist '()) ; Labels, ab denen noch verfolgt werden muß
  11264.         (seen-label-alist '()) ; Labels, die schon verfolgt wurden
  11265.           ; jeweils Aliste ((label . depth) ...)
  11266.           ; Es ist durchaus möglich, daß dasselbe Codestück mit unterschied-
  11267.           ; lichen SP-Tiefen durchgeführt werden kann (nämlich dann, wenn es
  11268.           ; mit einem Wegsprung THROW, RETURN-FROM, RETURN-FROM-I, GO, GO-I
  11269.           ; oder BARRIER endet)!
  11270.           ; seen-label-alist enthält zu jedem Label die maximale Tiefe, mit
  11271.           ; der ab diesem Label schon verfolgt wurde.
  11272.           ; unsee-label-alist enthält zu jedem Label die maximale bisher
  11273.           ; notierte Tiefe, mit der ab diesem Label noch verfolgt werden muß.
  11274.         (mitte code-list) ; restliche Codeliste
  11275.         (depth 0) ; aktuelle Tiefe
  11276.        )
  11277.     (macrolet ((check-depth (wanted-depth)
  11278.                  ; überprüft, ob depth gleich der Tiefe wanted-depth ist
  11279.                  `(unless (eql depth ,wanted-depth)
  11280.                     (compiler-error 'SP-depth)
  11281.                   )
  11282.               ))
  11283.       (loop
  11284.         ; mitte läuft durch die Codeliste, von der aktuellen Position
  11285.         ; bis zum nächsten Wegsprung, und zählt die Tiefe mit.
  11286.         (loop
  11287.           (when (null mitte) (return))
  11288.           (let ((item (car mitte)))
  11289.             (if (atom item)
  11290.               ; Label
  11291.               (let ((h (assoc item seen-label-alist)))
  11292.                 (if h
  11293.                   (if (<= depth (cdr h)) (return) (setf (cdr h) depth))
  11294.                   (push (cons item depth) seen-label-alist)
  11295.               ) )
  11296.               ; Instruktion
  11297.               (macrolet ((note-label (labelform)
  11298.                            ; notiere, daß zu label gesprungen werden kann
  11299.                            (let ((label (gensym)))
  11300.                              `(let* ((,label ,labelform)
  11301.                                      (h (assoc ,label seen-label-alist)))
  11302.                                 (unless (and h (<= depth (cdr h)))
  11303.                                   (setq h (assoc ,label unseen-label-alist))
  11304.                                   (if h
  11305.                                     (unless (<= depth (cdr h)) (setf (cdr h) depth))
  11306.                                     (push (cons ,label depth) unseen-label-alist)
  11307.                               ) ) )
  11308.                          ) )
  11309.                          (note-inc (amount)
  11310.                            ; notiere, daß depth um amount erhöht wird
  11311.                            `(progn
  11312.                               (incf depth ,amount)
  11313.                               (when (> depth max-depth) (setq max-depth depth))
  11314.                             )
  11315.                          )
  11316.                          (note-dec (amount)
  11317.                            ; notiere, daß depth um amount erniedrigt wird
  11318.                            `(progn
  11319.                               (decf depth ,amount)
  11320.                               (when (minusp depth) (compiler-error 'SP-depth "<0"))
  11321.                             )
  11322.                          )
  11323.                          (note-jmp ()
  11324.                            ; notiere, daß weggesprungen wird
  11325.                            `(return)
  11326.                         ))
  11327.                 (case (first item)
  11328.                   (JMP ; (JMP label)
  11329.                     (note-label (second item))
  11330.                     (note-jmp)
  11331.                   )
  11332.                   ((JMPIF JMPIF1 JMPIFNOT JMPIFNOT1 JMPIFBOUNDP) ; (JMP... label)
  11333.                     (note-label (second item))
  11334.                   )
  11335.                   ((JMPHASH JMPHASHV JMPTAIL) ; (JMPHASH.. n ht label . labels), (JMPTAIL m n label)
  11336.                     (dolist (label (cdddr item)) (note-label label))
  11337.                     (note-jmp)
  11338.                   )
  11339.                   (JSR ; (JSR n label)
  11340.                     (let ((depth 0)) (note-label (third item)))
  11341.                   )
  11342.                   ((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)
  11343.                     (note-jmp)
  11344.                   )
  11345.                   (RET ; (RET)
  11346.                     (check-depth 0)
  11347.                     (note-jmp)
  11348.                   )
  11349.                   (PROGV ; (PROGV)
  11350.                     (note-inc 1)
  11351.                   )
  11352.                   (CATCH-OPEN ; (CATCH-OPEN label)
  11353.                     (note-label (second item))
  11354.                     (note-inc (+ 2 *jmpbuf-size*))
  11355.                   )
  11356.                   (CATCH-CLOSE ; (CATCH-CLOSE)
  11357.                     (note-dec (+ 2 *jmpbuf-size*))
  11358.                   )
  11359.                   (UNWIND-PROTECT-OPEN ; (UNWIND-PROTECT-OPEN label)
  11360.                     ; eigentlich: (note-inc (+ 2 *jmpbuf-size*))
  11361.                     (note-inc 3) (note-label (second item)) (note-dec 3)
  11362.                     (note-inc (+ 2 *jmpbuf-size*))
  11363.                   )
  11364.                   (UNWIND-PROTECT-NORMAL-EXIT ; (UNWIND-PROTECT-NORMAL-EXIT), danach kommt label
  11365.                     (note-dec (+ 2 *jmpbuf-size*)) (note-inc 3)
  11366.                   )
  11367.                   (UNWIND-PROTECT-CLOSE ; (UNWIND-PROTECT-CLOSE label)
  11368.                     ; eigentlich: (note-dec 3)
  11369.                     (note-label (second item)) (note-dec 3)
  11370.                   )
  11371.                   (UNWIND-PROTECT-CLEANUP ; (UNWIND-PROTECT-CLEANUP)
  11372.                     ; eigentlich: (note-dec (+ 2 *jmpbuf-size*)) (note-inc 3) ... (note-dec 3)
  11373.                     (note-dec (+ 2 *jmpbuf-size*))
  11374.                   )
  11375.                   (BLOCK-OPEN ; (BLOCK-OPEN n label)
  11376.                     (note-label (third item))
  11377.                     (note-inc (+ 2 *jmpbuf-size*))
  11378.                   )
  11379.                   (BLOCK-CLOSE ; (BLOCK-CLOSE)
  11380.                     (note-dec (+ 2 *jmpbuf-size*))
  11381.                   )
  11382.                   (TAGBODY-OPEN ; (TAGBODY-OPEN n label1 ... labelm)
  11383.                     (note-inc (+ 1 *jmpbuf-size*))
  11384.                     (dolist (label (cddr item)) (note-label label))
  11385.                   )
  11386.                   ((TAGBODY-CLOSE-NIL TAGBODY-CLOSE) ; (TAGBODY-CLOSE-NIL), (TAGBODY-CLOSE)
  11387.                     (note-dec (+ 1 *jmpbuf-size*))
  11388.                   )
  11389.                   (HANDLER-OPEN ; (HANDLER-OPEN n v k label1 ... labelm)
  11390.                     (check-depth (fourth item))
  11391.                     (dolist (label (cddddr item)) (note-label label))
  11392.                   )
  11393.                   ((MVCALLP HANDLER-BEGIN) ; (MVCALLP), (HANDLER-BEGIN)
  11394.                     (note-inc 1)
  11395.                   )
  11396.                   (MVCALL ; (MVCALL)
  11397.                     (note-dec 1)
  11398.                   )
  11399.                   (SKIPSP ; (SKIPSP k)
  11400.                     (note-dec (second item))
  11401.                   )
  11402.                   (SKIPI ; (SKIPI k n)
  11403.                     (note-dec (+ (second item) 1))
  11404.                   )
  11405.               ) )
  11406.           ) )
  11407.           (setq mitte (cdr mitte))
  11408.         )
  11409.         ; Nächstes zu verfolgendes Label suchen:
  11410.         (loop
  11411.           (when (null unseen-label-alist) ; fertig ?
  11412.             (return-from SP-depth max-depth)
  11413.           )
  11414.           (let* ((unseen (pop unseen-label-alist)) ; nächstes zu verfolgendes
  11415.                  (label (car unseen))) ; Label
  11416.             (setq depth (cdr unseen))
  11417.             (let ((h (assoc label seen-label-alist)))
  11418.               (unless (and h (<= depth (cdr h)))
  11419.                 ; Ab diesem Label die Codeliste abarbeiten:
  11420.                 ; (Dadurch wird (label . depth) in seen-label-alist aufgenommen,
  11421.                 ; es ist bereits aus unseen-label-alist entfernt.)
  11422.                 (setq mitte (member label code-list :test #'eq))
  11423.                 (return)
  11424.         ) ) ) )
  11425. ) ) ) )
  11426.  
  11427.  
  11428. #|
  11429.                             6. Schritt:
  11430.                  Einführung von Kurz-Operationen
  11431.  
  11432. Dieser Schritt arbeitet auf der Codeliste und verändert sie dabei destruktiv.
  11433.  
  11434. 1. (ATOM) (JMPIF label NIL)             --> (JMPIFATOM label)
  11435.    (ATOM) (JMPIFNOT label NIL)          --> (JMPIFCONSP label)
  11436.    (CONSP) (JMPIF label NIL)            --> (JMPIFCONSP label)
  11437.    (CONSP) (JMPIFNOT label NIL)         --> (JMPIFATOM label)
  11438.    (ATOM)                               --> (PUSH) (CALLS ATOM)
  11439.    (CONSP)                              --> (PUSH) (CALLS CONSP)
  11440.  
  11441. 2. (NIL) (PUSH)                         --> (NIL&PUSH)
  11442.    (NIL) (PUSH) ... (NIL) (PUSH)        --> (PUSH-NIL n)
  11443.    (NIL) (STORE n)                      --> (NIL&STORE n)
  11444.    (PUSH-NIL 1)                         --> (NIL&PUSH)
  11445.  
  11446. 3. (T) (PUSH)                           --> (T&PUSH)
  11447.    (T) (STORE n)                        --> (T&STORE n)
  11448.  
  11449. 4. (CONST n c)                          --> (CONST n)
  11450.    (CONST n) (PUSH)                     --> (CONST&PUSH n)
  11451.    (CONST n) (SYMBOL-FUNCTION) (PUSH)   --> (CONST&SYMBOL-FUNCTION&PUSH n)
  11452.    (CONST n) (SYMBOL-FUNCTION) (STORE m)--> (CONST&SYMBOL-FUNCTION&STORE n m)
  11453.    (CONST n) (SYMBOL-FUNCTION)          --> (CONST&SYMBOL-FUNCTION n)
  11454.  
  11455. 5. (COPY-CLOSURE n m) (PUSH)            --> (COPY-CLOSURE&PUSH n m)
  11456.  
  11457. 6. (LOAD n) (PUSH)                      --> (LOAD&PUSH n)
  11458.    (LOAD k) (STOREC n m)                --> (LOAD&STOREC k n m)
  11459.    (LOAD n) (JMPIF label fv)            --> (LOAD&JMPIF n label)
  11460.    (LOAD n) (JMPIFNOT label fv)         --> (LOAD&JMPIFNOT n label)
  11461.    (LOAD n) (CAR) (PUSH)                --> (LOAD&CAR&PUSH n)
  11462.    (LOAD n) (CDR) (PUSH)                --> (LOAD&CDR&PUSH n)
  11463.    (LOAD n) (CDR) (STORE n)             --> (LOAD&CDR&STORE n)
  11464.    (LOAD n+1) (CONS) (STORE n)          --> (LOAD&CONS&STORE n)
  11465.    (LOAD n) (PUSH) (CALLS 1+) (STORE n) --> (LOAD&INC&STORE n)
  11466.    (LOAD n) (PUSH) (CALLS 1-) (STORE n) --> (LOAD&DEC&STORE n)
  11467.    (LOAD n) (PUSH) (CALLS 1+) (PUSH)    --> (LOAD&INC&PUSH n)
  11468.    (LOAD n) (PUSH) (CALLS 1-) (PUSH)    --> (LOAD&DEC&PUSH n)
  11469.    (LOAD n) (CAR) (STORE m)             --> (LOAD&CAR&STORE n m)
  11470.  
  11471. 7. (JMPIFBOUNDP n l) (NIL) (STORE n) l  --> (UNBOUND->NIL n) l
  11472.  
  11473. 8. (LOADI n1 n2) (PUSH)                 --> (LOADI&PUSH n1 n2)
  11474.    (LOADC n1 n2) (PUSH)                 --> (LOADC&PUSH n1 n2)
  11475.    (LOADV n1 n2) (PUSH)                 --> (LOADV&PUSH n1 n2)
  11476.  
  11477. 9. (GETVALUE n) (PUSH)                  --> (GETVALUE&PUSH n)
  11478.  
  11479. 10. (UNBIND1) ... (UNBIND1)             --> (UNBIND n)
  11480.  
  11481. 11. (CAR) (PUSH)                        --> (CAR&PUSH)
  11482.     (CDR) (PUSH)                        --> (CDR&PUSH)
  11483.     (CONS) (PUSH)                       --> (CONS&PUSH)
  11484.     (LIST n) (PUSH)                     --> (LIST&PUSH n)
  11485.     (LIST* n) (PUSH)                    --> (LIST*&PUSH n)
  11486.     (FUNCALL n) (PUS)                   --> (FUNCALL&PUSH n)
  11487.     (APPLY n) (PUSH)                    --> (APPLY&PUSH n)
  11488.  
  11489. 12. (POP) (STORE n)                      --> (POP&STORE n)
  11490.  
  11491. 13. (SKIP n) (RET)                      --> (SKIP&RET n)
  11492.     ; (RET)                             --> (SKIP&RET 0)
  11493.     ; kommt nicht vor, da im Stack stets noch die Closure selbst sitzt
  11494.  
  11495. 14. (UNWIND-PROTECT-CLOSE label)        --> (UNWIND-PROTECT-CLOSE)
  11496.  
  11497. 15. (JMPHASH n ht label . labels)       --> (JMPHASH n ht label)
  11498.     (JMPHASHV n ht label . labels)      --> (JMPHASHV n ht label)
  11499.  
  11500. 16. (JSR n label)                       --> (JSR label)
  11501.     (JSR n label) (PUSH)                --> (JSR&PUSH label)
  11502.  
  11503. 17. (CALL m n) (PUSH)                   --> (CALL&PUSH m n)
  11504.     (CALL1 n) (PUSH)                    --> (CALL1&PUSH n)
  11505.     (CALL2 n) (PUSH)                    --> (CALL2&PUSH n)
  11506.     (CALLS1 n) (PUSH)                   --> (CALLS1&PUSH n)
  11507.     (CALLS2 n) (PUSH)                   --> (CALLS2&PUSH n)
  11508.     (CALLSR m n) (PUSH)                 --> (CALLSR&PUSH m n)
  11509.     (CALLC) (PUSH)                      --> (CALLC&PUSH)
  11510.     (CALLCKEY) (PUSH)                   --> (CALLCKEY&PUSH)
  11511.  
  11512. 18. (CALL1 n) (JMPIF label fv)          --> (CALL1&JMPIF n label)
  11513.     (CALL1 n) (JMPIFNOT label fv)       --> (CALL1&JMPIFNOT n label)
  11514.     (CALL2 n) (JMPIF label fv)          --> (CALL2&JMPIF n label)
  11515.     (CALL2 n) (JMPIFNOT label fv)       --> (CALL2&JMPIFNOT n label)
  11516.     (CALLS1 n) (JMPIF label fv)         --> (CALLS1&JMPIF n label)
  11517.     (CALLS1 n) (JMPIFNOT label fv)      --> (CALLS1&JMPIFNOT n label)
  11518.     (CALLS2 n) (JMPIF label fv)         --> (CALLS2&JMPIF n label)
  11519.     (CALLS2 n) (JMPIFNOT label fv)      --> (CALLS2&JMPIFNOT n label)
  11520.     (CALLSR m n) (JMPIF label fv)       --> (CALLSR&JMPIF m n label)
  11521.     (CALLSR m n) (JMPIFNOT label fv)    --> (CALLSR&JMPIFNOT m n label)
  11522.  
  11523. 19. (CALLS1 n) (STORE k)                --> (CALLS1&STORE n k)
  11524.     (CALLS2 n) (STORE k)                --> (CALLS2&STORE n k)
  11525.     (CALLSR m n) (STORE k)              --> (CALLSR&STORE m n k)
  11526.  
  11527. 20. (EQ) (JMPIF label NIL)              --> (JMPIFEQ label)
  11528.     (EQ) (JMPIFNOT label NIL)           --> (JMPIFNOTEQ label)
  11529.     (CONST n) (EQ) (JMPIF label NIL)    --> (JMPIFEQTO n label)
  11530.     (CONST n) (EQ) (JMPIFNOT label NIL) --> (JMPIFNOTEQTO n label)
  11531.  
  11532. 21. (APPLY n) (SKIP k) (RET)            --> (APPLY&SKIP&RET n k)
  11533.  
  11534. 22. (HANDLER-BEGIN) (PUSH)              --> (HANDLER-BEGIN&PUSH)
  11535.  
  11536. 23. (BARRIER)                           -->
  11537.  
  11538. |#
  11539.  
  11540. (let ((CALLS-1+ (CALLS-code (gethash '1+ function-codes)))
  11541.       (CALLS-1- (CALLS-code (gethash '1- function-codes)))
  11542.       (CALLS-atom (CALLS-code (gethash 'atom function-codes)))
  11543.       (CALLS-consp (CALLS-code (gethash 'consp function-codes))))
  11544.   (defun insert-combined-LAPs (code-list)
  11545.     ; Zunächst die ATOM/CONSP-Umwandlung, weil diese PUSHs einführen kann:
  11546.     (do ((crest code-list (cdr crest)))
  11547.         ((null crest))
  11548.       (let ((item (car crest)))
  11549.         (when (consp item)
  11550.           (case (first item)
  11551.             (CONST ; (CONST n c) -> (CONST n)
  11552.               (setf (cddr item) '())
  11553.             )
  11554.             ((ATOM CONSP)
  11555.               (setq item (first item))
  11556.               (if (and #| (consp (cdr crest)) |#
  11557.                        (consp (cadr crest))
  11558.                        (memq (first (cadr crest)) '(JMPIF JMPIFNOT))
  11559.                        (null (third (cadr crest)))
  11560.                   )
  11561.                 ; z.B. (ATOM) (JMPIF label NIL) --> (JMPIFATOM label)
  11562.                 (setf (car crest)
  11563.                       `(,(if (eq (first (cadr crest)) 'JMPIF)
  11564.                            (if (eq item 'ATOM) 'JMPIFATOM 'JMPIFCONSP)
  11565.                            (if (eq item 'ATOM) 'JMPIFCONSP 'JMPIFATOM)
  11566.                          )
  11567.                         ,(second (cadr crest))
  11568.                        )
  11569.                       (cdr crest) (cddr crest)
  11570.                 )
  11571.                 ; z.B. (ATOM) --> (PUSH) (CALLS ATOM)
  11572.                 (setf (car crest) '(PUSH)
  11573.                       (cdr crest) (cons (if (eq item 'ATOM) CALLS-atom CALLS-consp)
  11574.                                         (cdr crest)
  11575.                 )                 )
  11576.     ) ) ) ) ) )
  11577.     ; Nun die sonstigen Umformungen: Ein einziger Durchlauf.
  11578.     ; Zwei Pointer laufen durch die Codeliste: ...mitte.rechts...
  11579.     (do* ((mitte code-list rechts)
  11580.           (rechts (cdr mitte) (cdr rechts)))
  11581.          ((null mitte))
  11582.       (macrolet ((ersetze (length new-code)
  11583.                    ; ersetzt die nächsten length Elemente
  11584.                    ; (nth 0 mitte) ... (nth (- length 1) mitte)
  11585.                    ; durch ein einziges Element new-code.
  11586.                    (assert (typep length '(INTEGER 0 4)))
  11587.                    `(progn
  11588.                       ,(case length
  11589.                          (0 `(setf (cdr mitte) (setq rechts (cons (car mitte) rechts))
  11590.                                    (car mitte) ,new-code
  11591.                          )   )
  11592.                          (1 `(setf (car mitte) ,new-code))
  11593.                          (t `(setf (car mitte) ,new-code
  11594.                                    (cdr mitte) ,(setq rechts
  11595.                                                   (case length
  11596.                                                     (2 `(cdr rechts))
  11597.                                                     (3 `(cddr rechts))
  11598.                                                     (4 `(cdddr rechts))
  11599.                                                 ) )
  11600.                        ) )   )
  11601.                       (go weiter)
  11602.                     )
  11603.                 ))
  11604.         (let ((item (car mitte)))
  11605.           (when (consp item)
  11606.             ; Untersuchung des Befehls item und der nachfolgenden:
  11607.             (when (and #| (consp rechts) |# (consp (car rechts)))
  11608.               ; normale Umwandlungen, mit Aneinanderhängen der Argumente:
  11609.               (let ((new-op
  11610.                       (cdr (assoc (first item)
  11611.                                   (case (first (car rechts))
  11612.                                     (PUSH  '((T        . T&PUSH)
  11613.                                              (CONST    . CONST&PUSH)
  11614.                                              (LOADI    . LOADI&PUSH)
  11615.                                              (LOADC    . LOADC&PUSH)
  11616.                                              (LOADV    . LOADV&PUSH)
  11617.                                              (GETVALUE . GETVALUE&PUSH)
  11618.                                              (CALL     . CALL&PUSH)
  11619.                                              (CALL1    . CALL1&PUSH)
  11620.                                              (CALL2    . CALL2&PUSH)
  11621.                                              (CALLS1   . CALLS1&PUSH)
  11622.                                              (CALLS2   . CALLS2&PUSH)
  11623.                                              (CALLSR   . CALLSR&PUSH)
  11624.                                              (CALLC    . CALLC&PUSH)
  11625.                                              (CALLCKEY . CALLCKEY&PUSH)
  11626.                                              (CAR      . CAR&PUSH)
  11627.                                              (CDR      . CDR&PUSH)
  11628.                                              (CONS     . CONS&PUSH)
  11629.                                              (LIST     . LIST&PUSH)
  11630.                                              (LIST*    . LIST*&PUSH)
  11631.                                              (FUNCALL  . FUNCALL&PUSH)
  11632.                                              (APPLY    . APPLY&PUSH)
  11633.                                              (COPY-CLOSURE . COPY-CLOSURE&PUSH)
  11634.                                              (HANDLER-BEGIN . HANDLER-BEGIN&PUSH)
  11635.                                     )       )
  11636.                                     (JMPIF
  11637.                                       (let ((alist
  11638.                                               '((EQ     . JMPIFEQ)
  11639.                                                 (LOAD   . LOAD&JMPIF)
  11640.                                                 (CALL1  . CALL1&JMPIF)
  11641.                                                 (CALL2  . CALL2&JMPIF)
  11642.                                                 (CALLS1 . CALLS1&JMPIF)
  11643.                                                 (CALLS2 . CALLS2&JMPIF)
  11644.                                                 (CALLSR . CALLSR&JMPIF)
  11645.                                                )
  11646.                                            ))
  11647.                                         (when (third (car rechts))
  11648.                                           (setq alist (cdr alist))
  11649.                                         )
  11650.                                         (setf (cddr (car rechts)) '())
  11651.                                         alist
  11652.                                     ) )
  11653.                                     (JMPIFNOT
  11654.                                       (let ((alist
  11655.                                               '((EQ     . JMPIFNOTEQ)
  11656.                                                 (LOAD   . LOAD&JMPIFNOT)
  11657.                                                 (CALL1  . CALL1&JMPIFNOT)
  11658.                                                 (CALL2  . CALL2&JMPIFNOT)
  11659.                                                 (CALLS1 . CALLS1&JMPIFNOT)
  11660.                                                 (CALLS2 . CALLS2&JMPIFNOT)
  11661.                                                 (CALLSR . CALLSR&JMPIFNOT)
  11662.                                                )
  11663.                                            ))
  11664.                                         (when (third (car rechts))
  11665.                                           (setq alist (cdr alist))
  11666.                                         )
  11667.                                         (setf (cddr (car rechts)) '())
  11668.                                         alist
  11669.                                     ) )
  11670.                                     (STORE '((NIL    . NIL&STORE)
  11671.                                              (T      . T&STORE)
  11672.                                              (POP    . POP&STORE)
  11673.                                              (CALLS1 . CALLS1&STORE)
  11674.                                              (CALLS2 . CALLS2&STORE)
  11675.                                              (CALLSR . CALLSR&STORE)
  11676.                                     )       )
  11677.                                     (STOREC '((LOAD . LOAD&STOREC)))
  11678.                                     (RET '((SKIP . SKIP&RET)))
  11679.                                   )
  11680.                                   :test #'eq
  11681.                    )) )    )
  11682.                 (when new-op
  11683.                   (ersetze 2 `(,new-op ,@(rest item) ,@(rest (car rechts))))
  11684.             ) ) )
  11685.             ; weitere Umwandlungen:
  11686.             (case (first item)
  11687.               ((NIL PUSH-NIL)
  11688.                 (flet ((nilpusher-p (coder)
  11689.                          ; Kommt (NIL) (PUSH) --> 1,
  11690.                          ; kommt (PUSH-NIL n) --> n,
  11691.                          ; sonst nil.
  11692.                          (and #| (consp coder) |# (consp (car coder))
  11693.                               (case (first (car coder))
  11694.                                 (PUSH-NIL (second (car coder)))
  11695.                                 ((NIL) (when (equal (cadr coder) '(PUSH))
  11696.                                          (setf (cdr coder) (cddr coder))
  11697.                                          1
  11698.                                 )      )
  11699.                                 (t nil)
  11700.                       )) )    )
  11701.                   (let ((count (nilpusher-p mitte)))
  11702.                     (when count
  11703.                       (setq rechts (cdr mitte))
  11704.                       (loop
  11705.                         (let ((next-count (nilpusher-p rechts)))
  11706.                           (unless next-count (return))
  11707.                           (incf count next-count)
  11708.                         )
  11709.                         (setq rechts (cdr rechts))
  11710.                       )
  11711.                       (setf (car mitte) (if (eql count 1) '(NIL&PUSH) `(PUSH-NIL ,count))
  11712.                             (cdr mitte) rechts
  11713.                       )
  11714.                       (go weiter)
  11715.               ) ) ) )
  11716.               (CONST
  11717.                 (when (and #| (consp rechts) |# (consp (car rechts)))
  11718.                   (case (first (car rechts))
  11719.                     (SYMBOL-FUNCTION
  11720.                       (let ((n (second item)))
  11721.                         (cond ((and #| (consp (cdr rechts)) |#
  11722.                                     (equal (cadr rechts) '(PUSH))
  11723.                                )
  11724.                                (ersetze 3 `(CONST&SYMBOL-FUNCTION&PUSH ,n))
  11725.                               )
  11726.                               ((and #| (consp (cdr rechts)) |#
  11727.                                     (consp (cadr rechts))
  11728.                                     (eq (first (cadr rechts)) 'STORE)
  11729.                                )
  11730.                                (ersetze 3
  11731.                                  `(CONST&SYMBOL-FUNCTION&STORE ,n ,(second (cadr rechts)))
  11732.                               ))
  11733.                               (t (ersetze 2 `(CONST&SYMBOL-FUNCTION ,n)))
  11734.                     ) ) )
  11735.                     (EQ
  11736.                       (when (and #| (consp (cdr rechts)) |#
  11737.                                  (consp (cadr rechts))
  11738.                                  (memq (first (cadr rechts)) '(JMPIF JMPIFNOT))
  11739.                                  (null (third (cadr rechts)))
  11740.                             )
  11741.                         (ersetze 3
  11742.                           `(,(if (eq (first (cadr rechts)) 'JMPIF)
  11743.                                'JMPIFEQTO
  11744.                                'JMPIFNOTEQTO
  11745.                              )
  11746.                             ,(second item)
  11747.                             ,(second (cadr rechts))
  11748.                            )
  11749.               ) ) ) ) ) )
  11750.               (LOAD
  11751.                 (when (and #| (consp rechts) |# (consp (car rechts)))
  11752.                   (let ((n (second item)))
  11753.                     (case (first (car rechts))
  11754.                       (CAR
  11755.                         (when (and #| (consp (cdr rechts)) |# (consp (cadr rechts)))
  11756.                           (case (first (cadr rechts))
  11757.                             (PUSH (ersetze 3 `(LOAD&CAR&PUSH ,n)))
  11758.                             (STORE
  11759.                               (ersetze 3
  11760.                                 `(LOAD&CAR&STORE ,n ,(second (cadr rechts)))
  11761.                       ) ) ) ) )
  11762.                       (CDR
  11763.                         (when (and #| (consp (cdr rechts)) |# (consp (cadr rechts)))
  11764.                           (case (first (cadr rechts))
  11765.                             (PUSH (ersetze 3 `(LOAD&CDR&PUSH ,n)))
  11766.                             (STORE
  11767.                               (when (eql n (second (cadr rechts)))
  11768.                                 (ersetze 3 `(LOAD&CDR&STORE ,n))
  11769.                       ) ) ) ) )
  11770.                       (CONS
  11771.                         (when (and #| (consp (cdr rechts)) |# (consp (cadr rechts))
  11772.                                    (eq (first (cadr rechts)) 'STORE)
  11773.                                    (eql (second (cadr rechts)) (- n 1))
  11774.                               )
  11775.                           (ersetze 3 `(LOAD&CONS&STORE ,(- n 1)))
  11776.                       ) )
  11777.                       (PUSH
  11778.                         (when (and #| (consp (cdr rechts)) |# (consp (cadr rechts))
  11779.                                    (or (equal (cadr rechts) CALLS-1+)
  11780.                                        (equal (cadr rechts) CALLS-1-)
  11781.                                    )
  11782.                                    #| (consp (cddr rechts)) |# (consp (caddr rechts))
  11783.                               )
  11784.                           (when (equal (caddr rechts) '(PUSH))
  11785.                             (ersetze 4
  11786.                               `(,(if (equal (cadr rechts) CALLS-1+)
  11787.                                    'LOAD&INC&PUSH
  11788.                                    'LOAD&DEC&PUSH
  11789.                                  )
  11790.                                 ,n
  11791.                                )
  11792.                           ) )
  11793.                           (when (and (eq (first (caddr rechts)) 'STORE)
  11794.                                      (eql (second (caddr rechts)) n)
  11795.                                 )
  11796.                             (ersetze 4
  11797.                               `(,(if (equal (cadr rechts) CALLS-1+)
  11798.                                    'LOAD&INC&STORE
  11799.                                    'LOAD&DEC&STORE
  11800.                                  )
  11801.                                 ,n
  11802.                                )
  11803.                         ) ) )
  11804.                         (ersetze 2 `(LOAD&PUSH ,n))
  11805.               ) ) ) ) )
  11806.               (JMPIFBOUNDP ; vereinfache (JMPIFBOUNDP n l) (NIL) (STORE n) l
  11807.                 (when (and #| (consp rechts) |#
  11808.                            (equal (car rechts) '(NIL))
  11809.                            #| (consp (cdr rechts)) |#
  11810.                            (consp (cadr rechts))
  11811.                            (eq (first (cadr rechts)) 'STORE)
  11812.                            (eql (second (cadr rechts)) (second item))
  11813.                            #| (consp (cddr rechts)) |#
  11814.                            (eq (caddr rechts) (third item))
  11815.                       )
  11816.                   (ersetze 3 `(UNBOUND->NIL ,(second item)))
  11817.               ) )
  11818.               (JSR
  11819.                 (if (and #| (consp rechts) |# (equal (car rechts) '(PUSH)))
  11820.                   (ersetze 2 `(JSR&PUSH ,(third item)))
  11821.                   (ersetze 1 `(JSR ,(third item)))
  11822.               ) )
  11823.               (UNBIND1
  11824.                 (let ((count 1))
  11825.                   (loop
  11826.                     (unless (and #| (consp rechts) |#
  11827.                                  (equal (car rechts) '(UNBIND1))
  11828.                             )
  11829.                       (return)
  11830.                     )
  11831.                     (incf count)
  11832.                     (setq rechts (cdr rechts))
  11833.                   )
  11834.                   (unless (eql count 1)
  11835.                     (setf (car mitte) `(UNBIND ,count))
  11836.                     (setf (cdr mitte) rechts)
  11837.                     (go weiter)
  11838.               ) ) )
  11839.               ;(RET (ersetze 1 '(SKIP&RET 0))) ; kommt nicht vor!
  11840.               (UNWIND-PROTECT-CLOSE (ersetze 1 '(UNWIND-PROTECT-CLOSE)))
  11841.               ((JMPIF JMPIFNOT) (ersetze 1 `(,(first item) ,(second item))))
  11842.               ((JMPHASH JMPHASHV)
  11843.                 (let ((hashtable (third item))
  11844.                       (labels (cddddr item)))
  11845.                   (maphash
  11846.                     #'(lambda (obj index) ; (gethash obj hashtable) = index
  11847.                         (setf (gethash obj hashtable) (nth index labels))
  11848.                       )
  11849.                     hashtable
  11850.                 ) )
  11851.                 (setf (cddddr item) '())
  11852.               )
  11853.               (HANDLER-OPEN
  11854.                 (do ((v (third item))
  11855.                      (labels (cddddr item) (cdr labels))
  11856.                      (i 1 (+ i 2)))
  11857.                     ((null labels))
  11858.                   (setf (svref v i) (car labels))
  11859.                 )
  11860.                 (setf (cdddr item) '())
  11861.               )
  11862.               (APPLY
  11863.                 (when (and #| (consp rechts) |#
  11864.                            (consp (car rechts))
  11865.                            (eq (first (car rechts)) 'SKIP)
  11866.                            #| (consp (cdr rechts)) |#
  11867.                            (equal (cadr rechts) '(RET))
  11868.                       )
  11869.                   (ersetze 3 `(APPLY&SKIP&RET ,(second item) ,(second (car rechts))))
  11870.               ) )
  11871.       ) ) ) )
  11872.       weiter ; Hier ist man mit (car mitte) fertig.
  11873.       (when (equal (car rechts) '(BARRIER))
  11874.         ; streiche Element (car rechts)
  11875.         (setf (cdr mitte) (setq rechts (cdr rechts)))
  11876.       )
  11877.     )
  11878.     code-list
  11879.   )
  11880. )
  11881.  
  11882.  
  11883. #|
  11884.                                 7. Schritt:
  11885.                 Umwandlung der Instruktionen in eine Byte-Folge
  11886.  
  11887. Erster Teilschritt: jeder Instruktion wird eine Klassifikation der Instruktion
  11888. und die Länge der Instruktion (Label-Operanden nicht mitgezählt)
  11889. vorangestellt, jedem Label wird sein PC als Wert zugewiesen.
  11890. Dabei werden die Operandenlängen - soweit möglich - bestimmt, in Instruktionen
  11891. auftretende Labels werden durch (vermutliche Verweislänge . label) ersetzt.
  11892. So wird aus (BLOCK-OPEN 2 #:G7) --> (NL 2 . (67 2 (1 . #:G7))) .
  11893. Weitere Teilschritte:
  11894. Immer wieder wird die Codeliste durchlaufen, dabei werden Sprungverweise
  11895. eventuell von 1 auf 2 oder 6 Byte verlängert. Dadurch kann der Code insgesamt
  11896. nur länger werden.
  11897. Letzter Teilschritt:
  11898. Die Sprungverweise werden in Distanzen umgesetzt, und die Codeliste wird
  11899. als Liste von Bytes neu aufgebaut.
  11900. |#
  11901. ; gibt an, wieviel Bytes ein numerischer Operand braucht:
  11902. (defun num-operand-length (n)
  11903.   (cond ((< n 128) 1) ; 7 Bit in 1 Byte
  11904.         ((< n 32768) 2) ; 15 Bit in 2 Bytes
  11905.         (t 6) ; sonst 6 Bytes
  11906. ) )
  11907. ; assembliert eine Code-Liste und liefert eine Bytecode-Liste:
  11908. (defun assemble-LAP (code-list)
  11909.   ; erster Teilschritt:
  11910.   (do ((code-listr code-list (cdr code-listr))
  11911.        (PC 0))
  11912.       ((null code-listr))
  11913.     (let ((item (car code-listr)))
  11914.       (if (atom item)
  11915.         (setf (symbol-value item) PC)
  11916.         (let ((instr-code (gethash (first item) instruction-codes)))
  11917.           (unless instr-code (compiler-error 'assemble-LAP "ILLEGAL INSTRUCTION"))
  11918.           (let ((instr-class (second (svref instruction-table instr-code)))
  11919.                 (instr-length 1))
  11920.             (if (and (eq instr-class 'K)
  11921.                      (< (second item)
  11922.                         (svref short-code-opsize (position (first item) instruction-table-K))
  11923.                 )    )
  11924.               (progn
  11925.                 (setq instr-code
  11926.                   (+ (svref short-code-ops
  11927.                             (position (first item) instruction-table-K)
  11928.                      )
  11929.                      (second item)
  11930.                 ) )
  11931.                 (setq instr-class 'O)
  11932.                 (setq item (list (first item)))
  11933.               )
  11934.               (case instr-class
  11935.                 (O)
  11936.                 ((K N NC) (incf instr-length (num-operand-length (second item))))
  11937.                 (B (incf instr-length 1))
  11938.                 (L (incf PC 1) (push 1 (second item)))
  11939.                 (NN (incf instr-length (num-operand-length (second item)))
  11940.                     (incf instr-length (num-operand-length (third item))) )
  11941.                 (NB (incf instr-length (num-operand-length (second item)))
  11942.                     (incf instr-length 1) )
  11943.                 (BN (incf instr-length 1)
  11944.                     (incf instr-length (num-operand-length (third item))) )
  11945.                 (NNN (incf instr-length (num-operand-length (second item)))
  11946.                      (incf instr-length (num-operand-length (third item)))
  11947.                      (incf instr-length (num-operand-length (fourth item))) )
  11948.                 (NBN (incf instr-length (num-operand-length (second item)))
  11949.                      (incf instr-length 1)
  11950.                      (incf instr-length (num-operand-length (fourth item))) )
  11951.                 (NL (incf instr-length (num-operand-length (second item)))
  11952.                     (incf PC 1) (push 1 (third item)) )
  11953.                 (BL (incf instr-length 1)
  11954.                     (incf PC 1) (push 1 (third item)) )
  11955.                 (NNL (incf instr-length (num-operand-length (second item)))
  11956.                      (incf instr-length (num-operand-length (third item)))
  11957.                      (incf PC 1) (push 1 (fourth item)) )
  11958.                 (NBL (incf instr-length (num-operand-length (second item)))
  11959.                      (incf instr-length 1)
  11960.                      (incf PC 1) (push 1 (fourth item)) )
  11961.                 (NHL (incf instr-length (num-operand-length (second item)))
  11962.                      (incf PC 1) (push 1 (fourth item)) )
  11963.                 (NLX (incf instr-length (num-operand-length (second item)))
  11964.                      (do ((L (cddr item) (cdr L)))
  11965.                          ((null L))
  11966.                        (incf PC 1) (push 1 (car L))
  11967.                 )    )
  11968.             ) )
  11969.             (incf PC instr-length)
  11970.             (setf (car code-listr)
  11971.               (list* instr-class instr-length instr-code (cdr item))
  11972.             )
  11973.   ) ) ) ) )
  11974.   ; weitere Teilschritte:
  11975.   (loop
  11976.     (unless
  11977.       (let ((modified nil) (PC 0))
  11978.         (dolist (item code-list)
  11979.           (if (atom item)
  11980.             (setf (symbol-value item) PC)
  11981.             (progn
  11982.               (incf PC (cadr item))
  11983.               (when (memq (car item) '(L NL BL NNL NBL NHL NLX))
  11984.                 (let ((itemargs (cdddr item)))
  11985.                   (dolist (x (case (car item)
  11986.                                (L itemargs)
  11987.                                ((NL BL NLX) (cdr itemargs))
  11988.                                ((NNL NBL NHL) (cddr itemargs))
  11989.                           )  )
  11990.                     (incf PC (car x))
  11991.                     (let ((new-dist (- (symbol-value (cdr x)) PC)))
  11992.                       ; bisher angenommene Sprunglänge und neu errechnete abgleichen:
  11993.                       (if (<= -64 new-dist 63) ; 7 Bits in 1 Byte
  11994.                         () ; Sprunglänge bleibt 1
  11995.                         (if (<= -16384 new-dist 16383) ; 15 Bits in 2 Bytes
  11996.                           (case (car x)
  11997.                             (1 (setf (car x) 2) ; neue Sprunglänge=2
  11998.                                (incf PC 1) ; gibt 2-1=1 Bytes Verlängerung
  11999.                                (setq modified t)
  12000.                           ) )
  12001.                           ; 32 Bits in 6 Bytes
  12002.                           (case (car x)
  12003.                             (1 (setf (car x) 6) ; neue Sprunglänge=6
  12004.                                (incf PC 5) ; gibt 6-1=5 Bytes Verlängerung
  12005.                                (setq modified t)
  12006.                             )
  12007.                             (2 (setf (car x) 6) ; neue Sprunglänge=6
  12008.                                (incf PC 4) ; gibt 6-2=4 Bytes Verlängerung
  12009.                                (setq modified t)
  12010.                       ) ) ) )
  12011.               ) ) ) )
  12012.         ) ) )
  12013.         modified
  12014.       )
  12015.       (return) ; nichts mehr verändert -> alle Sprunglängen optimal
  12016.   ) )
  12017.   ; letzter Teilschritt:
  12018.   (let ((byte-list '()) (PC 0))
  12019.     (flet ((new-byte (n) (push n byte-list)))
  12020.       (flet ((num-operand (n)
  12021.                (cond ((< n 128) (new-byte n))
  12022.                      ((< n 32768) (new-byte (+ 128 (ldb (byte 7 8) n)))
  12023.                                   (new-byte (ldb (byte 8 0) n))
  12024.                      )
  12025.                      (t (compiler-error 'assemble-LAP "15 BIT"))
  12026.              ) )
  12027.              (label-operand (x)
  12028.                (incf PC (car x))
  12029.                (let ((dist (- (symbol-value (cdr x)) PC)))
  12030.                  (case (car x)
  12031.                    (1 (new-byte (ldb (byte 7 0) dist)))
  12032.                    (2 (new-byte (+ 128 (ldb (byte 7 8) dist)))
  12033.                       (new-byte (ldb (byte 8 0) dist))
  12034.                    )
  12035.                    (6 (new-byte 128) (new-byte 0)
  12036.                       (new-byte (ldb (byte 8 24) dist))
  12037.                       (new-byte (ldb (byte 8 16) dist))
  12038.                       (new-byte (ldb (byte 8 8) dist))
  12039.                       (new-byte (ldb (byte 8 0) dist))
  12040.                  ) )
  12041.             )) )
  12042.         (dolist (item code-list)
  12043.           (when (consp item)
  12044.             (incf PC (cadr item))
  12045.             (new-byte (caddr item))
  12046.             (case (car item)
  12047.               (O) ; darin fallen auch die 1-Byte-Befehle vom Typ K
  12048.               ((K N) (num-operand (second (cddr item))))
  12049.               (B (new-byte (second (cddr item))))
  12050.               (L (label-operand (second (cddr item))))
  12051.               (NN (num-operand (second (cddr item)))
  12052.                   (num-operand (third (cddr item))) )
  12053.               (NB (num-operand (second (cddr item)))
  12054.                   (new-byte (third (cddr item))) )
  12055.               (BN (new-byte (second (cddr item)))
  12056.                   (num-operand (third (cddr item))) )
  12057.               (NNN (num-operand (second (cddr item)))
  12058.                    (num-operand (third (cddr item)))
  12059.                    (num-operand (fourth (cddr item))) )
  12060.               (NBN (num-operand (second (cddr item)))
  12061.                    (new-byte (third (cddr item)))
  12062.                    (num-operand (fourth (cddr item))) )
  12063.               (NL (num-operand (second (cddr item)))
  12064.                   (label-operand (third (cddr item))) )
  12065.               (BL (new-byte (second (cddr item)))
  12066.                   (label-operand (third (cddr item))) )
  12067.               (NNL (num-operand (second (cddr item)))
  12068.                    (num-operand (third (cddr item)))
  12069.                    (label-operand (fourth (cddr item))) )
  12070.               (NBL (num-operand (second (cddr item)))
  12071.                    (new-byte (third (cddr item)))
  12072.                    (label-operand (fourth (cddr item))) )
  12073.               (NHL (num-operand (second (cddr item)))
  12074.                    (let ((ht (third (cddr item))))
  12075.                      (maphash
  12076.                        #'(lambda (obj x) ; x = (gethash obj ht)
  12077.                            (setf (gethash obj ht) (- (symbol-value x) PC))
  12078.                          )
  12079.                        ht
  12080.                    ) )
  12081.                    (label-operand (fourth (cddr item)))
  12082.               )
  12083.               (NC (num-operand (second (cddr item)))
  12084.                   (let* ((v (third (cddr item)))
  12085.                          (m (length v)))
  12086.                     (do ((i 1 (+ i 2)))
  12087.                         ((>= i m))
  12088.                       (setf (svref v i) (symbol-value (svref v i)))
  12089.               )   ) )
  12090.               (NLX (num-operand (second (cddr item)))
  12091.                    (dolist (x (cddr (cddr item))) (label-operand x)) )
  12092.             )
  12093.         ) )
  12094.     ) )
  12095.     (nreverse byte-list)
  12096. ) )
  12097.  
  12098. ; die Umkehrung zu assemble-LAP : liefert zu einer Bytecode-Liste die dazu
  12099. ; gehörige Codeliste. In dieser steht allerdings vor jedem Item noch der PC.
  12100. (defun disassemble-LAP (byte-list const-list)
  12101.   (let ((code-list '()) (PC 0) instr-PC (label-alist '()))
  12102.     ; label-alist ist eine Liste von Conses (PC . label), in der die PCs streng
  12103.     ; fallend geordnet sind.
  12104.     (flet ((PC->label-a (PC)
  12105.              (cons PC (make-symbol
  12106.                         (string-concat "L" (prin1-to-string PC))
  12107.            ) )        )
  12108.            (next-byte () (incf PC) (pop byte-list))
  12109.           )
  12110.       (flet ((num-operand ()
  12111.                (let ((a (next-byte)))
  12112.                  (cond ((< a 128) a)
  12113.                        (t (+ (* 256 (- a 128)) (next-byte)))
  12114.              ) ) )
  12115.              (label-operand
  12116.                   (&optional
  12117.                     (dist
  12118.                       (let ((a (next-byte)))
  12119.                         (cond ((< a 128) (if (< a 64) a (- a 128)))
  12120.                               (t (setq a (- a 128))
  12121.                                  (unless (< a 64) (setq a (- a 128)))
  12122.                                  (setq a (+ (* 256 a) (next-byte)))
  12123.                                  (if (zerop a)
  12124.                                    (+ (* 256 (+ (* 256 (+ (* 256 (next-byte))
  12125.                                                           (next-byte)
  12126.                                                 )      )
  12127.                                                 (next-byte)
  12128.                                       )      )
  12129.                                       (next-byte)
  12130.                                    )
  12131.                                    a
  12132.                     ) ) )     )  )
  12133.                     (label-PC (+ PC dist))
  12134.                   )
  12135.                ; Suche label-PC in label-alist:
  12136.                (do* ((L1 nil L2)
  12137.                      (L2 label-alist (cdr L2))) ; L1 = nil oder L2 = (cdr L1)
  12138.                     ((cond
  12139.                        ((or (null L2) (> label-PC (caar L2))) ; einfügen
  12140.                         (setq L2 (cons (PC->label-a label-PC) L2))
  12141.                         (if L1 (setf (cdr L1) L2) (setq label-alist L2))
  12142.                         t)
  12143.                        ((= label-PC (caar L2)) t)
  12144.                        (t nil)
  12145.                      )
  12146.                      (cdar L2)
  12147.             )) )    )
  12148.         (loop
  12149.           (when (null byte-list) (return))
  12150.           (setq instr-PC PC) ; PC beim Start der Instruktion
  12151.           (let ((instruction
  12152.                   (let ((instr-code (next-byte)))
  12153.                     (if (>= instr-code short-code-base)
  12154.                       (let* ((q (position instr-code short-code-ops :test #'>= :from-end t))
  12155.                              (r (- instr-code (svref short-code-ops q))))
  12156.                         (list (svref instruction-table-K q) r)
  12157.                       )
  12158.                       (let* ((table-entry (svref instruction-table instr-code))
  12159.                              (instr-name (first table-entry)))
  12160.                         (case (second table-entry)
  12161.                           (O (list instr-name))
  12162.                           ((K N) (list instr-name (num-operand)))
  12163.                           (B (list instr-name (next-byte)))
  12164.                           (L (list instr-name (label-operand)))
  12165.                           (NN (list instr-name (num-operand) (num-operand)))
  12166.                           (NB (list instr-name (num-operand) (next-byte)))
  12167.                           (BN (list instr-name (next-byte) (num-operand)))
  12168.                           (NNN (list instr-name (num-operand) (num-operand) (num-operand)))
  12169.                           (NBN (list instr-name (num-operand) (next-byte) (num-operand)))
  12170.                           (NL (list instr-name (num-operand) (label-operand)))
  12171.                           (BL (list instr-name (next-byte) (label-operand)))
  12172.                           (NNL (list instr-name (num-operand) (num-operand) (label-operand)))
  12173.                           (NBL (list instr-name (num-operand) (next-byte) (label-operand)))
  12174.                           (NHL (let* ((n (num-operand))
  12175.                                       (ht (if (eq instr-name 'JMPHASH)
  12176.                                             (nth n const-list)           ; JMPHASH
  12177.                                             (svref (first const-list) n) ; JMPHASHV
  12178.                                       )   )
  12179.                                       (labels '()))
  12180.                                  (maphash
  12181.                                    #'(lambda (obj dist)
  12182.                                        (declare (ignore obj))
  12183.                                        (push (label-operand dist) labels)
  12184.                                      )
  12185.                                    ht
  12186.                                  )
  12187.                                  (list* instr-name n (label-operand) labels)
  12188.                           )    )
  12189.                           (NC (let* ((n (num-operand))
  12190.                                      (v (car (nth n const-list)))
  12191.                                      (m (length v))
  12192.                                      (labels '()))
  12193.                                 (do ((i 1 (+ i 2)))
  12194.                                     ((>= i m))
  12195.                                   (push (label-operand nil (svref v i)) labels)
  12196.                                 )
  12197.                                 (list* instr-name n (nreverse labels))
  12198.                           )   )
  12199.                           (NLX (let* ((n (num-operand))
  12200.                                       (m (length (nth n const-list)))
  12201.                                       (L '()))
  12202.                                  (dotimes (i m) (push (label-operand) L))
  12203.                                  (list* instr-name n (nreverse L))
  12204.                           )    )
  12205.                )) ) ) ) )
  12206.             (push (cons instr-PC instruction) code-list)
  12207.         ) )
  12208.     ) )
  12209.     ; (setq label-alist (sort label-alist #'> :key #'car))
  12210.     ; code-list umdrehen und dabei die Labels einfügen:
  12211.     (let ((new-code-list '()))
  12212.       (loop
  12213.         (when (and new-code-list label-alist
  12214.                    (= (caar new-code-list) (caar label-alist))
  12215.               )
  12216.           (push (car label-alist) new-code-list)
  12217.           (setq label-alist (cdr label-alist))
  12218.         )
  12219.         (when (null code-list) (return))
  12220.         ; eine Instruktion von code-list in new-code-list übernehmen:
  12221.         (psetq code-list (cdr code-list)
  12222.                new-code-list (rplacd code-list new-code-list)
  12223.       ) )
  12224.       new-code-list
  12225. ) ) )
  12226.  
  12227.  
  12228. #|
  12229.                            8. Schritt:
  12230.                     funktionales Objekt bilden
  12231.  
  12232. Die Funktion make-closure wird dazu vorausgesetzt.
  12233. |#
  12234. ; trägt eine Byteliste als Code in fnode ein.
  12235. (defun create-fun-obj (fnode byte-list #+CLISP3 SPdepth)
  12236.   (setf (fnode-code fnode)
  12237.     (make-closure
  12238.       :name (fnode-name fnode)
  12239.       :codevec
  12240.         (macrolet ((as-word (anz)
  12241.                      (if *big-endian*
  12242.                        ; BIG-ENDIAN-Prozessor
  12243.                        `(floor ,anz 256)
  12244.                        ; LITTLE-ENDIAN-Prozessor
  12245.                        `(multiple-value-bind (q r) (floor ,anz 256) (values r q))
  12246.                   )) )
  12247.           (multiple-value-call #'list*
  12248.             #+CLISP3 (as-word SPdepth)
  12249.             (as-word (fnode-req-anz fnode))
  12250.             (as-word (fnode-opt-anz fnode))
  12251.             (+ (if (fnode-rest-flag fnode) 1 0)
  12252.                (if (fnode-gf-p fnode) 16 0)
  12253.                (if (fnode-keyword-flag fnode)
  12254.                  (+ 128 (if (fnode-allow-other-keys-flag fnode) 64 0))
  12255.                  0
  12256.             )  )
  12257.             (values ; Argumenttyp-Kürzel
  12258.               (let ((req-anz (fnode-req-anz fnode))
  12259.                     (opt-anz (fnode-opt-anz fnode))
  12260.                     (rest (fnode-rest-flag fnode))
  12261.                     (key (fnode-keyword-flag fnode)))
  12262.                 (cond ((and (not rest) (not key) (< (+ req-anz opt-anz) 6))
  12263.                        (+ (svref '#(1 7 12 16 19 21) opt-anz) req-anz)
  12264.                       )
  12265.                       ((and rest (not key) (zerop opt-anz) (< req-anz 5))
  12266.                        (+ 22 req-anz)
  12267.                       )
  12268.                       ((and (not rest) key (< (+ req-anz opt-anz) 5))
  12269.                        (+ (svref '#(27 32 36 39 41) opt-anz) req-anz)
  12270.                       )
  12271.                       (t 0)
  12272.             ) ) )
  12273.             (if (fnode-keyword-flag fnode)
  12274.               (multiple-value-call #'values
  12275.                 (as-word (length (fnode-keywords fnode)))
  12276.                 (as-word (fnode-Keyword-Offset fnode))
  12277.               )
  12278.               (values)
  12279.             )
  12280.             byte-list
  12281.         ) )
  12282.       :consts
  12283.         (let* ((spare-list (make-list (fnode-Keyword-Offset fnode)))
  12284.                (l (append
  12285.                     spare-list
  12286.                     (fnode-keywords fnode)
  12287.                     (if *compiling-from-file*
  12288.                       (mapcar #'(lambda (value form)
  12289.                                   (if form (make-load-time-eval form) value)
  12290.                                 )
  12291.                               (fnode-Consts fnode) (fnode-Consts-forms fnode)
  12292.                       )
  12293.                       (fnode-Consts fnode)
  12294.               ))  ) )
  12295.           (if (fnode-gf-p fnode)
  12296.             (append spare-list (list (coerce l 'simple-vector)))
  12297.             l
  12298.         ) )
  12299.   ) )
  12300.   fnode
  12301. )
  12302.  
  12303. ; Liefert die Signatur eines funktionalen Objekts,
  12304. ; als Werte:
  12305. ; 1. req-anz
  12306. ; 2. opt-anz
  12307. ; 3. rest-p
  12308. ; 4. key-p
  12309. ; 5. keyword-list
  12310. ; 6. allow-other-keys-p
  12311. ; und zusätzlich
  12312. ; 7. byte-list
  12313. ; 8. const-list
  12314. (defun signature (closure)
  12315.   (let ((const-list (closure-consts closure))
  12316.         (byte-list (closure-codevec closure)))
  12317.     (macrolet ((pop2 (listvar)
  12318.                  (if *big-endian*
  12319.                    ; BIG-ENDIAN-Prozessor
  12320.                    `(+ (* 256 (pop ,listvar)) (pop ,listvar))
  12321.                    ; LITTLE-ENDIAN-Prozessor
  12322.                    `(+ (pop ,listvar) (* 256 (pop ,listvar)))
  12323.               )) )
  12324.       #+CLISP3 (progn (pop byte-list) (pop byte-list))
  12325.       (let* ((req-anz (pop2 byte-list))
  12326.              (opt-anz (pop2 byte-list))
  12327.              (h (pop byte-list))
  12328.              (key-p (logbitp 7 h)))
  12329.         (pop byte-list)
  12330.         (values
  12331.           req-anz
  12332.           opt-anz
  12333.           (logbitp 0 h)
  12334.           key-p
  12335.           (when key-p
  12336.             (let ((kw-count (pop2 byte-list))
  12337.                   (kw-offset (pop2 byte-list)))
  12338.               (subseq (if (logbitp 4 h) ; generische Funktion?
  12339.                         (coerce (first const-list) 'list)
  12340.                         const-list
  12341.                       )
  12342.                       kw-offset (+ kw-offset kw-count)
  12343.           ) ) )
  12344.           (logbitp 6 h)
  12345.           byte-list
  12346.           const-list
  12347. ) ) ) ) )
  12348.  
  12349.  
  12350. ;                  D R I T T E R   P A S S
  12351.  
  12352. (defun pass3 ()
  12353.   (dolist (pair *fnode-fixup-table*)
  12354.     (let ((code (fnode-code (first pair))) (n (second pair)))
  12355.       (macrolet ((closure-const (code n)
  12356.                    #-CLISP `(nth ,n (closure-consts ,code))
  12357.                    #+CLISP `(sys::%record-ref ,code (+ 2 ,n))
  12358.                 ))
  12359.         (setf (closure-const code n) (fnode-code (closure-const code n)))
  12360. ) ) ) )
  12361.  
  12362.  
  12363. ;             T O P - L E V E L - A U F R U F
  12364.  
  12365. ; compiliert einen Lambdabody und liefert seinen Code.
  12366. (defun compile-lambdabody (name lambdabody)
  12367.   (let ((fnode (c-lambdabody name lambdabody)))
  12368.     (unless *no-code*
  12369.       (let ((*fnode-fixup-table* '()))
  12370.         (pass2 fnode)
  12371.         (pass3)
  12372.       )
  12373.       (fnode-code fnode)
  12374. ) ) )
  12375.  
  12376. ; wird bei (lambda (...) (declare (compile)) ...) aufgerufen und liefert ein
  12377. ; zu diesem Lambda-Ausdruck äquivalentes funktionales Objekt.
  12378. (defun compile-lambda (name lambdabody %venv% %fenv% %benv% %genv% %denv%)
  12379.   (let ((*compiling* t)
  12380.         (*compiling-from-file* nil)
  12381.         (*c-listing-output* nil)
  12382.         (*c-error-output* *error-output*)
  12383.         (*known-special-vars* '())
  12384.         (*constant-special-vars* '())
  12385.         (*func* nil)
  12386.         (*fenv* %fenv%)
  12387.         (*benv* %benv%)
  12388.         (*genv* %genv%)
  12389.         (*venv* %venv%)
  12390.         (*venvc* nil)
  12391.         (*denv* %denv%)
  12392.         (*error-count* 0) (*warning-count* 0)
  12393.         (*no-code* nil)
  12394.        )
  12395.     (let ((funobj (compile-lambdabody name lambdabody)))
  12396.       (unless (zerop *error-count*)
  12397.         (return-from compile-lambda (compile-lambdabody name '(() NIL)))
  12398.       )
  12399.       funobj
  12400. ) ) )
  12401.  
  12402. ; wird bei (let/let*/multiple-value-bind ... (declare (compile)) ...) aufgerufen
  12403. ; und liefert ein funktionales Objekt, das - mit 0 Argumenten aufgerufen - diese
  12404. ; Form ausführt.
  12405. (let ((form-count 0))
  12406.   (defun compile-form (form %venv% %fenv% %benv% %genv% %denv%)
  12407.     (compile-lambda (symbol-suffix '#:COMPILED-FORM (incf form-count))
  12408.                     `(() ,form)
  12409.                     %venv% %fenv% %benv% %genv% %denv%
  12410.   ) )
  12411. )
  12412.  
  12413. ; Common-Lisp-Funktion COMPILE
  12414. #-CROSS
  12415. (defun compile (name &optional (definition nil svar)
  12416.                      &aux (macro-flag nil) (trace-flag nil) (save-flag nil))
  12417.   (unless (function-name-p name)
  12418.     (error-of-type 'error
  12419.                    #L{
  12420.                    DEUTSCH "Name einer zu compilierenden Funktion muß ein Symbol sein, nicht: ~S"
  12421.                    ENGLISH "Name of function to be compiled must be a symbol, not ~S"
  12422.                    FRANCAIS "Le nom d'une fonction à compiler doit être un symbole et non ~S"
  12423.                    }
  12424.                    name
  12425.   ) )
  12426.   (let ((symbol (get-funname-symbol name)))
  12427.     (if svar
  12428.       ; Neudefinition von name als Funktion.
  12429.       (progn
  12430.         ; Ist name getraced -> falls vorher Macro, erst untracen.
  12431.         (when (and name (setq svar (get symbol 'sys::traced-definition)))
  12432.           (if (consp svar)
  12433.             (progn
  12434.               (warn 
  12435.                #L{
  12436.                DEUTSCH "~S: ~S war getraced und wird umdefiniert!"
  12437.                ENGLISH "~S: redefining ~S; it was traced!"
  12438.                FRANCAIS "~S: ~S est redéfinie, alors qu'elle était tracée!"
  12439.                }
  12440.                'compile name
  12441.               )
  12442.               (sys::untrace2 name)
  12443.             )
  12444.             (setq trace-flag t)
  12445.         ) )
  12446.         (when (compiled-function-p definition)
  12447.           (warn 
  12448.            #L{
  12449.            DEUTSCH "~S ist schon compiliert."
  12450.            ENGLISH "~S is already compiled."
  12451.            FRANCAIS "~S est déjà compilée."
  12452.            }
  12453.            definition
  12454.           )
  12455.           (when name
  12456.             (if trace-flag
  12457.               (setf (get symbol 'sys::traced-definition) definition)
  12458.               (setf (symbol-function symbol) definition)
  12459.           ) )
  12460.           (return-from compile name)
  12461.         )
  12462.         (when name
  12463.           (setq save-flag
  12464.                 (cons `(SETF (FDEFINITION ',name) ',definition)
  12465.                       sys::*toplevel-environment*
  12466.         ) )     )
  12467.       )
  12468.       ; Compilierung der vorhandenen Funktions-/Macro-Definition.
  12469.       (progn
  12470.         (unless (fboundp symbol)
  12471.           (error-of-type 'undefined-function
  12472.             :name name
  12473.             #L{
  12474.             DEUTSCH "Funktion ~S ist undefiniert."
  12475.             ENGLISH "Undefined function ~S"
  12476.             FRANCAIS "Fonction non définie ~S."
  12477.             }
  12478.             name
  12479.         ) )
  12480.         (if (setq definition (get symbol 'sys::traced-definition))
  12481.           (setq trace-flag t)
  12482.           (setq definition (symbol-function symbol))
  12483.         )
  12484.         (when (and (consp definition) (eq (car definition) 'system::macro))
  12485.           (setq macro-flag t)
  12486.           (setq definition (cdr definition))
  12487.         )
  12488.         (when (compiled-function-p definition)
  12489.           (warn 
  12490.            #L{
  12491.            DEUTSCH "~S ist schon compiliert."
  12492.            ENGLISH "~S is already compiled."
  12493.            FRANCAIS "~S est déjà compilée."
  12494.            }
  12495.            name
  12496.           )
  12497.           (return-from compile name)
  12498.     ) ) )
  12499.     (unless (or (and (consp definition) (eq (car definition) 'lambda))
  12500.                 (sys::closurep definition)
  12501.             )
  12502.       (error-of-type 'error
  12503.                      #L{
  12504.                      DEUTSCH "Das ist weder ein Lambda-Ausdruck noch ein funktionales Objekt:~%~S"
  12505.                      ENGLISH "Not a lambda expression nor a function: ~S"
  12506.                      FRANCAIS "Ni expression lambda ni fonction : ~S"
  12507.                      }
  12508.                      definition
  12509.     ) )
  12510.     (let ((*compiling* t)
  12511.           (*error-count* 0)
  12512.           (*warning-count* 0)
  12513.           (*compiling-from-file* nil)
  12514.           (*c-listing-output* nil)
  12515.           (*c-error-output* *error-output*)
  12516.           (*known-special-vars* '())
  12517.           (*constant-special-vars* '())
  12518.           (*func* nil)
  12519.           (*fenv* (if (sys::closurep definition)
  12520.                     (sys::%record-ref definition 5)
  12521.                     nil
  12522.           )       )
  12523.           (*benv* (if (sys::closurep definition)
  12524.                     (sys::%record-ref definition 6)
  12525.                     nil
  12526.           )       )
  12527.           (*genv* (if (sys::closurep definition)
  12528.                     (sys::%record-ref definition 7)
  12529.                     nil
  12530.           )       )
  12531.           (*venv* (if (sys::closurep definition)
  12532.                     (sys::%record-ref definition 4)
  12533.                     nil
  12534.           )       )
  12535.           (*venvc* nil)
  12536.           (*denv* (if (sys::closurep definition)
  12537.                     (sys::%record-ref definition 8)
  12538.                     *toplevel-denv*
  12539.           )       )
  12540.           (*no-code* nil))
  12541.       (let ((lambdabody (if (sys::closurep definition)
  12542.                           (sys::%record-ref definition 1)
  12543.                           (cdr definition)
  12544.            ))           )
  12545.         (let ((funobj (compile-lambdabody name lambdabody)))
  12546.           (unless (zerop *error-count*) (return-from compile nil))
  12547.           (if name
  12548.             (progn
  12549.               (when macro-flag (setq funobj (cons 'system::macro funobj)))
  12550.               (if trace-flag
  12551.                 (setf (get symbol 'sys::traced-definition) funobj)
  12552.                 (setf (symbol-function symbol) funobj)
  12553.               )
  12554.               (when save-flag
  12555.                 (setf (get symbol 'sys::definition) save-flag)
  12556.               )
  12557.               name
  12558.             )
  12559.             funobj
  12560. ) ) ) ) ) )
  12561.  
  12562. ; Top-Level-Formen müssen einzeln aufs .fas-File rausgeschrieben werden,
  12563. ; wegen der Semantik von EVAL-WHEN und LOAD-TIME-VALUE.
  12564. ; Da Top-Level-Formen bei EVAL-WHEN, PROGN und LOCALLY auseinandergebrochen
  12565. ; werden können, muß man LET () verwenden, wenn man dies umgehen will.
  12566.  
  12567. ; Compiliert eine Top-Level-Form für COMPILE-FILE. Der *toplevel-name* wird
  12568. ; meist unverändert durchgereicht. *toplevel-for-value* gibt an, ob der Wert
  12569. ; gebraucht wird (für LOAD :PRINT T) oder nicht.
  12570. (defvar *toplevel-for-value*)
  12571. (defun compile-toplevel-form (form &optional (*toplevel-name* *toplevel-name*))
  12572.   (declare (special *toplevel-name*))
  12573.   (catch 'c-error
  12574.     ; CLtL2 S. 90: "Processing of top-level forms in the file compiler ..."
  12575.     ; 1. Schritt: Macroexpandieren
  12576.     (if (atom form)
  12577.       (when (symbolp form)
  12578.         (multiple-value-bind (macrop expansion) (venv-search-macro form *venv*)
  12579.           (when macrop ; Symbol-Macro ?
  12580.             (return-from compile-toplevel-form
  12581.               (compile-toplevel-form expansion) ; -> expandieren
  12582.       ) ) ) )
  12583.       (let ((fun (first form)))
  12584.         (when (symbolp fun)
  12585.           (multiple-value-bind (a b c) (fenv-search fun)
  12586.             (declare (ignore b c))
  12587.             (if (null a)
  12588.               ; nicht lokal definiert
  12589.               (case fun
  12590.                 (PROGN ; vgl. c-PROGN
  12591.                   (test-list form 1)
  12592.                   (let ((L (cdr form))) ; Liste der Formen
  12593.                     (cond ((null L) (compile-toplevel-form 'NIL)) ; keine Form
  12594.                           ((null (cdr L)) (compile-toplevel-form (car L))) ; genau eine Form
  12595.                           (t (let ((subform-count 0))
  12596.                                (do ((Lr L))
  12597.                                    ((null Lr))
  12598.                                  (let* ((subform (pop Lr))
  12599.                                         (*toplevel-for-value* (and *toplevel-for-value* (null Lr))))
  12600.                                    (compile-toplevel-form subform
  12601.                                      (symbol-suffix *toplevel-name* (incf subform-count))
  12602.                   ) )     )  ) ) ) )
  12603.                   (return-from compile-toplevel-form)
  12604.                 )
  12605.                 ((LOCALLY EVAL-WHEN COMPILER-LET MACROLET SYMBOL-MACROLET)
  12606.                   (let ((*form* form))
  12607.                     ; c-LOCALLY bzw. c-EVAL-WHEN bzw. c-COMPILER-LET bzw.
  12608.                     ; c-MACROLET bzw. c-SYMBOL-MACROLET aufrufen:
  12609.                     (funcall (gethash fun c-form-table) #'compile-toplevel-form)
  12610.                   )
  12611.                   (return-from compile-toplevel-form)
  12612.                 )
  12613.                 (t (when (macro-function fun) ; globaler Macro ?
  12614.                      (return-from compile-toplevel-form
  12615.                        (compile-toplevel-form (macroexpand-1 form (vector *venv* *fenv*))) ; -> expandieren
  12616.               ) )  ) )
  12617.               ; lokal definiert
  12618.               (when (eq a 'SYSTEM::MACRO) ; lokaler Macro
  12619.                 (return-from compile-toplevel-form
  12620.                   (compile-toplevel-form (macroexpand-1 form (vector *venv* *fenv*))) ; -> expandieren
  12621.               ) )
  12622.     ) ) ) ) )
  12623.     ; 2. Schritt: compilieren und rausschreiben
  12624.     (when (and (not *toplevel-for-value*) (c-constantp form))
  12625.       (return-from compile-toplevel-form)
  12626.     )
  12627.     (let ((*package-tasks* '()))
  12628.       (setq form
  12629.         (compile-lambdabody *toplevel-name*
  12630.           `(() ,form ,@(if *toplevel-for-value* '() '((VALUES)) ) )
  12631.       ) )
  12632.       (when *c-listing-output*
  12633.         (disassemble-closures form *c-listing-output*)
  12634.       )
  12635.       (when *fasoutput-stream*
  12636.         (terpri *fasoutput-stream*)
  12637.         (write form :stream *fasoutput-stream* :pretty t
  12638.                     :readably t
  12639.                     ; :closure t :circle t :array t :gensym t
  12640.                     ; :escape t :level nil :length nil :radix t
  12641.       ) )
  12642.       (when *package-tasks*
  12643.         (c-eval-when-compile `(PROGN ,@(nreverse *package-tasks*)))
  12644.       )
  12645. ) ) )
  12646.  
  12647. ; C-Output-File öffnen, falls noch nicht offen:
  12648. (defun prepare-coutput-file ()
  12649.   (if (and *compiling-from-file* *coutput-file*)
  12650.     (progn
  12651.       (unless *coutput-stream*
  12652.         (setq *coutput-stream* (open *coutput-file* :direction :output))
  12653.         (format *coutput-stream* "#include \"clisp.h\"~%~%")
  12654.       )
  12655.       t
  12656.     )
  12657.     nil
  12658. ) )
  12659. ; Hook fürs FFI:
  12660. (defun finalize-coutput-file ())
  12661.  
  12662. ; Common-Lisp-Funktion COMPILE-FILE
  12663. ; file          sollte ein Pathname/String/Symbol sein.
  12664. ; :output-file  sollte nil oder t oder ein Pathname/String/Symbol oder
  12665. ;               ein Output-Stream sein. Default: t.
  12666. ; :listing      sollte nil oder t oder ein Pathname/String/Symbol oder
  12667. ;               ein Output-Stream sein. Default: nil.
  12668. ; :warnings     gibt an, ob die Warnings auch auf dem Bildschirm erscheinen
  12669. ;               sollen.
  12670. ; :verbose      gibt an, ob die Errors auch auf dem Bildschirm erscheinen
  12671. ;               sollen.
  12672. (defun compile-file (file &key (output-file 'T) listing
  12673.                                ((:warnings *compile-warnings*) *compile-warnings*)
  12674.                                ((:verbose *compile-verbose*) *compile-verbose*)
  12675.                                ((:print *compile-print*) *compile-print*)
  12676.                           &aux (top-call nil) liboutput-file (*coutput-file* nil)
  12677.                                (new-output-stream nil) (new-listing-stream nil)
  12678.                     )
  12679.   (setq file (or (first (search-file file sys::*source-file-types*))
  12680.                  (merge-pathnames file (merge-pathnames '#".lsp"))
  12681.   )          )
  12682.   (when (and output-file (not (streamp output-file)))
  12683.     (setq output-file (if (eq output-file 'T)
  12684.                         (merge-pathnames '#".fas" file)
  12685.                         (merge-pathnames output-file)
  12686.     )                 )
  12687.     (setq liboutput-file (merge-pathnames '#".lib" output-file))
  12688.     (setq *coutput-file* (merge-pathnames '#".c" output-file))
  12689.     (setq new-output-stream t)
  12690.   )
  12691.   (when (and listing (not (streamp listing)))
  12692.     (setq listing (if (eq listing 'T)
  12693.                     (merge-pathnames '#".lis" file)
  12694.                     (merge-pathnames listing)
  12695.     )             )
  12696.     (setq new-listing-stream t)
  12697.   )
  12698.   (with-open-file (istream file :direction :input-immutable)
  12699.     (let ((listing-stream (if new-listing-stream
  12700.                             (open listing :direction :output)
  12701.                             (if (streamp listing) listing nil)
  12702.          ))               ) ; ein Stream oder NIL
  12703.       (unwind-protect
  12704.         (let ((*compile-file-pathname* file)
  12705.               (*compile-file-truename* (truename file))
  12706.               (*compile-file-lineno1* nil)
  12707.               (*compile-file-lineno2* nil)
  12708.               (*fasoutput-stream* (if new-output-stream
  12709.                                     (open output-file :direction :output)
  12710.                                     (if (streamp output-file) output-file nil)
  12711.               )                   ) ; ein Stream oder NIL
  12712.               (*liboutput-stream* (if new-output-stream
  12713.                                     (open liboutput-file :direction :output)
  12714.                                     nil
  12715.               )                   ) ; ein Stream oder NIL
  12716.               (*coutput-stream* nil) ; ein Stream oder vorerst NIL
  12717.               (*ffi-module* nil) ; vorerst NIL
  12718.               (compilation-successful nil))
  12719.           (unwind-protect
  12720.             (progn
  12721.               (when listing-stream
  12722.                 (format listing-stream
  12723.                         #L{
  12724.                         DEUTSCH "~&Listing der Compilation von Datei ~A~%am ~@? durch ~A in der Version ~A"
  12725.                         ENGLISH "~&Listing of compilation of file ~A~%on ~@? by ~A, version ~A"
  12726.                         FRANCAIS "~&Listage de la compilation du fichier ~A~%le ~@? par ~A, version ~A"
  12727.                         }
  12728.                         file
  12729.                         (date-format)
  12730.                         (multiple-value-list (get-decoded-time))
  12731.                         ;; Liste (sec min hour day month year ...)
  12732.                         (lisp-implementation-type) (lisp-implementation-version)
  12733.               ) )
  12734.               (unless *compiling* ; Variablen setzen, nicht binden!
  12735.                 (setq *functions-with-errors* '())
  12736.                 (setq *known-special-vars* '()) (setq *unknown-free-vars* '())
  12737.                 (setq *constant-special-vars* '())
  12738.                 (setq *known-functions* '()) (setq *unknown-functions* '())
  12739.                 (setq *inline-functions* '()) (setq *notinline-functions* '())
  12740.                 (setq *inline-definitions* '())
  12741.                 (setq *user-declaration-types* '())
  12742.                 (setq *compiled-modules* '())
  12743.                 (setq top-call t)
  12744.               )
  12745.               (let ((*compiling* t)
  12746.                     (*compiling-from-file* t)
  12747.                     (*package* *package*)
  12748.                     (*readtable* *readtable*)
  12749.                     (*c-listing-output* listing-stream)
  12750.                     (*c-error-output*
  12751.                       (if listing-stream
  12752.                         (make-broadcast-stream *error-output* listing-stream)
  12753.                         *error-output*
  12754.                     ) )
  12755.                     (*func* nil)
  12756.                     (*fenv* nil)
  12757.                     (*benv* nil)
  12758.                     (*genv* nil)
  12759.                     (*venv* nil)
  12760.                     (*venvc* nil)
  12761.                     (*denv* *toplevel-denv*)
  12762.                     (*error-count* 0) (*warning-count* 0)
  12763.                     (*no-code* (and (null *fasoutput-stream*) (null listing-stream)))
  12764.                     (*toplevel-for-value* t)
  12765.                     (eof-value "EOF")
  12766.                     (form-count 0)
  12767.                    )
  12768.                 (c-comment 
  12769.                  #L{
  12770.                  DEUTSCH "~%Datei ~A wird compiliert..."
  12771.                  ENGLISH "~%Compiling file ~A ..."
  12772.                  FRANCAIS "~%Compilation du fichier ~A..."
  12773.                  }
  12774.                  file
  12775.                 )
  12776.                 (when *fasoutput-stream*
  12777.                   (let ((*package* *keyword-package*))
  12778.                     (write `(SYSTEM::VERSION ',(version)) :stream *fasoutput-stream*
  12779.                            :readably t
  12780.                            ; :escape t :level nil :length nil :radix t
  12781.                 ) ) )
  12782.                 (loop
  12783.                   (peek-char t istream nil eof-value)
  12784.                   (setq *compile-file-lineno1* (line-number istream))
  12785.                   (let ((form (read istream nil eof-value)))
  12786.                     (setq *compile-file-lineno2* (line-number istream))
  12787.                     (when (eql form eof-value) (return))
  12788.                     (when *compile-print*
  12789.                       (format t "~%; ~A" (sys::write-to-short-string form (- sys::*prin-linelength* 2)))
  12790.                     )
  12791.                     (compile-toplevel-form form
  12792.                       (symbol-suffix '#:TOP-LEVEL-FORM (incf form-count))
  12793.                 ) ) )
  12794.                 (finalize-coutput-file)
  12795.                 (c-comment 
  12796.                  #L{
  12797.                  DEUTSCH "~&~%Compilation von Datei ~A beendet."
  12798.                  ENGLISH "~&~%Compilation of file ~A is finished."
  12799.                  FRANCAIS "~&~%Compilation du fichier ~A terminée."
  12800.                  }
  12801.                  file
  12802.                 )
  12803.                 (c-comment 
  12804.                  #L{
  12805.                  DEUTSCH "~%~D Error~:P, ~D Warnung~:[en~;~]"
  12806.                  ENGLISH "~%~D error~:P, ~D warning~:P"
  12807.                  FRANCAIS "~%~D erreur~:P, ~D avertissement~:P"
  12808.                  }
  12809.                  *error-count* *warning-count* (DEUTSCH (eql *warning-count* 1))
  12810.                 )
  12811.                 (when top-call
  12812.                   (when *functions-with-errors*
  12813.                     (c-comment 
  12814.                      #L{
  12815.                      DEUTSCH "~%Es gab Errors in den folgenden Funktionen:~%~{~<~%~:; ~S~>~^~}"
  12816.                      ENGLISH "~%There were errors in the following functions:~%~{~<~%~:; ~S~>~^~}"
  12817.                      FRANCAIS "~%Il y a des erreurs dans les fonctions :~%~{~<~%~:; ~S~>~^~}" 
  12818.                      }
  12819.                      (nreverse *functions-with-errors*)
  12820.                   ) )
  12821.                   (setq *unknown-functions*
  12822.                     (nset-difference *unknown-functions* *known-functions* :test #'equal)
  12823.                   )
  12824.                   (when *unknown-functions*
  12825.                     (c-comment 
  12826.                      #L{
  12827.                      DEUTSCH "~%Folgende Funktionen wurden verwendet, aber nicht definiert:~%~{~<~%~:; ~S~>~^~}"
  12828.                      ENGLISH "~%The following functions were used but not defined:~%~{~<~%~:; ~S~>~^~}"
  12829.                      FRANCAIS "~%Les fonctions suivantes sont utilisées mais non définies :~%~{~<~%~:; ~S~>~^~}"
  12830.                      }
  12831.                      (nreverse *unknown-functions*)
  12832.                   ) )
  12833.                   (let ((unknown-vars (set-difference *unknown-free-vars* *known-special-vars*))
  12834.                         (too-late-vars (intersection *unknown-free-vars* *known-special-vars*)))
  12835.                     (when unknown-vars
  12836.                       (c-comment 
  12837.                        #L{
  12838.                        DEUTSCH "~%Folgende Special-Variablen wurden nicht definiert:~%~{~<~%~:; ~S~>~^~}"
  12839.                        ENGLISH "~%The following special variables were not defined:~%~{~<~%~:; ~S~>~^~}"
  12840.                        FRANCAIS "~%Les variables utilisées comme SPECIAL ne sont pas définies :~%~{~<~%~:; ~S~>~^~}"
  12841.                        }
  12842.                        (nreverse unknown-vars)
  12843.                     ) )
  12844.                     (when too-late-vars
  12845.                       (c-comment 
  12846.                        #L{
  12847.                        DEUTSCH "~%Folgende Special-Variablen wurden zu spät definiert:~%~{~<~%~:; ~S~>~^~}"
  12848.                        ENGLISH "~%The following special variables were defined too late:~%~{~<~%~:; ~S~>~^~}"
  12849.                        FRANCAIS "~%Les variables déclarées SPECIAL sont définies trop tard :~%~{~<~%~:; ~S~>~^~}"
  12850.                        }
  12851.                        (nreverse too-late-vars)
  12852.                 ) ) ) )
  12853.                 (c-comment "~%")
  12854.                 (setq compilation-successful
  12855.                   (zerop *error-count*) ; Wert T, falls Compilation erfolgreich
  12856.             ) ) )
  12857.             (when new-output-stream
  12858.               (terpri *fasoutput-stream*) (close *fasoutput-stream*)
  12859.               (close *liboutput-stream*)
  12860.               (if *coutput-stream*
  12861.                 (close *coutput-stream*)
  12862.                 (when (probe-file *coutput-file*) (delete-file *coutput-file*))
  12863.               )
  12864.               (unless compilation-successful
  12865.                 (delete-file output-file) (delete-file liboutput-file)
  12866.                 (when (probe-file *coutput-file*) (delete-file *coutput-file*))
  12867.             ) )
  12868.         ) )
  12869.         (when new-listing-stream (close listing-stream))
  12870. ) ) ) )
  12871.  
  12872. ; Das muß mit compile-file (s.o.) konsistent sein!
  12873. (defun compile-file-pathname (file &key (output-file 'T) listing warnings verbose print)
  12874.   (declare (ignore listing warnings verbose print))
  12875.   (setq file (or (first (search-file file sys::*source-file-types*))
  12876.                  (merge-pathnames file (merge-pathnames '#".lsp"))
  12877.   )          )
  12878.   (when (and output-file (not (streamp output-file)))
  12879.     (setq output-file (if (eq output-file 'T)
  12880.                         (merge-pathnames '#".fas" file)
  12881.                         (merge-pathnames output-file)
  12882.     )                 )
  12883.   )
  12884.   output-file
  12885. )
  12886.  
  12887. (defun disassemble-closures (closure stream)
  12888.   (let ((closures '()))
  12889.     (labels ((mark (cl) ; trägt eine Closure cl (rekursiv) in closures ein.
  12890.                (push cl closures) ; cl markieren
  12891.                (dolist (c (closure-consts cl)) ; und alle Teil-Closures
  12892.                  (when #+CLISP (and (sys::closurep c) (compiled-function-p c))
  12893.                        #-CLISP (closure-p c)
  12894.                    (unless (member c closures) (mark c)) ; ebenfalls markieren
  12895.             )) ) )
  12896.       (mark closure) ; Haupt-Closure markieren
  12897.     )
  12898.     (dolist (c (nreverse closures)) ; alle Closures disassemblieren
  12899.       (disassemble-closure c stream)
  12900. ) ) )
  12901.  
  12902. #-CLISP
  12903. (defun disassemble-closure (closure &optional (stream *standard-output*))
  12904.   (format stream 
  12905.           #L{
  12906.           DEUTSCH "~%~%Disassembly von Funktion ~S"
  12907.           ENGLISH "~%~%Disassembly of function ~S"
  12908.           FRANCAIS "~%~%Déassemblage de la fonction ~S"
  12909.           }
  12910.           (closure-name closure)
  12911.   )
  12912.   (multiple-value-bind (req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p
  12913.                         byte-list const-list)
  12914.       (signature closure)
  12915.     (do ((L const-list (cdr L))
  12916.          (i 0 (1+ i)))
  12917.         ((null L))
  12918.       (format stream "~%(CONST ~S) = ~S" i (car L))
  12919.     )
  12920.     (format stream 
  12921.             #L{
  12922.             DEUTSCH "~%~S notwendige Argumente"
  12923.             ENGLISH "~%~S required arguments"
  12924.             FRANCAIS "~%~S arguments nécessaires"
  12925.             }
  12926.             req-anz
  12927.     )
  12928.     (format stream 
  12929.             #L{
  12930.             DEUTSCH "~%~S optionale Argumente"
  12931.             ENGLISH "~%~S optional arguments"
  12932.             FRANCAIS "~%~S arguments facultatifs"
  12933.             }
  12934.             opt-anz
  12935.     )
  12936.     (format stream 
  12937.             #L{
  12938.             DEUTSCH "~%~:[Kein Rest-Parameter~;Rest-Parameter vorhanden~]"
  12939.             ENGLISH "~%~:[No rest parameter~;Rest parameter~]"
  12940.             FRANCAIS "~%~:[Pas de paramètre &REST~;Paramètre &REST~]"
  12941.             }
  12942.             rest-p
  12943.     )
  12944.     (if key-p
  12945.       (let ((kw-count (length keyword-list)))
  12946.         (format stream 
  12947.                 #L{
  12948.                 DEUTSCH "~%~S Keyword-Parameter: ~{~S~^, ~}."
  12949.                 ENGLISH "~%~S keyword parameter~:P: ~{~S~^, ~}."
  12950.                 FRANCAIS "~%~S Mot~:P-clé : ~{~S~^, ~}."
  12951.                 }
  12952.                 kw-count keyword-list
  12953.         )
  12954.         (when allow-other-keys-p
  12955.           (format stream 
  12956.                   #L{
  12957.                   DEUTSCH "~%Andere Keywords sind zugelassen."
  12958.                   ENGLISH "~%Other keywords are allowed."
  12959.                   FRANCAIS "~%D'autres mots-clé sont permis."
  12960.                   }
  12961.       ) ) )
  12962.       (format stream 
  12963.               #L{
  12964.               DEUTSCH "~%Keine Keyword-Parameter"
  12965.               ENGLISH "~%No keyword parameters"
  12966.               FRANCAIS "~%Pas de mot-clé"
  12967.               }
  12968.     ) )
  12969.     (let ((const-string-list (mapcar #'write-to-string const-list)))
  12970.       (do ((L (disassemble-LAP byte-list const-list) (cdr L)))
  12971.           ((null L))
  12972.         (let ((PC (caar L))
  12973.               (instr (cdar L)))
  12974.           (format stream "~%~S~6T~A" PC instr)
  12975.           (multiple-value-bind ... ; siehe unten
  12976.             ...
  12977.     ) ) ) )
  12978.     (format stream "~%")
  12979. ) )
  12980.  
  12981. (defun comment-values (instr const-string-list)
  12982.   (when (consp instr)
  12983.     (case (first instr)
  12984.       ((CALLS1 CALLS1&PUSH CALLS1&STORE CALLS1&JMPIFNOT CALLS1&JMPIF)
  12985.        (values t (%funtabref (second instr)) 1)
  12986.        )
  12987.       ((CALLS2 CALLS2&PUSH CALLS2&STORE CALLS2&JMPIFNOT CALLS2&JMPIF)
  12988.        (values t (%funtabref (+ 256 (second instr))) 1)
  12989.        )
  12990.       ((CALLSR CALLSR&PUSH CALLSR&STORE CALLSR&JMPIFNOT CALLSR&JMPIF)
  12991.        (values t (%funtabref (+ funtabR-index (third instr))) 2)
  12992.        )
  12993.       ((CALL CALL&PUSH)
  12994.        (values 'string (nth (third instr) const-string-list) 2)
  12995.        )
  12996.       ((CALL0 CALL1 CALL1&PUSH CALL1&JMPIFNOT CALL1&JMPIF
  12997.               CALL2 CALL2&PUSH CALL2&JMPIFNOT CALL2&JMPIF
  12998.               JMPIFEQTO JMPIFNOTEQTO CONST CONST&PUSH SETVALUE GETVALUE
  12999.               GETVALUE&PUSH BIND CONST&STORE CONST&SYMBOL-FUNCTION&PUSH
  13000.               CONST&SYMBOL-FUNCTION COPY-CLOSURE&PUSH COPY-CLOSURE
  13001.               CONST&SYMBOL-FUNCTION&STORE TAGBODY-OPEN HANDLER-OPEN
  13002.               )
  13003.        (values 'string (nth (second instr) const-string-list) 1)
  13004. ) ) ) )
  13005.   
  13006. #+CLISP
  13007. (defun disassemble-closure (closure &optional (stream *standard-output*))
  13008.   (terpri stream)
  13009.   (terpri stream)
  13010.   (write-string 
  13011.    #L{
  13012.    DEUTSCH "Disassembly von Funktion "
  13013.    ENGLISH "Disassembly of function "
  13014.    FRANCAIS "Déassemblage de la fonction "
  13015.    }
  13016.    stream
  13017.   )
  13018.   (prin1 (closure-name closure) stream)
  13019.   (multiple-value-bind (req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p
  13020.                         byte-list const-list)
  13021.       (signature closure)
  13022.     (do ((L const-list (cdr L))
  13023.          (i 0 (1+ i)))
  13024.         ((null L))
  13025.       (terpri stream)
  13026.       (write-string "(CONST " stream)
  13027.       (prin1 i stream)
  13028.       (write-string ") = " stream)
  13029.       (prin1 (car L) stream)
  13030.     )
  13031.     (terpri stream)
  13032.     (prin1 req-anz stream)
  13033.     (write-string 
  13034.      #L{
  13035.      DEUTSCH " notwendige Argumente"
  13036.      ENGLISH " required arguments"
  13037.      FRANCAIS " arguments nécessaires"
  13038.      }
  13039.      stream
  13040.     )
  13041.     (terpri stream)
  13042.     (prin1 opt-anz stream)
  13043.     (write-string 
  13044.      #L{
  13045.      DEUTSCH " optionale Argumente"
  13046.      ENGLISH " optional arguments"
  13047.      FRANCAIS " arguments facultatifs"
  13048.      }
  13049.      stream
  13050.     )
  13051.     (terpri stream)
  13052.     (if rest-p
  13053.       (write-string 
  13054.        #L{
  13055.        DEUTSCH "Rest-Parameter vorhanden"
  13056.        ENGLISH "Rest parameter"
  13057.        FRANCAIS "Paramètre &REST"
  13058.        }
  13059.        stream
  13060.       )
  13061.       (write-string 
  13062.        #L{
  13063.        DEUTSCH "Kein Rest-Parameter"
  13064.        ENGLISH "No rest parameter"
  13065.        FRANCAIS "Pas de paramètre &REST"
  13066.        }
  13067.        stream
  13068.     ) )
  13069.     (if key-p
  13070.       (let ((kw-count (length keyword-list)))
  13071.         (terpri stream)
  13072.         (prin1 kw-count stream)
  13073.         (language-case
  13074.           (DEUTSCH (write-string " Keyword-Parameter: " stream))
  13075.           (ENGLISH (write-string " keyword parameter" stream)
  13076.                    (unless (eql kw-count 1) (write-string "s" stream))
  13077.                    (write-string ": " stream)
  13078.           )
  13079.           (FRANCAIS (write-string " mot" stream)
  13080.                     (unless (eql kw-count 1) (write-string "s" stream))
  13081.                     (write-string "-clé" stream)
  13082.         ) )
  13083.         (do ((L keyword-list))
  13084.             ((endp L))
  13085.           (prin1 (pop L) stream)
  13086.           (if (endp L) (write-string "." stream) (write-string ", " stream))
  13087.         )
  13088.         (when allow-other-keys-p
  13089.           (terpri stream)
  13090.           (write-string 
  13091.            #L{
  13092.            DEUTSCH "Andere Keywords sind zugelassen."
  13093.            ENGLISH "Other keywords are allowed."
  13094.            FRANCAIS "D'autres mots-clé sont permis."
  13095.            }
  13096.            stream
  13097.       ) ) )
  13098.       (progn
  13099.         (terpri stream)
  13100.         (write-string 
  13101.          #L{
  13102.          DEUTSCH "Keine Keyword-Parameter"
  13103.          ENGLISH "No keyword parameters"
  13104.          FRANCAIS "Pas de mot-clé"
  13105.          }
  13106.          stream
  13107.     ) ) )
  13108.     (let ((const-string-list
  13109.             (mapcar #'(lambda (x) (sys::write-to-short-string x 35)) const-list)
  13110.          ))
  13111.       (do ((L (disassemble-LAP byte-list const-list) (cdr L)))
  13112.           ((null L))
  13113.         (let ((PC (caar L))
  13114.               (instr (cdar L)))
  13115.           (terpri stream)
  13116.           (prin1 PC stream)
  13117.           (dotimes (i (- 6 (sys::line-position stream))) (write-char #\Space stream)) ; Tab 6
  13118.           (princ instr stream) ; instr ausgeben, Symbole ohne Package-Marker!
  13119.           (multiple-value-bind (commentp comment) (comment-values instr const-string-list)
  13120.             (when commentp
  13121.               (dotimes (i (max 1 (- 42 (sys::line-position stream)))) (write-char #\Space stream)) ; Tab 42
  13122.               (write-string "; " stream)
  13123.               (if (eq commentp 'string)
  13124.                 (write-string comment stream)
  13125.                 (prin1 comment stream)
  13126.     ) ) ) ) ) )
  13127.     (terpri stream)
  13128. ) )
  13129.  
  13130. #-CROSS
  13131. (defun disassemble (object &aux name)
  13132.   (when (function-name-p object)
  13133.     (unless (fboundp object)
  13134.       (error-of-type 'undefined-function
  13135.         :name object
  13136.         #L{
  13137.         DEUTSCH "Funktion ~S ist undefiniert."
  13138.         ENGLISH "Undefined function ~S"
  13139.         FRANCAIS "Fonction non-définie ~S"
  13140.         }
  13141.         object
  13142.     ) )
  13143.     (setq name object)
  13144.     (setq object (get-funname-symbol object))
  13145.     (setq object (or (get object 'sys::traced-definition)
  13146.                      (symbol-function object)
  13147.   ) )            )
  13148.   (when (and (consp object) (eq (car object) 'system::macro))
  13149.     (setq object (cdr object))
  13150.   )
  13151.   #+(or UNIX WIN32-UNIX) (when (stringp object)
  13152.            (return-from disassemble
  13153.              (disassemble-machine-code (sys::program-name) (sys::program-id)
  13154.                           object
  13155.          ) ) )
  13156.   #+(or UNIX WIN32-UNIX) (when (sys::code-address-of object)
  13157.            (return-from disassemble
  13158.              (disassemble-machine-code (sys::program-name) (sys::program-id)
  13159.                           (format nil "0x~X" (sys::code-address-of object))
  13160.          ) ) )
  13161.   (unless (sys::closurep object)
  13162.     (error-of-type 'error
  13163.                    #L{
  13164.                    DEUTSCH "~S kann nicht disassembliert werden."
  13165.                    ENGLISH "Cannot disassemble ~S"
  13166.                    FRANCAIS "Impossible de déassembler ~S"
  13167.                    }
  13168.                    object
  13169.   ) )
  13170.   ; object ist eine Closure.
  13171.   (unless (compiled-function-p object)
  13172.     (setq object
  13173.       (compile-lambda (sys::%record-ref object 0) ; name
  13174.                       (sys::%record-ref object 1) ; lambdabody
  13175.                       (sys::%record-ref object 4) ; venv
  13176.                       (sys::%record-ref object 5) ; fenv
  13177.                       (sys::%record-ref object 6) ; benv
  13178.                       (sys::%record-ref object 7) ; genv
  13179.                       (sys::%record-ref object 8) ; denv
  13180.   ) ) )
  13181.   ; object ist eine compilierte Closure.
  13182.   (disassemble-closure object) ; Disassemblieren
  13183.   object ; compilierte Closure als Wert
  13184. )
  13185.