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