conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Load now skips the first line of a file if that line starts with 

a shebang "#!".
This commit is contained in:
Abdulaziz Ghuloum 2006-12-02 05:02:05 -05:00
parent b09f5ba142
commit 23ff529aa2
4 changed files with 193 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lib/ikarus.boot
View File

Binary file not shown.

268
lib/libtokenizer.ss
View File

@ -260,77 +260,79 @@
(list->string (reverse (cons c chars))))])))) (list->string (reverse (cons c chars))))]))))
(define tokenize-hash (define tokenize-hash
(lambda (p) (lambda (p)
(let ([c (read-char p)]) (tokenize-hash/c (read-char p) p)))
(cond (define tokenize-hash/c
[(eof-object? c) (error 'tokenize "invalid # near end of file")] (lambda (c p)
[($char= c #\t) (cond
(let ([c (peek-char p)]) [(eof-object? c) (error 'tokenize "invalid # near end of file")]
(cond [($char= c #\t)
[(eof-object? c) '(datum . #t)] (let ([c (peek-char p)])
[(delimiter? c) '(datum . #t)] (cond
[else (error 'tokenize "invalid syntax near #t")]))] [(eof-object? c) '(datum . #t)]
[($char= c #\f) [(delimiter? c) '(datum . #t)]
(let ([c (peek-char p)]) [else (error 'tokenize "invalid syntax near #t")]))]
(cond [($char= c #\f)
[(eof-object? c) '(datum . #f)] (let ([c (peek-char p)])
[(delimiter? c) '(datum . #f)] (cond
[else (error 'tokenize "invalid syntax near #f")]))] [(eof-object? c) '(datum . #f)]
[($char= #\\ c) (tokenize-char p)] [(delimiter? c) '(datum . #f)]
[($char= #\( c) 'vparen] [else (error 'tokenize "invalid syntax near #f")]))]
[($char= #\x c) (tokenize-hex-init p)] [($char= #\\ c) (tokenize-char p)]
[($char= #\' c) '(macro . syntax)] [($char= #\( c) 'vparen]
[($char= #\; c) 'hash-semi] [($char= #\x c) (tokenize-hex-init p)]
[($char= #\% c) '(macro . |#primitive|)] [($char= #\' c) '(macro . syntax)]
[($char= #\| c) (multiline-comment p) (tokenize p)] [($char= #\; c) 'hash-semi]
[($char= #\b c) [($char= #\% c) '(macro . |#primitive|)]
(let ([c (read-char p)]) [($char= #\| c) (multiline-comment p) (tokenize p)]
(cond [($char= #\b c)
[(eof-object? c) (let ([c (read-char p)])
(error 'tokenize "invalid eof while reading #b")] (cond
[($char= #\- c) [(eof-object? c)
(let ([c (read-char p)]) (error 'tokenize "invalid eof while reading #b")]
(cond [($char= #\- c)
[(eof-object? c) (let ([c (read-char p)])
(error 'tokenize "invalid eof while reading #b-")] (cond
[($char= #\0 c) [(eof-object? c)
(cons 'datum (error 'tokenize "invalid eof while reading #b-")]
(* -1 (read-binary 0 '(#\0 #\-) p)))] [($char= #\0 c)
[($char= #\1 c) (cons 'datum
(cons 'datum (* -1 (read-binary 0 '(#\0 #\-) p)))]
(* -1 (read-binary 1 '(#\1 #\-) p)))] [($char= #\1 c)
[else (cons 'datum
(unread-char c p) (* -1 (read-binary 1 '(#\1 #\-) p)))]
(error 'tokenize "invalid binary syntax #b-~a" c)]))] [else
[($char= #\0 c) (unread-char c p)
(cons 'datum (read-binary 0 '(#\0) p))] (error 'tokenize "invalid binary syntax #b-~a" c)]))]
[($char= #\1 c) [($char= #\0 c)
(cons 'datum (read-binary 1 '(#\1) p))] (cons 'datum (read-binary 0 '(#\0) p))]
[else [($char= #\1 c)
(unread-char c p) (cons 'datum (read-binary 1 '(#\1) p))]
(error 'tokenize "invalid syntax #b~a" c)] [else
))] (unread-char c p)
[($char= #\! c) (error 'tokenize "invalid syntax #b~a" c)]
(let ([e (read-char p)]) ))]
(when (eof-object? e) [($char= #\! c)
(error 'tokenize "invalid eof near #!")) (let ([e (read-char p)])
(unless ($char= #\e e) (when (eof-object? e)
(error 'tokenize "invalid syntax near #!~a" e)) (error 'tokenize "invalid eof near #!"))
(let ([o (read-char p)]) (unless ($char= #\e e)
(when (eof-object? o) (error 'tokenize "invalid syntax near #!~a" e))
(error 'tokenize "invalid eof near #!e")) (let ([o (read-char p)])
(unless ($char= #\o o) (when (eof-object? o)
(error 'tokenize "invalid syntax near #!e~a" o)) (error 'tokenize "invalid eof near #!e"))
(let ([f (read-char p)]) (unless ($char= #\o o)
(when (eof-object? f) (error 'tokenize "invalid syntax near #!e~a" o))
(error 'tokenize "invalid syntax near #!eo")) (let ([f (read-char p)])
(unless ($char= #\f f) (when (eof-object? f)
(error 'tokenize "invalid syntax near #!eo~a" f)) (error 'tokenize "invalid syntax near #!eo"))
(cons 'datum (eof-object)))))] (unless ($char= #\f f)
[(digit? c) (error 'tokenize "invalid syntax near #!eo~a" f))
(tokenize-hashnum p (char->num c))] (cons 'datum (eof-object)))))]
[else [(digit? c)
(unread-char c p) (tokenize-hashnum p (char->num c))]
(error 'tokenize "invalid syntax #~a" c)])))) [else
(unread-char c p)
(error 'tokenize "invalid syntax #~a" c)])))
(define (tokenize-hashnum p n) (define (tokenize-hashnum p n)
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
@ -357,50 +359,71 @@
[else (tokenize-bar p (cons c ac))]))] [else (tokenize-bar p (cons c ac))]))]
[($char= #\| c) ac] [($char= #\| c) ac]
[else (tokenize-bar p (cons c ac))])))) [else (tokenize-bar p (cons c ac))]))))
(define tokenize/c
(lambda (c p)
(cond
[(eof-object? c) (eof-object)]
[(char-whitespace? c) (tokenize p)]
[($char= #\( c) 'lparen]
[($char= #\) c) 'rparen]
[($char= #\[ c) 'lbrack]
[($char= #\] c) 'rbrack]
[($char= #\' c) '(macro . quote)]
[($char= #\` c) '(macro . quasiquote)]
[($char= #\, c)
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(macro . unquote)]
[($char= c #\@)
(read-char p)
'(macro . unquote-splicing)]
[else '(macro . unquote)]))]
[($char= #\# c) (tokenize-hash p)]
[(digit? c)
(cons 'datum (tokenize-number (char->num c) p))]
[(initial? c)
(let ([ls (reverse (tokenize-identifier (cons c '()) p))])
(cons 'datum (string->symbol (list->string ls))))]
[($char= #\" c)
(let ([ls (tokenize-string '() p)])
(cons 'datum (list->string (reverse ls))))]
[($char= #\; c)
(skip-comment p)
(tokenize p)]
[($char= #\+ c)
(tokenize-plus p)]
[($char= #\- c)
(tokenize-minus p)]
[($char= #\. c)
(tokenize-dot p)]
[($char= #\| c)
(let ([ls (reverse (tokenize-bar p '()))])
(cons 'datum (string->symbol (list->string ls))))]
[else
(unread-char c p)
(error 'tokenize "invalid syntax ~a" c)])))
(define tokenize (define tokenize
(lambda (p)
(tokenize/c (read-char p) p)))
(define tokenize-initial
(lambda (p) (lambda (p)
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
[(eof-object? c) (eof-object)] [(eof-object? c) c]
[(char-whitespace? c) (tokenize p)] [($char= #\# c)
[($char= #\( c) 'lparen] (let ([c (read-char p)])
[($char= #\) c) 'rparen]
[($char= #\[ c) 'lbrack]
[($char= #\] c) 'rbrack]
[($char= #\' c) '(macro . quote)]
[($char= #\` c) '(macro . quasiquote)]
[($char= #\, c)
(let ([c (peek-char p)])
(cond (cond
[(eof-object? c) '(macro . unquote)] [(eof-object? c)
[($char= c #\@) (error 'tokenize "invalid eof after #")]
(read-char p) [($char= #\! c)
'(macro . unquote-splicing)] (skip-comment p)
[else '(macro . unquote)]))] (tokenize p)]
[($char= #\# c) (tokenize-hash p)] [else
[(digit? c) (tokenize-hash/c c p)]))]
(cons 'datum (tokenize-number (char->num c) p))] [else (tokenize/c c p)]))))
[(initial? c)
(let ([ls (reverse (tokenize-identifier (cons c '()) p))])
(cons 'datum (string->symbol (list->string ls))))]
[($char= #\" c)
(let ([ls (tokenize-string '() p)])
(cons 'datum (list->string (reverse ls))))]
[($char= #\; c)
(skip-comment p)
(tokenize p)]
[($char= #\+ c)
(tokenize-plus p)]
[($char= #\- c)
(tokenize-minus p)]
[($char= #\. c)
(tokenize-dot p)]
[($char= #\| c)
(let ([ls (reverse (tokenize-bar p '()))])
(cons 'datum (string->symbol (list->string ls))))]
[else
(unread-char c p)
(error 'tokenize "invalid syntax ~a" c)]))))
;;; ;;;
;;;--------------------------------------------------------------* READ *--- ;;;--------------------------------------------------------------* READ *---
@ -554,10 +577,15 @@
[else (error 'read "invalid token! ~s" t)])] [else (error 'read "invalid token! ~s" t)])]
[else [else
(error 'read "unexpected ~s found" t)]))) (error 'read "unexpected ~s found" t)])))
(define read-expr (define read-expr
(lambda (p locs k) (lambda (p locs k)
(parse-token p locs k (read-token p)))) (parse-token p locs k (read-token p))))
(define read-expr-initial
(lambda (p locs k)
(parse-token p locs k (tokenize-initial p))))
(define reduce-loc! (define reduce-loc!
(lambda (x) (lambda (x)
(let ([loc (cdr x)]) (let ([loc (cdr x)])
@ -592,7 +620,17 @@
(loc-value expr) (loc-value expr)
expr)])))) expr)]))))
(define read-initial
(lambda (p)
(let-values ([(expr locs k) (read-expr-initial p '() void)])
(cond
[(null? locs) expr]
[else
(for-each reduce-loc! locs)
(k)
(if (loc? expr)
(loc-value expr)
expr)]))))
;;; ;;;
@ -619,12 +657,16 @@
(unless (eof-object? x) (unless (eof-object? x)
(eval x) (eval x)
(read-and-eval p))))) (read-and-eval p)))))
(primitive-set! 'load (primitive-set! 'load
(lambda (x) (lambda (x)
(unless (string? x) (unless (string? x)
(error 'load "~s is not a string" x)) (error 'load "~s is not a string" x))
(let ([p (open-input-file x)]) (let ([p (open-input-file x)])
(read-and-eval p) (let ([x (read-initial p)])
(unless (eof-object? x)
(eval x)
(read-and-eval p)))
(close-input-port p))))) (close-input-port p)))))
) )

79
lib/makefile.ss
View File

@ -116,60 +116,53 @@
)) ))
(define system-primitives (define system-primitives
'(immediate? $unbound-object? $forward-ptr? '(
pointer-value
primitive-ref primitive-set! immediate? $unbound-object? $forward-ptr? pointer-value
$fx= $fx< $fx<= $fx> $fx>= $fxzero? primitive-ref primitive-set! $fx= $fx< $fx<= $fx> $fx>=
$fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient $fxremainder $fxmodulo $fxzero? $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient
$fxsll $fxsra $fxlognot $fxlogor $fxlogand $fxlogxor $fxremainder $fxmodulo $fxsll $fxsra $fxlognot $fxlogor
$fixnum->char $char->fixnum $fxlogand $fxlogxor $fixnum->char $char->fixnum $char= $char<
$char= $char< $char<= $char> $char>= $char<= $char> $char>= $car $cdr $set-car! $set-cdr!
$car $cdr $set-car! $set-cdr!
$make-vector $vector-ref $vector-set! $vector-length $make-vector $vector-ref $vector-set! $vector-length
$make-string $string-ref $string-set! $string-length $string $make-string $string-ref $string-set! $string-length $string
$symbol-string $symbol-unique-string $symbol-value $symbol-string $symbol-unique-string $symbol-value
$set-symbol-string! $set-symbol-unique-string! $set-symbol-value! $set-symbol-string! $set-symbol-unique-string!
$make-symbol $set-symbol-plist! $symbol-plist $set-symbol-value! $make-symbol $set-symbol-plist!
$sc-put-cte $symbol-plist $sc-put-cte $record? $record/rtd? $record-set!
$record? $record/rtd? $record-set! $record-ref $record-rtd $record-ref $record-rtd $make-record $record $base-rtd $code?
$make-record $record $code-reloc-vector $code-freevars $code-size $code-ref
$base-rtd $code-set! $code->closure list*->code* make-code code?
$code? $code-reloc-vector $code-freevars $code-size $code-ref $code-set! set-code-reloc-vector! code-reloc-vector code-freevars code-size
$code->closure list*->code* code-ref code-set! $frame->continuation $fp-at-base
make-code code? set-code-reloc-vector! code-reloc-vector code-freevars $current-frame $arg-list $seal-frame-and-call
code-size code-ref code-set!
$frame->continuation $fp-at-base $current-frame $arg-list $seal-frame-and-call
$make-call-with-values-procedure $make-values-procedure $make-call-with-values-procedure $make-values-procedure
do-overflow collect do-overflow collect $make-tcbucket $tcbucket-next $tcbucket-key
$make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val $tcbucket-val $set-tcbucket-next! $set-tcbucket-val!
$set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc! $set-tcbucket-tconc! $tcbucket-dlink-prev $tcbucket-dlink-next
$tcbucket-dlink-prev $set-tcbucket-dlink-prev! $set-tcbucket-dlink-next! call/cf
$tcbucket-dlink-next trace-symbol! untrace-symbol! make-traced-procedure
$set-tcbucket-dlink-prev! fixnum->string vector-memq vector-memv
$set-tcbucket-dlink-next!
call/cf trace-symbol! untrace-symbol! make-traced-procedure
fixnum->string
vector-memq vector-memv
;;; must open-code ;;; TODO: must open-code
$make-port/input
$make-port/output $make-port/input $make-port/output $make-port/both
$make-port/both
$make-input-port $make-output-port $make-input/output-port $make-input-port $make-output-port $make-input/output-port
$port-handler $port-handler $port-input-buffer $port-input-index
$port-input-buffer $port-input-index $port-input-size $port-input-size $port-output-buffer $port-output-index
$port-output-buffer $port-output-index $port-output-size $port-output-size $set-port-input-index! $set-port-input-size!
$set-port-input-index! $set-port-input-size!
$set-port-output-index! $set-port-output-size! $set-port-output-index! $set-port-output-size!
;;; better open-code ;;; better open-code
$write-char $read-char $peek-char $unread-char $write-char $read-char $peek-char $unread-char
;;; never open-code ;;; never open-code
$reset-input-port! $close-input-port
$close-output-port $flush-output-port $reset-input-port! $close-input-port $close-output-port
*standard-output-port* *standard-error-port* *current-output-port* $flush-output-port *standard-output-port* *standard-error-port*
*standard-input-port* *current-input-port* *current-output-port* *standard-input-port* *current-input-port*
)) ))
@ -214,6 +207,7 @@
(when (eq? "" "") (when (eq? "" "")
(error #f "SEVERELY OUT OF DATE!\n")
(load "chez-compat.ss") (load "chez-compat.ss")
(set! primitive-ref top-level-value) (set! primitive-ref top-level-value)
(set! primitive-set! set-top-level-value!) (set! primitive-set! set-top-level-value!)
@ -300,3 +294,4 @@
(system (system
(format "cat ~a > ikarus.boot" (format "cat ~a > ikarus.boot"
(join " " (map caddr scheme-library-files)))) (join " " (map caddr scheme-library-files))))

1
lib/psyntax-7.1.ss
View File

@ -4101,6 +4101,7 @@
(else (match* (unannotate e) p empty-wrap '()))))) (else (match* (unannotate e) p empty-wrap '())))))
)) ))
;;; global macros
(define-syntax with-syntax (define-syntax with-syntax
(lambda (x) (lambda (x)