120 lines
4.7 KiB
ArmAsm
120 lines
4.7 KiB
ArmAsm
|
;;; PC Scheme toplevel
|
|||
|
;;; Copyright 1987 (c) Texas Instruments
|
|||
|
|
|||
|
|
|||
|
;;; The following is the PC Scheme standard toplevel function.
|
|||
|
;;; This definition of it is suitable for loading via an .INI file.
|
|||
|
|
|||
|
|
|||
|
; When this is loaded, the fluid variable SCHEME-TOP-LEVEL is set
|
|||
|
; to the outer lambda expression. When PC Scheme finishes loading
|
|||
|
; the .INI file, it does an internal SCHEME-RESET. That activates
|
|||
|
; this function, and also snapshots the VM state; further SCHEME-RESET's
|
|||
|
; will always restore the state of PC Scheme to this initial snapshot.
|
|||
|
; The outer lambda expression's body calls the local function ==SCHEME-RESET==.
|
|||
|
; The fluid variables INPUT-PORT and OUTPUT-PORT are initialized to the
|
|||
|
; values of STANDARD-INPUT and STANDARD-OUTPUT, which in turn are always
|
|||
|
; bound to 'CONSOLE unless you explicitly set them otherwise.
|
|||
|
; The history list is set to nil. The debug-mode flag is examined and
|
|||
|
; an appropriate message is output. Then comes the most interesting
|
|||
|
; part--a continuation snapshots the context at this point of execution
|
|||
|
; in the function and is assigned to the variable ==RESET==. Then the
|
|||
|
; fluid variable SCHEME-TOP-LEVEL is rebound to this continuation.
|
|||
|
; Henceforth, further RESET's will start execution of the toplevel function
|
|||
|
; at this point, skipping the above initializations. A GC is done before
|
|||
|
; executing the local function MORE.
|
|||
|
|
|||
|
; MORE is the read-eval-print section of the toplevel. The prompt is
|
|||
|
; displayed. Input is read, consed onto the history list, and evaluated,
|
|||
|
; with the result printed with WRITE and also consed onto the history list.
|
|||
|
; In the midst of this, the local variable NEXT is bound to SCHEME-TOP-LEVEL's
|
|||
|
; value. It is possible that the evaluation of the input form might have
|
|||
|
; changed SCHEME-TOP-LEVEL. If NEXT is still bound to ==RESET==, the
|
|||
|
; continuation derived above, then the current toplevel function is still
|
|||
|
; in control and we loop back to MORE, skipping the initializations that
|
|||
|
; RESET or SCHEME-RESET would perform. Otherwise, a new toplevel is
|
|||
|
; indicated, and we call it.
|
|||
|
|
|||
|
; To summarize, the system's toplevel function has 3 entry points.
|
|||
|
; First, SCHEME-RESET restarts the outer lambda expression,
|
|||
|
; which invokes the local function ==SCHEME-RESET==, and that
|
|||
|
; resets the history list and input and output ports, among other things.
|
|||
|
; Second, RESET restarts the continuation marked by the CALL/CC,
|
|||
|
; and a GC occurs. Finally, the local function MORE takes care
|
|||
|
; of the read-eval-print loop. Once entered, MORE is never exited
|
|||
|
; unless a RESET or SCHEME-RESET are executed to redo their appropriate
|
|||
|
; levels of initialization.
|
|||
|
|
|||
|
|
|||
|
;;; define standard toplevel loop and support functions
|
|||
|
|
|||
|
|
|||
|
(set! (fluid scheme-top-level)
|
|||
|
(lambda () ; outer lambda
|
|||
|
(letrec
|
|||
|
((==reset== '())
|
|||
|
(==scheme-reset== ; here for SCHEME-RESET
|
|||
|
(lambda ()
|
|||
|
(set! (fluid input-port) standard-input)
|
|||
|
(set! (fluid output-port) standard-output)
|
|||
|
(putprop '%PCS-STL-HISTORY (list '()) %pcs-stl-history)
|
|||
|
(newline)
|
|||
|
(display "[PCS-DEBUG-MODE is ")
|
|||
|
(display (if pcs-debug-mode "ON]" "OFF]"))
|
|||
|
(newline)
|
|||
|
(call/cc
|
|||
|
(lambda (k)
|
|||
|
(set! ==reset== (lambda () (k '())))
|
|||
|
(set! (fluid scheme-top-level)
|
|||
|
==reset==)))
|
|||
|
; here for RESET
|
|||
|
(gc)
|
|||
|
(more)))
|
|||
|
(more ; read-eval-print loop
|
|||
|
(lambda ()
|
|||
|
(fresh-line)
|
|||
|
(display "[")
|
|||
|
(display (length (getprop '%PCS-STL-HISTORY %pcs-stl-history)))
|
|||
|
(display "]> ")
|
|||
|
(let ((problem (read)))
|
|||
|
(flush-input)
|
|||
|
(if (eof-object? problem)
|
|||
|
(display "[End of file read by SCHEME-TOP-LEVEL]")
|
|||
|
(begin
|
|||
|
(putprop '%PCS-STL-HISTORY
|
|||
|
(cons (list problem)
|
|||
|
(getprop '%PCS-STL-HISTORY
|
|||
|
%pcs-stl-history))
|
|||
|
%pcs-stl-history)
|
|||
|
(let* ((answer (eval problem))
|
|||
|
(next (fluid scheme-top-level)))
|
|||
|
(when (not (eq? answer *the-non-printing-object*))
|
|||
|
(write answer))
|
|||
|
(putprop '%PCS-STL-HISTORY
|
|||
|
(cons (cons problem answer)
|
|||
|
(cdr (getprop '%PCS-STL-HISTORY
|
|||
|
%pcs-stl-history)))
|
|||
|
%pcs-stl-history)
|
|||
|
(if (eq? next ==reset==)
|
|||
|
(more)
|
|||
|
(next))))))))) ;end of letrec vars
|
|||
|
(==scheme-reset==) ;letrec body
|
|||
|
)))
|
|||
|
|
|||
|
;;; %C accesses the nth user command
|
|||
|
;;; %D accesses the result of the nth user command
|
|||
|
|
|||
|
(define %c ; %C
|
|||
|
(lambda (n)
|
|||
|
(let ((history (getprop '%PCS-STL-HISTORY %pcs-stl-history)))
|
|||
|
(and (positive? n)
|
|||
|
(< n (length history))
|
|||
|
(car (list-ref (reverse history) n))))))
|
|||
|
|
|||
|
(define %d ; %D
|
|||
|
(lambda (n)
|
|||
|
(let ((history (getprop '%PCS-STL-HISTORY %pcs-stl-history)))
|
|||
|
(and (positive? n)
|
|||
|
(< n (length history))
|
|||
|
(cdr (list-ref (reverse history) n))))))
|
|||
|
|