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

Last change on this file since 12867 was 12867, checked in by felix winkelmann, 11 years ago

csi toplevel commands resolve identifier names

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