* libtoplevel.ss is now using libraries only
This commit is contained in:
Abdulaziz Ghuloum
parent
149ace20d9
commit
5e0649c5c0
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -1,6 +1,142 @@
|
|||
|
||||
|
||||
(library (flush me top-level-and-module-init)
|
||||
(export)
|
||||
(import (scheme))
|
||||
|
||||
;;; this junk should all go away soon
|
||||
;;; this file is one big hack that initializes the whole system.
|
||||
|
||||
(define (macros)
|
||||
'(|#primitive| lambda case-lambda set! quote begin define if letrec
|
||||
foreign-call ;$apply
|
||||
quasiquote unquote unquote-splicing
|
||||
define-syntax identifier-syntax let-syntax letrec-syntax
|
||||
fluid-let-syntax alias meta eval-when with-implicit with-syntax
|
||||
type-descriptor
|
||||
syntax-case syntax-rules module $module import $import import-only
|
||||
syntax quasisyntax unsyntax unsyntax-splicing datum
|
||||
let let* let-values cond case define-record or and when unless do
|
||||
include parameterize trace untrace trace-lambda trace-define
|
||||
rec library
|
||||
time))
|
||||
|
||||
(define (public-primitives)
|
||||
'(
|
||||
null? pair? char? fixnum? bignum? symbol? gensym? string? vector? list?
|
||||
boolean? procedure? not eof-object eof-object? bwp-object?
|
||||
void fx= fx< fx<= fx> fx>= fxzero? fx+ fx- fx* fxadd1 fxsub1
|
||||
fxquotient fxremainder fxmodulo fxsll fxsra fxlognot fxlogor
|
||||
fxlogand fxlogxor integer->char char->integer char=? char<?
|
||||
char<=? char>? char>=? cons car cdr set-car! set-cdr! caar
|
||||
cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
||||
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
|
||||
cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr list list*
|
||||
make-list length list-ref append make-vector vector-ref
|
||||
vector-set! vector-length vector vector->list list->vector
|
||||
make-string string-ref string-set! string-length string
|
||||
string->list list->string uuid string-append substring string=?
|
||||
string<? string<=? string>? string>=? remprop putprop getprop
|
||||
property-list $$apply apply map for-each andmap ormap memq memv assq
|
||||
assv assoc eq? eqv? equal? reverse string->symbol symbol->string
|
||||
top-level-value set-top-level-value! top-level-bound?
|
||||
gensym gensym-count gensym-prefix print-gensym
|
||||
gensym->unique-string call-with-values values make-parameter
|
||||
dynamic-wind display write print-graph fasl-write printf fprintf format
|
||||
print-error read-token read comment-handler error warning exit call/cc
|
||||
error-handler eval current-eval compile alt-compile compile-file
|
||||
alt-compile-file
|
||||
new-cafe load system expand sc-expand current-expand expand-mode
|
||||
environment? interaction-environment identifier?
|
||||
free-identifier=? bound-identifier=? literal-identifier=?
|
||||
datum->syntax-object syntax-object->datum syntax-error
|
||||
syntax->list generate-temporaries record? record-set! record-ref
|
||||
record-length record-type-descriptor make-record-type
|
||||
record-printer record-name record-field-accessor
|
||||
record-field-mutator record-predicate record-constructor
|
||||
record-type-name record-type-symbol record-type-field-names
|
||||
hash-table? make-hash-table get-hash-table put-hash-table!
|
||||
assembler-output $make-environment features
|
||||
command-line-arguments port? input-port? output-port?
|
||||
make-input-port make-output-port make-input/output-port
|
||||
port-handler port-input-buffer port-input-index port-input-size
|
||||
port-output-buffer port-output-index port-output-size
|
||||
set-port-input-index! set-port-input-size!
|
||||
set-port-output-index! set-port-output-size! port-name
|
||||
input-port-name output-port-name write-char read-char
|
||||
unread-char peek-char newline reset-input-port!
|
||||
flush-output-port close-input-port close-output-port
|
||||
console-input-port current-input-port standard-output-port
|
||||
standard-error-port console-output-port current-output-port
|
||||
open-output-file open-input-file open-output-string
|
||||
with-output-to-string
|
||||
get-output-string with-output-to-file call-with-output-file
|
||||
open-input-string
|
||||
with-input-from-file call-with-input-file date-string
|
||||
file-exists? delete-file + - add1 sub1 * / expt
|
||||
quotient+remainder quotient remainder modulo number? positive?
|
||||
negative? zero? number->string logand = < > <= >=
|
||||
last-pair
|
||||
make-guardian weak-cons collect
|
||||
interrupt-handler
|
||||
time-it
|
||||
posix-fork fork waitpid env environ
|
||||
pretty-print
|
||||
even? odd? member char-whitespace? char-alphabetic?
|
||||
char-downcase max min complex? real? rational?
|
||||
exact? inexact? integer?
|
||||
string->number exact->inexact
|
||||
flonum? flonum->string string->flonum
|
||||
sin cos atan sqrt
|
||||
))
|
||||
|
||||
(define (system-primitives)
|
||||
'(
|
||||
$primitive-call/cc
|
||||
$closure-code immediate? $unbound-object? $forward-ptr?
|
||||
pointer-value primitive-ref primitive-set! $fx= $fx< $fx<= $fx>
|
||||
$fx>= $fxzero? $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient
|
||||
$fxremainder $fxmodulo $fxsll $fxsra $fxlognot $fxlogor
|
||||
$fxlogand $fxlogxor $fixnum->char $char->fixnum $char= $char<
|
||||
$char<= $char> $char>= $car $cdr $set-car! $set-cdr!
|
||||
$make-vector $vector-ref $vector-set! $vector-length
|
||||
$make-string $string-ref $string-set! $string-length $string
|
||||
$symbol-string $symbol-unique-string $symbol-value
|
||||
$set-symbol-string! $set-symbol-unique-string!
|
||||
$set-symbol-value! $set-symbol-function! $make-symbol $set-symbol-plist!
|
||||
$symbol-plist $sc-put-cte $record? $record/rtd? $record-set!
|
||||
$record-ref $record-rtd $make-record $record $base-rtd $code?
|
||||
$code-reloc-vector $code-freevars $code-size $code-ref
|
||||
$code-set! $code->closure list*->code* make-code code?
|
||||
set-code-reloc-vector! code-reloc-vector code-freevars
|
||||
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
|
||||
do-overflow $make-tcbucket $tcbucket-next $tcbucket-key
|
||||
$tcbucket-val $set-tcbucket-next! $set-tcbucket-val!
|
||||
$set-tcbucket-tconc!
|
||||
call/cf
|
||||
trace-symbol! untrace-symbol! make-traced-procedure
|
||||
fixnum->string
|
||||
$interrupted? $unset-interrupted! $do-event
|
||||
$fasl-read
|
||||
;;; TODO: must open-code
|
||||
$make-port/input $make-port/output $make-port/both
|
||||
$make-input-port $make-output-port $make-input/output-port
|
||||
$port-handler $port-input-buffer $port-input-index
|
||||
$port-input-size $port-output-buffer $port-output-index
|
||||
$port-output-size $set-port-input-index! $set-port-input-size!
|
||||
$set-port-output-index! $set-port-output-size!
|
||||
;;; better open-code
|
||||
$write-char $read-char $peek-char $unread-char
|
||||
;;; never open-code
|
||||
$reset-input-port! $close-input-port $close-output-port
|
||||
$flush-output-port *standard-output-port* *standard-error-port*
|
||||
*current-output-port* *standard-input-port* *current-input-port*
|
||||
;;;
|
||||
compile-core-expr-to-port
|
||||
compiler-giveup-tally
|
||||
))
|
||||
|
||||
;;; first, it defines all public primitives to their primref values.
|
||||
;;; (cross your fingers they're all defined in code)
|
||||
|
|
@ -49,7 +185,7 @@
|
|||
(vector '(top))
|
||||
(vector (getprop x '|#system|))))))
|
||||
(define (make-module stx* name)
|
||||
`($module . #(interface (top) ,(list->vector stx*) ,name)))
|
||||
(cons '$module (vector 'interface '(top) (list->vector stx*) name)))
|
||||
(putprop '|#system| '|#system| gsys)
|
||||
(putprop 'scheme '|#system| gsch)
|
||||
(putprop 'scheme '*scheme* gsch)
|
||||
|
|
@ -65,7 +201,7 @@
|
|||
(putprop gsys '*sc-expander* sysmod)
|
||||
(putprop '|#system| '*sc-expander* sysmod)
|
||||
(putprop 'scheme '*sc-expander* schmod))))
|
||||
|
||||
)
|
||||
|
||||
;;; Finally, we're ready to evaluate the files and enter the cafe.
|
||||
(library (ikarus interaction)
|
||||
|
|
|
|||
182
src/syntax.ss
182
src/syntax.ss
|
|
@ -20,7 +20,12 @@
|
|||
; (syntax-rules ()
|
||||
; [(_ f ls ls* ...)
|
||||
; (my-map '(map f ls ls* ...) f ls ls* ...)]))
|
||||
|
||||
(define-syntax build-let
|
||||
(syntax-rules ()
|
||||
[(_ ae lhs* rhs* body)
|
||||
(build-application ae
|
||||
(build-lambda ae lhs* body)
|
||||
rhs*)]))
|
||||
(define who 'chi-top-library)
|
||||
(define-syntax assert
|
||||
(syntax-rules ()
|
||||
|
|
@ -281,22 +286,27 @@
|
|||
(values 'other #f #f)))])))
|
||||
(define parse-library
|
||||
(lambda (e)
|
||||
(syntax-case e ()
|
||||
(syntax-match e
|
||||
[(_ (name name* ...)
|
||||
(export exp* ...)
|
||||
(import (scheme))
|
||||
b* ...)
|
||||
(and (eq? #'export 'export)
|
||||
(eq? #'import 'import)
|
||||
(eq? #'scheme 'scheme)
|
||||
(symbol? #'name)
|
||||
(andmap symbol? #'(name* ...))
|
||||
(andmap symbol? #'(exp* ...)))
|
||||
(values #'(name name* ...) #'(exp* ...) #'(b* ...))]
|
||||
(if (and (eq? export 'export)
|
||||
(eq? import 'import)
|
||||
(eq? scheme 'scheme)
|
||||
(symbol? name)
|
||||
(andmap symbol? name*)
|
||||
(andmap symbol? exp*))
|
||||
(values (cons name name*) exp* b*)
|
||||
(error who "malformed library ~s" e))]
|
||||
[_ (error who "malformed library ~s" e)])))
|
||||
(define stx-error
|
||||
(lambda (stx . args)
|
||||
(error 'chi "invalid syntax ~s" (strip stx '()))))
|
||||
(define-syntax stx-error
|
||||
(syntax-rules ()
|
||||
[(_ stx) (error 'chi "invalid syntax ~s" (strip stx '()))]
|
||||
[(_ stx msg) (error 'chi "~a: ~s" msg (strip stx '()))]))
|
||||
;(define stx-error
|
||||
; (lambda (stx . args)
|
||||
; (error 'chi "invalid syntax ~s" (strip stx '()))))
|
||||
(define-syntax syntax-match-test
|
||||
(lambda (stx)
|
||||
(define dots?
|
||||
|
|
@ -466,11 +476,13 @@
|
|||
(if (id? id)
|
||||
(values id (cons 'expr val))
|
||||
(stx-error x))])))
|
||||
(define scheme-env
|
||||
(define scheme-env ; the-env
|
||||
'([define define-label (define)]
|
||||
[quote quote-label (core-macro . quote)]
|
||||
[lambda lambda-label (core-macro . lambda)]
|
||||
[let-values let-values-label (core-macro . let-values)]
|
||||
[let let-label (core-macro . let)]
|
||||
[let* let*-label (core-macro . let*)]
|
||||
[cond cond-label (core-macro . cond)]
|
||||
[cons cons-label (core-prim . cons)]
|
||||
[values values-label (core-prim . values)]
|
||||
|
|
@ -482,8 +494,19 @@
|
|||
[new-cafe new-cafe-label (core-prim . new-cafe)]
|
||||
[load load-label (core-prim . load)]
|
||||
[for-each for-each-label (core-prim . for-each)]
|
||||
[map map-label (core-prim . map)]
|
||||
[display display-label (core-prim . display)]
|
||||
[gensym gensym-label (core-prim . gensym)]
|
||||
[getprop getprop-label (core-prim . getprop)]
|
||||
[putprop putprop-label (core-prim . putprop)]
|
||||
[vector vector-label (core-prim . vector)]
|
||||
[list list-label (core-prim . list)]
|
||||
[append append-label (core-prim . append)]
|
||||
[list->vector list->vector-label (core-prim . list->vector)]
|
||||
[symbol->string symbol->string-label (core-prim . symbol->string)]
|
||||
[current-eval current-eval-label (core-prim . current-eval)]
|
||||
[primitive-ref primitive-ref-label (core-prim . primitive-ref)]
|
||||
[$set-symbol-value! $set-symbol-value!-label (core-prim . $set-symbol-value!)]
|
||||
[compile compile-label (core-prim . compile)]
|
||||
[printf printf-label (core-prim . printf)]
|
||||
[string=? string=?-label (core-prim . string=?)]
|
||||
|
|
@ -538,6 +561,36 @@
|
|||
(build-lambda no-source '() (car rhs*))
|
||||
(build-lambda no-source (car lex**)
|
||||
(f (cdr lex**) (cdr rhs*)))))])))))])))
|
||||
(define let*-transformer
|
||||
(lambda (e r mr)
|
||||
(syntax-match e
|
||||
[(_ ([lhs* rhs*] ...) b b* ...)
|
||||
(let f ([lhs* lhs*] [rhs* rhs*]
|
||||
[subst-lhs* '()] [subst-lab* '()]
|
||||
[r r])
|
||||
(cond
|
||||
[(null? lhs*)
|
||||
(chi-internal
|
||||
(add-subst
|
||||
(id/label-rib subst-lhs* subst-lab*)
|
||||
(cons b b*))
|
||||
r mr)]
|
||||
[else
|
||||
(let ([lhs (car lhs*)]
|
||||
[rhs (chi-expr
|
||||
(add-subst
|
||||
(id/label-rib subst-lhs* subst-lab*)
|
||||
(car rhs*))
|
||||
r mr)])
|
||||
(unless (id? lhs)
|
||||
(stx-error lhs "invalid binding"))
|
||||
(let ([lex (gen-lexical lhs)]
|
||||
[lab (gen-label lhs)])
|
||||
(build-let no-source (list lex) (list rhs)
|
||||
(f (cdr lhs*) (cdr rhs*)
|
||||
(cons lhs subst-lhs*)
|
||||
(cons lab subst-lab*)
|
||||
(add-lexicals (list lab) (list lex) r)))))]))])))
|
||||
(define let-transformer
|
||||
(lambda (e r mr)
|
||||
(syntax-match e
|
||||
|
|
@ -628,12 +681,22 @@
|
|||
(lambda (e r mr)
|
||||
(syntax-match e
|
||||
[(_ datum) (build-data no-source (strip datum '()))])))
|
||||
(define lambda-transformer
|
||||
(lambda (e r mr)
|
||||
(syntax-match e
|
||||
[(_ fmls b b* ...)
|
||||
(let-values ([(fmls body)
|
||||
(chi-lambda-clause fmls
|
||||
(cons b b*) r mr)])
|
||||
(build-lambda no-source fmls body))])))
|
||||
(define core-macro-transformer
|
||||
(lambda (name)
|
||||
(case name
|
||||
[(quote) quote-transformer]
|
||||
[(lambda) lambda-transformer]
|
||||
[(let-values) let-values-transformer]
|
||||
[(let) let-transformer]
|
||||
[(let*) let*-transformer]
|
||||
[(cond) cond-transformer]
|
||||
[else (error 'macro-transformer "cannot find ~s" name)])))
|
||||
;;; chi procedures
|
||||
|
|
@ -664,13 +727,62 @@
|
|||
(build-data no-source datum))]
|
||||
[else (error 'chi-expr "invalid type ~s for ~s" type
|
||||
(strip e '())) (stx-error e)]))))
|
||||
(define chi-lambda-clause
|
||||
(lambda (fmls body* r mr)
|
||||
(syntax-match fmls
|
||||
[(x* ...)
|
||||
(if (valid-bound-ids? x*)
|
||||
(let ([lex* (map gen-lexical x*)]
|
||||
[lab* (map gen-label x*)])
|
||||
(values
|
||||
lex*
|
||||
(chi-internal
|
||||
(add-subst
|
||||
(id/label-rib x* lab*)
|
||||
body*)
|
||||
(add-lexicals lab* lex* r)
|
||||
mr)))
|
||||
(stx-error fmls "invalid fmls"))]
|
||||
[(x* ... . x)
|
||||
(if (valid-bound-ids? (cons rest x*))
|
||||
(let ([lex* (map gen-lexical x*)]
|
||||
[lab* (map gen-label x*)]
|
||||
[lex (gen-lexical x)]
|
||||
[lab (gen-label x)])
|
||||
(values
|
||||
(append lex* lex)
|
||||
(chi-internal
|
||||
(add-subst
|
||||
(id/label-rib (cons x x*) (cons lab lab*))
|
||||
body*)
|
||||
(add-lexicals (cons lab lab*)
|
||||
(cons lex lex*)
|
||||
r)
|
||||
mr)))
|
||||
(stx-error fmls "invalid fmls"))]
|
||||
[_ (stx-error fmls "invalid fmls")])))
|
||||
(define chi-rhs*
|
||||
(lambda (rhs* r mr)
|
||||
(map (lambda (rhs)
|
||||
(case (car rhs)
|
||||
[(defun)
|
||||
(let ([x (cdr rhs)])
|
||||
(let ([fmls (car x)] [body* (cdr x)])
|
||||
(let-values ([(fmls body)
|
||||
(chi-lambda-clause fmls body* r mr)])
|
||||
(build-lambda no-source fmls body))))]
|
||||
[(expr)
|
||||
(let ([expr (cdr rhs)])
|
||||
(chi-expr expr r mr))]
|
||||
[else (error 'chi-rhs "invalid rhs ~s" rhs)]))
|
||||
rhs*)))
|
||||
(define chi-internal
|
||||
(lambda (e* r mr)
|
||||
(define return
|
||||
(lambda (init* r mr lhs* lex* rhs*)
|
||||
(unless (valid-bound-ids? lhs*)
|
||||
(error 'chi-internal "multiple definitions"))
|
||||
(let ([rhs* (chi-expr* rhs* r mr)]
|
||||
(let ([rhs* (chi-rhs* rhs* r mr)]
|
||||
[init* (chi-expr* init* r mr)])
|
||||
(build-letrec no-source
|
||||
(reverse lex*) (reverse rhs*)
|
||||
|
|
@ -691,10 +803,10 @@
|
|||
(when (bound-id-member? id kwd*)
|
||||
(stx-error id "undefined identifier"))
|
||||
(let ([lex (gen-lexical id)]
|
||||
[label (gen-label)])
|
||||
(extend-rib! rib id label)
|
||||
[lab (gen-label id)])
|
||||
(extend-rib! rib id lab)
|
||||
(f (cdr e*)
|
||||
(cons (cons label (cons 'lexical lex)) r)
|
||||
(cons (cons lab (cons 'lexical lex)) r)
|
||||
mr
|
||||
(cons id lhs*)
|
||||
(cons lex lex*)
|
||||
|
|
@ -705,11 +817,11 @@
|
|||
(define chi-library-internal
|
||||
(lambda (e* r rib)
|
||||
(define return
|
||||
(lambda (init* r mr lhs* rhs*)
|
||||
(values init* r mr (reverse lhs*) (reverse rhs*))))
|
||||
(let f ([e* e*] [r r] [mr r] [lhs* '()] [rhs* '()] [kwd* '()])
|
||||
(lambda (init* r mr lhs* lex* rhs*)
|
||||
(values init* r mr (reverse lhs*) (reverse lex*) (reverse rhs*))))
|
||||
(let f ([e* e*] [r r] [mr r] [lhs* '()] [lex* '()] [rhs* '()] [kwd* '()])
|
||||
(cond
|
||||
[(null? e*) (return e* r mr lhs* rhs*)]
|
||||
[(null? e*) (return e* r mr lhs* lex* rhs*)]
|
||||
[else
|
||||
(let ([e (car e*)])
|
||||
(let-values ([(type value kwd) (syntax-type e r)])
|
||||
|
|
@ -719,27 +831,31 @@
|
|||
(let-values ([(id rhs) (parse-define e)])
|
||||
(when (bound-id-member? id kwd*)
|
||||
(stx-error id "undefined identifier"))
|
||||
(let ([lexical (gen-lexical (id->sym id))]
|
||||
[label (gen-label)])
|
||||
(extend-rib! rib id label)
|
||||
(f (cdr e*) r mr (cons id lhs*) (cons rhs rhs*)
|
||||
(let ([lex (gen-lexical id)]
|
||||
[lab (gen-label id)])
|
||||
(extend-rib! rib id lab)
|
||||
(f (cdr e*)
|
||||
(cons (cons lab (cons 'lexical lex)) r)
|
||||
mr
|
||||
(cons id lhs*) (cons lex lex*) (cons rhs rhs*)
|
||||
kwd*)))]
|
||||
[else
|
||||
(return e* r mr lhs* rhs*)]))))]))))
|
||||
(return e* r mr lhs* lex* rhs*)]))))]))))
|
||||
(define chi-top-library
|
||||
(lambda (e)
|
||||
(let-values ([(name exp* b*) (parse-library e)])
|
||||
(let ([rib (make-scheme-rib)]
|
||||
[r (make-scheme-env)])
|
||||
(let ([b* (map (lambda (x) (stx x top-mark* (list rib))) b*)])
|
||||
(let-values ([(init* r mr lhs* rhs*)
|
||||
(let-values ([(init* r mr lhs* lex* rhs*)
|
||||
(chi-library-internal b* r rib)])
|
||||
(unless (null? lhs*)
|
||||
(error who "cannot handle definitions yet"))
|
||||
(if (null? init*)
|
||||
(chi-void)
|
||||
(build-sequence no-source
|
||||
(chi-expr* init* r mr)))))))))
|
||||
(build-letrec no-source
|
||||
lex*
|
||||
(chi-rhs* rhs* r mr)
|
||||
(if (null? init*)
|
||||
(chi-void)
|
||||
(build-sequence no-source
|
||||
(chi-expr* init* r mr))))))))))
|
||||
(lambda (x)
|
||||
(let ([x (chi-top-library x)])
|
||||
; (pretty-print x)
|
||||
|
|
|
|||
Loading…
Reference in New Issue