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

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

merged from prerelease branch rev. 7930 - release version 3.0.0; fixed wrong version numbers in some files

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