home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / debug.d < prev    next >
Encoding:
Text File  |  1994-08-29  |  53.3 KB  |  1,238 lines
  1. # Top-Level-Schleife, Hilfsfunktionen fⁿr Debugger, Stepper von CLISP
  2. # Bruno Haible 29.8.1994
  3. # ILISP friendliness: Marcus Daniels 8.4.1994
  4.  
  5. #include "lispbibl.c"
  6.  
  7.  
  8. # ---------------------------------------------------------------------------- #
  9. #                             Top-Level-Schleifen
  10.  
  11. # (SYS::READ-FORM ostream istream prompt [commandlist])
  12. # Liest eine Form (interaktiv) von einem Input-Stream.
  13. # Statt einer Form kann auch eine Sondertaste aus commandlist (eine frische
  14. # Aliste) oder SYS::*KEY-BINDINGS* eingegeben werden.
  15. # > STACK_1: prompt, ein String
  16. # > STACK_0: Befehlsliste (frische Aliste) oder #<UNBOUND>
  17. # < STACK_1: Output-Stream *standard-output*
  18. # < STACK_0: Input-Stream *standard-input*
  19. # < mv_space/mv_count: Werte form, NIL oder (bei EOF) T, T
  20. # kann GC ausl÷sen
  21.   local Values read_form (void);
  22. # (defun read-form (ostream istream prompt &optional (command-list nil))
  23. #   (loop
  24. #     (clear-input istream)
  25. #     (unless (listen istream)
  26. #       (terpri ostream)
  27. #       (write-string prompt ostream)
  28. #     )
  29. #     (let* ((eof-value "EOF")
  30. #            (form (let ((*read-suppress* nil)
  31. #                        (*key-bindings* (nreconc command-list *key-bindings*)))
  32. #                    (read istream nil eof-value nil)
  33. #           ))     )
  34. #       (if (eql form eof-value)
  35. #         (progn (clear-input istream) (setq istream *debug-io*))
  36. #         (progn (clear-input istream) (return (values form nil)))
  37. # ) ) ) )
  38.   local Values read_form()
  39.   { pushSTACK(STACK_1); pushSTACK(STACK_1);
  40.     STACK_3 = var_stream(S(standard_output)); # ostream := Wert von *STANDARD-OUTPUT*
  41.     STACK_2 = var_stream(S(standard_input)); # istream := Wert von *STANDARD-INPUT*
  42.     # Stackaufbau: ostream, istream, prompt, command-list.
  43.     clear_input(STACK_2); # wartenden Input l÷schen und
  44.    {var reg4 signean status = stream_listen(STACK_2); # horchen
  45.     if (status<0) goto eof;
  46.     # bereits Zeichen verfⁿgbar (und nicht im ilisp_mode) -> kein Prompt
  47.     if (ilisp_mode || status>0)
  48.       { # interaktiver Input-Stream -> Prompt ausgeben:
  49.         terpri(&STACK_3); # (TERPRI ostream)
  50.         write_string(&STACK_3,STACK_1); # (WRITE-STRING prompt ostream)
  51.       }
  52.     # Prompt OK
  53.     { var reg3 object* istream_ = &STACK_2;
  54.       #if 0 # Das erweist sich doch als ungeschickt: Drⁿckt man Ctrl-C wΣhrend
  55.             # der Eingabe, so hat man dann in der Break-Schleife manche Kommandos
  56.             # doppelt in der Liste!
  57.       {var reg1 object list = Symbol_value(S(key_bindings)); # bisherige Key-Bindings
  58.        if (!eq(STACK_0,unbound)) # command-list angegeben?
  59.          { list = nreconc(STACK_0,list); } # ja -> davorhΣngen
  60.        dynamic_bind(S(key_bindings),list); # SYS::*KEY-BINDINGS* binden
  61.       }
  62.       #else
  63.       # statt        (nreconc command-list *key-bindings*)
  64.       # doch lieber  (nreverse command-list)
  65.       {var reg1 object list = (eq(STACK_0,unbound) ? NIL : nreverse(STACK_0));
  66.        dynamic_bind(S(key_bindings),list); # SYS::*KEY-BINDINGS* binden
  67.       }
  68.       #endif
  69.       #if !defined(TERMINAL_USES_KEYBOARD) # auf dem Atari geht's ⁿber Funktionstasten
  70.       if (status>0) # nur bei interaktivem Input-Stream
  71.         { # Erkennung von Kommandos statt Formen:
  72.           # (multiple-value-bind (line flag) (read-line istream)
  73.           #   (let ((h (assoc line *key-bindings* :test #'string-equal)))
  74.           #     (when h (funcall (cdr h)) (return t))
  75.           #   )
  76.           #   (setq istream
  77.           #     (make-concatenated-stream
  78.           #       (make-string-input-stream
  79.           #         (if flag line (concatenate 'string line (string #\Newline)))
  80.           #       )
  81.           #       istream
  82.           # ) ) )
  83.           pushSTACK(*istream_); pushSTACK(NIL); pushSTACK(NIL);
  84.           funcall(L(read_line),3); # (READ-LINE istream nil nil)
  85.          {var reg2 object line = value1;
  86.           if (nullp(line)) { dynamic_unbind(); goto eof; } # EOF am Zeilenanfang?
  87.           # line in *KEY-BINDINGS* suchen:
  88.           {var reg1 object alist = Symbol_value(S(key_bindings));
  89.            while (consp(alist))
  90.              { if (mconsp(Car(alist)) && simple_string_p(Car(Car(alist)))
  91.                    && string_equal(line,Car(Car(alist)))
  92.                   )
  93.                  # gefunden -> Funktion dazu aufrufen:
  94.                  { funcall(Cdr(Car(alist)),0); dynamic_unbind(); goto eof; }
  95.                alist = Cdr(alist);
  96.           }  }
  97.           # String-Input-Stream fⁿr diese Zeile basteln:
  98.           if (nullp(value2))
  99.             { pushSTACK(line); pushSTACK(O(newline_string));
  100.               line = string_concat(2); # evtl. noch ein Newline anhΣngen
  101.             }
  102.           pushSTACK(line); funcall(L(make_string_input_stream),1);
  103.           # Concatenated-Stream basteln:
  104.           pushSTACK(value1); pushSTACK(*istream_);
  105.           funcall(L(make_concatenated_stream),2);
  106.           *istream_ = value1; # und an istream zuweisen
  107.         }}
  108.       #endif
  109.      {var reg1 object obj;
  110.       dynamic_bind(S(read_suppress),NIL); # *READ-SUPPRESS* = NIL
  111.       obj = read(istream_,NIL,NIL); # Objekt lesen (recursive-p=NIL, whitespace-p=NIL)
  112.       dynamic_unbind();
  113.       dynamic_unbind();
  114.       if (!eq(obj,eof_value)) # EOF (nach Whitespace) abfragen
  115.         { pushSTACK(obj);
  116.           clear_input(STACK_(2+1)); # wartenden Input (hoffentlich nur
  117.                                     # bis Zeilenende) l÷schen
  118.           value1 = popSTACK(); value2 = NIL; mv_count=2; # obj, NIL als Werte
  119.           skipSTACK(2); return;
  120.         }
  121.     }}
  122.     eof: # bei EOF angelangt
  123.     # (clear-input istream) ausfⁿhren (um bei interaktivem Stream das EOF zu
  124.     # schlucken: das fortzusetzende Programm k÷nnte das EOF mi▀verstehen):
  125.     clear_input(STACK_2);
  126.     value1 = value2 = T; mv_count=2; # T, T als Werte
  127.     skipSTACK(2); return;
  128.   }}
  129.  
  130. # (SYS::READ-FORM prompt [commandlist])
  131. # liest eine Form (interaktiv) von *standard-input*.
  132. # prompt mu▀ ein String sein.
  133. # Statt einer Form kann auch eine Sondertaste aus commandlist (eine frische
  134. # Aliste) oder SYS::*KEY-BINDINGS* eingegeben werden.
  135. # Werte: form, NIL oder (bei EOF) T, T
  136. LISPFUN(read_form,1,1,norest,nokey,0,NIL)
  137.   { read_form(); skipSTACK(2); }
  138.  
  139. # (SYS::READ-EVAL-PRINT prompt [commandlist])
  140. # liest eine Form, wertet sie aus und gibt die Werte aus.
  141. # prompt mu▀ ein String sein.
  142. # Statt einer Form kann auch eine Sondertaste aus commandlist (eine frische
  143. # Aliste) oder SYS::*KEY-BINDINGS* eingegeben werden.
  144. # Werte: NIL oder (bei Sondertaste oder EOF) T
  145. LISPFUN(read_eval_print,1,1,norest,nokey,0,NIL)
  146. # (defun read-eval-print (prompt &optional (command-list nil))
  147. #   (multiple-value-bind (form flag)
  148. #       (read-form *standard-output* *standard-input* prompt command-list)
  149. #     (if flag
  150. #       form ; T zurⁿck
  151. #       (progn
  152. #         (setq +++ ++ ++ + + - - form)
  153. #         (let ((vals (multiple-value-list (eval-env form [aktuellesEnvironment]))))
  154. #           (setq /// // // / / vals)
  155. #           (setq *** ** ** * * (first vals))
  156. #           #+ATARI
  157. #           (do ((ostream *standard-output*)
  158. #                (L vals (cdr L)))
  159. #               ((atom L))
  160. #             (write (car L) ostream)
  161. #             (when (consp (cdr L))
  162. #               (write-string " ;" ostream)
  163. #               (terpri ostream)
  164. #           ) )
  165. #           #-ATARI ; unn÷tige Leerzeile zwischen Input und Output vermeiden
  166. #           (let ((ostream *standard-output*))
  167. #             (fresh-line ostream)
  168. #             (when (consp vals)
  169. #               (write (car vals) ostream)
  170. #               (do ((L (cdr vals) (cdr L)))
  171. #                   ((atom L))
  172. #                 (write-string " ;" ostream)
  173. #                 (terpri ostream)
  174. #                 (write (car L) ostream)
  175. #           ) ) )
  176. #         )
  177. #         nil
  178. # ) ) ) )
  179.   { read_form(); # Form lesen
  180.     # Stackaufbau: ostream, istream.
  181.     if (!nullp(value2)) # flag ?
  182.       { mv_count=1; skipSTACK(2); return; } # T als Wert zurⁿck
  183.     Symbol_value(S(plus3)) = Symbol_value(S(plus2)); # (SETQ +++ ++)
  184.     Symbol_value(S(plus2)) = Symbol_value(S(plus)); # (SETQ ++ +)
  185.     Symbol_value(S(plus)) = Symbol_value(S(minus)); # (SETQ + -)
  186.     Symbol_value(S(minus)) = value1; # (SETQ - form)
  187.     eval(value1); # Form auswerten (im aktuellen Environment)
  188.     pushSTACK(value1); # einen Wert retten
  189.     mv_to_list(); # Werte in Liste packen
  190.     # Stackaufbau: ..., val1, vals.
  191.     Symbol_value(S(durch3)) = Symbol_value(S(durch2)); # (SETQ /// //)
  192.     Symbol_value(S(durch2)) = Symbol_value(S(durch)); # (SETQ // /)
  193.     Symbol_value(S(durch)) = STACK_0; # (SETQ / vals)
  194.     Symbol_value(S(mal3)) = Symbol_value(S(mal2)); # (SETQ *** **)
  195.     Symbol_value(S(mal2)) = Symbol_value(S(mal)); # (SETQ ** *)
  196.     Symbol_value(S(mal)) = STACK_1; # (SETQ * val1)
  197.     # Werte ausgeben:
  198.     STACK_(1+2) = var_stream(S(standard_output)); # ostream := Wert von *STANDARD-OUTPUT*
  199.     #if 0
  200.     if (mconsp(STACK_0))
  201.       { loop
  202.           { var reg1 object valsr = STACK_0;
  203.             STACK_0 = Cdr(valsr);
  204.             terpri(&STACK_(1+2));
  205.             prin1(&STACK_(1+2),Car(valsr)); # nΣchsten Wert ausgeben
  206.             # ';' als Trennzeichen vorm Zeilenende:
  207.             if (matomp(STACK_0)) break;
  208.             write_schar(&STACK_(1+2),' ');
  209.             write_schar(&STACK_(1+2),';');
  210.       }   }
  211.     #else
  212.     # unn÷tige Leerzeile zwischen Input und Output vermeiden:
  213.     # (Es erscheint immer noch eine unn÷tige Leerzeile am Bildschirm,
  214.     # wenn stdin vom Terminal kommt und stdout eine Pipe ist, die
  215.     # letztendlich wieder aufs Terminal geht - z.B. via '| tee logfile'.
  216.     # In diesem Fall mⁿssen wir aber - eben wegen 'logfile' - ein NL auf
  217.     # stdout ausgeben, und da stdin am Zeilenende von selbst ein NL aus-
  218.     # gibt, ist diese Leerzeile wirklich unvermeidlich.)
  219.     if (!eq(get_line_position(STACK_(1+2)),Fixnum_0))
  220.       { terpri(&STACK_(1+2)); } # (fresh-line ostream)
  221.     if (mconsp(STACK_0))
  222.       { loop
  223.           { var reg1 object valsr = STACK_0;
  224.             STACK_0 = Cdr(valsr);
  225.             prin1(&STACK_(1+2),Car(valsr)); # nΣchsten Wert ausgeben
  226.             # ';' als Trennzeichen vorm Zeilenende:
  227.             if (matomp(STACK_0)) break;
  228.             write_schar(&STACK_(1+2),' ');
  229.             write_schar(&STACK_(1+2),';');
  230.             terpri(&STACK_(1+2));
  231.       }   }
  232.     #endif
  233.     skipSTACK(4);
  234.     value1 = NIL; mv_count=1; # NIL als Wert
  235.   }
  236.  
  237. # Startet den normalen Driver (Read-Eval-Print-Loop)
  238. # driver();
  239.   global void driver (void);
  240.   global void driver()
  241.     { loop
  242.         { var reg1 object driverfun = Symbol_value(S(driverstern)); # Wert von *DRIVER*
  243.           if (nullp(driverfun)) break;
  244.           funcall(driverfun,0); # mit 0 Argumenten aufrufen
  245.         }
  246.       # Default-Driver:
  247.       Symbol_value(S(break_count)) = Fixnum_0; # SYS::*BREAK-COUNT* := 0
  248.       # dann einen Driver-Frame aufbauen:
  249.       { var reg1 object* top_of_frame = STACK; # Pointer ⁿbern Frame
  250.         var DRIVER_frame_data returner_and_data; # Rⁿcksprungpunkt merken
  251.         #ifdef HAVE_NUM_STACK
  252.         returner_and_data.old_NUM_STACK_normal = NUM_STACK_normal;
  253.         #endif
  254.         finish_entry_frame(DRIVER,&!returner_and_data.returner,,;);
  255.       }
  256.       # Hier ist der Einsprungpunkt.
  257.       loop
  258.         { # (SYS::READ-EVAL-PRINT "> ") ausfⁿhren:
  259.           pushSTACK(O(prompt_string)); # Prompt "> "
  260.           funcall(L(read_eval_print),1);
  261.           if (eq(value1,T)) break; # EOF gelesen -> Schleife beenden
  262.         }
  263.       skipSTACK(2); # Driver-Frame aufl÷sen
  264.     }
  265.  
  266. # Startet einen untergeordneten Driver (Read-Eval-Print-Loop)
  267. # break_driver(continuable);
  268. # > continuable: Flag, ob nach Beendigung des Drivers fortgefahren werden kann.
  269. # kann GC ausl÷sen
  270.   global void break_driver (object continuable);
  271.   global void break_driver(continuable)
  272.     var reg3 object continuable;
  273.     { pushSTACK(continuable);
  274.      {var reg4 object driverfun = Symbol_value(S(break_driver)); # Wert von *BREAK-DRIVER*
  275.       if (!nullp(driverfun))
  276.         {
  277.           #ifdef HAVE_NUM_STACK
  278.           var reg2 uintD* old_NUM_STACK = NUM_STACK;
  279.           var reg1 uintD* old_NUM_STACK_normal = NUM_STACK_normal;
  280.           #endif
  281.           pushSTACK(STACK_0); funcall(driverfun,1); # mit Argument continuable aufrufen
  282.           if (nullp(popSTACK())) # nicht continuable?
  283.             { reset(); } # -> dann zur nΣchsten Schleife zurⁿck
  284.           #ifdef HAVE_NUM_STACK
  285.           NUM_STACK = old_NUM_STACK;
  286.           NUM_STACK_normal = old_NUM_STACK_normal;
  287.           #endif
  288.         }
  289.         else
  290.         { # Default-Driver:
  291.           # (CLEAR-INPUT *DEBUG-IO*) ausfⁿhren (weil das, was der Benutzer bisher
  292.           # getippt hat, sicher nicht in Erwartung des Errors getippt wurde):
  293.           clear_input(var_stream(S(debug_io)));
  294.           # SYS::*BREAK-COUNT* erh÷hen:
  295.           dynamic_bind(S(break_count),fixnum_inc(Symbol_value(S(break_count)),1));
  296.           if (!mposfixnump(Symbol_value(S(break_count)))) # sollte ein Fixnum >=0 sein
  297.             { Symbol_value(S(break_count)) = Fixnum_0; } # sonst Notkorrektur
  298.           # *STANDARD-INPUT* und *STANDARD-OUTPUT* an *DEBUG-IO* binden:
  299.           {var reg1 object stream = var_stream(S(debug_io));
  300.            dynamic_bind(S(standard_input),stream);
  301.            dynamic_bind(S(standard_output),stream);
  302.           }
  303.           # *PRINT-ESCAPE* an T binden:
  304.           dynamic_bind(S(print_escape),T);
  305.           # Prompt aufbauen:
  306.           { # (format nil "~S. Break> " SYS::*BREAK-COUNT*)
  307.             #   ==
  308.             # (with-output-to-string (s)
  309.             #   (prin1 SYS::*BREAK-COUNT* s) (write-string ". Break> " s)
  310.             # )
  311.             #   ==
  312.             # (let ((s (make-string-output-stream)))
  313.             #   (prin1 SYS::*BREAK-COUNT* s) (write-string ". Break> " s)
  314.             #   (get-output-stream-string s)
  315.             # )
  316.             pushSTACK(make_string_output_stream());
  317.             prin1(&STACK_0,Symbol_value(S(break_count)));
  318.             write_sstring(&STACK_0,O(breakprompt_string));
  319.             STACK_0 = get_output_stream_string(&STACK_0);
  320.           }
  321.           # Driver-Frame aufbauen:
  322.          {var reg1 object* top_of_frame = STACK; # Pointer ⁿbern Frame
  323.           var DRIVER_frame_data returner_and_data; # Rⁿcksprungpunkt merken
  324.           #ifdef HAVE_NUM_STACK
  325.           var reg2 uintD* old_NUM_STACK = NUM_STACK;
  326.           returner_and_data.old_NUM_STACK_normal = NUM_STACK_normal;
  327.           #endif
  328.           finish_entry_frame(DRIVER,&!returner_and_data.returner,,;);
  329.           # Hier ist der Einsprungpunkt.
  330.           #ifdef HAVE_NUM_STACK
  331.           NUM_STACK_normal = old_NUM_STACK;
  332.           #endif
  333.           loop
  334.             { # (SYS::READ-EVAL-PRINT Prompt) ausfⁿhren:
  335.               pushSTACK(STACK_(0+2)); # Prompt "nnn. Break> "
  336.               funcall(L(read_eval_print),1);
  337.               if (eq(value1,T)) break; # EOF gelesen -> Schleife beenden
  338.             }
  339.           if (nullp(STACK_(0+4*3+1+2))) # nicht continuable?
  340.             { unwind(); reset(); } # -> dann zur nΣchsten Schleife zurⁿck
  341.           #ifdef HAVE_NUM_STACK
  342.           NUM_STACK = old_NUM_STACK;
  343.           NUM_STACK_normal = returner_and_data.old_NUM_STACK_normal;
  344.           #endif
  345.           skipSTACK(1+2); # Driver-Frame aufl÷sen, Prompt vergessen
  346.           dynamic_unbind(); dynamic_unbind(); dynamic_unbind(); dynamic_unbind();
  347.           skipSTACK(1);
  348.     }}  }}
  349.  
  350. LISPFUNN(load,1)
  351. # (LOAD filename), primitivere Version als in CLTL S. 426
  352.   # Methode:
  353.   # (defun load (filename)
  354.   #   (let ((stream (open filename))
  355.   #         (end-of-file "EOF")) ; einmaliges Objekt
  356.   #     (loop
  357.   #       (let ((obj (read stream nil end-of-file)))
  358.   #         (when (eql obj end-of-file) (return))
  359.   #         (if (compiled-function-p obj) (funcall obj) (eval obj))
  360.   #     ) )
  361.   #     (close stream)
  362.   #     t
  363.   # ) )
  364.   { funcall(L(open),1); # (OPEN filename)
  365.     pushSTACK(value1); # stream retten
  366.     loop
  367.       { var reg1 object obj = read(&STACK_0,NIL,NIL); # Objekt lesen
  368.         if (eq(obj,eof_value)) break; # EOF -> fertig
  369.         if (closurep(obj))
  370.           { funcall(obj,0); } # Closure (vermutlich compilierte Closure) aufrufen
  371.           else
  372.           { eval_noenv(obj); } # sonstige Form evaluieren
  373.       }
  374.     stream_close(&STACK_0); # stream schlie▀en
  375.     skipSTACK(1); value1 = T; mv_count=1; # Wert T
  376.   }
  377.  
  378. # ---------------------------------------------------------------------------- #
  379. #                   Hilfsfunktionen fⁿr Debugger und Stepper
  380.  
  381. # Die folgenden Funktionen klettern im Stack herum, ⁿberschreiten jedoch
  382. # keinen Driver-Frame und auch nicht das obere Stackende.
  383. # Gⁿltige "Stackpointer" sind hierbei Pointer auf Stackelemente oder
  384. # Frames, wo nicht das Stackende und auch kein Driver-Frame ist.
  385. # Modus 1: alle Stackitems
  386. # Modus 2: Frames
  387. # Modus 3: lexikalische Frames: Frame-Info hat FRAME_BIT = 1 und
  388. #          (SKIP2_BIT = 1 oder ENTRYPOINT_BIT = 0 oder BLOCKGO_BIT = 1)
  389. # Modus 4: EVAL- und APPLY-Frames: Frame-Info = [TRAPPED_]EVAL/APPLY_FRAME_INFO
  390. # Modus 5: APPLY-Frames: Frame-Info = [TRAPPED_]APPLY_FRAME_INFO
  391.  
  392. # Macro: Testet, ob FRAME ein Stackende erreicht hat.
  393. #define stack_upend_p()  \
  394.   (   eq(FRAME_(0),nullobj) # Nullword = oberes Stackende                    \
  395.    || (mtypecode(FRAME_(0)) == DRIVER_frame_info) # Driver-Frame = Stackende \
  396.    || ((mtypecode(Symbol_value(S(frame_limit2))) == system_type)             \
  397.        && (uTheFramepointer(Symbol_value(S(frame_limit2))) cmpSTACKop FRAME) # FRAME > *frame-limit2* ? \
  398.   )   )
  399. #define stack_downend_p()  \
  400.   (   (mtypecode(FRAME_(0)) == DRIVER_frame_info) # Driver-Frame = Stackende \
  401.    || ((mtypecode(Symbol_value(S(frame_limit1))) == system_type)             \
  402.        && (FRAME cmpSTACKop uTheFramepointer(Symbol_value(S(frame_limit1)))) # FRAME < *frame-limit1* ? \
  403.   )   )
  404.  
  405. # Macro: Testet, ob FRAME auf einen Frame zeigt.
  406. # in erster NΣherung:
  407. # #define frame_p()  (!( (as_oint(FRAME_(0)) & wbit(frame_bit_o)) ==0))
  408. # in zweiter NΣherung, unter Berⁿcksichtigung der Frames mit Skip2-bit:
  409.   #define frame_p()  framep(FRAME)
  410.   local boolean framep (object* FRAME);
  411.   local boolean framep(FRAME)
  412.     var reg1 object* FRAME;
  413.     { # Ein normales Lisp-Objekt ist kein Frame:
  414.       if ((as_oint(FRAME_(0)) & wbit(frame_bit_o)) ==0) return FALSE;
  415.       # Beginnt bei FRAME_(-1) ein Frame ohne Skip2-Bit, so ist FRAME_(0)
  416.       # Teil dieses Frames, also nicht selber Beginn eines Frames:
  417.       if (   (!(FRAME==STACK)) # nicht die STACK-Grenzen ⁿberschreiten!
  418.           && ((as_oint(FRAME_(-1)) & wbit(skip2_bit_o)) == 0)
  419.           && framep(FRAME STACKop -1)
  420.          )
  421.         return FALSE;
  422.       return TRUE; # Sonst beginnt hier ein Frame.
  423.     }
  424.  
  425. # Macro: Erniedrigt FRAME bis zum nΣchsten Frame.
  426. #define next_frame_down()  do { FRAME skipSTACKop -1; } until (frame_p());
  427.  
  428. # Macro: Testet, ob der Frame bei FRAME ein lexikalischer Frame ist.
  429. #ifdef entrypoint_bit_t
  430. #define lexical_frame_p()  \
  431.   (   (!( (as_oint(FRAME_(0)) & wbit(skip2_bit_o)) ==0))   \
  432.    || ( (as_oint(FRAME_(0)) & wbit(entrypoint_bit_o)) ==0) \
  433.    || (!( (as_oint(FRAME_(0)) & wbit(blockgo_bit_o)) ==0)) \
  434.   )
  435. #else
  436. #define lexical_frame_p()  \
  437.   (/* (!( (as_oint(FRAME_(0)) & wbit(skip2_bit_o)) ==0))   \
  438.    || */ (mtypecode(FRAME_(0)) >= entrypoint_limit_t)      \
  439.    || (!( (as_oint(FRAME_(0)) & wbit(blockgo_bit_o)) ==0)) \
  440.   )
  441. #endif
  442.  
  443. # Macro: Testet, ob der Frame bei FRAME ein EVAL/APPLY-Frame ist.
  444. #define evalapply_frame_p()  \
  445.   ((mtypecode(FRAME_(0)) & ~(bit(eval_bit_t)|bit(trapped_bit_t))) == \
  446.    ((EVAL_frame_info|APPLY_frame_info) & ~(bit(eval_bit_t)|bit(trapped_bit_t))))
  447.  
  448. # Macro: Testet, ob der Frame bei FRAME ein APPLY-Frame ist.
  449. #define apply_frame_p()  \
  450.   ((mtypecode(FRAME_(0)) & ~bit(trapped_bit_t)) == (APPLY_frame_info & ~bit(trapped_bit_t)))
  451.  
  452. # UP: ⁿberspringt ein Stackitem nach oben
  453.   local object* frame_up_1 (object* stackptr);
  454.   local object* frame_up_1(stackptr)
  455.     var reg2 object* stackptr;
  456.     { var reg1 object* FRAME = stackptr;
  457.       if (frame_p())
  458.         { FRAME = topofframe(FRAME_(0)); } # Pointer ⁿbern Frame
  459.         else
  460.         { FRAME skipSTACKop 1; } # Pointer aufs nΣchste Objekt
  461.       return (stack_upend_p() ? stackptr : FRAME);
  462.     }
  463.  
  464. # UP: ⁿberspringt ein Stackitem nach unten
  465.   local object* frame_down_1 (object* stackptr);
  466.   local object* frame_down_1(stackptr)
  467.     var reg2 object* stackptr;
  468.     { var reg1 object* FRAME = stackptr;
  469.       next_frame_down(); # nΣchsten Frame drunter suchen
  470.       if (!(topofframe(FRAME_(0)) == stackptr)) # nicht direkt unterhalb stackptr?
  471.         { FRAME = stackptr STACKop -1; }
  472.       return (stack_downend_p() ? stackptr : FRAME);
  473.     }
  474.  
  475. # UP: springt zum nΣchsth÷heren Frame
  476.   local object* frame_up_2 (object* stackptr);
  477.   local object* frame_up_2(stackptr)
  478.     var reg2 object* stackptr;
  479.     { var reg1 object* FRAME = stackptr;
  480.       if (frame_p())
  481.         { FRAME = topofframe(FRAME_(0)); } # Pointer ⁿbern Frame
  482.         else
  483.         { FRAME skipSTACKop 1; } # Pointer aufs nΣchste Objekt
  484.       loop
  485.         { if (stack_upend_p()) return stackptr;
  486.           if (as_oint(FRAME_(0)) & wbit(frame_bit_o)) return FRAME;
  487.           FRAME skipSTACKop 1;
  488.         }
  489.     }
  490.  
  491. # UP: springt zum nΣchstniedrigeren Frame
  492.   local object* frame_down_2 (object* stackptr);
  493.   local object* frame_down_2(stackptr)
  494.     var reg2 object* stackptr;
  495.     { var reg1 object* FRAME = stackptr;
  496.       next_frame_down(); # nΣchsten Frame drunter suchen
  497.       return (stack_downend_p() ? stackptr : FRAME);
  498.     }
  499.  
  500. # UP: springt zum nΣchsth÷heren lexikalischen Frame
  501.   local object* frame_up_3 (object* stackptr);
  502.   local object* frame_up_3(stackptr)
  503.     var reg2 object* stackptr;
  504.     { var reg1 object* FRAME = stackptr;
  505.       if (frame_p())
  506.         { FRAME = topofframe(FRAME_(0)); } # Pointer ⁿbern Frame
  507.         else
  508.         { FRAME skipSTACKop 1; } # Pointer aufs nΣchste Objekt
  509.       loop
  510.         { if (stack_upend_p()) return stackptr;
  511.           if (frame_p())
  512.             { if (lexical_frame_p())
  513.                 { return FRAME; }
  514.                 else
  515.                 { FRAME = topofframe(FRAME_(0)); } # Pointer ⁿbern Frame
  516.             }
  517.             else
  518.             { FRAME skipSTACKop 1; }
  519.         }
  520.     }
  521.  
  522. # UP: springt zum nΣchstniedrigeren lexikalischen Frame
  523.   local object* frame_down_3 (object* stackptr);
  524.   local object* frame_down_3(stackptr)
  525.     var reg2 object* stackptr;
  526.     { var reg1 object* FRAME = stackptr;
  527.       loop
  528.         { next_frame_down(); # nΣchsten Frame drunter suchen
  529.           if (stack_downend_p()) return stackptr;
  530.           if (lexical_frame_p()) break;
  531.         }
  532.       return FRAME;
  533.     }
  534.  
  535. # UP: springt zum nΣchsth÷heren EVAL/APPLY-Frame
  536.   local object* frame_up_4 (object* stackptr);
  537.   local object* frame_up_4(stackptr)
  538.     var reg2 object* stackptr;
  539.     { var reg1 object* FRAME = stackptr;
  540.       if (frame_p())
  541.         { FRAME = topofframe(FRAME_(0)); } # Pointer ⁿbern Frame
  542.         else
  543.         { FRAME skipSTACKop 1; } # Pointer aufs nΣchste Objekt
  544.       loop
  545.         { if (stack_upend_p()) return stackptr;
  546.           if (frame_p())
  547.             { if (evalapply_frame_p())
  548.                 { return FRAME; }
  549.                 else
  550.                 { FRAME = topofframe(FRAME_(0)); } # Pointer ⁿbern Frame
  551.             }
  552.             else
  553.             { FRAME skipSTACKop 1; }
  554.         }
  555.     }
  556.  
  557. # UP: springt zum nΣchstniedrigeren EVAL/APPLY-Frame
  558.   local object* frame_down_4 (object* stackptr);
  559.   local object* frame_down_4(stackptr)
  560.     var reg2 object* stackptr;
  561.     { var reg1 object* FRAME = stackptr;
  562.       loop
  563.         { next_frame_down(); # nΣchsten Frame drunter suchen
  564.           if (stack_downend_p()) return stackptr;
  565.           if (evalapply_frame_p()) break;
  566.         }
  567.       return FRAME;
  568.     }
  569.  
  570. # UP: springt zum nΣchsth÷heren APPLY-Frame
  571.   local object* frame_up_5 (object* stackptr);
  572.   local object* frame_up_5(stackptr)
  573.     var reg2 object* stackptr;
  574.     { var reg1 object* FRAME = stackptr;
  575.       if (frame_p())
  576.         { FRAME = topofframe(FRAME_(0)); } # Pointer ⁿbern Frame
  577.         else
  578.         { FRAME skipSTACKop 1; } # Pointer aufs nΣchste Objekt
  579.       loop
  580.         { if (stack_upend_p()) return stackptr;
  581.           if (frame_p())
  582.             { if (apply_frame_p())
  583.                 { return FRAME; }
  584.                 else
  585.                 { FRAME = topofframe(FRAME_(0)); } # Pointer ⁿbern Frame
  586.             }
  587.             else
  588.             { FRAME skipSTACKop 1; }
  589.         }
  590.     }
  591.  
  592. # UP: springt zum nΣchstniedrigeren APPLY-Frame
  593.   local object* frame_down_5 (object* stackptr);
  594.   local object* frame_down_5(stackptr)
  595.     var reg2 object* stackptr;
  596.     { var reg1 object* FRAME = stackptr;
  597.       loop
  598.         { next_frame_down(); # nΣchsten Frame drunter suchen
  599.           if (stack_downend_p()) return stackptr;
  600.           if (apply_frame_p()) break;
  601.         }
  602.       return FRAME;
  603.     }
  604.  
  605. # Typ eines Pointers auf eine Hochsteige- bzw. Absteige-Routine:
  606.   typedef object* (*kletterfun) (object* stackptr);
  607.  
  608. local kletterfun frame_up_table[] =
  609.   { &frame_up_1, &frame_up_2, &frame_up_3, &frame_up_4, &frame_up_5, };
  610. local kletterfun frame_down_table[] =
  611.   { &frame_down_1, &frame_down_2, &frame_down_3, &frame_down_4, &frame_down_5, };
  612.  
  613. # UP: ▄berprⁿft und decodiert das mode-Argument.
  614. # test_mode_arg(table)
  615. # > STACK_0: mode
  616. # > table: Tabelle der Routinen zum Hochsteigen bzw. zum Absteigen
  617. # > subr_self: Aufrufer (ein SUBR)
  618. # < ergebnis: Routine zum Hochsteigen bzw. zum Absteigen
  619. # erh÷ht STACK um 1
  620.   local kletterfun test_mode_arg (kletterfun* table);
  621.   local kletterfun test_mode_arg(table)
  622.     var reg3 kletterfun* table;
  623.     { var reg1 object arg = popSTACK();
  624.       var reg2 uintL mode;
  625.       if (!(posfixnump(arg)
  626.             && ((mode = posfixnum_to_L(arg)) > 0)
  627.             && (mode<=5)
  628.          ) )
  629.         { pushSTACK(arg); # Wert fⁿr Slot DATUM von TYPE-ERROR
  630.           pushSTACK(O(type_climb_mode)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  631.           pushSTACK(arg);
  632.           pushSTACK(TheSubr(subr_self)->name);
  633.           fehler(type_error,
  634.                  DEUTSCH ? "~: Ungⁿltiger Frame-Kletter-Modus ~" :
  635.                  ENGLISH ? "~: bad frame climbing mode ~" :
  636.                  FRANCAIS ? "~: Mauvais mode de saut d'environnement ~." :
  637.                  ""
  638.                 );
  639.         }
  640.       return table[mode-1];
  641.     }
  642.  
  643. # UP: ▄berprⁿft ein Frame-Pointer-Argument.
  644. # test_framepointer_arg()
  645. # > STACK_0: Lisp-Objekt, sollte ein Frame-Pointer sein
  646. # > subr_self: Aufrufer (ein SUBR)
  647. # < ergebnis: Frame-Pointer
  648. # erh÷ht STACK um 1
  649.   local object* test_framepointer_arg (void);
  650.   local object* test_framepointer_arg()
  651.     { var reg1 object arg = popSTACK();
  652.       if (!(stack_env_p(arg)))
  653.         { pushSTACK(arg);
  654.           pushSTACK(TheSubr(subr_self)->name);
  655.           fehler(error,
  656.                  DEUTSCH ? "~: ~ ist kein Stackpointer." :
  657.                  ENGLISH ? "~: ~ is not a stack pointer" :
  658.                  FRANCAIS ? "~: ~ n'est pas un pointeur de pile." :
  659.                  ""
  660.                 );
  661.         }
  662.       return uTheFramepointer(arg);
  663.     }
  664.  
  665. LISPFUNN(frame_up_1,2)
  666. # (SYS::FRAME-UP-1 framepointer mode) liefert den Frame-Pointer 1 h÷her.
  667.   { var reg2 kletterfun frame_up_x = test_mode_arg(&frame_up_table[0]);
  668.     var reg1 object* stackptr = test_framepointer_arg();
  669.     stackptr = (*frame_up_x)(stackptr); # einmal hochsteigen
  670.     value1 = make_framepointer(stackptr); mv_count=1;
  671.   }
  672.  
  673. LISPFUNN(frame_up,2)
  674. # (SYS::FRAME-UP framepointer mode) liefert den Frame-Pointer ganz oben.
  675.   { var reg2 kletterfun frame_up_x = test_mode_arg(&frame_up_table[0]);
  676.     var reg1 object* stackptr = test_framepointer_arg();
  677.     # hochsteigen, bis es nicht mehr weiter geht:
  678.     loop
  679.       { var reg3 object* next_stackptr = (*frame_up_x)(stackptr);
  680.         if (next_stackptr == stackptr) break;
  681.         stackptr = next_stackptr;
  682.       }
  683.     value1 = make_framepointer(stackptr); mv_count=1;
  684.   }
  685.  
  686. LISPFUNN(frame_down_1,2)
  687. # (SYS::FRAME-DOWN-1 framepointer mode) liefert den Frame-Pointer 1 drunter.
  688.   { var reg2 kletterfun frame_down_x = test_mode_arg(&frame_down_table[0]);
  689.     var reg1 object* stackptr = test_framepointer_arg();
  690.     stackptr = (*frame_down_x)(stackptr); # einmal hinabsteigen
  691.     value1 = make_framepointer(stackptr); mv_count=1;
  692.   }
  693.  
  694. LISPFUNN(frame_down,2)
  695. # (SYS::FRAME-DOWN framepointer mode) liefert den Frame-Pointer ganz unten.
  696.   { var reg2 kletterfun frame_down_x = test_mode_arg(&frame_down_table[0]);
  697.     var reg1 object* stackptr = test_framepointer_arg();
  698.     # hinabsteigen, bis es nicht mehr weiter geht:
  699.     loop
  700.       { var reg3 object* next_stackptr = (*frame_down_x)(stackptr);
  701.         if (next_stackptr == stackptr) break;
  702.         stackptr = next_stackptr;
  703.       }
  704.     value1 = make_framepointer(stackptr); mv_count=1;
  705.   }
  706.  
  707. LISPFUNN(the_frame,0)
  708. # (SYS::THE-FRAME) liefert den aktuellen Stackpointer als Frame-Pointer.
  709.   { var reg1 object* stackptr = STACK;
  710.     stackptr = frame_up_2(stackptr); # bis zum nΣchsth÷heren Frame hoch
  711.     value1 = make_framepointer(stackptr); mv_count=1;
  712.   }
  713.  
  714. # UP: aktiviert dasselbe lexikalische Environment, das beim Framepointer
  715. # STACK_0 aktiv war.
  716. # same_env_as();
  717. # erh÷ht STACK um 1, baut auf dem STACK einen ENV5-Frame auf
  718.   local void same_env_as (void);
  719.   local void same_env_as()
  720.     { var reg1 object* FRAME = test_framepointer_arg();
  721.       var environment env;
  722.       # 5 Environments noch "leer":
  723.       env.var_env = nullobj;
  724.       env.fun_env = nullobj;
  725.       env.block_env = nullobj;
  726.       env.go_env = nullobj;
  727.       env.decl_env = nullobj;
  728.       # und fⁿllen:
  729.       loop
  730.         { # ab FRAME abwΣrts nach ENV-Frames suchen:
  731.           loop
  732.             { FRAME skipSTACKop -1;
  733.               if (FRAME==STACK) goto end; # Stack zu Ende?
  734.               if (frame_p()
  735.                   && (!( (as_oint(FRAME_(0)) & wbit(skip2_bit_o)) ==0))
  736.                   && (!( (as_oint(FRAME_(0)) & wbit(envbind_bit_o)) ==0))
  737.                  )
  738.                 break;
  739.             }
  740.           # NΣchster ENV-Frame gefunden.
  741.           # Sein Inhalt fⁿllt die noch leeren Komponenten von env:
  742.           switch (mtypecode(FRAME_(0)) & envbind_case_mask_t)
  743.             { case (ENV1V_frame_info & envbind_case_mask_t): # 1 VAR_ENV
  744.                 if (eq(env.var_env,nullobj)) { env.var_env = FRAME_(1); }
  745.                 break;
  746.               case (ENV1F_frame_info & envbind_case_mask_t): # 1 FUN_ENV
  747.                 if (eq(env.fun_env,nullobj)) { env.fun_env = FRAME_(1); }
  748.                 break;
  749.               case (ENV1B_frame_info & envbind_case_mask_t): # 1 BLOCK_ENV
  750.                 if (eq(env.block_env,nullobj)) { env.block_env = FRAME_(1); }
  751.                 break;
  752.               case (ENV1G_frame_info & envbind_case_mask_t): # 1 GO_ENV
  753.                 if (eq(env.go_env,nullobj)) { env.go_env = FRAME_(1); }
  754.                 break;
  755.               case (ENV1D_frame_info & envbind_case_mask_t): # 1 DECL_ENV
  756.                 if (eq(env.decl_env,nullobj)) { env.decl_env = FRAME_(1); }
  757.                 break;
  758.               case (ENV2VD_frame_info & envbind_case_mask_t): # 1 VAR_ENV und 1 DECL_ENV
  759.                 if (eq(env.var_env,nullobj)) { env.var_env = FRAME_(1); }
  760.                 if (eq(env.decl_env,nullobj)) { env.decl_env = FRAME_(2); }
  761.                 break;
  762.               case (ENV5_frame_info & envbind_case_mask_t): # alle 5 Environments
  763.                 if (eq(env.var_env,nullobj)) { env.var_env = FRAME_(1); }
  764.                 if (eq(env.fun_env,nullobj)) { env.fun_env = FRAME_(2); }
  765.                 if (eq(env.block_env,nullobj)) { env.block_env = FRAME_(3); }
  766.                 if (eq(env.go_env,nullobj)) { env.go_env = FRAME_(4); }
  767.                 if (eq(env.decl_env,nullobj)) { env.decl_env = FRAME_(5); }
  768.                 break;
  769.               default: NOTREACHED
  770.             }
  771.           # Falls alle einzelnen Environments von env gefⁿllt (/=nullobj) sind,
  772.           # ist das Environment fertig:
  773.           if (   (!eq(env.var_env,nullobj))
  774.               && (!eq(env.fun_env,nullobj))
  775.               && (!eq(env.block_env,nullobj))
  776.               && (!eq(env.go_env,nullobj))
  777.               && (!eq(env.decl_env,nullobj))
  778.              )
  779.             goto fertig;
  780.         }
  781.       end: # Stack zu Ende.
  782.       # Hole restliche Environment-Komponenten aus dem aktuellen Environment:
  783.       if (eq(env.var_env,nullobj)) { env.var_env = aktenv.var_env; }
  784.       if (eq(env.fun_env,nullobj)) { env.fun_env = aktenv.fun_env; }
  785.       if (eq(env.block_env,nullobj)) { env.block_env = aktenv.block_env; }
  786.       if (eq(env.go_env,nullobj)) { env.go_env = aktenv.go_env; }
  787.       if (eq(env.decl_env,nullobj)) { env.decl_env = aktenv.decl_env; }
  788.       fertig: # env fertig.
  789.       # Environment-Frame aufbauen:
  790.       make_ENV5_frame();
  791.       # aktuelle Environments setzen:
  792.       aktenv = env;
  793.     }
  794.  
  795. LISPFUNN(same_env_as,2)
  796. # (SYS::SAME-ENV-AS framepointer fun) aktiviert dasselbe lexikalische
  797. # Environment, das bei framepointer aktiv war, und ruft dann fun auf.
  798.   { var reg1 object fun = popSTACK();
  799.     same_env_as(); # Environment von framepointer aktivieren
  800.     funcall(fun,0); # fun aufrufen
  801.     unwind(); # Environment-Frame aufl÷sen
  802.   }
  803.  
  804. LISPFUNN(eval_at,2)
  805. # (SYS::EVAL-AT framepointer form) aktiviert dasselbe lexikalische
  806. # Environment, das bei framepointer aktiv war, und wertet darin die Form aus.
  807.   { var reg1 object form = popSTACK();
  808.     same_env_as(); # Environment von framepointer aktivieren
  809.     eval(form); # form auswerten
  810.     unwind(); # Environment-Frame aufl÷sen
  811.   }
  812.  
  813. LISPFUNN(eval_frame_p,1)
  814. # (SYS::EVAL-FRAME-P framepointer)
  815. # gibt an, ob framepointer auf einen EVAL/APPLY-Frame zeigt.
  816.   { var reg1 object* FRAME = test_framepointer_arg();
  817.     value1 = (evalapply_frame_p() ? T : NIL); mv_count=1;
  818.   }
  819.  
  820. LISPFUNN(driver_frame_p,1)
  821. # (SYS::DRIVER-FRAME-P framepointer)
  822. # gibt an, ob framepointer auf einen Driver-Frame zeigt.
  823.   { var reg1 object* FRAME = test_framepointer_arg();
  824.     value1 = (mtypecode(FRAME_(0)) == DRIVER_frame_info ? T : NIL); mv_count=1;
  825.   }
  826.  
  827. # Fehlermeldung, wenn kein EVAL/APPLY-Frame-Pointer vorliegt.
  828. # fehler_evalframe(obj);
  829. # > subr_self: Aufrufer (ein SUBR)
  830. # > obj: kein EVAL/APPLY-Frame-Pointer
  831.   nonreturning_function(local, fehler_evalframe, (object obj));
  832.   local void fehler_evalframe(obj)
  833.     var reg1 object obj;
  834.     { pushSTACK(obj);
  835.       pushSTACK(TheSubr(subr_self)->name);
  836.       fehler(error,
  837.              DEUTSCH ? "~: ~ ist kein Pointer auf einen EVAL/APPLY-Frame." :
  838.              ENGLISH ? "~: ~ is not a pointer to an EVAL/APPLY frame" :
  839.              FRANCAIS ? "~: ~ n'est pas une pointeur vers un environnement EVAL/APPLY." :
  840.              ""
  841.             );
  842.     }
  843.  
  844. LISPFUNN(trap_eval_frame,2)
  845. # (SYS::TRAP-EVAL-FRAME framepointer flag) schaltet den Breakpoint am
  846. # angegebenen EVAL/APPLY-Frame je nach flag an bzw. aus.
  847.   { var reg3 object flag = popSTACK();
  848.     var reg2 object frame = popSTACK();
  849.     if (!stack_env_p(frame)) { fehler_evalframe(frame); }
  850.    {var reg1 object* FRAME = uTheFramepointer(frame);
  851.     if (!evalapply_frame_p()) { fehler_evalframe(frame); }
  852.     # FRAME zeigt auf den EVAL/APPLY-Frame.
  853.     if (!nullp(flag))
  854.       # Breakpoint einschalten
  855.       { *(oint*)(&FRAME_(0)) |= wbit(trapped_bit_o); }
  856.       else
  857.       # Breakpoint ausschalten
  858.       { *(oint*)(&FRAME_(0)) &= ~wbit(trapped_bit_o); }
  859.     value1 = frame; mv_count=1; # framepointer als Wert
  860.   }}
  861.  
  862. LISPFUNN(redo_eval_frame,1)
  863. # (SYS::REDO-EVAL-FRAME framepointer) unwindet bis zum angegebenen
  864. # EVAL/APPLY-Frame und fΣngt erneut an, diesen abzuarbeiten.
  865.   { var reg2 object frame = popSTACK();
  866.     if (!stack_env_p(frame)) { fehler_evalframe(frame); }
  867.    {var reg1 object* FRAME = uTheFramepointer(frame);
  868.     if (!evalapply_frame_p()) { fehler_evalframe(frame); }
  869.     # FRAME zeigt auf den EVAL/APPLY-Frame.
  870.     value1 = NIL; mv_count=0; # keine Werte zu retten
  871.     unwind_upto(FRAME); # bis zum EVAL/APPLY-Frame alles aufl÷sen, dorthin springen
  872.   }}
  873.  
  874. LISPFUNN(return_from_eval_frame,2)
  875. # (SYS::RETURN-FROM-EVAL-FRAME framepointer form)
  876. # unwindet bis zum angegebenen EVAL/APPLY-Frame und gibt als dessen Werte die
  877. # Werte der Evaluierung der angegebenen form zurⁿck.
  878.   { var reg3 object form = popSTACK();
  879.     var reg2 object frame = popSTACK();
  880.     if (!stack_env_p(frame)) { fehler_evalframe(frame); }
  881.    {var reg1 object* FRAME = uTheFramepointer(frame);
  882.     if (!evalapply_frame_p()) { fehler_evalframe(frame); }
  883.     # FRAME zeigt auf den EVAL/APPLY-Frame.
  884.     value1 = form; mv_count=1; # form retten und ⁿbergeben
  885.     unwind_upto(FRAME); # bis zum EVAL/APPLY-Frame alles aufl÷sen, dorthin springen
  886.   }}
  887.  
  888. # ---------------------------------------------------------------------------- #
  889. #                                 Debughilfen
  890.  
  891. # UP: Gibt das Stackitem FRAME_(0) detailliert auf den Stream aus
  892. # und liefert den nΣchsth÷heren stackptr.
  893. # print_stackitem(&stream,FRAME)
  894. # kann GC ausl÷sen
  895.   local object* print_stackitem (object* stream_, object* FRAME);
  896.   local object* print_stackitem(stream_,FRAME)
  897.     var reg2 object* stream_;
  898.     var reg1 object* FRAME;
  899.     { if (!frame_p())
  900.         # kein Frame, normales LISP-Objekt
  901.         { write_sstring(stream_,O(showstack_string_lisp_obj)); # "┐- "
  902.          {var reg3 object obj = FRAME_(0);
  903.           switch (typecode(obj)) # evtl. Symbol-Flags entfernen
  904.             { case_symbolflagged: obj = symbol_without_flags(obj);
  905.               default: break;
  906.             }
  907.           prin1(stream_,obj); # LISP-Objekt ausgeben
  908.           return FRAME STACKop 1;
  909.         }}
  910.         else
  911.         # Frame angetroffen
  912.         { var reg6 object* FRAME_top = topofframe(FRAME_(0)); # Pointer ⁿbern Frame
  913.           switch (mtypecode(FRAME_(0))) # je nach Frametyp
  914.             { case TRAPPED_APPLY_frame_info:
  915.                 # getrapte APPLY-Frames:
  916.                 write_sstring(stream_,OL(showstack_string_TRAPPED_APPLY_frame)); # "┐APPLY-Frame mit Breakpoint fⁿr Aufruf "
  917.                 goto APPLY_frame;
  918.               case APPLY_frame_info:
  919.                 # APPLY-Frames:
  920.                 write_sstring(stream_,OL(showstack_string_APPLY_frame)); # "┐APPLY-Frame fⁿr Aufruf "
  921.               APPLY_frame:
  922.                 # Funktionsnamen und Argumente ausgeben:
  923.                 write_schar(stream_,'('); # '(' ausgeben
  924.                 prin1(stream_,TheIclosure(FRAME_(frame_closure))->clos_name); # Namen ausgeben
  925.                 { var reg3 object* argptr = FRAME_top;
  926.                   var reg4 uintL count = STACK_item_count(FRAME STACKop frame_args,FRAME_top);
  927.                   dotimesL(count,count,
  928.                     { write_schar(stream_,' '); # ' ' ausgeben
  929.                       write_schar(stream_,'\''); # "'" ausgeben
  930.                       prin1(stream_,NEXT(argptr)); # nΣchstes Argument ausgeben
  931.                     });
  932.                 }
  933.                 write_schar(stream_,')'); # ')' ausgeben
  934.                 break;
  935.               case TRAPPED_EVAL_frame_info:
  936.                 # getrapte EVAL-Frames:
  937.                 write_sstring(stream_,OL(showstack_string_TRAPPED_EVAL_frame)); # "┐EVAL-Frame mit Breakpoint fⁿr Form "
  938.                 goto EVAL_frame;
  939.               case EVAL_frame_info:
  940.                 # EVAL-Frames:
  941.                 write_sstring(stream_,OL(showstack_string_EVAL_frame)); # "┐EVAL-Frame fⁿr Form "
  942.               EVAL_frame:
  943.                 prin1(stream_,FRAME_(frame_form)); # Form ausgeben
  944.                 break;
  945.               case DYNBIND_frame_info:
  946.                 # dynamische Variablenbindungsframes:
  947.                 write_sstring(stream_,OL(showstack_string_DYNBIND_frame)); # "┐Variablenbindungs-Frame bindet (~ = dynamisch):"
  948.                 # Bindungen ausgeben:
  949.                 FRAME skipSTACKop 1;
  950.                 until (FRAME==FRAME_top)
  951.                   { # Bindung von Symbol FRAME_(0) an Wert FRAME_(1) ausgeben:
  952.                     write_sstring(stream_,O(showstack_string_bindung)); # "┐  | "
  953.                     write_schar(stream_,'~'); # '~' ausgeben
  954.                     write_schar(stream_,' '); # ' ' ausgeben
  955.                     prin1(stream_,FRAME_(0)); # Symbol ausgeben
  956.                     write_sstring(stream_,O(showstack_string_zuord)); # " <--> "
  957.                     prin1(stream_,FRAME_(1)); # Wert ausgeben
  958.                     FRAME skipSTACKop 2;
  959.                   }
  960.                 break;
  961.               # Variablen- und Funktionsbindungsframes:
  962.               case VAR_frame_info:
  963.                 write_sstring(stream_,OL(showstack_string_VAR_frame)); # "┐Variablenbindungs-Frame "
  964.                 #ifdef NO_symbolflags
  965.                 prin1(stream_,make_framepointer(FRAME)); # Frame-Pointer ausgeben
  966.                 write_sstring(stream_,OL(showstack_string_binds)); # " bindet (~ = dynamisch):"
  967.                 pushSTACK(FRAME_(frame_next_env)); # weiteres Environment retten
  968.                 # Bindungen ausgeben:
  969.                 FRAME skipSTACKop frame_bindings;
  970.                 until (FRAME==FRAME_top)
  971.                   { if (!( ((oint)FRAME_(varframe_binding_mark) & wbit(active_bit_o)) ==0))
  972.                       # Bindung von Symbol FRAME_(1) an Wert FRAME_(2) ausgeben:
  973.                       { write_sstring(stream_,O(showstack_string_bindung)); # "┐  | "
  974.                         if (!( ((oint)FRAME_(varframe_binding_mark) & wbit(dynam_bit_o)) ==0)) # Bindung dynamisch?
  975.                           { write_schar(stream_,'~'); } # ja -> '~' ausgeben
  976.                         write_schar(stream_,' '); # ' ' ausgeben
  977.                         prin1(stream_,symbol_without_flags(FRAME_(varframe_binding_sym))); # Symbol ausgeben
  978.                         write_sstring(stream_,O(showstack_string_zuord)); # " <--> "
  979.                         prin1(stream_,FRAME_(varframe_binding_value)); # Wert ausgeben
  980.                       }
  981.                     FRAME skipSTACKop varframe_binding_size;
  982.                   }
  983.                 goto VARFUN_frame_next;
  984.                 #else
  985.                 goto VARFUN_frame;
  986.                 #endif
  987.               case FUN_frame_info:
  988.                 write_sstring(stream_,OL(showstack_string_FUN_frame)); # "┐Funktionsbindungs-Frame "
  989.                 goto VARFUN_frame;
  990.               VARFUN_frame:
  991.                 prin1(stream_,make_framepointer(FRAME)); # Frame-Pointer ausgeben
  992.                 write_sstring(stream_,OL(showstack_string_binds)); # " bindet (~ = dynamisch):"
  993.                 pushSTACK(FRAME_(frame_next_env)); # weiteres Environment retten
  994.                 # Bindungen ausgeben:
  995.                 FRAME skipSTACKop frame_bindings;
  996.                 until (FRAME==FRAME_top)
  997.                   { if (!( (as_oint(FRAME_(0)) & wbit(active_bit_o)) ==0))
  998.                       # Bindung von Symbol FRAME_(0) an Wert FRAME_(1) ausgeben:
  999.                       { write_sstring(stream_,O(showstack_string_bindung)); # "┐  | "
  1000.                         if (!( (as_oint(FRAME_(0)) & wbit(dynam_bit_o)) ==0)) # Bindung dynamisch?
  1001.                           { write_schar(stream_,'~'); } # ja -> '~' ausgeben
  1002.                         write_schar(stream_,' '); # ' ' ausgeben
  1003.                         prin1(stream_,symbol_without_flags(FRAME_(0))); # Symbol ausgeben
  1004.                         write_sstring(stream_,O(showstack_string_zuord)); # " <--> "
  1005.                         prin1(stream_,FRAME_(1)); # Wert ausgeben
  1006.                       }
  1007.                     FRAME skipSTACKop 2;
  1008.                   }
  1009.               VARFUN_frame_next:
  1010.                 # Weiteres Environment ausgeben:
  1011.                 write_sstring(stream_,OL(showstack_string_next_env)); # "┐  Weiteres Environment: "
  1012.                 { var reg3 object env = popSTACK(); # weiteres Environment
  1013.                   if (!simple_vector_p(env))
  1014.                     { prin1(stream_,env); }
  1015.                     else
  1016.                     # weiteres Environment ist ein Vektor, der LΣnge 2n+1
  1017.                     do { pushSTACK(env);
  1018.                         {var reg5 uintL count = floor(TheSvector(env)->length,2); # = n = Bindungszahl
  1019.                          var reg4 uintL index = 0;
  1020.                          dotimesL(count,count,
  1021.                            { write_sstring(stream_,O(showstack_string_bindung)); # "┐  | "
  1022.                              prin1(stream_,TheSvector(STACK_0)->data[index++]); # Symbol ausgeben
  1023.                              write_sstring(stream_,O(showstack_string_zuord)); # " <--> "
  1024.                              prin1(stream_,TheSvector(STACK_0)->data[index++]); # Symbol ausgeben
  1025.                            });
  1026.                          env = TheSvector(popSTACK())->data[index]; # letztes Vektor-Element
  1027.                        }}
  1028.                        while (simple_vector_p(env));
  1029.                 }
  1030.                 break;
  1031.               # Interpretierte Block-Frames:
  1032.               case IBLOCK_frame_info:
  1033.                 write_sstring(stream_,OL(showstack_string_IBLOCK_frame)); # "┐Block-Frame "
  1034.                 goto IBLOCK_frame;
  1035.               case NESTED_IBLOCK_frame_info:
  1036.                 write_sstring(stream_,OL(showstack_string_NESTED_IBLOCK_frame)); # "┐Block-Frame (genestet) "
  1037.                 goto IBLOCK_frame;
  1038.               IBLOCK_frame:
  1039.                 pushSTACK(FRAME_(frame_next_env));
  1040.                 prin1(stream_,make_framepointer(FRAME)); # Frame-Pointer ausgeben
  1041.                 write_sstring(stream_,OL(showstack_string_for1)); # " fⁿr "
  1042.                 prin1(stream_,FRAME_(frame_name)); # Blockname
  1043.                 goto NEXT_ENV;
  1044.               case CBLOCK_frame_info:
  1045.                 # compilierte Block-Frames:
  1046.                 write_sstring(stream_,OL(showstack_string_CBLOCK_frame)); # "┐Block-Frame (compiliert) fⁿr "
  1047.                 prin1(stream_,FRAME_(frame_ctag)); # Blockname
  1048.                 break;
  1049.               # Interpretierte Tagbody-Frames:
  1050.               case ITAGBODY_frame_info:
  1051.                 write_sstring(stream_,OL(showstack_string_ITAGBODY_frame)); # "┐Tagbody-Frame "
  1052.                 goto ITAGBODY_frame;
  1053.               case NESTED_ITAGBODY_frame_info:
  1054.                 write_sstring(stream_,OL(showstack_string_NESTED_ITAGBODY_frame)); # "┐Tagbody-Frame (genestet) "
  1055.                 goto ITAGBODY_frame;
  1056.               ITAGBODY_frame:
  1057.                 pushSTACK(FRAME_(frame_next_env));
  1058.                 prin1(stream_,make_framepointer(FRAME)); # Frame-Pointer ausgeben
  1059.                 write_sstring(stream_,OL(showstack_string_for2)); # " fⁿr"
  1060.                 # Tags/Bodys ausgeben:
  1061.                 FRAME skipSTACKop frame_bindings;
  1062.                 until (FRAME==FRAME_top)
  1063.                   { # Bindung von Tag FRAME_(0) an Body FRAME_(1) ausgeben:
  1064.                     write_sstring(stream_,O(showstack_string_bindung)); # "┐  | "
  1065.                     prin1(stream_,FRAME_(0)); # Tag ausgeben
  1066.                     write_sstring(stream_,O(showstack_string_zuordtag)); # " --> "
  1067.                     prin1(stream_,FRAME_(1)); # Body ausgeben
  1068.                     FRAME skipSTACKop 2;
  1069.                   }
  1070.                 goto NEXT_ENV;
  1071.               NEXT_ENV: # Ausgeben eines Block- oder Tagbody-Environments STACK_0
  1072.                 write_sstring(stream_,OL(showstack_string_next_env)); # "┐  Weiteres Environment: "
  1073.                 { var reg3 object env = popSTACK();
  1074.                   if (!consp(env))
  1075.                     { prin1(stream_,env); }
  1076.                     else
  1077.                     # weiteres Environment ist eine Aliste
  1078.                     do { pushSTACK(Cdr(env));
  1079.                          env = Car(env);
  1080.                          if (atomp(env))
  1081.                            { pushSTACK(S(show_stack));
  1082.                              fehler(error,
  1083.                                     DEUTSCH ? "~: Environment ist keine Aliste" :
  1084.                                     ENGLISH ? "~: environment is not an alist" :
  1085.                                     FRANCAIS ? "~: L'environnement n'est pas une liste d'association." :
  1086.                                     ""
  1087.                                    );
  1088.                            }
  1089.                          pushSTACK(Cdr(env));
  1090.                          pushSTACK(Car(env));
  1091.                          write_sstring(stream_,O(showstack_string_bindung)); # "┐  | "
  1092.                          prin1(stream_,popSTACK());
  1093.                          write_sstring(stream_,O(showstack_string_zuordtag)); # " --> "
  1094.                          prin1(stream_,popSTACK());
  1095.                          env = popSTACK();
  1096.                        }
  1097.                        while (consp(env));
  1098.                 }
  1099.                 break;
  1100.               case CTAGBODY_frame_info:
  1101.                 # compilierte Tagbody-Frames:
  1102.                 write_sstring(stream_,OL(showstack_string_CTAGBODY_frame)); # "┐Tagbody-Frame (compiliert) fⁿr "
  1103.                 prin1(stream_,Car(FRAME_(frame_ctag))); # Tag-Vektor
  1104.                 break;
  1105.               case CATCH_frame_info:
  1106.                 # Catch-Frames:
  1107.                 write_sstring(stream_,OL(showstack_string_CATCH_frame)); # "┐Catch-Frame fⁿr Tag "
  1108.                 prin1(stream_,FRAME_(frame_tag)); # Tag
  1109.                 break;
  1110.               case HANDLER_frame_info:
  1111.                 # Handler-Frames:
  1112.                 write_sstring(stream_,OL(showstack_string_HANDLER_frame)); # "┐Handler-Frame fⁿr Conditions"
  1113.                 { var reg4 uintL m2 = TheSvector(Car(FRAME_(frame_handlers)))->length; # 2*m
  1114.                   var reg3 uintL i = 0;
  1115.                   do { write_schar(stream_,' '); # ' ' ausgeben
  1116.                        prin1(stream_,TheSvector(Car(FRAME_(frame_handlers)))->data[i]); # Typ i ausgeben
  1117.                        i += 2;
  1118.                      }
  1119.                      while (i < m2);
  1120.                 }
  1121.                 break;
  1122.               case UNWIND_PROTECT_frame_info:
  1123.                 # Unwind-Protect-Frames:
  1124.                 write_sstring(stream_,OL(showstack_string_UNWIND_PROTECT_frame)); # "┐Unwind-Protect-Frame"
  1125.                 break;
  1126.               case DRIVER_frame_info:
  1127.                 # Driver-Frames:
  1128.                 write_sstring(stream_,OL(showstack_string_DRIVER_frame)); # "┐┐Driver-Frame"
  1129.                 break;
  1130.               # Environment-Frames:
  1131.               case ENV1V_frame_info:
  1132.                 write_sstring(stream_,OL(showstack_string_ENV_frame)); # "┐Environment-Bindungs-Frame"
  1133.                 write_sstring(stream_,O(showstack_string_VENV_frame)); # "┐  VAR_ENV <--> "
  1134.                 prin1(stream_,FRAME_(1));
  1135.                 break;
  1136.               case ENV1F_frame_info:
  1137.                 write_sstring(stream_,OL(showstack_string_ENV_frame)); # "┐Environment-Bindungs-Frame"
  1138.                 write_sstring(stream_,O(showstack_string_FENV_frame)); # "┐  FUN_ENV <--> "
  1139.                 prin1(stream_,FRAME_(1));
  1140.                 break;
  1141.               case ENV1B_frame_info:
  1142.                 write_sstring(stream_,OL(showstack_string_ENV_frame)); # "┐Environment-Bindungs-Frame"
  1143.                 write_sstring(stream_,O(showstack_string_BENV_frame)); # "┐  BLOCK_ENV <--> "
  1144.                 prin1(stream_,FRAME_(1));
  1145.                 break;
  1146.               case ENV1G_frame_info:
  1147.                 write_sstring(stream_,OL(showstack_string_ENV_frame)); # "┐Environment-Bindungs-Frame"
  1148.                 write_sstring(stream_,O(showstack_string_GENV_frame)); # "┐  GO_ENV <--> "
  1149.                 prin1(stream_,FRAME_(1));
  1150.                 break;
  1151.               case ENV1D_frame_info:
  1152.                 write_sstring(stream_,OL(showstack_string_ENV_frame)); # "┐Environment-Bindungs-Frame"
  1153.                 write_sstring(stream_,O(showstack_string_DENV_frame)); # "┐  DECL_ENV <--> "
  1154.                 prin1(stream_,FRAME_(1));
  1155.                 break;
  1156.               case ENV2VD_frame_info:
  1157.                 write_sstring(stream_,OL(showstack_string_ENV_frame)); # "┐Environment-Bindungs-Frame"
  1158.                 write_sstring(stream_,O(showstack_string_VENV_frame)); # "┐  VAR_ENV <--> "
  1159.                 prin1(stream_,FRAME_(1));
  1160.                 write_sstring(stream_,O(showstack_string_DENV_frame)); # "┐  DECL_ENV <--> "
  1161.                 prin1(stream_,FRAME_(2));
  1162.                 break;
  1163.               case ENV5_frame_info:
  1164.                 write_sstring(stream_,OL(showstack_string_ENV_frame)); # "┐Environment-Bindungs-Frame"
  1165.                 write_sstring(stream_,O(showstack_string_VENV_frame)); # "┐  VAR_ENV <--> "
  1166.                 prin1(stream_,FRAME_(1));
  1167.                 write_sstring(stream_,O(showstack_string_FENV_frame)); # "┐  FUN_ENV <--> "
  1168.                 prin1(stream_,FRAME_(2));
  1169.                 write_sstring(stream_,O(showstack_string_BENV_frame)); # "┐  BLOCK_ENV <--> "
  1170.                 prin1(stream_,FRAME_(3));
  1171.                 write_sstring(stream_,O(showstack_string_GENV_frame)); # "┐  GO_ENV <--> "
  1172.                 prin1(stream_,FRAME_(4));
  1173.                 write_sstring(stream_,O(showstack_string_DENV_frame)); # "┐  DECL_ENV <--> "
  1174.                 prin1(stream_,FRAME_(5));
  1175.                 break;
  1176.               default:
  1177.                 pushSTACK(S(show_stack));
  1178.                 fehler(serious_condition,
  1179.                        DEUTSCH ? "~: Unbekannter Frame-Typ" :
  1180.                        ENGLISH ? "~: unknown frame type" :
  1181.                        FRANCAIS ? "~: Type d'environnement inconnu." :
  1182.                        ""
  1183.                       );
  1184.             }
  1185.           return FRAME_top; # Pointer ⁿbern Frame
  1186.         }
  1187.     }
  1188.  
  1189. LISPFUNN(describe_frame,2)
  1190. # (SYS::DESCRIBE-FRAME stream framepointer) gibt das Stackitem, auf das der
  1191. # Pointer zeigt, detailliert aus.
  1192.   { var reg1 object* FRAME = test_framepointer_arg(); # Pointer in den Stack
  1193.     if (!mstreamp(STACK_0)) { fehler_stream(STACK_0); }
  1194.     print_stackitem(&STACK_0,FRAME); # Stack-Item ausgeben
  1195.     skipSTACK(1); value1 = NIL; mv_count=0; # keine Werte
  1196.   }
  1197.  
  1198. LISPFUNN(show_stack,0)
  1199. # (SHOW-STACK) zeigt den Inhalt des Stacks an.
  1200.   { var reg1 object* FRAME = STACK; # lΣuft durch den Stack nach oben
  1201.     pushSTACK(var_stream(S(standard_output))); # Stream *STANDARD-OUTPUT*
  1202.    {var reg2 object* stream_ = &STACK_0;
  1203.     until (eq(FRAME_(0),nullobj)) # Nullword = oberes Stackende
  1204.       { FRAME = print_stackitem(stream_,FRAME); } # Stack-Item ausgeben
  1205.     skipSTACK(1); value1 = NIL; mv_count=0; # keine Werte
  1206.   }}
  1207.  
  1208. LISPFUNN(debug,0)
  1209. # (SYSTEM::DEBUG) springt in einen im Hintergrund sitzenden Debugger.
  1210.   {
  1211.     #if !defined(AMIGAOS)
  1212.       abort();
  1213.     #else # AMIGAOS
  1214.       Debug(0);
  1215.     #endif
  1216.     value1 = NIL; mv_count=0; # keine Werte
  1217.   }
  1218.  
  1219. LISPFUNN(room,0)
  1220. # (ROOM), liefert 2 Werte:
  1221. # - von LISP-Objekten belegter Platz
  1222. # - fⁿr LISP-Objekte freier Platz
  1223. # bei SPVW_PAGES ausfⁿhrlicher machen??
  1224.   { value1 = fixnum(used_space());
  1225.     value2 = fixnum(free_space());
  1226.     mv_count=2;
  1227.   }
  1228.  
  1229. LISPFUNN(gc,0)
  1230. # (GC) fⁿhrt eine GC aus
  1231. # und liefert den fⁿr LISP-Objekte freien Platz (in Bytes)
  1232.   { gar_col(); # GC ausfⁿhren
  1233.     value1 = fixnum(free_space()); mv_count=1;
  1234.   }
  1235.  
  1236. # read-form neu schreiben, in Zusammenarbeit mit dem Terminal-Stream??
  1237.  
  1238.