home *** CD-ROM | disk | FTP | other *** search
Text File | 1996-04-15 | 55.5 KB | 1,269 lines |
- # Top-Level-Schleife, Hilfsfunktionen für Debugger, Stepper von CLISP
- # Bruno Haible 25.5.1995
- # ILISP friendliness: Marcus Daniels 8.4.1994
-
- #include "lispbibl.c"
-
-
- # ---------------------------------------------------------------------------- #
- # Top-Level-Schleifen
-
- # (SYS::READ-FORM ostream istream prompt [commandlist])
- # Liest eine Form (interaktiv) von einem Input-Stream.
- # Statt einer Form kann auch eine Sondertaste aus commandlist (eine frische
- # Aliste) oder SYS::*KEY-BINDINGS* eingegeben werden.
- # > STACK_1: prompt, ein String
- # > STACK_0: Befehlsliste (frische Aliste) oder #<UNBOUND>
- # < STACK_1: Output-Stream *standard-output*
- # < STACK_0: Input-Stream *standard-input*
- # < mv_space/mv_count: Werte form, NIL oder (bei EOF) T, T
- # kann GC auslösen
- local Values read_form (void);
- # (defun read-form (ostream istream prompt &optional (command-list nil))
- # (loop
- # (let ((raw (terminal-raw istream nil)))
- # (clear-input istream)
- # (unless (listen istream)
- # (terpri ostream)
- # (write-string prompt ostream)
- # )
- # (let* ((eof-value "EOF")
- # (form (let ((*read-suppress* nil)
- # (*key-bindings* (nreconc command-list *key-bindings*)))
- # (read istream nil eof-value nil)
- # )) )
- # (terminal-raw istream raw)
- # (if (eql form eof-value)
- # (progn (clear-input istream) (setq istream *debug-io*))
- # (progn (clear-input istream) (return (values form nil)))
- # ) ) ) ) )
- local Values read_form()
- { pushSTACK(STACK_1); pushSTACK(STACK_1);
- STACK_3 = var_stream(S(standard_output),strmflags_wr_ch_B); # ostream := Wert von *STANDARD-OUTPUT*
- STACK_2 = var_stream(S(standard_input),strmflags_rd_ch_B); # istream := Wert von *STANDARD-INPUT*
- # Stackaufbau: ostream, istream, prompt, command-list.
- pushSTACK(STACK_2); pushSTACK(NIL); funcall(L(terminal_raw),2); pushSTACK(value1);
- # Stackaufbau: ostream, istream, prompt, command-list, raw.
- clear_input(STACK_3); # wartenden Input löschen und
- {var reg4 signean status = stream_listen(STACK_3); # horchen
- if (status<0) goto eof;
- # bereits Zeichen verfügbar (und nicht im ilisp_mode) -> kein Prompt
- if (ilisp_mode || status>0)
- { var object *ostream_ptr = &STACK_4;
- # interaktiver Input-Stream -> Prompt ausgeben:
- #if 0
- terpri(ostream_ptr); # (TERPRI ostream)
- #else
- # Dasselbe mit Abfangen von Endlosrekursion:
- # (let ((*recurse-count-standard-output* (1+ *recurse-count-standard-output*)))
- # (when (> *recurse-count-standard-output* 3)
- # (setq *recurse-count-standard-output* 0)
- # (close *standard-output*)
- # (symbol-stream '*standard-output* :output)
- # )
- # (terpri *standard-output*)
- # )
- dynamic_bind(S(recurse_count_standard_output),fixnum_inc(Symbol_value(S(recurse_count_standard_output)),1)); # sys::*recurse-count-standard-output* erhöhen
- if (!sym_posfixnump(S(recurse_count_standard_output))) # sollte ein Fixnum >=0 sein
- { set_Symbol_value(S(recurse_count_standard_output),Fixnum_0); } # sonst Notkorrektur
- if (posfixnum_to_L(Symbol_value(S(recurse_count_standard_output))) > 3)
- { # Mehrfach verschachtelte Fehlermeldung.
- set_Symbol_value(S(recurse_count_standard_output),Fixnum_0);
- stream_close(ostream_ptr);
- *ostream_ptr = var_stream(S(standard_output),strmflags_wr_ch_B); # ostream := Wert von *STANDARD-OUTPUT*
- }
- terpri(ostream_ptr); # (TERPRI ostream)
- dynamic_unbind();
- #endif
- write_string(ostream_ptr,STACK_2); # (WRITE-STRING prompt ostream)
- }
- # Prompt OK
- { var reg3 object* istream_ = &STACK_3;
- #if 0 # Das erweist sich doch als ungeschickt: Drückt man Ctrl-C während
- # der Eingabe, so hat man dann in der Break-Schleife manche Kommandos
- # doppelt in der Liste!
- {var reg1 object list = Symbol_value(S(key_bindings)); # bisherige Key-Bindings
- if (!eq(STACK_1,unbound)) # command-list angegeben?
- { list = nreconc(STACK_1,list); } # ja -> davorhängen
- dynamic_bind(S(key_bindings),list); # SYS::*KEY-BINDINGS* binden
- }
- #else
- # statt (nreconc command-list *key-bindings*)
- # doch lieber (nreverse command-list)
- {var reg1 object list = (eq(STACK_1,unbound) ? NIL : nreverse(STACK_1));
- dynamic_bind(S(key_bindings),list); # SYS::*KEY-BINDINGS* binden
- }
- #endif
- #if !defined(TERMINAL_USES_KEYBOARD)
- if (status>0) # nur bei interaktivem Input-Stream
- { # Erkennung von Kommandos statt Formen:
- # (multiple-value-bind (line flag) (read-line istream)
- # (let ((h (assoc line *key-bindings* :test #'string-equal)))
- # (when h (funcall (cdr h)) (return t))
- # )
- # (setq istream
- # (make-concatenated-stream
- # (make-string-input-stream
- # (if flag line (concatenate 'string line (string #\Newline)))
- # )
- # istream
- # ) ) )
- pushSTACK(*istream_); pushSTACK(NIL); pushSTACK(NIL);
- funcall(L(read_line),3); # (READ-LINE istream nil nil)
- {var reg2 object line = value1;
- if (nullp(line)) { dynamic_unbind(); goto eof; } # EOF am Zeilenanfang?
- # line in *KEY-BINDINGS* suchen:
- {var reg1 object alist = Symbol_value(S(key_bindings));
- while (consp(alist))
- { if (mconsp(Car(alist)) && simple_string_p(Car(Car(alist)))
- && string_equal(line,Car(Car(alist)))
- )
- # gefunden -> Funktion dazu aufrufen:
- { funcall(Cdr(Car(alist)),0); dynamic_unbind(); goto eof; }
- alist = Cdr(alist);
- } }
- # String-Input-Stream für diese Zeile basteln:
- if (nullp(value2))
- { pushSTACK(line); pushSTACK(O(newline_string));
- line = string_concat(2); # evtl. noch ein Newline anhängen
- }
- pushSTACK(line); funcall(L(make_string_input_stream),1);
- # Concatenated-Stream basteln:
- pushSTACK(value1); pushSTACK(*istream_);
- funcall(L(make_concatenated_stream),2);
- *istream_ = value1; # und an istream zuweisen
- }}
- #endif
- {var reg1 object obj;
- dynamic_bind(S(read_suppress),NIL); # *READ-SUPPRESS* = NIL
- obj = read(istream_,NIL,NIL); # Objekt lesen (recursive-p=NIL, whitespace-p=NIL)
- dynamic_unbind();
- dynamic_unbind();
- if (!eq(obj,eof_value)) # EOF (nach Whitespace) abfragen
- { pushSTACK(obj);
- pushSTACK(STACK_(3+1)); pushSTACK(STACK_(0+1+1)); funcall(L(terminal_raw),2);
- clear_input(STACK_(3+1)); # wartenden Input (hoffentlich nur
- # bis Zeilenende) löschen
- value1 = popSTACK(); value2 = NIL; mv_count=2; # obj, NIL als Werte
- skipSTACK(3); return;
- }
- }}
- eof: # bei EOF angelangt
- pushSTACK(STACK_3); pushSTACK(STACK_(0+1)); funcall(L(terminal_raw),2);
- # (clear-input istream) ausführen (um bei interaktivem Stream das EOF zu
- # schlucken: das fortzusetzende Programm könnte das EOF mißverstehen):
- clear_input(STACK_3);
- value1 = value2 = T; mv_count=2; # T, T als Werte
- skipSTACK(3); return;
- }}
-
- # (SYS::READ-FORM prompt [commandlist])
- # liest eine Form (interaktiv) von *standard-input*.
- # prompt muß ein String sein.
- # Statt einer Form kann auch eine Sondertaste aus commandlist (eine frische
- # Aliste) oder SYS::*KEY-BINDINGS* eingegeben werden.
- # Werte: form, NIL oder (bei EOF) T, T
- LISPFUN(read_form,1,1,norest,nokey,0,NIL)
- { read_form(); skipSTACK(2); }
-
- # (SYS::READ-EVAL-PRINT prompt [commandlist])
- # liest eine Form, wertet sie aus und gibt die Werte aus.
- # prompt muß ein String sein.
- # Statt einer Form kann auch eine Sondertaste aus commandlist (eine frische
- # Aliste) oder SYS::*KEY-BINDINGS* eingegeben werden.
- # Werte: NIL oder (bei Sondertaste oder EOF) T
- LISPFUN(read_eval_print,1,1,norest,nokey,0,NIL)
- # (defun read-eval-print (prompt &optional (command-list nil))
- # (multiple-value-bind (form flag)
- # (read-form *standard-output* *standard-input* prompt command-list)
- # (if flag
- # form ; T zurück
- # (progn
- # (setq +++ ++ ++ + + - - form)
- # (let ((vals (multiple-value-list (eval-env form [aktuellesEnvironment]))))
- # (setq /// // // / / vals)
- # (setq *** ** ** * * (first vals))
- # (let ((ostream *standard-output*))
- # (fresh-line ostream)
- # (when (consp vals)
- # (write (car vals) ostream)
- # (do ((L (cdr vals) (cdr L)))
- # ((atom L))
- # (write-string " ;" ostream)
- # (terpri ostream)
- # (write (car L) ostream)
- # ) ) )
- # )
- # nil
- # ) ) ) )
- { read_form(); # Form lesen
- # Stackaufbau: ostream, istream.
- if (!nullp(value2)) # flag ?
- { mv_count=1; skipSTACK(2); return; } # T als Wert zurück
- set_Symbol_value(S(plus3),Symbol_value(S(plus2))); # (SETQ +++ ++)
- set_Symbol_value(S(plus2),Symbol_value(S(plus))); # (SETQ ++ +)
- set_Symbol_value(S(plus),Symbol_value(S(minus))); # (SETQ + -)
- set_Symbol_value(S(minus),value1); # (SETQ - form)
- eval(value1); # Form auswerten (im aktuellen Environment)
- pushSTACK(value1); # einen Wert retten
- mv_to_list(); # Werte in Liste packen
- # Stackaufbau: ..., val1, vals.
- set_Symbol_value(S(durch3),Symbol_value(S(durch2))); # (SETQ /// //)
- set_Symbol_value(S(durch2),Symbol_value(S(durch))); # (SETQ // /)
- set_Symbol_value(S(durch),STACK_0); # (SETQ / vals)
- set_Symbol_value(S(mal3),Symbol_value(S(mal2))); # (SETQ *** **)
- set_Symbol_value(S(mal2), Symbol_value(S(mal))); # (SETQ ** *)
- set_Symbol_value(S(mal),STACK_1); # (SETQ * val1)
- # Werte ausgeben:
- STACK_(1+2) = var_stream(S(standard_output),strmflags_wr_ch_B); # ostream := Wert von *STANDARD-OUTPUT*
- #if 0
- if (mconsp(STACK_0))
- { loop
- { var reg1 object valsr = STACK_0;
- STACK_0 = Cdr(valsr);
- terpri(&STACK_(1+2));
- prin1(&STACK_(1+2),Car(valsr)); # nächsten Wert ausgeben
- # ';' als Trennzeichen vorm Zeilenende:
- if (matomp(STACK_0)) break;
- write_schar(&STACK_(1+2),' ');
- write_schar(&STACK_(1+2),';');
- } }
- #else
- # unnötige Leerzeile zwischen Input und Output vermeiden:
- # (Es erscheint immer noch eine unnötige Leerzeile am Bildschirm,
- # wenn stdin vom Terminal kommt und stdout eine Pipe ist, die
- # letztendlich wieder aufs Terminal geht - z.B. via '| tee logfile'.
- # In diesem Fall müssen wir aber - eben wegen 'logfile' - ein NL auf
- # stdout ausgeben, und da stdin am Zeilenende von selbst ein NL aus-
- # gibt, ist diese Leerzeile wirklich unvermeidlich.)
- if (!eq(get_line_position(STACK_(1+2)),Fixnum_0))
- { terpri(&STACK_(1+2)); } # (fresh-line ostream)
- if (mconsp(STACK_0))
- { loop
- { var reg1 object valsr = STACK_0;
- STACK_0 = Cdr(valsr);
- prin1(&STACK_(1+2),Car(valsr)); # nächsten Wert ausgeben
- # ';' als Trennzeichen vorm Zeilenende:
- if (matomp(STACK_0)) break;
- write_schar(&STACK_(1+2),' ');
- write_schar(&STACK_(1+2),';');
- terpri(&STACK_(1+2));
- } }
- #endif
- skipSTACK(4);
- value1 = NIL; mv_count=1; # NIL als Wert
- }
-
- # Startet den normalen Driver (Read-Eval-Print-Loop)
- # driver();
- global void driver (void);
- global void driver()
- { loop
- { var reg1 object driverfun = Symbol_value(S(driverstern)); # Wert von *DRIVER*
- if (nullp(driverfun)) break;
- funcall(driverfun,0); # mit 0 Argumenten aufrufen
- }
- # Default-Driver:
- set_Symbol_value(S(break_count),Fixnum_0); # SYS::*BREAK-COUNT* := 0
- # dann einen Driver-Frame aufbauen:
- { var reg1 object* top_of_frame = STACK; # Pointer übern Frame
- var DRIVER_frame_data returner_and_data; # Rücksprungpunkt merken
- #ifdef HAVE_NUM_STACK
- returner_and_data.old_NUM_STACK_normal = NUM_STACK_normal;
- #endif
- finish_entry_frame(DRIVER,&!returner_and_data.returner,_EMA_,;);
- }
- # Hier ist der Einsprungpunkt.
- loop
- { # (SYS::READ-EVAL-PRINT "> ") ausführen:
- pushSTACK(O(prompt_string)); # Prompt "> "
- funcall(L(read_eval_print),1);
- if (eq(value1,T)) break; # EOF gelesen -> Schleife beenden
- }
- skipSTACK(2); # Driver-Frame auflösen
- }
-
- # Startet einen untergeordneten Driver (Read-Eval-Print-Loop)
- # break_driver(continuable);
- # > continuable: Flag, ob nach Beendigung des Drivers fortgefahren werden kann.
- # kann GC auslösen
- global void break_driver (object continuable);
- global void break_driver(continuable)
- var reg3 object continuable;
- { pushSTACK(continuable);
- {var reg4 object driverfun = Symbol_value(S(break_driver)); # Wert von *BREAK-DRIVER*
- if (!nullp(driverfun))
- {
- #ifdef HAVE_NUM_STACK
- var reg2 uintD* old_NUM_STACK = NUM_STACK;
- var reg1 uintD* old_NUM_STACK_normal = NUM_STACK_normal;
- #endif
- pushSTACK(STACK_0); funcall(driverfun,1); # mit Argument continuable aufrufen
- if (nullp(popSTACK())) # nicht continuable?
- { reset(); } # -> dann zur nächsten Schleife zurück
- #ifdef HAVE_NUM_STACK
- NUM_STACK = old_NUM_STACK;
- NUM_STACK_normal = old_NUM_STACK_normal;
- #endif
- }
- else
- { # Default-Driver:
- # (CLEAR-INPUT *DEBUG-IO*) ausführen (weil das, was der Benutzer bisher
- # getippt hat, sicher nicht in Erwartung des Errors getippt wurde):
- clear_input(var_stream(S(debug_io),strmflags_rd_ch_B|strmflags_wr_ch_B));
- # SYS::*BREAK-COUNT* erhöhen:
- dynamic_bind(S(break_count),fixnum_inc(Symbol_value(S(break_count)),1));
- if (!sym_posfixnump(S(break_count))) # sollte ein Fixnum >=0 sein
- { set_Symbol_value(S(break_count),Fixnum_0); } # sonst Notkorrektur
- # *STANDARD-INPUT* und *STANDARD-OUTPUT* an *DEBUG-IO* binden:
- {var reg1 object stream = var_stream(S(debug_io),strmflags_rd_ch_B|strmflags_wr_ch_B);
- dynamic_bind(S(standard_input),stream);
- dynamic_bind(S(standard_output),Symbol_value(S(standard_input)));
- }
- # *PRINT-ESCAPE* an T binden:
- dynamic_bind(S(print_escape),T);
- # Prompt aufbauen:
- { # (format nil "~S. Break> " SYS::*BREAK-COUNT*)
- # ==
- # (with-output-to-string (s)
- # (prin1 SYS::*BREAK-COUNT* s) (write-string ". Break> " s)
- # )
- # ==
- # (let ((s (make-string-output-stream)))
- # (prin1 SYS::*BREAK-COUNT* s) (write-string ". Break> " s)
- # (get-output-stream-string s)
- # )
- pushSTACK(make_string_output_stream());
- prin1(&STACK_0,Symbol_value(S(break_count)));
- write_sstring(&STACK_0,O(breakprompt_string));
- STACK_0 = get_output_stream_string(&STACK_0);
- }
- # Driver-Frame aufbauen:
- {var reg1 object* top_of_frame = STACK; # Pointer übern Frame
- var DRIVER_frame_data returner_and_data; # Rücksprungpunkt merken
- #ifdef HAVE_NUM_STACK
- var reg2 uintD* old_NUM_STACK = NUM_STACK;
- returner_and_data.old_NUM_STACK_normal = NUM_STACK_normal;
- #endif
- finish_entry_frame(DRIVER,&!returner_and_data.returner,_EMA_,;);
- # Hier ist der Einsprungpunkt.
- #ifdef HAVE_NUM_STACK
- NUM_STACK_normal = old_NUM_STACK;
- #endif
- loop
- { # (SYS::READ-EVAL-PRINT Prompt) ausführen:
- pushSTACK(STACK_(0+2)); # Prompt "nnn. Break> "
- funcall(L(read_eval_print),1);
- if (eq(value1,T)) break; # EOF gelesen -> Schleife beenden
- }
- if (nullp(STACK_(0+4*DYNBIND_SIZE+1+2))) # nicht continuable?
- { unwind(); reset(); } # -> dann zur nächsten Schleife zurück
- #ifdef HAVE_NUM_STACK
- NUM_STACK = old_NUM_STACK;
- NUM_STACK_normal = returner_and_data.old_NUM_STACK_normal;
- #endif
- skipSTACK(1+2); # Driver-Frame auflösen, Prompt vergessen
- dynamic_unbind(); dynamic_unbind(); dynamic_unbind(); dynamic_unbind();
- skipSTACK(1);
- }} }}
-
- LISPFUNN(load,1)
- # (LOAD filename), primitivere Version als in CLTL S. 426
- # Methode:
- # (defun load (filename)
- # (let ((stream (open filename))
- # (end-of-file "EOF")) ; einmaliges Objekt
- # (loop
- # (let ((obj (read stream nil end-of-file)))
- # (when (eql obj end-of-file) (return))
- # (if (compiled-function-p obj) (funcall obj) (eval obj))
- # ) )
- # (close stream)
- # t
- # ) )
- { funcall(L(open),1); # (OPEN filename)
- pushSTACK(value1); # stream retten
- set_Symbol_value(S(load_input_stream),value1);
- loop
- { var reg1 object obj = read(&STACK_0,NIL,NIL); # Objekt lesen
- if (eq(obj,eof_value)) break; # EOF -> fertig
- if (closurep(obj))
- { funcall(obj,0); } # Closure (vermutlich compilierte Closure) aufrufen
- else
- { eval_noenv(obj); } # sonstige Form evaluieren
- }
- stream_close(&STACK_0); # stream schließen
- set_Symbol_value(S(load_input_stream),NIL);
- skipSTACK(1); value1 = T; mv_count=1; # Wert T
- }
-
- # ---------------------------------------------------------------------------- #
- # Hilfsfunktionen für Debugger und Stepper
-
- # Die folgenden Funktionen klettern im Stack herum, überschreiten jedoch
- # keinen Driver-Frame und auch nicht das obere Stackende.
- # Gültige "Stackpointer" sind hierbei Pointer auf Stackelemente oder
- # Frames, wo nicht das Stackende und auch kein Driver-Frame ist.
- # Modus 1: alle Stackitems
- # Modus 2: Frames
- # Modus 3: lexikalische Frames: Frame-Info hat FRAME_BIT = 1 und
- # (SKIP2_BIT = 1 oder ENTRYPOINT_BIT = 0 oder BLOCKGO_BIT = 1)
- # Modus 4: EVAL- und APPLY-Frames: Frame-Info = [TRAPPED_]EVAL/APPLY_FRAME_INFO
- # Modus 5: APPLY-Frames: Frame-Info = [TRAPPED_]APPLY_FRAME_INFO
-
- # Macro: Testet, ob FRAME ein Stackende erreicht hat.
- #define stack_upend_p() \
- ( eq(FRAME_(0),nullobj) # Nullword = oberes Stackende \
- || (mtypecode(FRAME_(0)) == DRIVER_frame_info) # Driver-Frame = Stackende \
- || ((typecode(Symbol_value(S(frame_limit2))) == system_type) \
- && (uTheFramepointer(Symbol_value(S(frame_limit2))) cmpSTACKop FRAME) # FRAME > *frame-limit2* ? \
- ) )
- #define stack_downend_p() \
- ( (mtypecode(FRAME_(0)) == DRIVER_frame_info) # Driver-Frame = Stackende \
- || ((typecode(Symbol_value(S(frame_limit1))) == system_type) \
- && (FRAME cmpSTACKop uTheFramepointer(Symbol_value(S(frame_limit1)))) # FRAME < *frame-limit1* ? \
- ) )
-
- # Macro: Testet, ob FRAME auf einen Frame zeigt.
- # in erster Näherung:
- # #define frame_p() (!( (as_oint(FRAME_(0)) & wbit(frame_bit_o)) ==0))
- # in zweiter Näherung, unter Berücksichtigung der Frames mit Skip2-bit:
- #define frame_p() framep(FRAME)
- local boolean framep (object* FRAME);
- local boolean framep(FRAME)
- var reg1 object* FRAME;
- { # Ein normales Lisp-Objekt ist kein Frame:
- if ((as_oint(FRAME_(0)) & wbit(frame_bit_o)) ==0) return FALSE;
- # Beginnt bei FRAME_(-1) ein Frame ohne Skip2-Bit, so ist FRAME_(0)
- # Teil dieses Frames, also nicht selber Beginn eines Frames:
- if ( (!(FRAME==STACK)) # nicht die STACK-Grenzen überschreiten!
- && ((as_oint(FRAME_(-1)) & wbit(skip2_bit_o)) == 0)
- && framep(FRAME STACKop -1)
- )
- return FALSE;
- return TRUE; # Sonst beginnt hier ein Frame.
- }
-
- # Macro: Erniedrigt FRAME bis zum nächsten Frame.
- #define next_frame_down() do { FRAME skipSTACKop -1; } until (frame_p());
-
- # Macro: Testet, ob der Frame bei FRAME ein lexikalischer Frame ist.
- #ifdef entrypoint_bit_t
- #define lexical_frame_p() \
- ( (!( (as_oint(FRAME_(0)) & wbit(skip2_bit_o)) ==0)) \
- || ( (as_oint(FRAME_(0)) & wbit(entrypoint_bit_o)) ==0) \
- || (!( (as_oint(FRAME_(0)) & wbit(blockgo_bit_o)) ==0)) \
- )
- #else
- #define lexical_frame_p() \
- (/* (!( (as_oint(FRAME_(0)) & wbit(skip2_bit_o)) ==0)) \
- || */ (mtypecode(FRAME_(0)) >= entrypoint_limit_t) \
- || (!( (as_oint(FRAME_(0)) & wbit(blockgo_bit_o)) ==0)) \
- )
- #endif
-
- # Macro: Testet, ob der Frame bei FRAME ein EVAL/APPLY-Frame ist.
- #define evalapply_frame_p() \
- ((mtypecode(FRAME_(0)) & ~(bit(eval_bit_t)|bit(trapped_bit_t))) == \
- ((EVAL_frame_info|APPLY_frame_info) & ~(bit(eval_bit_t)|bit(trapped_bit_t))))
-
- # Macro: Testet, ob der Frame bei FRAME ein APPLY-Frame ist.
- #define apply_frame_p() \
- ((mtypecode(FRAME_(0)) & ~bit(trapped_bit_t)) == (APPLY_frame_info & ~bit(trapped_bit_t)))
-
- # UP: überspringt ein Stackitem nach oben
- local object* frame_up_1 (object* stackptr);
- local object* frame_up_1(stackptr)
- var reg2 object* stackptr;
- { var reg1 object* FRAME = stackptr;
- if (frame_p())
- { FRAME = topofframe(FRAME_(0)); } # Pointer übern Frame
- else
- { FRAME skipSTACKop 1; } # Pointer aufs nächste Objekt
- return (stack_upend_p() ? stackptr : FRAME);
- }
-
- # UP: überspringt ein Stackitem nach unten
- local object* frame_down_1 (object* stackptr);
- local object* frame_down_1(stackptr)
- var reg2 object* stackptr;
- { var reg1 object* FRAME = stackptr;
- next_frame_down(); # nächsten Frame drunter suchen
- if (!(topofframe(FRAME_(0)) == stackptr)) # nicht direkt unterhalb stackptr?
- { FRAME = stackptr STACKop -1; }
- return (stack_downend_p() ? stackptr : FRAME);
- }
-
- # UP: springt zum nächsthöheren Frame
- local object* frame_up_2 (object* stackptr);
- local object* frame_up_2(stackptr)
- var reg2 object* stackptr;
- { var reg1 object* FRAME = stackptr;
- if (frame_p())
- { FRAME = topofframe(FRAME_(0)); } # Pointer übern Frame
- else
- { FRAME skipSTACKop 1; } # Pointer aufs nächste Objekt
- loop
- { if (stack_upend_p()) return stackptr;
- if (as_oint(FRAME_(0)) & wbit(frame_bit_o)) return FRAME;
- FRAME skipSTACKop 1;
- }
- }
-
- # UP: springt zum nächstniedrigeren Frame
- local object* frame_down_2 (object* stackptr);
- local object* frame_down_2(stackptr)
- var reg2 object* stackptr;
- { var reg1 object* FRAME = stackptr;
- next_frame_down(); # nächsten Frame drunter suchen
- return (stack_downend_p() ? stackptr : FRAME);
- }
-
- # UP: springt zum nächsthöheren lexikalischen Frame
- local object* frame_up_3 (object* stackptr);
- local object* frame_up_3(stackptr)
- var reg2 object* stackptr;
- { var reg1 object* FRAME = stackptr;
- if (frame_p())
- { FRAME = topofframe(FRAME_(0)); } # Pointer übern Frame
- else
- { FRAME skipSTACKop 1; } # Pointer aufs nächste Objekt
- loop
- { if (stack_upend_p()) return stackptr;
- if (frame_p())
- { if (lexical_frame_p())
- { return FRAME; }
- else
- { FRAME = topofframe(FRAME_(0)); } # Pointer übern Frame
- }
- else
- { FRAME skipSTACKop 1; }
- }
- }
-
- # UP: springt zum nächstniedrigeren lexikalischen Frame
- local object* frame_down_3 (object* stackptr);
- local object* frame_down_3(stackptr)
- var reg2 object* stackptr;
- { var reg1 object* FRAME = stackptr;
- loop
- { next_frame_down(); # nächsten Frame drunter suchen
- if (stack_downend_p()) return stackptr;
- if (lexical_frame_p()) break;
- }
- return FRAME;
- }
-
- # UP: springt zum nächsthöheren EVAL/APPLY-Frame
- local object* frame_up_4 (object* stackptr);
- local object* frame_up_4(stackptr)
- var reg2 object* stackptr;
- { var reg1 object* FRAME = stackptr;
- if (frame_p())
- { FRAME = topofframe(FRAME_(0)); } # Pointer übern Frame
- else
- { FRAME skipSTACKop 1; } # Pointer aufs nächste Objekt
- loop
- { if (stack_upend_p()) return stackptr;
- if (frame_p())
- { if (evalapply_frame_p())
- { return FRAME; }
- else
- { FRAME = topofframe(FRAME_(0)); } # Pointer übern Frame
- }
- else
- { FRAME skipSTACKop 1; }
- }
- }
-
- # UP: springt zum nächstniedrigeren EVAL/APPLY-Frame
- local object* frame_down_4 (object* stackptr);
- local object* frame_down_4(stackptr)
- var reg2 object* stackptr;
- { var reg1 object* FRAME = stackptr;
- loop
- { next_frame_down(); # nächsten Frame drunter suchen
- if (stack_downend_p()) return stackptr;
- if (evalapply_frame_p()) break;
- }
- return FRAME;
- }
-
- # UP: springt zum nächsthöheren APPLY-Frame
- local object* frame_up_5 (object* stackptr);
- local object* frame_up_5(stackptr)
- var reg2 object* stackptr;
- { var reg1 object* FRAME = stackptr;
- if (frame_p())
- { FRAME = topofframe(FRAME_(0)); } # Pointer übern Frame
- else
- { FRAME skipSTACKop 1; } # Pointer aufs nächste Objekt
- loop
- { if (stack_upend_p()) return stackptr;
- if (frame_p())
- { if (apply_frame_p())
- { return FRAME; }
- else
- { FRAME = topofframe(FRAME_(0)); } # Pointer übern Frame
- }
- else
- { FRAME skipSTACKop 1; }
- }
- }
-
- # UP: springt zum nächstniedrigeren APPLY-Frame
- local object* frame_down_5 (object* stackptr);
- local object* frame_down_5(stackptr)
- var reg2 object* stackptr;
- { var reg1 object* FRAME = stackptr;
- loop
- { next_frame_down(); # nächsten Frame drunter suchen
- if (stack_downend_p()) return stackptr;
- if (apply_frame_p()) break;
- }
- return FRAME;
- }
-
- # Typ eines Pointers auf eine Hochsteige- bzw. Absteige-Routine:
- typedef object* (*kletterfun) (object* stackptr);
-
- local kletterfun frame_up_table[] =
- { &frame_up_1, &frame_up_2, &frame_up_3, &frame_up_4, &frame_up_5, };
- local kletterfun frame_down_table[] =
- { &frame_down_1, &frame_down_2, &frame_down_3, &frame_down_4, &frame_down_5, };
-
- # UP: Überprüft und decodiert das mode-Argument.
- # test_mode_arg(table)
- # > STACK_0: mode
- # > table: Tabelle der Routinen zum Hochsteigen bzw. zum Absteigen
- # > subr_self: Aufrufer (ein SUBR)
- # < ergebnis: Routine zum Hochsteigen bzw. zum Absteigen
- # erhöht STACK um 1
- local kletterfun test_mode_arg (kletterfun* table);
- local kletterfun test_mode_arg(table)
- var reg3 kletterfun* table;
- { var reg1 object arg = popSTACK();
- var reg2 uintL mode;
- if (!(posfixnump(arg)
- && ((mode = posfixnum_to_L(arg)) > 0)
- && (mode<=5)
- ) )
- { pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
- pushSTACK(O(type_climb_mode)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
- pushSTACK(arg);
- pushSTACK(TheSubr(subr_self)->name);
- //: DEUTSCH "~: Ungültiger Frame-Kletter-Modus ~"
- //: ENGLISH "~: bad frame climbing mode ~"
- //: FRANCAIS "~: Mauvais mode de saut d'environnement ~."
- fehler(type_error,GETTEXT("~: bad frame climbing mode ~"));
- }
- return table[mode-1];
- }
-
- # UP: Überprüft ein Frame-Pointer-Argument.
- # test_framepointer_arg()
- # > STACK_0: Lisp-Objekt, sollte ein Frame-Pointer sein
- # > subr_self: Aufrufer (ein SUBR)
- # < ergebnis: Frame-Pointer
- # erhöht STACK um 1
- local object* test_framepointer_arg (void);
- local object* test_framepointer_arg()
- { var reg1 object arg = popSTACK();
- if (!(stack_env_p(arg)))
- { pushSTACK(arg);
- pushSTACK(TheSubr(subr_self)->name);
- //: DEUTSCH "~: ~ ist kein Stackpointer."
- //: ENGLISH "~: ~ is not a stack pointer"
- //: FRANCAIS "~: ~ n'est pas un pointeur de pile."
- fehler(error,GETTEXT("~: ~ is not a stack pointer"));
- }
- return uTheFramepointer(arg);
- }
-
- LISPFUNN(frame_up_1,2)
- # (SYS::FRAME-UP-1 framepointer mode) liefert den Frame-Pointer 1 höher.
- { var reg2 kletterfun frame_up_x = test_mode_arg(&frame_up_table[0]);
- var reg1 object* stackptr = test_framepointer_arg();
- stackptr = (*frame_up_x)(stackptr); # einmal hochsteigen
- value1 = make_framepointer(stackptr); mv_count=1;
- }
-
- LISPFUNN(frame_up,2)
- # (SYS::FRAME-UP framepointer mode) liefert den Frame-Pointer ganz oben.
- { var reg2 kletterfun frame_up_x = test_mode_arg(&frame_up_table[0]);
- var reg1 object* stackptr = test_framepointer_arg();
- # hochsteigen, bis es nicht mehr weiter geht:
- loop
- { var reg3 object* next_stackptr = (*frame_up_x)(stackptr);
- if (next_stackptr == stackptr) break;
- stackptr = next_stackptr;
- }
- value1 = make_framepointer(stackptr); mv_count=1;
- }
-
- LISPFUNN(frame_down_1,2)
- # (SYS::FRAME-DOWN-1 framepointer mode) liefert den Frame-Pointer 1 drunter.
- { var reg2 kletterfun frame_down_x = test_mode_arg(&frame_down_table[0]);
- var reg1 object* stackptr = test_framepointer_arg();
- stackptr = (*frame_down_x)(stackptr); # einmal hinabsteigen
- value1 = make_framepointer(stackptr); mv_count=1;
- }
-
- LISPFUNN(frame_down,2)
- # (SYS::FRAME-DOWN framepointer mode) liefert den Frame-Pointer ganz unten.
- { var reg2 kletterfun frame_down_x = test_mode_arg(&frame_down_table[0]);
- var reg1 object* stackptr = test_framepointer_arg();
- # hinabsteigen, bis es nicht mehr weiter geht:
- loop
- { var reg3 object* next_stackptr = (*frame_down_x)(stackptr);
- if (next_stackptr == stackptr) break;
- stackptr = next_stackptr;
- }
- value1 = make_framepointer(stackptr); mv_count=1;
- }
-
- LISPFUNN(the_frame,0)
- # (SYS::THE-FRAME) liefert den aktuellen Stackpointer als Frame-Pointer.
- { var reg1 object* stackptr = STACK;
- stackptr = frame_up_2(stackptr); # bis zum nächsthöheren Frame hoch
- value1 = make_framepointer(stackptr); mv_count=1;
- }
-
- # UP: aktiviert dasselbe lexikalische Environment, das beim Framepointer
- # STACK_0 aktiv war.
- # same_env_as();
- # erhöht STACK um 1, baut auf dem STACK einen ENV5-Frame auf
- local void same_env_as (void);
- local void same_env_as()
- { var reg1 object* FRAME = test_framepointer_arg();
- var environment env;
- # 5 Environments noch "leer":
- env.var_env = nullobj;
- env.fun_env = nullobj;
- env.block_env = nullobj;
- env.go_env = nullobj;
- env.decl_env = nullobj;
- # und füllen:
- loop
- { # ab FRAME abwärts nach ENV-Frames suchen:
- loop
- { FRAME skipSTACKop -1;
- if (FRAME==STACK) goto end; # Stack zu Ende?
- if (frame_p()
- && (!( (as_oint(FRAME_(0)) & wbit(skip2_bit_o)) ==0))
- && (!( (as_oint(FRAME_(0)) & wbit(envbind_bit_o)) ==0))
- )
- break;
- }
- # Nächster ENV-Frame gefunden.
- # Sein Inhalt füllt die noch leeren Komponenten von env:
- switch (mtypecode(FRAME_(0)) & envbind_case_mask_t)
- { case (ENV1V_frame_info & envbind_case_mask_t): # 1 VAR_ENV
- if (eq(env.var_env,nullobj)) { env.var_env = FRAME_(1); }
- break;
- case (ENV1F_frame_info & envbind_case_mask_t): # 1 FUN_ENV
- if (eq(env.fun_env,nullobj)) { env.fun_env = FRAME_(1); }
- break;
- case (ENV1B_frame_info & envbind_case_mask_t): # 1 BLOCK_ENV
- if (eq(env.block_env,nullobj)) { env.block_env = FRAME_(1); }
- break;
- case (ENV1G_frame_info & envbind_case_mask_t): # 1 GO_ENV
- if (eq(env.go_env,nullobj)) { env.go_env = FRAME_(1); }
- break;
- case (ENV1D_frame_info & envbind_case_mask_t): # 1 DECL_ENV
- if (eq(env.decl_env,nullobj)) { env.decl_env = FRAME_(1); }
- break;
- case (ENV2VD_frame_info & envbind_case_mask_t): # 1 VAR_ENV und 1 DECL_ENV
- if (eq(env.var_env,nullobj)) { env.var_env = FRAME_(1); }
- if (eq(env.decl_env,nullobj)) { env.decl_env = FRAME_(2); }
- break;
- case (ENV5_frame_info & envbind_case_mask_t): # alle 5 Environments
- if (eq(env.var_env,nullobj)) { env.var_env = FRAME_(1); }
- if (eq(env.fun_env,nullobj)) { env.fun_env = FRAME_(2); }
- if (eq(env.block_env,nullobj)) { env.block_env = FRAME_(3); }
- if (eq(env.go_env,nullobj)) { env.go_env = FRAME_(4); }
- if (eq(env.decl_env,nullobj)) { env.decl_env = FRAME_(5); }
- break;
- default: NOTREACHED
- }
- # Falls alle einzelnen Environments von env gefüllt (/=nullobj) sind,
- # ist das Environment fertig:
- if ( (!eq(env.var_env,nullobj))
- && (!eq(env.fun_env,nullobj))
- && (!eq(env.block_env,nullobj))
- && (!eq(env.go_env,nullobj))
- && (!eq(env.decl_env,nullobj))
- )
- goto fertig;
- }
- end: # Stack zu Ende.
- # Hole restliche Environment-Komponenten aus dem aktuellen Environment:
- if (eq(env.var_env,nullobj)) { env.var_env = aktenv.var_env; }
- if (eq(env.fun_env,nullobj)) { env.fun_env = aktenv.fun_env; }
- if (eq(env.block_env,nullobj)) { env.block_env = aktenv.block_env; }
- if (eq(env.go_env,nullobj)) { env.go_env = aktenv.go_env; }
- if (eq(env.decl_env,nullobj)) { env.decl_env = aktenv.decl_env; }
- fertig: # env fertig.
- # Environment-Frame aufbauen:
- make_ENV5_frame();
- # aktuelle Environments setzen:
- aktenv = env;
- }
-
- LISPFUNN(same_env_as,2)
- # (SYS::SAME-ENV-AS framepointer fun) aktiviert dasselbe lexikalische
- # Environment, das bei framepointer aktiv war, und ruft dann fun auf.
- { var reg1 object fun = popSTACK();
- same_env_as(); # Environment von framepointer aktivieren
- funcall(fun,0); # fun aufrufen
- unwind(); # Environment-Frame auflösen
- }
-
- LISPFUNN(eval_at,2)
- # (SYS::EVAL-AT framepointer form) aktiviert dasselbe lexikalische
- # Environment, das bei framepointer aktiv war, und wertet darin die Form aus.
- { var reg1 object form = popSTACK();
- same_env_as(); # Environment von framepointer aktivieren
- eval(form); # form auswerten
- unwind(); # Environment-Frame auflösen
- }
-
- LISPFUNN(eval_frame_p,1)
- # (SYS::EVAL-FRAME-P framepointer)
- # gibt an, ob framepointer auf einen EVAL/APPLY-Frame zeigt.
- { var reg1 object* FRAME = test_framepointer_arg();
- value1 = (evalapply_frame_p() ? T : NIL); mv_count=1;
- }
-
- LISPFUNN(driver_frame_p,1)
- # (SYS::DRIVER-FRAME-P framepointer)
- # gibt an, ob framepointer auf einen Driver-Frame zeigt.
- { var reg1 object* FRAME = test_framepointer_arg();
- value1 = (mtypecode(FRAME_(0)) == DRIVER_frame_info ? T : NIL); mv_count=1;
- }
-
- # Fehlermeldung, wenn kein EVAL/APPLY-Frame-Pointer vorliegt.
- # fehler_evalframe(obj);
- # > subr_self: Aufrufer (ein SUBR)
- # > obj: kein EVAL/APPLY-Frame-Pointer
- nonreturning_function(local, fehler_evalframe, (object obj));
- local void fehler_evalframe(obj)
- var reg1 object obj;
- { pushSTACK(obj);
- pushSTACK(TheSubr(subr_self)->name);
- //: DEUTSCH "~: ~ ist kein Pointer auf einen EVAL/APPLY-Frame."
- //: ENGLISH "~: ~ is not a pointer to an EVAL/APPLY frame"
- //: FRANCAIS "~: ~ n'est pas une pointeur vers un environnement EVAL/APPLY."
- fehler(error,GETTEXT("~: ~ is not a pointer to an EVAL/APPLY frame"));
- }
-
- LISPFUNN(trap_eval_frame,2)
- # (SYS::TRAP-EVAL-FRAME framepointer flag) schaltet den Breakpoint am
- # angegebenen EVAL/APPLY-Frame je nach flag an bzw. aus.
- { var reg3 object flag = popSTACK();
- var reg2 object frame = popSTACK();
- if (!stack_env_p(frame)) { fehler_evalframe(frame); }
- {var reg1 object* FRAME = uTheFramepointer(frame);
- if (!evalapply_frame_p()) { fehler_evalframe(frame); }
- # FRAME zeigt auf den EVAL/APPLY-Frame.
- if (!nullp(flag))
- # Breakpoint einschalten
- { *(oint*)(&FRAME_(0)) |= wbit(trapped_bit_o); }
- else
- # Breakpoint ausschalten
- { *(oint*)(&FRAME_(0)) &= ~wbit(trapped_bit_o); }
- value1 = frame; mv_count=1; # framepointer als Wert
- }}
-
- LISPFUNN(redo_eval_frame,1)
- # (SYS::REDO-EVAL-FRAME framepointer) unwindet bis zum angegebenen
- # EVAL/APPLY-Frame und fängt erneut an, diesen abzuarbeiten.
- { var reg2 object frame = popSTACK();
- if (!stack_env_p(frame)) { fehler_evalframe(frame); }
- {var reg1 object* FRAME = uTheFramepointer(frame);
- if (!evalapply_frame_p()) { fehler_evalframe(frame); }
- # FRAME zeigt auf den EVAL/APPLY-Frame.
- value1 = NIL; mv_count=0; # keine Werte zu retten
- unwind_upto(FRAME); # bis zum EVAL/APPLY-Frame alles auflösen, dorthin springen
- }}
-
- LISPFUNN(return_from_eval_frame,2)
- # (SYS::RETURN-FROM-EVAL-FRAME framepointer form)
- # unwindet bis zum angegebenen EVAL/APPLY-Frame und gibt als dessen Werte die
- # Werte der Evaluierung der angegebenen form zurück.
- { var reg3 object form = popSTACK();
- var reg2 object frame = popSTACK();
- if (!stack_env_p(frame)) { fehler_evalframe(frame); }
- {var reg1 object* FRAME = uTheFramepointer(frame);
- if (!evalapply_frame_p()) { fehler_evalframe(frame); }
- # FRAME zeigt auf den EVAL/APPLY-Frame.
- value1 = form; mv_count=1; # form retten und übergeben
- unwind_upto(FRAME); # bis zum EVAL/APPLY-Frame alles auflösen, dorthin springen
- }}
-
- # ---------------------------------------------------------------------------- #
- # Debughilfen
-
- local void write_nl_sstring (object* stream_, object string);
- local void write_nl_sstring(stream_,string)
- var reg2 object* stream_;
- var reg1 object string;
- {
- write_schar(stream_,NLstring[0]);
- write_sstring(stream_,string);
- }
-
- local void write_nlnl_sstring (object* stream_, object string);
- local void write_nlnl_sstring(stream_,string)
- var reg2 object* stream_;
- var reg1 object string;
- {
- write_schar(stream_,NLstring[0]);
- write_schar(stream_,NLstring[0]);
- write_sstring(stream_,string);
- }
-
- # UP: Gibt das Stackitem FRAME_(0) detailliert auf den Stream aus
- # und liefert den nächsthöheren stackptr.
- # print_stackitem(&stream,FRAME)
- # kann GC auslösen
- local object* print_stackitem (object* stream_, object* FRAME);
- local object* print_stackitem(stream_,FRAME)
- var reg2 object* stream_;
- var reg1 object* FRAME;
- { if (!frame_p())
- # kein Frame, normales LISP-Objekt
- { write_sstring(stream_,O(showstack_string_lisp_obj)); # "¿- "
- {var reg3 object obj = FRAME_(0);
- switch (typecode(obj)) # evtl. Symbol-Flags entfernen
- { case_symbolflagged: obj = symbol_without_flags(obj);
- default: break;
- }
- prin1(stream_,obj); # LISP-Objekt ausgeben
- return FRAME STACKop 1;
- }}
- else
- # Frame angetroffen
- { var reg6 object* FRAME_top = topofframe(FRAME_(0)); # Pointer übern Frame
- switch (mtypecode(FRAME_(0))) # je nach Frametyp
- { case TRAPPED_APPLY_frame_info:
- # getrapte APPLY-Frames:
- write_nl_sstring(stream_,OL(showstack_string_TRAPPED_APPLY_frame)); # "¿APPLY-Frame mit Breakpoint für Aufruf "
- goto APPLY_frame;
- case APPLY_frame_info:
- # APPLY-Frames:
- write_nl_sstring(stream_,OL(showstack_string_APPLY_frame)); # "¿APPLY-Frame für Aufruf "
- APPLY_frame:
- # Funktionsnamen und Argumente ausgeben:
- write_schar(stream_,'('); # '(' ausgeben
- prin1(stream_,TheIclosure(FRAME_(frame_closure))->clos_name); # Namen ausgeben
- { var reg3 object* argptr = FRAME_top;
- var reg4 uintL count = STACK_item_count(FRAME STACKop frame_args,FRAME_top);
- dotimesL(count,count,
- { write_schar(stream_,' '); # ' ' ausgeben
- write_schar(stream_,'\''); # "'" ausgeben
- prin1(stream_,NEXT(argptr)); # nächstes Argument ausgeben
- });
- }
- write_schar(stream_,')'); # ')' ausgeben
- break;
- case TRAPPED_EVAL_frame_info:
- # getrapte EVAL-Frames:
- write_nl_sstring(stream_,OL(showstack_string_TRAPPED_EVAL_frame)); # "¿EVAL-Frame mit Breakpoint für Form "
- goto EVAL_frame;
- case EVAL_frame_info:
- # EVAL-Frames:
- write_nl_sstring(stream_,OL(showstack_string_EVAL_frame)); # "¿EVAL-Frame für Form "
- EVAL_frame:
- prin1(stream_,FRAME_(frame_form)); # Form ausgeben
- break;
- case DYNBIND_frame_info:
- # dynamische Variablenbindungsframes:
- write_nl_sstring(stream_,OL(showstack_string_DYNBIND_frame)); # "¿Variablenbindungs-Frame bindet (~ = dynamisch):"
- # Bindungen ausgeben:
- FRAME skipSTACKop 1;
- until (FRAME==FRAME_top)
- { # Bindung von Symbol FRAME_(0) an Wert FRAME_(1) ausgeben:
- write_sstring(stream_,O(showstack_string_bindung)); # "¿ | "
- write_schar(stream_,'~'); # '~' ausgeben
- write_schar(stream_,' '); # ' ' ausgeben
- prin1(stream_,FRAME_(0)); # Symbol ausgeben
- write_sstring(stream_,O(showstack_string_zuord)); # " <--> "
- prin1(stream_,FRAME_(1)); # Wert ausgeben
- FRAME skipSTACKop 2;
- }
- break;
- # Variablen- und Funktionsbindungsframes:
- case VAR_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_VAR_frame)); # "¿Variablenbindungs-Frame "
- #ifdef NO_symbolflags
- prin1(stream_,make_framepointer(FRAME)); # Frame-Pointer ausgeben
- write_sstring(stream_,OL(showstack_string_binds)); # " bindet (~ = dynamisch):"
- pushSTACK(FRAME_(frame_next_env)); # weiteres Environment retten
- # Bindungen ausgeben:
- FRAME skipSTACKop frame_bindings;
- until (FRAME==FRAME_top)
- { if (!( (as_oint(FRAME_(varframe_binding_mark)) & wbit(active_bit_o)) ==0))
- # Bindung von Symbol FRAME_(1) an Wert FRAME_(2) ausgeben:
- { write_sstring(stream_,O(showstack_string_bindung)); # "¿ | "
- if (!( (as_oint(FRAME_(varframe_binding_mark)) & wbit(dynam_bit_o)) ==0)) # Bindung dynamisch?
- { write_schar(stream_,'~'); } # ja -> '~' ausgeben
- write_schar(stream_,' '); # ' ' ausgeben
- prin1(stream_,symbol_without_flags(FRAME_(varframe_binding_sym))); # Symbol ausgeben
- write_sstring(stream_,O(showstack_string_zuord)); # " <--> "
- prin1(stream_,FRAME_(varframe_binding_value)); # Wert ausgeben
- }
- FRAME skipSTACKop varframe_binding_size;
- }
- goto VARFUN_frame_next;
- #else
- goto VARFUN_frame;
- #endif
- case FUN_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_FUN_frame)); # "¿Funktionsbindungs-Frame "
- goto VARFUN_frame;
- VARFUN_frame:
- prin1(stream_,make_framepointer(FRAME)); # Frame-Pointer ausgeben
- write_sstring(stream_,OL(showstack_string_binds)); # " bindet (~ = dynamisch):"
- pushSTACK(FRAME_(frame_next_env)); # weiteres Environment retten
- # Bindungen ausgeben:
- FRAME skipSTACKop frame_bindings;
- until (FRAME==FRAME_top)
- { if (!( (as_oint(FRAME_(0)) & wbit(active_bit_o)) ==0))
- # Bindung von Symbol FRAME_(0) an Wert FRAME_(1) ausgeben:
- { write_sstring(stream_,O(showstack_string_bindung)); # "¿ | "
- if (!( (as_oint(FRAME_(0)) & wbit(dynam_bit_o)) ==0)) # Bindung dynamisch?
- { write_schar(stream_,'~'); } # ja -> '~' ausgeben
- write_schar(stream_,' '); # ' ' ausgeben
- prin1(stream_,symbol_without_flags(FRAME_(0))); # Symbol ausgeben
- write_sstring(stream_,O(showstack_string_zuord)); # " <--> "
- prin1(stream_,FRAME_(1)); # Wert ausgeben
- }
- FRAME skipSTACKop 2;
- }
- VARFUN_frame_next:
- # Weiteres Environment ausgeben:
- write_nl_sstring(stream_,OL(showstack_string_next_env)); # "¿ Weiteres Environment: "
- { var reg3 object env = popSTACK(); # weiteres Environment
- if (!simple_vector_p(env))
- { prin1(stream_,env); }
- else
- # weiteres Environment ist ein Vektor, der Länge 2n+1
- do { pushSTACK(env);
- {var reg5 uintL count = floor(TheSvector(env)->length,2); # = n = Bindungszahl
- var reg4 uintL index = 0;
- dotimesL(count,count,
- { write_sstring(stream_,O(showstack_string_bindung)); # "¿ | "
- prin1(stream_,TheSvector(STACK_0)->data[index++]); # Symbol ausgeben
- write_sstring(stream_,O(showstack_string_zuord)); # " <--> "
- prin1(stream_,TheSvector(STACK_0)->data[index++]); # Symbol ausgeben
- });
- env = TheSvector(popSTACK())->data[index]; # letztes Vektor-Element
- }}
- while (simple_vector_p(env));
- }
- break;
- # Interpretierte Block-Frames:
- case IBLOCK_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_IBLOCK_frame)); # "¿Block-Frame "
- goto IBLOCK_frame;
- case NESTED_IBLOCK_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_NESTED_IBLOCK_frame)); # "¿Block-Frame (genestet) "
- goto IBLOCK_frame;
- IBLOCK_frame:
- pushSTACK(FRAME_(frame_next_env));
- prin1(stream_,make_framepointer(FRAME)); # Frame-Pointer ausgeben
- write_sstring(stream_,OL(showstack_string_for1)); # " für "
- prin1(stream_,FRAME_(frame_name)); # Blockname
- goto NEXT_ENV;
- case CBLOCK_frame_info:
- # compilierte Block-Frames:
- write_nl_sstring(stream_,OL(showstack_string_CBLOCK_frame)); # "¿Block-Frame (compiliert) für "
- prin1(stream_,FRAME_(frame_ctag)); # Blockname
- break;
- # Interpretierte Tagbody-Frames:
- case ITAGBODY_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_ITAGBODY_frame)); # "¿Tagbody-Frame "
- goto ITAGBODY_frame;
- case NESTED_ITAGBODY_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_NESTED_ITAGBODY_frame)); # "¿Tagbody-Frame (genestet) "
- goto ITAGBODY_frame;
- ITAGBODY_frame:
- pushSTACK(FRAME_(frame_next_env));
- prin1(stream_,make_framepointer(FRAME)); # Frame-Pointer ausgeben
- write_sstring(stream_,OL(showstack_string_for2)); # " für"
- # Tags/Bodys ausgeben:
- FRAME skipSTACKop frame_bindings;
- until (FRAME==FRAME_top)
- { # Bindung von Tag FRAME_(0) an Body FRAME_(1) ausgeben:
- write_sstring(stream_,O(showstack_string_bindung)); # "¿ | "
- prin1(stream_,FRAME_(0)); # Tag ausgeben
- write_sstring(stream_,O(showstack_string_zuordtag)); # " --> "
- prin1(stream_,FRAME_(1)); # Body ausgeben
- FRAME skipSTACKop 2;
- }
- goto NEXT_ENV;
- NEXT_ENV: # Ausgeben eines Block- oder Tagbody-Environments STACK_0
- write_nl_sstring(stream_,OL(showstack_string_next_env)); # "¿ Weiteres Environment: "
- { var reg3 object env = popSTACK();
- if (!consp(env))
- { prin1(stream_,env); }
- else
- # weiteres Environment ist eine Aliste
- do { pushSTACK(Cdr(env));
- env = Car(env);
- if (atomp(env))
- { pushSTACK(S(show_stack));
- //: DEUTSCH "~: Environment ist keine Aliste"
- //: ENGLISH "~: environment is not an alist"
- //: FRANCAIS "~: L'environnement n'est pas une liste d'association."
- fehler(error,GETTEXT("~: environment is not an alist"));
- }
- pushSTACK(Cdr(env));
- pushSTACK(Car(env));
- write_sstring(stream_,O(showstack_string_bindung)); # "¿ | "
- prin1(stream_,popSTACK());
- write_sstring(stream_,O(showstack_string_zuordtag)); # " --> "
- prin1(stream_,popSTACK());
- env = popSTACK();
- }
- while (consp(env));
- }
- break;
- case CTAGBODY_frame_info:
- # compilierte Tagbody-Frames:
- write_nl_sstring(stream_,OL(showstack_string_CTAGBODY_frame)); # "¿Tagbody-Frame (compiliert) für "
- prin1(stream_,Car(FRAME_(frame_ctag))); # Tag-Vektor
- break;
- case CATCH_frame_info:
- # Catch-Frames:
- write_nl_sstring(stream_,OL(showstack_string_CATCH_frame)); # "¿Catch-Frame für Tag "
- prin1(stream_,FRAME_(frame_tag)); # Tag
- break;
- case HANDLER_frame_info:
- # Handler-Frames:
- write_nl_sstring(stream_,OL(showstack_string_HANDLER_frame)); # "¿Handler-Frame für Conditions"
- { var reg4 uintL m2 = TheSvector(Car(FRAME_(frame_handlers)))->length; # 2*m
- var reg3 uintL i = 0;
- do { write_schar(stream_,' '); # ' ' ausgeben
- prin1(stream_,TheSvector(Car(FRAME_(frame_handlers)))->data[i]); # Typ i ausgeben
- i += 2;
- }
- while (i < m2);
- }
- break;
- case UNWIND_PROTECT_frame_info:
- # Unwind-Protect-Frames:
- write_nl_sstring(stream_,OL(showstack_string_UNWIND_PROTECT_frame)); # "¿Unwind-Protect-Frame"
- break;
- case DRIVER_frame_info:
- # Driver-Frames:
- write_nlnl_sstring(stream_,OL(showstack_string_DRIVER_frame)); # "¿¿Driver-Frame"
- break;
- # Environment-Frames:
- case ENV1V_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_ENV_frame)); # "¿Environment-Bindungs-Frame"
- write_nl_sstring(stream_,O(showstack_string_VENV_frame)); # "¿ VAR_ENV <--> "
- prin1(stream_,FRAME_(1));
- break;
- case ENV1F_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_ENV_frame)); # "¿Environment-Bindungs-Frame"
- write_nl_sstring(stream_,O(showstack_string_FENV_frame)); # "¿ FUN_ENV <--> "
- prin1(stream_,FRAME_(1));
- break;
- case ENV1B_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_ENV_frame)); # "¿Environment-Bindungs-Frame"
- write_nl_sstring(stream_,O(showstack_string_BENV_frame)); # "¿ BLOCK_ENV <--> "
- prin1(stream_,FRAME_(1));
- break;
- case ENV1G_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_ENV_frame)); # "¿Environment-Bindungs-Frame"
- write_nl_sstring(stream_,O(showstack_string_GENV_frame)); # "¿ GO_ENV <--> "
- prin1(stream_,FRAME_(1));
- break;
- case ENV1D_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_ENV_frame)); # "¿Environment-Bindungs-Frame"
- write_nl_sstring(stream_,O(showstack_string_DENV_frame)); # "¿ DECL_ENV <--> "
- prin1(stream_,FRAME_(1));
- break;
- case ENV2VD_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_ENV_frame)); # "¿Environment-Bindungs-Frame"
- write_nl_sstring(stream_,O(showstack_string_VENV_frame)); # "¿ VAR_ENV <--> "
- prin1(stream_,FRAME_(1));
- write_nl_sstring(stream_,O(showstack_string_DENV_frame)); # "¿ DECL_ENV <--> "
- prin1(stream_,FRAME_(2));
- break;
- case ENV5_frame_info:
- write_nl_sstring(stream_,OL(showstack_string_ENV_frame)); # "¿Environment-Bindungs-Frame"
- write_nl_sstring(stream_,O(showstack_string_VENV_frame)); # "¿ VAR_ENV <--> "
- prin1(stream_,FRAME_(1));
- write_nl_sstring(stream_,O(showstack_string_FENV_frame)); # "¿ FUN_ENV <--> "
- prin1(stream_,FRAME_(2));
- write_nl_sstring(stream_,O(showstack_string_BENV_frame)); # "¿ BLOCK_ENV <--> "
- prin1(stream_,FRAME_(3));
- write_nl_sstring(stream_,O(showstack_string_GENV_frame)); # "¿ GO_ENV <--> "
- prin1(stream_,FRAME_(4));
- write_nl_sstring(stream_,O(showstack_string_DENV_frame)); # "¿ DECL_ENV <--> "
- prin1(stream_,FRAME_(5));
- break;
- default:
- pushSTACK(S(show_stack));
- //: DEUTSCH "~: Unbekannter Frame-Typ"
- //: ENGLISH "~: unknown frame type"
- //: FRANCAIS "~: Type d'environnement inconnu."
- fehler(serious_condition,GETTEXT("~: unknown frame type"));
- }
- return FRAME_top; # Pointer übern Frame
- }
- }
-
- LISPFUNN(describe_frame,2)
- # (SYS::DESCRIBE-FRAME stream framepointer) gibt das Stackitem, auf das der
- # Pointer zeigt, detailliert aus.
- { var reg1 object* FRAME = test_framepointer_arg(); # Pointer in den Stack
- if (!mstreamp(STACK_0)) { fehler_stream(STACK_0); }
- print_stackitem(&STACK_0,FRAME); # Stack-Item ausgeben
- skipSTACK(1); value1 = NIL; mv_count=0; # keine Werte
- }
-
- LISPFUNN(show_stack,0)
- # (SHOW-STACK) zeigt den Inhalt des Stacks an.
- { var reg1 object* FRAME = STACK; # läuft durch den Stack nach oben
- pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B)); # Stream *STANDARD-OUTPUT*
- {var reg2 object* stream_ = &STACK_0;
- until (eq(FRAME_(0),nullobj)) # Nullword = oberes Stackende
- { FRAME = print_stackitem(stream_,FRAME); } # Stack-Item ausgeben
- skipSTACK(1); value1 = NIL; mv_count=0; # keine Werte
- }}
-
- LISPFUNN(debug,0)
- # (SYSTEM::DEBUG) springt in einen im Hintergrund sitzenden Debugger.
- {
- #if !defined(AMIGAOS)
- abort();
- #else # AMIGAOS
- Debug(0);
- #endif
- value1 = NIL; mv_count=0; # keine Werte
- }
-
- LISPFUNN(room,0)
- # (ROOM), liefert 2 Werte:
- # - von LISP-Objekten belegter Platz
- # - für LISP-Objekte freier Platz
- # bei SPVW_PAGES ausführlicher machen??
- { value1 = fixnum(used_space());
- value2 = fixnum(free_space());
- mv_count=2;
- }
-
- LISPFUNN(gc,0)
- # (GC) führt eine GC aus
- # und liefert den für LISP-Objekte freien Platz (in Bytes)
- { gar_col(); # GC ausführen
- value1 = fixnum(free_space()); mv_count=1;
- }
-
- # read-form neu schreiben, in Zusammenarbeit mit dem Terminal-Stream??
-
-