repl.scm - chicken-core

~ chicken-core (master) /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(import (only (scheme base) make-parameter))
 42
 43(include "common-declarations.scm")
 44
 45(define ##sys#repl-print-length-limit #f)
 46(define ##sys#repl-read-hook #f)
 47(define ##sys#repl-recent-call-chain #f) ; used in csi for ,c command
 48
 49(define (##sys#repl-print-hook x port)
 50  (##sys#with-print-length-limit ##sys#repl-print-length-limit (cut ##sys#print x #t port))
 51  (##sys#write-char-0 #\newline port))
 52
 53(define (quit-hook result) (exit))
 54(define (quit #!optional result) (quit-hook result))
 55
 56(define reset-handler ##sys#reset-handler)
 57(define (reset) ((reset-handler)))
 58
 59(define repl-prompt
 60  (make-parameter (lambda () "#;> ")))
 61
 62(define ##sys#read-prompt-hook
 63  (let ((repl-prompt repl-prompt))
 64    (lambda ()
 65      (##sys#print ((repl-prompt)) #f ##sys#standard-output)
 66      (##sys#flush-output ##sys#standard-output))))
 67
 68(define (##sys#resize-trace-buffer i)
 69  (##sys#check-fixnum i)
 70  (##core#inline "C_resize_trace_buffer" i))
 71
 72(define repl
 73  (let ((eval eval)
 74	(call-with-current-continuation call-with-current-continuation)
 75	(string-append string-append))
 76    (lambda (#!optional (evaluator eval))
 77
 78      (define (write-err xs)
 79	(for-each (cut ##sys#repl-print-hook <> ##sys#standard-error) xs))
 80
 81      (define (write-results xs)
 82	(cond ((null? xs)
 83	       (##sys#print "; no values\n" #f ##sys#standard-output))
 84	      ((not (eq? (##core#undefined) (car xs)))
 85	       (for-each (cut ##sys#repl-print-hook <> ##sys#standard-output) xs)
 86	       (when (pair? (cdr xs))
 87		 (##sys#print
 88		  (string-append "; " (##sys#number->string (length xs)) " values\n")
 89		  #f ##sys#standard-output)))))
 90
 91      (let ((stdin ##sys#standard-input)
 92	    (stdout ##sys#standard-output)
 93	    (stderr ##sys#standard-error)
 94	    (ehandler (##sys#error-handler))
 95	    (rhandler (##sys#reset-handler))
 96	    (notices ##sys#notices-enabled)
 97	    (lv #f)
 98	    (qh quit-hook)
 99	    (uie ##sys#unbound-in-eval))
100
101	(define (saveports)
102	  (set! stdin ##sys#standard-input)
103	  (set! stdout ##sys#standard-output)
104	  (set! stderr ##sys#standard-error))
105
106	(define (resetports)
107	  (set! ##sys#standard-input stdin)
108	  (set! ##sys#standard-output stdout)
109	  (set! ##sys#standard-error stderr))
110
111	(call-with-current-continuation
112	 (lambda (k)
113	   (##sys#dynamic-wind
114	    (lambda ()
115	      (set! lv (load-verbose))
116	      (set! quit-hook (lambda (result) (k result)))
117	      (load-verbose #t)
118	      (set! ##sys#notices-enabled #t)
119	      (##sys#error-handler
120	       (lambda (msg . args)
121		 (resetports)
122		 (##sys#print "\nError" #f ##sys#standard-error)
123		 (when msg
124		   (##sys#print ": " #f ##sys#standard-error)
125		   (##sys#print msg #f ##sys#standard-error))
126		 (if (and (pair? args) (null? (cdr args)))
127		     (begin
128		       (##sys#print ": " #f ##sys#standard-error)
129		       (write-err args))
130		     (begin
131		       (##sys#write-char-0 #\newline ##sys#standard-error)
132		       (write-err args)))
133		 (set! ##sys#repl-recent-call-chain
134		   (let ((ct (or (and-let* ((lexn ##sys#last-exception) ;XXX not really right
135			  	            ((##sys#structure? lexn 'condition))
136				            (a (member '(exn . call-chain) (##sys#slot lexn 2))))
137			           (cadr a))
138                                 (get-call-chain 0 ##sys#current-thread))))
139	             (##sys#really-print-call-chain
140		      ##sys#standard-error ct
141		      "\n\tCall history:\n")
142		     ct))
143		 (flush-output ##sys#standard-error))))
144	    (lambda ()
145	      (let loop ()
146		(saveports)
147		(call-with-current-continuation
148		 (lambda (c)
149		   (##sys#reset-handler
150		    (lambda ()
151		      (set! ##sys#read-error-with-line-number #f)
152		      (resetports)
153		      (c #f)))))
154		(##sys#read-prompt-hook)
155		;; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing
156		(let ((exp ((or ##sys#repl-read-hook chicken.syntax#read-with-source-info))))
157		  (unless (eof-object? exp)
158		    (when (eq? #\newline (##sys#peek-char-0 ##sys#standard-input))
159		      (##sys#read-char-0 ##sys#standard-input))
160		    (foreign-code "C_clear_trace_buffer();")
161		    (set! ##sys#unbound-in-eval '())
162		    (receive result (evaluator exp)
163		      (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval))
164			(let loop ((vars ##sys#unbound-in-eval)
165				   (u '()))
166			  (cond ((null? vars)
167				 (when (pair? u)
168				   (when ##sys#notices-enabled
169				     (##sys#notice
170				      "the following toplevel variables are referenced but unbound:\n")
171				     (for-each
172				      (lambda (v)
173					(##sys#print "  " #f ##sys#standard-error)
174					(##sys#print (car v) #t ##sys#standard-error)
175					(when (cdr v)
176					  (##sys#print " (in " #f ##sys#standard-error)
177					  (##sys#print (cdr v) #t ##sys#standard-error)
178					  (##sys#write-char-0 #\) ##sys#standard-error))
179					(##sys#write-char-0 #\newline ##sys#standard-error))
180				      u)
181				     (##sys#flush-output ##sys#standard-error))))
182				((or (memq (caar vars) u)
183				     (##core#inline "C_u_i_namespaced_symbolp" (caar vars))
184				     (##sys#symbol-has-toplevel-binding? (caar vars)))
185				 (loop (cdr vars) u))
186				(else (loop (cdr vars) (cons (car vars) u)))) 9))
187		      (write-results result)
188		      (loop))))))
189	    (lambda ()
190	      (load-verbose lv)
191	      (set! quit-hook qh)
192	      (set! ##sys#notices-enabled notices)
193	      (set! ##sys#unbound-in-eval uie)
194	      (##sys#error-handler ehandler)
195	      (##sys#reset-handler rhandler))))))))))
Trap