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

Last change on this file since 6175 was 6175, checked in by Kon Lovett, 12 years ago

Changes for PCRE 7.4, use of compiled regexp in posix & utils units.

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