Context Navigation

source: project/chicken/branches/hygienic/csi.scm @ 10753

Last change on this file since 10753 was 10753, checked in by felix winkelmann, 13 years ago
chicken import lib, trivial fixes, foreign import lib (untested)
File size: 31.6 KB

Line
1	;;;; csi.scm - Interpreter stub for CHICKEN
2	;
3	; Copyright (c) 2000-2007, Felix L. Winkelmann
4	; Copyright (c) 2008, The Chicken Team
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
28	(declare
29	(usual-integrations)
30	(disable-interrupts)
31	(disable-warning var)
32	(run-time-macros) ;*** later: compile-syntax
33	(foreign-declare #<<EOF
34	#if (defined(_MSC_VER) && defined(_WIN32)) \|\| defined(HAVE_DIRECT_H)
35	# include <direct.h>
36	#else
37	# define _getcwd(buf, len) NULL
38	#endif
39	EOF
40	) )
41
42	(include "chicken-more-macros")
43	(include "banner")
44
45	(private csi
46	print-usage print-banner
47	run hexdump del
48	parse-option-string chop-separator lookup-script-file
49	report describe dump hexdump bytevector-data get-config
50	deldups tty-input?
51	history-list history-count history-add history-ref
52	trace-indent trace-indent-level traced-procedure-entry traced-procedure-exit)
53
54	(declare
55	(always-bound
56	##sys#windows-platform)
57	(hide parse-option-string bytevector-data member* canonicalize-args do-trace do-untrace
58	traced-procedures describer-table dirseparator?
59	findall trace-indent command-table do-break do-unbreak broken-procedures) )
60
61
62	;;; Parameters:
63
64	(define-constant init-file ".csirc")
65
66	(set! ##sys#repl-print-length-limit 2048)
67	(set! ##sys#features (cons #:csi ##sys#features))
68
69
70	;;; Print all sorts of information:
71
72	(define (print-usage)
73	(display
74	"usage: csi [FILENAME \| OPTION ...]
75
76	where OPTION may be one of the following:
77
78	-h -help --help display this text and exit
79	-v -version display version and exit
80	-release print release number and exit
81	-i -case-insensitive enable case-insensitive reading
82	-e -eval EXPRESSION evaluate given expression
83	-p -print EXPRESSION evaluate and print result(s)
84	-P -pretty-print EXPRESSION evaluate and print result(s) prettily
85	-D -feature SYMBOL register feature identifier
86	-q -quiet do not print banner
87	-n -no-init do not load initialization file `")
88	(display init-file)
89	(display
90	"'
91	-b -batch terminate after command-line processing
92	-w -no-warnings disable all warnings
93	-k -keyword-style STYLE enable alternative keyword-syntax (none, prefix or suffix)
94	-s -script PATHNAME use interpreter for shell scripts
95	-ss PATHNAME shell script with `main' procedure
96	-se PATHNAME same as `-s', but print each expression as it is evaluated
97	-R -require-extension NAME require extension before executing code
98	-I -include-path PATHNAME add PATHNAME to include path
99	-- ignore all following options
100
101	") )
102
103	(define (print-banner)
104	(print +banner+ (chicken-version #t) "\n") )
105
106
107	;;; Reader for REPL history:
108
109	(set! ##sys#user-read-hook
110	(let ([read-char read-char]
111	[read read]
112	[old-hook ##sys#user-read-hook] )
113	(lambda (char port)
114	(cond [(or (char=? #\) char) (char-whitespace? char))
115	`',(history-ref (fx- history-count 1)) ]
116	[else (old-hook char port)] ) ) ) )
117
118	(set! ##sys#sharp-number-hook
119	(lambda (port n)
120	`',(history-ref n) ) )
121
122
123	;;; Chop terminating separator from pathname:
124
125	(define (dirseparator? c)
126	(or (char=? c #\\) (char=? c #\/)))
127
128	(define chop-separator
129	(let ([substring substring] )
130	(lambda (str)
131	(let* ((len (sub1 (##sys#size str)))
132	(c (string-ref str len)))
133	(if (and (fx> len 0) (dirseparator? c))
134	(substring str 0 len)
135	str) ) ) ) )
136
137
138	;;; Find script in PATH (only used for Windows/DOS):
139
140	(define @ #f)
141
142	(define lookup-script-file
143	(let* ([buf (make-string 256)]
144	[_getcwd (foreign-lambda nonnull-c-string "_getcwd" scheme-pointer int)] )
145	(define (addext name)
146	(if (file-exists? name)
147	name
148	(let ([n2 (string-append name ".bat")])
149	(and (file-exists? n2) n2) ) ) )
150	(define (string-index proc str1)
151	(let ((len (##sys#size str1)))
152	(let loop ((i 0))
153	(cond ((fx>= i len) #f)
154	((proc (##core#inline "C_subchar" str1 i)) i)
155	(else (loop (fx+ i 1))) ) ) ) )
156	(lambda (name)
157	(let ([path (getenv "PATH")])
158	(and (> (##sys#size name) 0)
159	(cond [(dirseparator? (string-ref name 0)) (addext name)]
160	[(string-index dirseparator? name)
161	(and-let* ([p (_getcwd buf 256)])
162	(addext (string-append (chop-separator p) "/" name)) ) ]
163	[(addext name)]
164	[else
165	(let ([name2 (string-append "/" name)])
166	(let loop ([ps (string-split path ";")])
167	(and (pair? ps)
168	(let ([name2 (string-append (chop-separator (##sys#slot ps 0)) name2)])
169	(or (addext name2)
170	(loop (##sys#slot ps 1)) ) ) ) ) ) ] ) ) ) ) ) )
171
172
173	;;; REPL customization:
174
175	(define history-list (make-vector 32))
176	(define history-count 1)
177
178	(define history-add
179	(let ([vector-resize vector-resize])
180	(lambda (vals)
181	(let ([x (if (null? vals) (##sys#void) (##sys#slot vals 0))]
182	[size (##sys#size history-list)] )
183	(when (fx>= history-count size)
184	(set! history-list (vector-resize history-list (fx* 2 size))) )
185	(vector-set! history-list history-count x)
186	(set! history-count (fx+ history-count 1))
187	x) ) ) )
188
189	(define (history-ref index)
190	(let ([i (inexact->exact index)])
191	(if (and (fx> i 0) (fx<= i history-count))
192	(vector-ref history-list i)
193	(##sys#error "history entry index out of range" index) ) ) )
194
195	(repl-prompt
196	(let ([sprintf sprintf])
197	(lambda ()
198	(sprintf "#;~A> " history-count) ) ) )
199
200	(define (tty-input?)
201	(or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input)) )
202
203	(set! ##sys#break-on-error #f)
204
205	(set! ##sys#read-prompt-hook
206	(let ([old ##sys#read-prompt-hook])
207	(lambda ()
208	(when (tty-input?) (old)) ) ) )
209
210	(define command-table (make-vector 37 '()))
211
212	(define (toplevel-command name proc #!optional help)
213	(##sys#check-symbol name 'toplevel-command)
214	(when help (##sys#check-string help 'toplevel-command))
215	(##sys#hash-table-set! command-table name (cons proc help)) )
216
217	(set! ##sys#repl-eval-hook
218	(let ((eval eval)
219	(load-noisily load-noisily)
220	(read read)
221	(singlestep singlestep)
222	(read-line read-line)
223	(length length)
224	(display display)
225	(write write)
226	(string-split string-split)
227	(printf printf)
228	(expand expand)
229	(pretty-print pretty-print)
230	(integer? integer?)
231	(values values) )
232	(lambda (form)
233	(set! trace-indent-level 0)
234	(cond ((eof-object? form) (exit))
235	((and (pair? form)
236	(eq? 'unquote (##sys#slot form 0)) )
237	(let ((cmd (cadr form)))
238	(cond ((and (symbol? cmd) (##sys#hash-table-ref command-table cmd)) =>
239	(lambda (p)
240	((car p))
241	(##sys#void) ) )
242	(else
243	(case cmd
244	((x)
245	(let ([x (read)])
246	(pretty-print (##sys#strip-syntax (expand x)))
247	(##sys#void) ) )
248	((p)
249	(let* ([x (read)]
250	[xe (eval x)] )
251	(pretty-print xe)
252	(##sys#void) ) )
253	((d)
254	(let* ([x (read)]
255	[xe (eval x)] )
256	(describe xe) ) )
257	((du)
258	(let* ([x (read)]
259	[xe (eval x)] )
260	(dump xe) ) )
261	((dur)
262	(let* ([x (read)]
263	[n (read)]
264	[xe (eval x)]
265	[xn (eval n)] )
266	(dump xe xn) ) )
267	((r) (report))
268	((q) (exit))
269	((l)
270	(let ((fns (string-split (read-line))))
271	(for-each load fns)
272	(##sys#void) ) )
273	((ln)
274	(let ((fns (string-split (read-line))))
275	(for-each (cut load-noisily <> printer: (lambda (x) (pretty-print x) (print* "==> "))) fns)
276	(##sys#void) ) )
277	((t)
278	(let ((x (read)))
279	(receive rs (time (eval x))
280	(history-add rs)
281	(apply values rs) ) ) )
282	((tr) (do-trace (map string->symbol (string-split (read-line)))))
283	((utr) (do-untrace (map string->symbol (string-split (read-line)))))
284	((br) (do-break (map string->symbol (string-split (read-line)))))
285	((ubr) (do-unbreak (map string->symbol (string-split (read-line)))))
286	((uba) (do-unbreak-all))
287	((breakall)
288	(set! ##sys#break-in-thread #f) )
289	((breakonly)
290	(set! ##sys#break-in-thread (eval (read))) )
291	((info)
292	(when (pair? traced-procedures)
293	(printf "Traced: ~s~%" (map car traced-procedures)) )
294	(when (pair? broken-procedures)
295	(printf "Breakpoints: ~s~%" (map car broken-procedures)) ) )
296	((c)
297	(cond (##sys#last-breakpoint
298	(let ((exn ##sys#last-breakpoint))
299	(set! ##sys#last-breakpoint #f)
300	(##sys#break-resume exn) ) )
301	(else (display "no breakpoint pending\n") ) ) )
302	((exn)
303	(when ##sys#last-exception
304	(history-add (list ##sys#last-exception))
305	(describe ##sys#last-exception) ) )
306	((step)
307	(let ((x (read)))
308	(read-line)
309	(singlestep (eval `(lambda () ,x))) ) )
310	((s)
311	(let* ((str (read-line))
312	(r (system str)) )
313	(history-add (list r))
314	r) )
315	((?)
316	(display
317	"Toplevel commands:
318
319	,? Show this text
320	,p EXP Pretty print evaluated expression EXP
321	,d EXP Describe result of evaluated expression EXP
322	,du EXP Dump data of expression EXP
323	,dur EXP N Dump range
324	,q Quit interpreter
325	,l FILENAME ... Load one or more files
326	,ln FILENAME ... Load one or more files and print result of each top-level expression
327	,r Show system information
328	,s TEXT ... Execute shell-command
329	,tr NAME ... Trace procedures
330	,utr NAME ... Untrace procedures
331	,br NAME ... Set breakpoints
332	,ubr NAME ... Remove breakpoints
333	,uba Remove all breakpoints
334	,breakall Break in all threads (default)
335	,breakonly THREAD Break only in specified thread
336	,c Continue from breakpoint
337	,info List traced procedures and breakpoints
338	,step EXPR Execute EXPR in single-stepping mode
339	,exn Describe last exception
340	,t EXP Evaluate form and print elapsed time
341	,x EXP Pretty print expanded expression EXP\n")
342	(##sys#hash-table-for-each
343	(lambda (k v)
344	(let ((help (cdr v)))
345	(if help
346	(print #\space help)
347	(print " ," k) ) ) )
348	command-table)
349	(##sys#void) )
350	(else
351	(printf "Undefined toplevel command ~s - enter `,?' for help~%" form)
352	(##sys#void) ) ) ) ) ) )
353	(else
354	(receive rs (eval form)
355	(history-add rs)
356	(apply values rs) ) ) ) ) ) )
357
358
359	;;; Tracing:
360
361	(define (del x lst tst)
362	(let loop ([lst lst])
363	(if (null? lst)
364	'()
365	(let ([y (car lst)])
366	(if (tst x y)
367	(cdr lst)
368	(cons y (loop (cdr lst))) ) ) ) ) )
369
370	(define trace-indent-level 0)
371	(define traced-procedures '())
372	(define broken-procedures '())
373
374	(define trace-indent
375	(lambda ()
376	(write-char #\\|)
377	(do ((i trace-indent-level (sub1 i)))
378	((<= i 0))
379	(write-char #\space) ) ) )
380
381	(define traced-procedure-entry
382	(lambda (name args)
383	(trace-indent)
384	(set! trace-indent-level (add1 trace-indent-level))
385	(write (cons name args))
386	(##sys#write-char-0 #\newline ##sys#standard-output)
387	(flush-output) ) )
388
389	(define traced-procedure-exit
390	(lambda (name results)
391	(set! trace-indent-level (sub1 trace-indent-level))
392	(trace-indent)
393	(write name)
394	(display " -> ")
395	(for-each
396	(lambda (x)
397	(write x)
398	(write-char #\space) )
399	results)
400	(##sys#write-char-0 #\newline ##sys#standard-output)
401	(flush-output) ) )
402
403	(define do-trace
404	(lambda (names)
405	(if (null? names)
406	(for-each (lambda (a) (print (car a))) traced-procedures)
407	(for-each
408	(lambda (s)
409	(let ((s (expand s)))
410	(cond ((assq s traced-procedures)
411	(##sys#warn "procedure already traced" s) )
412	((assq s broken-procedures)
413	(##sys#warn "procedure already has breakpoint") )
414	(else
415	(let ((old (##sys#slot s 0)))
416	(cond ((not (procedure? old)) (##sys#error "can not trace non-procedure" s))
417	(else
418	(set! traced-procedures (cons (cons s old) traced-procedures))
419	(##sys#setslot
420	s 0
421	(lambda args
422	(traced-procedure-entry s args)
423	(call-with-values (lambda () (apply old args))
424	(lambda results
425	(traced-procedure-exit s results)
426	(apply values results) ) ) ) ) ) ) ) ) ) ) )
427	names) ) ) )
428
429	(define do-untrace
430	(lambda (names)
431	(for-each
432	(lambda (s)
433	(let* ((s (expand s))
434	(p (assq s traced-procedures)) )
435	(cond ((not p) (##sys#warn "procedure not traced" s))
436	(else
437	(##sys#setslot s 0 (cdr p))
438	(set! traced-procedures (del p traced-procedures eq?) ) ) ) ) )
439	names) ) )
440
441	(define do-break
442	(lambda (names)
443	(if (null? names)
444	(for-each (lambda (b) (print (car a))) broken-procedures)
445	(for-each
446	(lambda (s)
447	(let* ((s (expand s))
448	(a (assq s traced-procedures)))
449	(when a
450	(##sys#warn "un-tracing procedure" s)
451	(##sys#setslot s 0 (cdr a))
452	(set! traced-procedures (del a traced-procedures eq?)) )
453	(let ((old (##sys#slot s 0)))
454	(cond ((not (procedure? old)) (##sys#error "can not set breakpoint on non-procedure" s))
455	(else
456	(set! broken-procedures (cons (cons s old) broken-procedures))
457	(##sys#setslot
458	s 0
459	(lambda args
460	(##sys#break-entry s args)
461	(##sys#apply old args) ) ) ) ) ) ) )
462	names) ) ) )
463
464	(define do-unbreak
465	(lambda (names)
466	(for-each
467	(lambda (s)
468	(let* ((s (expand s))
469	(p (assq s broken-procedures)) )
470	(cond ((not p) (##sys#warn "procedure has no breakpoint" s))
471	(else
472	(##sys#setslot s 0 (cdr p))
473	(set! broken-procedures (del p broken-procedures eq?) ) ) ) ) )
474	names) ) )
475
476	(define do-unbreak-all
477	(lambda ()
478	(for-each (lambda (bp)
479	(##sys#setslot (car bp) 0 (cdr bp)))
480	broken-procedures)
481	(set! broken-procedures '())
482	(##sys#void)))
483
484	;;; Parse options from string:
485
486	(define (parse-option-string str)
487	(let ([ins (open-input-string str)])
488	(map (lambda (o)
489	(if (string? o)
490	o
491	(let ([os (open-output-string)])
492	(write o os)
493	(get-output-string os) ) ) )
494	(handle-exceptions ex (##sys#error "invalid option syntax" str)
495	(do ([x (read ins) (read ins)]
496	[xs '() (cons x xs)] )
497	((eof-object? x) (reverse xs)) ) ) ) ) )
498
499
500	;;; Print status information:
501
502	(define report
503	(let ((printf printf)
504	(chop chop)
505	(sort sort)
506	(with-output-to-port with-output-to-port)
507	(current-output-port current-output-port) )
508	(lambda port
509	(with-output-to-port (if (pair? port) (car port) (current-output-port))
510	(lambda ()
511	(gc)
512	(let ([sinfo (##sys#symbol-table-info)]
513	[minfo (memory-statistics)] )
514	(define (shorten n) (/ (truncate (* n 100)) 100))
515	(printf "Features:")
516	(for-each
517	(lambda (lst)
518	(display "\n ")
519	(for-each
520	(lambda (f)
521	(printf "~a~a" f (make-string (fxmax 1 (fx- 16 (string-length f))) #\space)) )
522	lst) )
523	(chop (sort (map keyword->string ##sys#features) string<?) 5))
524	(printf "~%~
525	Machine type: \t~A ~A~%~
526	Software type: \t~A~%~
527	Software version:\t~A~%~
528	Build platform: \t~A~%~
529	Include path: \t~A~%~
530	Symbol-table load:\t~S~% ~
531	Avg bucket length:\t~S~% ~
532	Total symbols:\t~S~%~
533	Memory:\theap size is ~S bytes~A with ~S bytes currently in use~%~
534	nursery size is ~S bytes, stack grows ~A~%"
535	(machine-type)
536	(if (##sys#fudge 3) "(64-bit)" "")
537	(software-type)
538	(software-version)
539	(build-platform)
540	##sys#include-pathnames
541	(shorten (vector-ref sinfo 0))
542	(shorten (vector-ref sinfo 1))
543	(vector-ref sinfo 2)
544	(vector-ref minfo 0)
545	(if (##sys#fudge 17) " (fixed)" "")
546	(vector-ref minfo 1)
547	(vector-ref minfo 2)
548	(if (= 1 (##sys#fudge 18)) "downward" "upward") )
549	(##sys#write-char-0 #\newline ##sys#standard-output)
550	(when (##sys#fudge 14) (display "interrupts are enabled\n"))
551	(when (##sys#fudge 15) (display "symbol gc is enabled\n"))
552	(##core#undefined) ) ) ) ) ) )
553
554
555	;;; Describe & dump:
556
557	(define bytevector-data
558	'((u8vector "vector of unsigned bytes" u8vector-length u8vector-ref)
559	(s8vector "vector of signed bytes" s8vector-length s8vector-ref)
560	(u16vector "vector of unsigned 16-bit words" u16vector-length u16vector-ref)
561	(s16vector "vector of signed 16-bit words" s16vector-length s16vector-ref)
562	(u32vector "vector of unsigned 32-bit words" u32vector-length u32vector-ref)
563	(s32vector "vector of signed 32-bit words" s32vector-length s32vector-ref)
564	(f32vector "vector of 32-bit floats" f32vector-length f32vector-ref)
565	(f64vector "vector of 64-bit floats" f64vector-length f64vector-ref) ) )
566
567	(define-constant max-describe-lines 40)
568
569	(define describer-table (make-vector 37 '()))
570
571	(define describe
572	(let ([sprintf sprintf]
573	[printf printf]
574	[fprintf fprintf]
575	[length length]
576	[list-ref list-ref]
577	[string-ref string-ref])
578	(lambda (x #!optional (out ##sys#standard-output))
579	(define (descseq name plen pref start)
580	(let ((len (fx- (plen x) start)))
581	(when name (fprintf out "~A of length ~S~%" name len))
582	(let loop1 ((i 0))
583	(cond ((fx>= i len))
584	((fx>= i max-describe-lines)
585	(fprintf out "~% (~A elements not displayed)~%" (fx- len i)) )
586	(else
587	(let ((v (pref x (fx+ start i))))
588	(let loop2 ((n 1) (j (fx+ i (fx+ start 1))))
589	(cond ((fx>= j len)
590	(fprintf out " ~S: ~S" i v)
591	(if (fx> n 1)
592	(fprintf out "\t(followed by ~A identical instance~a)~% ...~%"
593	(fx- n 1)
594	(if (eq? n 2) "" "s"))
595	(newline out) )
596	(loop1 (fx+ i n)) )
597	((eq? v (pref x j)) (loop2 (fx+ n 1) (fx+ j 1)))
598	(else (loop2 n len)) ) ) ) ) ) ) ) )
599	(when (##sys#permanent? x)
600	(fprintf out "statically allocated (0x~X) " (##sys#block-address x)) )
601	(cond [(char? x)
602	(let ([code (char->integer x)])
603	(fprintf out "character ~S, code: ~S, #x~X, #o~O~%" x code code code) ) ]
604	[(eq? x #t) (fprintf out "boolean true~%")]
605	[(eq? x #f) (fprintf out "boolean false~%")]
606	[(null? x) (fprintf out "empty list~%")]
607	[(eof-object? x) (fprintf out "end-of-file object~%")]
608	[(eq? (##sys#void) x) (fprintf out "unspecified object~%")]
609	[(fixnum? x)
610	(fprintf out "exact integer ~S, #x~X, #o~O, #b~B" x x x x)
611	(let ([code (integer->char x)])
612	(when (fx< code #x10000) (fprintf out ", character ~S" code)) )
613	(##sys#write-char-0 #\newline ##sys#standard-output) ]
614	[(eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))
615	(fprintf out "unbound value~%") ]
616	[(##sys#number? x) (fprintf out "number ~S~%" x)]
617	[(string? x) (descseq "string" ##sys#size string-ref 0)]
618	[(vector? x) (descseq "vector" ##sys#size ##sys#slot 0)]
619	[(symbol? x)
620	(unless (##sys#symbol-has-toplevel-binding? x) (display "unbound " out))
621	(when (and (symbol? x) (fx= 0 (##sys#byte (##sys#slot x 1) 0)))
622	(display "keyword " out) )
623	(fprintf out "symbol with name ~S~%" (##sys#symbol->string x))
624	(let ((plist (##sys#slot x 2)))
625	(unless (null? plist)
626	(display " \nproperties:\n\n" out)
627	(do ((plist plist (cddr plist)))
628	((null? plist))
629	(fprintf out " ~s\t" (car plist))
630	(##sys#with-print-length-limit
631	1000
632	(lambda ()
633	(write (cadr plist) out) ) )
634	(newline out) ) ) ) ]
635	[(list? x) (descseq "list" length list-ref 0)]
636	[(pair? x) (fprintf out "pair with car ~S and cdr ~S~%" (car x) (cdr x))]
637	[(procedure? x)
638	(let ([len (##sys#size x)])
639	(if (and (> len 3)
640	(memq #:tinyclos ##sys#features)
641	(eq? ##tinyclos#entity-tag (##sys#slot x (fx- len 1))) ) ;XXX handle this in tinyclos egg (difficult)
642	(describe-object x out)
643	(descseq
644	(sprintf "procedure with code pointer ~X" (##sys#peek-unsigned-integer x 0))
645	##sys#size ##sys#slot 1) ) ) ]
646	[(port? x)
647	(fprintf out
648	"~A port of type ~A with name ~S and file pointer ~X~%"
649	(if (##sys#slot x 1) "input" "output")
650	(##sys#slot x 7)
651	(##sys#slot x 3)
652	(##sys#peek-unsigned-integer x 0) ) ]
653	[(and (memq #:tinyclos ##sys#features) (instance? x)) ; XXX put into tinyclos egg
654	(describe-object x out) ]
655	[(##sys#locative? x)
656	(fprintf out "locative~% pointer ~X~% index ~A~% type ~A~%"
657	(##sys#peek-unsigned-integer x 0)
658	(##sys#slot x 1)
659	(case (##sys#slot x 2)
660	[(0) "slot"]
661	[(1) "char"]
662	[(2) "u8vector"]
663	[(3) "s8vector"]
664	[(4) "u16vector"]
665	[(5) "s16vector"]
666	[(6) "u32vector"]
667	[(7) "s32vector"]
668	[(8) "f32vector"]
669	[(9) "f64vector"] ) ) ]
670	[(##sys#pointer? x) (fprintf out "machine pointer ~X~%" (##sys#peek-unsigned-integer x 0))]
671	[(##sys#bytevector? x)
672	(let ([len (##sys#size x)])
673	(fprintf out "blob of size ~S:~%" len)
674	(hexdump x len ##sys#byte out) ) ]
675	[(##core#inline "C_lambdainfop" x)
676	(fprintf out "lambda information: ~s~%" (##sys#lambda-info->string x)) ]
677	[(##sys#structure? x 'hash-table)
678	(let ((n (##sys#slot x 2)))
679	(fprintf out "hash-table with ~S element~a~% comparison procedure: ~A~%"
680	n (if (fx= n 1) "" "s") (##sys#slot x 3)) )
681	(fprintf out " hash function: ~a~%" (##sys#slot x 4))
682	(hash-table-walk ; blindly assumes it is bound
683	x
684	(lambda (k v) (fprintf out " ~S\t-> ~S~%" k v)) ) ]
685	[(##sys#structure? x 'condition)
686	(fprintf out "condition: ~s~%" (##sys#slot x 1))
687	(for-each
688	(lambda (k)
689	(fprintf out " ~s~%" k)
690	(let loop ((props (##sys#slot x 2)))
691	(unless (null? props)
692	(when (eq? k (caar props))
693	(fprintf out "\t~s: ~s~%" (cdar props) (cadr props)) )
694	(loop (cddr props)) ) ) )
695	(##sys#slot x 1) ) ]
696	[(and (##sys#structure? x 'meroon-instance) (provided? 'meroon)) ; XXX put this into meroon egg (really!)
697	(unveil x out) ]
698	[(##sys#generic-structure? x)
699	(let ([st (##sys#slot x 0)])
700	(cond ((##sys#hash-table-ref describer-table st) => (cut <> x out))
701	((assq st bytevector-data) =>
702	(lambda (data)
703	(apply descseq (append (map eval (cdr data)) (list 0)))) )
704	(else
705	(fprintf out "structure of type `~S':~%" (##sys#slot x 0))
706	(descseq #f ##sys#size ##sys#slot 1) ) ) ) ]
707	[else (fprintf out "unknown object~%")] )
708	(##sys#void) ) ) )
709
710	(define (set-describer! tag proc)
711	(##sys#check-symbol tag 'symbol 'set-describer!)
712	(##sys#hash-table-set! describer-table tag proc) )
713
714
715	;;; Display hexdump:
716
717	(define dump
718	(lambda (x . len-out)
719	(let-optionals len-out
720	([len #f]
721	[out ##sys#standard-output] )
722	(define (bestlen n) (if len (min len n) n))
723	(cond [(##sys#immediate? x) (##sys#error 'dump "can not dump immediate object" x)]
724	[(##sys#bytevector? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]
725	[(string? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]
726	[(and (not (##sys#immediate? x)) (##sys#pointer? x))
727	(hexdump x 32 ##sys#peek-byte out) ]
728	[(and (##sys#generic-structure? x) (assq (##sys#slot x 0) bytevector-data))
729	(let ([bv (##sys#slot x 1)])
730	(hexdump bv (bestlen (##sys#size bv)) ##sys#byte out) ) ]
731	[else (##sys#error 'dump "can not dump object" x)] ) ) ) )
732
733	(define hexdump
734	(let ([display display]
735	[string-append string-append]
736	[make-string make-string]
737	[write-char write-char] )
738	(lambda (bv len ref out)
739
740	(define (justify n m base lead)
741	(let* ([s (number->string n base)]
742	[len (##sys#size s)] )
743	(if (fx< len m)
744	(string-append (make-string (fx- m len) lead) s)
745	s) ) )
746
747	(do ([a 0 (fx+ a 16)])
748	((fx>= a len))
749	(display (justify a 4 10 #\space) out)
750	(write-char #\: out)
751	(do ([j 0 (fx+ j 1)]
752	[a a (fx+ a 1)] )
753	((or (fx>= j 16) (fx>= a len))
754	(and-let* ([(fx>= a len)]
755	[o (fxmod len 16)]
756	[(not (fx= o 0))] )
757	(do ([k (fx- 16 o) (fx- k 1)])
758	((fx= k 0))
759	(display " " out) ) ) )
760	(write-char #\space out)
761	(display (justify (ref bv a) 2 16 #\0) out) )
762	(write-char #\space out)
763	(do ([j 0 (fx+ j 1)]
764	[a a (fx+ a 1)] )
765	((or (fx>= j 16) (fx>= a len)))
766	(let ([c (ref bv a)])
767	(if (and (fx>= c 32) (fx< c 128))
768	(write-char (integer->char c) out)
769	(write-char #\. out) ) ) )
770	(##sys#write-char-0 #\newline out) ) ) ) )
771
772
773	;;; Start interpreting:
774
775	(define (deldups lis . maybe-=)
776	(let ((elt= (optional maybe-= equal?)))
777	(let recur ((lis lis))
778	(if (null? lis) lis
779	(let* ((x (car lis))
780	(tail (cdr lis))
781	(new-tail (recur (del x tail elt=))))
782	(if (eq? tail new-tail) lis (cons x new-tail)))))))
783
784	(define (member* keys set)
785	(let loop ((set set))
786	(and (pair? set)
787	(let find ((ks keys))
788	(cond ((null? ks) (loop (cdr set)))
789	((equal? (car ks) (car set)) set)
790	(else (find (cdr ks))) ) ) ) ) )
791
792	(define-constant short-options
793	'(#\k #\s #\v #\h #\D #\e #\i #\R #\b #\n #\q #\w #\- #\I #\p #\P) )
794
795	(define-constant long-options
796	'("-keyword-style" "-script" "-version" "-help" "--help" "--" "-feature"
797	"-eval" "-case-insensitive"
798	"-require-extension" "-batch" "-quiet" "-no-warnings" "-no-init"
799	"-include-path" "-release" "-ss" "-se"
800	"-print" "-pretty-print") )
801
802	(define (canonicalize-args args)
803	(let loop ((args args))
804	(if (null? args)
805	'()
806	(let ((x (car args)))
807	(cond
808	((member x '("-s" "-ss" "-script" "--")) args)
809	((and (fx> (##sys#size x) 2)
810	(char=? #\- (##core#inline "C_subchar" x 0))
811	(not (member x long-options)) )
812	(if (char=? #\: (##core#inline "C_subchar" x 1))
813	(loop (cdr args))
814	(let ((cs (string->list (substring x 1))))
815	(if (findall cs short-options)
816	(append (map (cut string #\- <>) cs) (loop (cdr args)))
817	(##sys#error "invalid option" x) ) ) ) )
818	(else (cons x (loop (cdr args)))))))))
819
820	(define (findall chars clist)
821	(let loop ((chars chars))
822	(or (null? chars)
823	(and (memq (car chars) clist)
824	(loop (cdr chars))))))
825
826	(define (run)
827	(let* ([extraopts (parse-option-string (or (getenv "CSI_OPTIONS") ""))]
828	[args (canonicalize-args (command-line-arguments))]
829	[kwstyle (member* '("-k" "-keyword-style") args)]
830	[script (member* '("-s" "-ss" "-se" "-script") args)])
831	(cond [script
832	(when (or (not (pair? (cdr script)))
833	(zero? (string-length (cadr script)))
834	(char=? #\- (string-ref (cadr script) 0)) )
835	(##sys#error "missing or invalid script argument"))
836	(program-name (cadr script))
837	(command-line-arguments (cddr script))
838	(register-feature! 'script)
839	(set-cdr! (cdr script) '())
840	(when ##sys#windows-platform
841	(and-let* ((sname (lookup-script-file (cadr script))))
842	(set-car! (cdr script) sname) ) ) ]
843	[else
844	(set! args (append (canonicalize-args extraopts) args))
845	(and-let* ([p (member "--" args)])
846	(set-cdr! p '()) ) ] )
847	(let* ([eval? (member* '("-e" "-p" "-P" "-eval" "-print" "-pretty-print") args)]
848	[batch (or script (member* '("-b" "-batch") args) eval?)]
849	[quietflag (member* '("-q" "-quiet") args)]
850	[quiet (or script quietflag eval?)]
851	[ipath (map chop-separator (string-split (or (getenv "CHICKEN_INCLUDE_PATH") "") ";"))] )
852	(define (collect-options opt)
853	(let loop ([opts args])
854	(cond [(member opt opts)
855	=> (lambda (p)
856	(if (null? (cdr p))
857	(##sys#error "missing argument to command-line option" opt)
858	(cons (cadr p) (loop (cddr p)))) ) ]
859	[else '()] ) ) )
860	(define (loadinit)
861	(let ([fn (##sys#string-append "./" init-file)])
862	(if (file-exists? fn)
863	(load fn)
864	(let* ([prefix (chop-separator (or (getenv "HOME") "."))]
865	[fn (string-append prefix "/" init-file)] )
866	(when (file-exists? fn)
867	(load fn) ) ) ) ) )
868	(define (evalstring str #!optional (rec (lambda _ (void))))
869	(let ((in (open-input-string str)))
870	(do ([x (read in) (read in)])
871	((eof-object? x))
872	(rec (receive (eval x))) ) ) )
873	(when quietflag (set! ##sys#eval-debug-level 0))
874	(when (member* '("-h" "-help" "--help") args)
875	(print-usage)
876	(exit 0) )
877	(when (member* '("-v" "-version") args)
878	(print-banner)
879	(exit 0) )
880	(when (member "-release" args)
881	(print (chicken-version))
882	(exit 0) )
883	(when (member* '("-w" "-no-warnings") args)
884	(unless quiet (display "Warnings are disabled\n"))
885	(set! ##sys#warnings-enabled #f) )
886	(unless quiet
887	(load-verbose #t)
888	(print-banner) )
889	(when (member* '("-i" "-case-insensitive") args)
890	(unless quiet (display "Identifiers and symbols are case insensitive\n"))
891	(register-feature! 'case-insensitive)
892	(case-sensitive #f) )
893	(for-each register-feature! (collect-options "-feature"))
894	(for-each register-feature! (collect-options "-D"))
895	(set! ##sys#include-pathnames
896	(deldups
897	(append (map chop-separator (collect-options "-include-path"))
898	(map chop-separator (collect-options "-I"))
899	##sys#include-pathnames
900	ipath)
901	string=?) )
902	(when kwstyle
903	(cond [(not (pair? (cdr kwstyle)))
904	(##sys#error "missing argument to `-keyword-style' option") ]
905	[(string=? "prefix" (cadr kwstyle))
906	(keyword-style #:prefix) ]
907	[(string=? "none" (cadr kwstyle))
908	(keyword-style #:none) ]
909	[(string=? "suffix" (cadr kwstyle))
910	(keyword-style #:suffix) ] ) )
911	(unless (or (member* '("-n" "-no-init") args) script) (loadinit))
912	(do ([args args (cdr args)])
913	((null? args)
914	(unless batch
915	(repl)
916	(##sys#write-char-0 #\newline ##sys#standard-output) ) )
917	(let* ([arg (car args)]
918	[len (string-length arg)] )
919	(cond ((member
920	arg
921	'("--" "-batch" "-quiet" "-no-init" "-no-warnings" "-script"
922	"-b" "-q" "-n" "-w" "-s" "-i"
923	"-case-insensitive" "-ss" "-se") ) )
924	((member arg '("-feature" "-include-path" "-keyword-style"
925	"-D" "-I" "-k"))
926	(set! args (cdr args)) )
927	((or (string=? "-R" arg) (string=? "-require-extension" arg))
928	(eval `(##core#require-extension ,(string->symbol (cadr args))))
929	(set! args (cdr args)) )
930	((or (string=? "-e" arg) (string=? "-eval" arg))
931	(evalstring (cadr args))
932	(set! args (cdr args)) )
933	((or (string=? "-p" arg) (string=? "-print" arg))
934	(evalstring
935	(cadr args)
936	(cut for-each print <...>) )
937	(set! args (cdr args)) )
938	((or (string=? "-P" arg) (string=? "-pretty-print" arg))
939	(evalstring
940	(cadr args)
941	(cut for-each pretty-print <...>) )
942	(set! args (cdr args)) )
943	(else
944	(let ((scr (and script (car script))))
945	(##sys#load
946	arg
947	(and (equal? "-se" scr)
948	(lambda (x)
949	(pretty-print x ##sys#standard-error)
950	(newline ##sys#standard-error)
951	(eval x)))
952	#f)
953	(when (and scr (member scr '("-ss" "-se")))
954	(call-with-values (cut main (command-line-arguments))
955	(lambda results
956	(exit
957	(if (and (pair? results) (fixnum? (car results)))
958	(car results)
959	0) ) ) ) ) ) ) ) ) ) ) ) )
960
961	(run)

Note: See TracBrowser for help on using the repository browser.

Download in other formats: