;;; This file implements the basic "read-eval-print" for SCHEME->C.  The
;;; interpreter is designed so that it can be run either "stand-alone", or
;;; embedded in some application.  Initialization of this module will assure
;;; that the entire library is initialized.

;*              Copyright 1989 Digital Equipment Corporation
;*                         All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions.  Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software.  Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software.  Correspondence should be provided to Digital at:
;* 
;*                       Director of Licensing
;*                       Western Research Laboratory
;*                       Digital Equipment Corporation
;*                       100 Hamilton Avenue
;*                       Palo Alto, California  94301  
;* 
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.  
;* 
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.

(module screp
    (top-level TOP-LEVEL READ-EVAL-PRINT LOAD LOADE LOADQ)
    (with scdebug sceval scexpand scexpanders1 scexpanders2 scqquote))

;;; External definitions.

(define-constant SIG_IGN 1)
(define-constant SIGINT  2)
(define-constant SIGFPE  8)
(define-constant SIGBUS  10)
(define-constant SIGSEGV 11)
(define-constant SIGSYS  12)

(define-external CURRENT-INPUT-PORT-VALUE scrt5)

(define-external CURRENT-OUTPUT-PORT-VALUE scrt5)

(define-external OPEN-FILE-PORTS scrt5)

(include "repdef.sc")

;;; The function TOP-LEVEL will return to the outer most interpreter.

(define  TOP-LEVEL #f)

;;; The global flag *EMACSCHEME* indicates whether interpreter is running
;;; in GNU emacs.

(define  *EMACSCHEME* #f)

;;; The global flag *READING-STDIN* indicates that the interpreter is reading
;;; stdin.  If control-c is pressed while this is true, then the debugger
;;; is not entered and a reset is performed.

(define *READING-STDIN* #f)

;;; The entry point to this module is the following function.  On entry it
;;; saves the current EXIT, RESET, TRACE-LEVEL, and keyboard interrupt
;;; handler.  After arming the keyboard interrupt, it passes control
;;; to the next step, REP.  On return from that function, the saved values
;;; will be restored and then the function will exit.
;;;
;;; The function is called with an optional list of options.  They are:
;;;
;;;	ECHO	-		echo the input on the output file.
;;;	"-e"
;;;	QUIET	-		do not print the result on the output file.
;;;	"-q"
;;;	PROMPT  "prompt" / #f	prompt input with the string "prompt".
;;;	"-np"			do not prompt input.
;;;	HEADER	"header" / #f	print the "header" on entry.
;;;	"-nh"			do not print header.
;;;	LOAD			LOAD / LOADE / LOADQ from current input.
;;;     RESULT  value		value to return unless overridden by proceed.
;;;	ENV	alist		interpreter environment.
;;;     "-emacs"		GNU emacs mode 

(define (READ-EVAL-PRINT . flags)
    (letrec ((save-exit exit)
	     (save-reset reset)
	     (save-interrupt (signal sigint sig_ign))
	     (save-trace trace-level)
	     (input current-input-port-value)
	     (output current-output-port-value)
	     (echoinput (or (member 'echo flags) (member "-e" flags)))
	     (quiet (or (member 'quiet flags) (member "-q" flags)))
	     (prompt (let ((x (member 'prompt flags)))
			  (cond (x (cadr x))
				((member "-np" flags) #f)
				(else "> "))))
	     (header (let ((x (member 'header flags)))
			  (cond (x (cadr x))
				((member "-nh" flags) #f)
				(else (format "~a -- ~a -- ~a ~a"
					    (car (implementation-information))
					    (cadr (implementation-information))
			                    "Copyright 1989 Digital"
					    "Equipment Corporation")))))
	     (env (let ((x (member 'env flags)))
		       (if x (cadr x) '())))
	     (load (member 'load flags))
	     (return-value (let ((x (member 'result flags)))
				(if x (cadr x) #f)))
	     
	     ;;; Exit function and proceed functions.
	     (MAKE-EXIT
		 (lambda (exit-here)
			 (set! proceed
			       (lambda x (if x (set! return-value (car x)))
					 (exit-here #f)))
			 (set! exit (lambda () (exit-here #f)))
			 #t))
	     
	     ;;; Reset function.
	     (MAKE-RESET
		 (lambda (reset-here)
			 (if (not load)
			     (set! reset
				   (let ((save-exit exit))
					 (lambda ()
						 (set! exit save-exit)
						 (reset-here #f)))))
			 #t))

	     ;;; One-time initialization code to set up TOP-LEVEL, backtracing
	     ;;; error handler, and trap handlers.
	     (ONE-TIME-INITIALIZATION
		 (lambda ()
		         (set! *emacscheme* (member "-emacs" flags))
			 (set! top-level
			       (let ((top-reset reset))
				    (lambda ()
					    (set! *debug-on-error* #t)
					    (set! reset top-reset)
					    (reset))))
			 (set! *error-handler* backtrace-error-handler)
			 (set! *debug-on-error* #t)
			 (signal sigbus
				 (lambda (sig) (error '???? "Bus error")))
			 (signal sigsegv
				 (lambda (sig) (error '????
						   "Segment violation")))
			 (signal sigsys
				 (lambda (sig) (error '????
						 "Bad argument to system call"
						 ))))))

	    ;;; Function body starts here.
	    (if (call-with-current-continuation make-exit)
		(begin (if (call-with-current-continuation make-reset)
			   (begin (cond (load
					    (signal sigint save-interrupt))
					((not (eq? save-interrupt sig_ign))
					 (signal sigint on-interrupt)))
				  (if echoinput (echo input output))
		 		  (if header
				      (format stdout-port "~a~%" header)))
			   (begin (set! current-input-port-value input)
				  (set! current-output-port-value output)
				  (set! trace-level save-trace)))
		       (if (not top-level) (one-time-initialization))
		       (rep env (if load (current-input-port) stdin-port)
			    stdout-port prompt quiet)))
	    (signal sigint save-interrupt)
	    (if echoinput (echo input #f))
	    (set! exit save-exit)
	    (set! reset save-reset)
	    (set! trace-level save-trace)
	    return-value))

;;; Flushes white space characters from the input file.

(define (FLUSH-WHITE inport)
    (let ((c (and (char-ready? inport) (peek-char inport))))
	 (if (and c (not (eof-object? c)) (char-whitespace? c))
	     (begin (read-char inport)
		    (flush-white inport)))))

;;; REP is called from READ-EVAL-PRINT to actually read the commands once
;;; the initial environment is set up.

(define (REP env inport outport prompt quiet)
    (let loop ((exp #f))
	 (flush-white inport)
	 (if (and prompt (not (char-ready? inport))) (display prompt outport))
	 (set! *reading-stdin* (eq? inport stdin-port))
	 (set! exp (read inport))
	 (set! *reading-stdin* #f)
	 (cond ((eof-object? exp)
		(if prompt (newline outport)))
	       ((and (pair? exp) (memq (car exp) '(module include)))
		(flush-white inport)
		(if (not quiet)
		    (format outport "~s form ignored~%" (car exp)))
		(loop #f))
	       (else (if *emacscheme* (newline outport))
		     (set! exp (eval exp env))
		     (flush-white inport)
		     (if (not quiet) (format outport "~s~%" exp))
		     (loop #f)))))

;;; Expressions within files are loaded by the following functions.

(define (LOAD file-name)
    (with-input-from-file
	file-name
	(lambda () (read-eval-print 'header #f 'prompt #f 'load)))
    file-name)

(define (LOADQ file-name)
    (with-input-from-file
	file-name
	(lambda () (read-eval-print 'header #f 'prompt #f 'quiet 'load)))
    file-name)

(define (LOADE file-name)
    (with-input-from-file
	file-name
	(lambda () (read-eval-print 'header #f 'prompt #f 'echo 'load)))
    file-name)