source: project/chicken/branches/release/csi.scm @ 7276

Last change on this file since 7276 was 7276, checked in by felix winkelmann, 12 years ago

merged trunk

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