skint/pre/k.sf

;------------------------------------------------------------------------------
;
;  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) #t (main #f))))