source: project/chicken/branches/hygienic/csi.scm @ 10753

Last change on this file since 10753 was 10753, checked in by felix winkelmann, 13 years ago

chicken import lib, trivial fixes, foreign import lib (untested)

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