ikarus/lib/libtoplevel.ss

88 lines
2.9 KiB
Scheme
Raw Normal View History

2006-11-23 19:44:29 -05:00
(for-each
(lambda (x)
($set-symbol-value! x (primitive-ref x)))
(public-primitives))
(let ()
(define add-prim
(lambda (x)
(let ([g (gensym (symbol->string x))])
(putprop x '|#system| g)
(putprop g '*sc-expander* (cons 'core-primitive x)))))
(for-each add-prim (public-primitives))
(for-each add-prim (system-primitives)))
(for-each
(lambda (x)
(cond
[(getprop x '*sc-expander*) =>
(lambda (p)
(let ([g (gensym (symbol->string x))])
(putprop x '|#system| g)
(putprop g '*sc-expander* p)))]
[(getprop x '|#system|) =>
(lambda (g)
(let ([p (getprop g '*sc-expander*)])
(putprop x '*sc-expander* p)))]
[else (error #f "~s is not a macro" x)]))
(macros))
(let ([gsys (gensym "#system")] [gsch (gensym "*scheme*")])
(define (make-stx x)
(vector 'syntax-object x
(list '(top)
(vector 'ribcage
(vector x)
(vector '(top))
(vector (getprop x '|#system|))))))
(define (make-module stx* name)
`($module . #(interface (top) ,(list->vector stx*) ,name)))
(putprop '|#system| '|#system| gsys)
(putprop 'scheme '|#system| gsch)
(putprop 'scheme '*scheme* gsch)
(let* ([schls (append '(scheme) (public-primitives) (macros))]
[sysls (append '(|#system|) (system-primitives) schls)])
(let ([sysmod (make-module (map make-stx sysls) '|#system|)]
[schmod (make-module (map make-stx schls) '*scheme*)])
(for-each
(lambda (x)
(putprop x '*scheme* (getprop x '|#system|)))
schls)
(putprop gsch '*sc-expander* schmod)
(putprop gsys '*sc-expander* sysmod)
(putprop '|#system| '*sc-expander* sysmod)
(putprop 'scheme '*sc-expander* schmod))))
(let-values ([(files script args)
(let f ([args (command-line-arguments)])
(cond
[(null? args) (values '() #f '())]
[(string=? (car args) "--")
(values '() #f (cdr args))]
[(string=? (car args) "--script")
(let ([d (cdr args)])
(cond
[(null? d)
(error #f "--script requires a script name")]
[else
(values '() (car d) (cdr d))]))]
[else
(let-values ([(f* script a*) (f (cdr args))])
(values (cons (car args) f*) script a*))]))])
(current-eval compile)
(cond
[script ; no greeting, no cafe
(command-line-arguments (cons script args))
(for-each load files)
(load script)
(exit 0)]
[else
(printf "Ikarus Scheme (Build ~a)\n" (compile-time-date-string))
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
(command-line-arguments args)
(for-each load files)
(new-cafe)]))