mirror of
https://github.com/false-schemers/skint.git
synced 2024-12-27 21:58:53 +01:00
145 lines
4.6 KiB
Text
145 lines
4.6 KiB
Text
|
|
;------------------------------------------------------------------------------
|
|
;
|
|
; SKINT Startup code (minimal)
|
|
;
|
|
;------------------------------------------------------------------------------
|
|
|
|
(load "n.sf") ; needed for basic runtime internals
|
|
|
|
|
|
;---------------------------------------------------------------------------------------------
|
|
; Minimal additional definitions to compile code below
|
|
;---------------------------------------------------------------------------------------------
|
|
|
|
(define-syntax let-syntax
|
|
(syntax-rules ()
|
|
[(_ ([kw init] ...))
|
|
(begin)]
|
|
[(_ ([kw init] ...) . body)
|
|
((syntax-lambda (kw ...) . body)
|
|
init ...)]))
|
|
|
|
(define-syntax %const
|
|
(let-syntax ([old-%const %const])
|
|
(syntax-rules (boolean null integer string)
|
|
[(_ boolean b) (%prim ("bool(" b ")"))]
|
|
[(_ null) (%prim "obj(mknull())")]
|
|
[(_ integer 8 sign digs 10) (%prim ("fixnum(" #&(id->string sign) digs ")"))]
|
|
[(_ integer 16 sign digs 10) (%prim ("fixnum(" #&(id->string sign) digs ")"))]
|
|
[(_ string s) (%prim* ("obj(hpushstr($live, newstring(\"" s "\")))"))]
|
|
[(_ string 8 c ...)
|
|
(%prim* ("{ static char s[] = { " (c ", ") ... "0 };\n"
|
|
" $return obj(hpushstr($live, newstring(s))); }"))]
|
|
[(_ arg ...) (old-%const arg ...)])))
|
|
|
|
(define-syntax make-vector
|
|
(syntax-rules ()
|
|
[(_ n i)
|
|
(%prim* "{ /* make-vector */
|
|
obj o; int i = 0, c = fixnum_from_$arg;
|
|
hreserve(hbsz(c+1), $live); /* $live live regs */
|
|
o = obj_from_$arg; /* gc-safe */
|
|
while (i++ < c) *--hp = o;
|
|
*--hp = obj_from_size(VECTOR_BTAG);
|
|
$return obj(hendblk(c+1)); }" n i)]))
|
|
|
|
(define-syntax cons
|
|
(syntax-rules ()
|
|
[(_ a d)
|
|
(%prim* "{ /* cons */
|
|
hreserve(hbsz(3), $live); /* $live live regs */
|
|
*--hp = obj_from_$arg;
|
|
*--hp = obj_from_$arg;
|
|
*--hp = obj_from_size(PAIR_BTAG);
|
|
$return obj(hendblk(3)); }" d a)]))
|
|
|
|
(define-syntax eq?
|
|
(syntax-rules ()
|
|
[(_ x y) (%prim "bool(obj_from_$arg == obj_from_$arg)" x y)]))
|
|
|
|
|
|
;---------------------------------------------------------------------------------------------
|
|
; Runtime globals
|
|
;---------------------------------------------------------------------------------------------
|
|
|
|
(%localdef "#include \"i.h\"")
|
|
|
|
(define *globals* (make-vector 991 '())) ; nice prime number
|
|
|
|
(define *dynamic-state* (cons #f '())) ; for dynamic-wind
|
|
|
|
(define *current-input* #f)
|
|
(define *current-output* #f)
|
|
(define *current-error* #f)
|
|
|
|
|
|
;---------------------------------------------------------------------------------------------
|
|
; Code deserializer and Evaluator (use built-ins)
|
|
;---------------------------------------------------------------------------------------------
|
|
|
|
(define execute-thunk-closure
|
|
(%prim "{ /* define execute-thunk-closure */
|
|
static obj c[] = { obj_from_objptr(vmcases+0) };
|
|
$return objptr(c); }"))
|
|
|
|
(define make-closure
|
|
(%prim "{ /* define make-closure */
|
|
static obj c[] = { obj_from_objptr(vmcases+1) };
|
|
$return objptr(c); }"))
|
|
|
|
(define decode-sexp
|
|
(%prim "{ /* define decode-sexp */
|
|
static obj c[] = { obj_from_objptr(vmcases+2) };
|
|
$return objptr(c); }"))
|
|
|
|
(define decode
|
|
(%prim "{ /* define decode */
|
|
static obj c[] = { obj_from_objptr(vmcases+3) };
|
|
$return objptr(c); }"))
|
|
|
|
|
|
;---------------------------------------------------------------------------------------------
|
|
; Initial environment
|
|
;---------------------------------------------------------------------------------------------
|
|
|
|
; initial transformers
|
|
(define *transformers* '())
|
|
|
|
; adapter code for continuation closures produced by letcc
|
|
(define continuation-adapter-code #f) ; inited via (decode "k!...") in i.c
|
|
|
|
; adapter closure for values/call-with-values pair
|
|
(define callmv-adapter-closure (make-closure (decode "K5")))
|
|
|
|
(define install-global-lambdas
|
|
(%prim "{ /* define install-global-lambdas */
|
|
static obj c[] = { obj_from_objptr(vmcases+6) };
|
|
$return objptr(c); }"))
|
|
|
|
(install-global-lambdas)
|
|
|
|
(define initialize-modules
|
|
(%prim "{ /* define initialize-modules */
|
|
static obj c[] = { obj_from_objptr(vmcases+7) };
|
|
$return objptr(c); }"))
|
|
|
|
(initialize-modules)
|
|
|
|
|
|
;---------------------------------------------------------------------------------------------
|
|
; Main
|
|
;---------------------------------------------------------------------------------------------
|
|
|
|
(define tcode-repl
|
|
(lambda ()
|
|
(execute-thunk-closure (make-closure (decode "${@(y4:repl)[00}")))))
|
|
|
|
(define main
|
|
(lambda (argv)
|
|
; if we fell out of tcode repl on error, go back
|
|
(if (eq? (tcode-repl) #t)
|
|
#f ; normal exit, exit code = 0 (#f conventions)
|
|
(main #f))))
|
|
|
|
|