repl.scm - chicken-core

~ chicken-core (chicken-5) /repl.scm
  1;;;; repl.scm - CHICKEN's read/eval/print loop
  2;
  3; Copyright (c) 2008-2022, The CHICKEN Team
  4; Copyright (c) 2000-2007, Felix L. Winkelmann
  5; All rights reserved.
  6;
  7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
  8; conditions are met:
  9;
 10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
 11;     disclaimer.
 12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
 13;     disclaimer in the documentation and/or other materials provided with the distribution.
 14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
 15;     products derived from this software without specific prior written permission.
 16;
 17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
 18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 25; POSSIBILITY OF SUCH DAMAGE.
 26
 27(declare
 28  (unit repl)
 29  (uses eval)
 30  (not inline ##sys#repl-read-hook ##sys#repl-print-hook ##sys#read-prompt-hook))
 31
 32(module chicken.repl
 33  (quit repl repl-prompt reset reset-handler)
 34
 35(import scheme
 36	chicken.base
 37	chicken.eval
 38	chicken.foreign
 39	chicken.load
 40	chicken.syntax)
 41
 42(include "common-declarations.scm")
 43
 44(define ##sys#repl-print-length-limit #f)
 45(define ##sys#repl-read-hook #f)
 46(define ##sys#repl-recent-call-chain #f) ; used in csi for ,c command
 47
 48(define (##sys#repl-print-hook x port)
 49  (##sys#with-print-length-limit ##sys#repl-print-length-limit (cut ##sys#print x #t port))
 50  (##sys#write-char-0 #\newline port))
 51
 52(define (quit-hook result) (exit))
 53(define (quit #!optional result) (quit-hook result))
 54
 55(define reset-handler ##sys#reset-handler)
 56(define (reset) ((reset-handler)))
 57
 58(define repl-prompt
 59  (make-parameter (lambda () "#;> ")))
 60
 61(define ##sys#read-prompt-hook
 62  (let ((repl-prompt repl-prompt))
 63    (lambda ()
 64      (##sys#print ((repl-prompt)) #f ##sys#standard-output)
 65      (##sys#flush-output ##sys#standard-output))))
 66
 67(define (##sys#resize-trace-buffer i)
 68  (##sys#check-fixnum i)
 69  (##core#inline "C_resize_trace_buffer" i))
 70
 71(define repl
 72  (let ((eval eval)
 73	(call-with-current-continuation call-with-current-continuation)
 74	(string-append string-append))
 75    (lambda (#!optional (evaluator eval))
 76
 77      (define (write-err xs)
 78	(for-each (cut ##sys#repl-print-hook <> ##sys#standard-error) xs))
 79
 80      (define (write-results xs)
 81	(cond ((null? xs)
 82	       (##sys#print "; no values\n" #f ##sys#standard-output))
 83	      ((not (eq? (##core#undefined) (car xs)))
 84	       (for-each (cut ##sys#repl-print-hook <> ##sys#standard-output) xs)
 85	       (when (pair? (cdr xs))
 86		 (##sys#print
 87		  (string-append "; " (##sys#number->string (length xs)) " values\n")
 88		  #f ##sys#standard-output)))))
 89
 90      (let ((stdin ##sys#standard-input)
 91	    (stdout ##sys#standard-output)
 92	    (stderr ##sys#standard-error)
 93	    (ehandler (##sys#error-handler))
 94	    (rhandler (##sys#reset-handler))
 95	    (notices ##sys#notices-enabled)
 96	    (lv #f)
 97	    (qh quit-hook)
 98	    (uie ##sys#unbound-in-eval))
 99
100	(define (saveports)
101	  (set! stdin ##sys#standard-input)
102	  (set! stdout ##sys#standard-output)
103	  (set! stderr ##sys#standard-error))
104
105	(define (resetports)
106	  (set! ##sys#standard-input stdin)
107	  (set! ##sys#standard-output stdout)
108	  (set! ##sys#standard-error stderr))
109
110	(call-with-current-continuation
111	 (lambda (k)
112	   (##sys#dynamic-wind
113	    (lambda ()
114	      (set! lv (load-verbose))
115	      (set! quit-hook (lambda (result) (k result)))
116	      (load-verbose #t)
117	      (set! ##sys#notices-enabled #t)
118	      (##sys#error-handler
119	       (lambda (msg . args)
120		 (resetports)
121		 (##sys#print "\nError" #f ##sys#standard-error)
122		 (when msg
123		   (##sys#print ": " #f ##sys#standard-error)
124		   (##sys#print msg #f ##sys#standard-error))
125		 (if (and (pair? args) (null? (cdr args)))
126		     (begin
127		       (##sys#print ": " #f ##sys#standard-error)
128		       (write-err args))
129		     (begin
130		       (##sys#write-char-0 #\newline ##sys#standard-error)
131		       (write-err args)))
132		 (set! ##sys#repl-recent-call-chain
133		   (let ((ct (or (and-let* ((lexn ##sys#last-exception) ;XXX not really right
134			  	            ((##sys#structure? lexn 'condition))
135				            (a (member '(exn . call-chain) (##sys#slot lexn 2))))
136			           (cadr a))
137                                 (get-call-chain 0 ##sys#current-thread))))
138	             (##sys#really-print-call-chain
139		      ##sys#standard-error ct
140		      "\n\tCall history:\n")
141		     ct))
142		 (flush-output ##sys#standard-error))))
143	    (lambda ()
144	      (let loop ()
145		(saveports)
146		(call-with-current-continuation
147		 (lambda (c)
148		   (##sys#reset-handler
149		    (lambda ()
150		      (set! ##sys#read-error-with-line-number #f)
151		      (resetports)
152		      (c #f)))))
153		(##sys#read-prompt-hook)
154		;; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing
155		(let ((exp ((or ##sys#repl-read-hook chicken.syntax#read-with-source-info))))
156		  (unless (eof-object? exp)
157		    (when (eq? #\newline (##sys#peek-char-0 ##sys#standard-input))
158		      (##sys#read-char-0 ##sys#standard-input))
159		    (foreign-code "C_clear_trace_buffer();")
160		    (set! ##sys#unbound-in-eval '())
161		    (receive result (evaluator exp)
162		      (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval))
163			(let loop ((vars ##sys#unbound-in-eval)
164				   (u '()))
165			  (cond ((null? vars)
166				 (when (pair? u)
167				   (when ##sys#notices-enabled
168				     (##sys#notice
169				      "the following toplevel variables are referenced but unbound:\n")
170				     (for-each
171				      (lambda (v)
172					(##sys#print "  " #f ##sys#standard-error)
173					(##sys#print (car v) #t ##sys#standard-error)
174					(when (cdr v)
175					  (##sys#print " (in " #f ##sys#standard-error)
176					  (##sys#print (cdr v) #t ##sys#standard-error)
177					  (##sys#write-char-0 #\) ##sys#standard-error))
178					(##sys#write-char-0 #\newline ##sys#standard-error))
179				      u)
180				     (##sys#flush-output ##sys#standard-error))))
181				((or (memq (caar vars) u)
182				     (##core#inline "C_u_i_namespaced_symbolp" (caar vars))
183				     (##sys#symbol-has-toplevel-binding? (caar vars)))
184				 (loop (cdr vars) u))
185				(else (loop (cdr vars) (cons (car vars) u)))) 9))
186		      (write-results result)
187		      (loop))))))
188	    (lambda ()
189	      (load-verbose lv)
190	      (set! quit-hook qh)
191	      (set! ##sys#notices-enabled notices)
192	      (set! ##sys#unbound-in-eval uie)
193	      (##sys#error-handler ehandler)
194	      (##sys#reset-handler rhandler))))))))))
Trap