source: project/chicken/trunk/csi.scm @ 13694

Last change on this file since 13694 was 13694, checked in by Kon Lovett, 11 years ago

Added 'symbol-escape' support. Renamed 'parenthesis-synonyms' -> 'parentheses-synonyms'. Changed command-line option for 'parentheses-synonyms' to 'no-parentheses-synonyms' since binary only. Added minor comments to 'regex', used common identifier name for regular-expression argument. Re-flowed command usage so under 80 columns. Updated manual with new features.

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