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

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