Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

2413 lines (1855 sloc) 63.009 kB
;;;============================================================================
;;; File: "_t-univ.scm"
;;; Copyright (c) 2011-2012 by Marc Feeley, All Rights Reserved.
;;; Copyright (c) 2012 by Eric Thivierge, All Rights Reserved.
(include "generic.scm")
(include-adt "_envadt.scm")
(include-adt "_gvmadt.scm")
(include-adt "_ptreeadt.scm")
(include-adt "_sourceadt.scm")
(define univ-enable-jump-destination-inlining? #f)
(set! univ-enable-jump-destination-inlining? #t)
(define (univ-prefix ctx name) (gen "Gambit_" name))
;;;----------------------------------------------------------------------------
;;
;; "Universal" back-end.
;; Initialization/finalization of back-end.
(define (univ-setup target-language file-extension)
(let ((targ (make-target 8 target-language 0)))
(define (begin! info-port)
(target-dump-set!
targ
(lambda (procs output c-intf script-line options)
(univ-dump targ procs output c-intf script-line options)))
(target-nb-regs-set! targ univ-nb-gvm-regs)
(target-prim-info-set!
targ
(lambda (name)
(univ-prim-info targ name)))
(target-label-info-set!
targ
(lambda (nb-parms closed?)
(univ-label-info targ nb-parms closed?)))
(target-jump-info-set!
targ
(lambda (nb-args)
(univ-jump-info targ nb-args)))
(target-frame-constraints-set!
targ
(make-frame-constraints univ-frame-reserve univ-frame-alignment))
(target-proc-result-set!
targ
(make-reg 1))
(target-task-return-set!
targ
(make-reg 0))
(target-switch-testable?-set!
targ
(lambda (obj)
(univ-switch-testable? targ obj)))
(target-object-type-set!
targ
(lambda (obj)
(univ-object-type targ obj)))
(target-file-extension-set!
targ
file-extension)
#f)
(define (end!)
#f)
(target-begin!-set! targ begin!)
(target-end!-set! targ end!)
(target-add targ)))
(univ-setup 'js ".js")
(univ-setup 'python ".py")
(univ-setup 'ruby ".rb")
(univ-setup 'php ".php")
;;;----------------------------------------------------------------------------
;; Generation of textual target code.
(define (univ-indent . rest)
(cons '$$indent$$ rest))
(define (univ-display x port)
(define indent-level 0)
(define after-newline? #t)
(define (indent)
(if after-newline?
(begin
(display (make-string (* 2 indent-level) #\space) port)
(set! after-newline? #f))))
(define (disp x)
(cond ((string? x)
(let loop1 ((i 0))
(let loop2 ((j i))
(define (display-substring limit)
(if (< i limit)
(begin
(indent)
(if (and (= i 0) (= limit (string-length x)))
(display x port)
(display (substring x i limit) port)))))
(if (< j (string-length x))
(let ((c (string-ref x j))
(j+1 (+ j 1)))
(if (char=? c #\newline)
(begin
(display-substring j+1)
(set! after-newline? #t)
(loop1 j+1))
(loop2 j+1)))
(display-substring j)))))
((symbol? x)
(disp (symbol->string x)))
((char? x)
(disp (string x)))
((null? x))
((pair? x)
(if (eq? (car x) '$$indent$$)
(begin
(set! indent-level (+ indent-level 1))
(disp (cdr x))
(set! indent-level (- indent-level 1)))
(begin
(disp (car x))
(disp (cdr x)))))
((vector? x)
(disp (vector->list x)))
(else
(indent)
(display x port))))
(disp x))
;;;----------------------------------------------------------------------------
;; ***** PROCEDURE CALLING CONVENTION
(define univ-nb-gvm-regs 5)
(define univ-nb-arg-regs 3)
(define (univ-label-info targ nb-parms closed?)
;; After a GVM "entry-point" or "closure-entry-point" label, the following
;; is true:
;;
;; * return address is in GVM register 0
;;
;; * if nb-parms <= nb-arg-regs
;;
;; then parameter N is in GVM register N
;;
;; else parameter N is in
;; GVM register N-F, if N > F
;; GVM stack slot N, if N <= F
;; where F = nb-parms - nb-arg-regs
;;
;; * for a "closure-entry-point" GVM register nb-arg-regs+1 contains
;; a pointer to the closure object
;;
;; * other GVM registers contain an unspecified value
(let ((nb-stacked (max 0 (- nb-parms univ-nb-arg-regs))))
(define (location-of-parms i)
(if (> i nb-parms)
'()
(cons (cons i
(if (> i nb-stacked)
(make-reg (- i nb-stacked))
(make-stk i)))
(location-of-parms (+ i 1)))))
(let ((x (cons (cons 'return 0) (location-of-parms 1))))
(make-pcontext nb-stacked
(if closed?
(cons (cons 'closure-env
(make-reg (+ univ-nb-arg-regs 1)))
x)
x)))))
(define (univ-jump-info targ nb-args)
;; After a GVM "jump" instruction with argument count, the following
;; is true:
;;
;; * the return address is in GVM register 0
;;
;; * if nb-args <= nb-arg-regs
;;
;; then argument N is in GVM register N
;;
;; else argument N is in
;; GVM register N-F, if N > F
;; GVM stack slot N, if N <= F
;; where F = nb-args - nb-arg-regs
;;
;; * GVM register nb-arg-regs+1 contains a pointer to the closure object
;; if a closure is being jumped to
;;
;; * other GVM registers contain an unspecified value
(let ((nb-stacked (max 0 (- nb-args univ-nb-arg-regs))))
(define (location-of-args i)
(if (> i nb-args)
'()
(cons (cons i
(if (> i nb-stacked)
(make-reg (- i nb-stacked))
(make-stk i)))
(location-of-args (+ i 1)))))
(make-pcontext nb-stacked
(cons (cons 'return (make-reg 0))
(location-of-args 1)))))
;; The frame constraints are defined by the parameters
;; univ-frame-reserve and univ-frame-alignment.
(define univ-frame-reserve 0) ;; no extra slots reserved
(define univ-frame-alignment 1) ;; no alignment constraint
;; ***** PRIMITIVE PROCEDURE DATABASE
(define (univ-prim-info targ name)
(univ-prim-info* name))
(define (univ-prim-info* name)
(table-ref univ-prim-proc-table name #f))
(define univ-prim-proc-table (make-table))
(define (univ-prim-proc-add! x)
(let ((name (string->canonical-symbol (car x))))
(table-set! univ-prim-proc-table
name
(apply make-proc-obj (car x) #f #t #f (cdr x)))))
(for-each univ-prim-proc-add! prim-procs)
(define (univ-switch-testable? targ obj)
(pretty-print (list 'univ-switch-testable? 'targ obj))
#f)
(define (univ-object-type targ obj)
(pretty-print (list 'univ-object-type 'targ obj))
'bignum)
;; ***** DUMPING OF A COMPILATION MODULE
(define (univ-dump targ procs output c-intf script-line options)
(call-with-output-file
output
(lambda (port)
(univ-display
(runtime-system targ)
port)
(univ-dump-procs targ procs port)
(univ-display
(entry-point (make-ctx targ #f) (list-ref procs 0))
port)))
#f)
(define (univ-dump-procs targ procs port)
(let ((proc-seen (queue-empty))
(proc-left (queue-empty)))
(define (scan-obj obj)
(if (and (proc-obj? obj)
(proc-obj-code obj)
(not (memq obj (queue->list proc-seen))))
(begin
(queue-put! proc-seen obj)
(queue-put! proc-left obj))))
(define (dump-proc p)
(define (scan-bbs bbs)
(let* ((bb-done (make-stretchable-vector #f))
(bb-todo (queue-empty)))
(define (todo-lbl-num! n)
(queue-put! bb-todo (lbl-num->bb n bbs)))
(define (scan-bb ctx bb)
(if (stretchable-vector-ref bb-done (bb-lbl-num bb))
(gen "")
(begin
(stretchable-vector-set! bb-done (bb-lbl-num bb) #t)
(scan-bb-all ctx bb))))
(define (scan-bb-all ctx bb)
(scan-gvm-label
ctx
(bb-label-instr bb)
(lambda (ctx)
(scan-bb-all-except-label ctx bb))))
(define (scan-bb-all-except-label ctx bb)
(let loop ((lst (bb-non-branch-instrs bb))
(rev-res '()))
(if (pair? lst)
(loop (cdr lst)
(cons (scan-gvm-instr ctx (car lst))
rev-res))
(reverse
(cons (scan-gvm-instr ctx (bb-branch-instr bb))
rev-res)))))
(define (scan-gvm-label ctx gvm-instr proc)
(define (frame-info gvm-instr)
(let* ((frame
(gvm-instr-frame gvm-instr))
(fs
(frame-size frame))
(vars
(reverse (frame-slots frame)))
(link
(pos-in-list ret-var vars)))
(vector fs link)))
(let ((id (lbl->id ctx (label-lbl-num gvm-instr) (ctx-ns ctx))))
(gen (univ-function
ctx
id
(univ-indent
(case (label-type gvm-instr)
((simple)
(gen "\n"))
((entry)
(gen " "
(univ-comment
ctx
(if (label-entry-closed? gvm-instr)
"closure-entry-point\n"
"entry-point\n"))
(univ-if-then
ctx
(univ-not= ctx
(univ-global ctx (univ-prefix ctx "nargs"))
(label-entry-nb-parms gvm-instr))
(univ-throw ctx "\"wrong number of arguments\""))))
((return)
(gen " " (univ-comment ctx "return-point\n")))
((task-entry)
(gen " " (univ-comment ctx "task-entry-point\n")
(univ-throw ctx "\"task-entry-point GVM label unimplemented\"")))
((task-return)
(gen " " (univ-comment ctx "task-return-point\n")
(univ-throw ctx "\"task-return-point GVM label unimplemented\"")))
(else
(compiler-internal-error
"scan-gvm-label, unknown label type"))))
(univ-indent
(with-stack-base-offset
ctx
(- (frame-size (gvm-instr-frame gvm-instr)))
(lambda (ctx)
(proc ctx)))))
(if (and (eq? (label-type gvm-instr) 'return)
(eq? (target-name (ctx-target ctx)) 'js))
(let ((info (frame-info gvm-instr)))
(gen id ".fs = " (vector-ref info 0) ";\n"
id ".link = " (vector-ref info 1) ";\n"))
""))))
(define (scan-gvm-instr ctx gvm-instr)
;; TODO: combine with scan-gvm-opnd
(define (scan-opnd gvm-opnd)
(cond ((not gvm-opnd))
((obj? gvm-opnd)
(scan-obj (obj-val gvm-opnd)))
((clo? gvm-opnd)
(scan-opnd (clo-base gvm-opnd)))))
;; TODO: combine with scan-gvm-opnd
(case (gvm-instr-type gvm-instr)
((apply)
(for-each scan-opnd (apply-opnds gvm-instr))
(if (apply-loc gvm-instr)
(scan-opnd (apply-loc gvm-instr))))
((copy)
(scan-opnd (copy-opnd gvm-instr))
(scan-opnd (copy-loc gvm-instr)))
((close)
(for-each (lambda (parms)
(scan-opnd (closure-parms-loc parms))
(for-each scan-opnd (closure-parms-opnds parms)))
(close-parms gvm-instr)))
((ifjump)
(for-each scan-opnd (ifjump-opnds gvm-instr)))
((switch)
(scan-opnd (switch-opnd gvm-instr))
(for-each (lambda (c) (scan-obj (switch-case-obj c)))
(switch-cases gvm-instr)))
((jump)
(scan-opnd (jump-opnd gvm-instr))))
(case (gvm-instr-type gvm-instr)
((apply)
(let ((loc (apply-loc gvm-instr))
(prim (apply-prim gvm-instr))
(opnds (apply-opnds gvm-instr)))
(let ((proc (proc-obj-inline prim)))
(if (not proc)
(compiler-internal-error
"scan-gvm-instr, unknown 'prim'" prim)
(proc ctx opnds loc)))))
((copy)
(let ((loc (copy-loc gvm-instr))
(opnd (copy-opnd gvm-instr)))
(if opnd
(univ-assign ctx
(scan-gvm-opnd ctx loc)
(scan-gvm-opnd ctx opnd))
(gen ""))))
((close)
;; TODO
;; (close-parms gvm-instr)
(univ-throw ctx "\"close GVM instruction unimplemented\""))
((ifjump)
;; TODO
;; (ifjump-poll? gvm-instr)
(let ((test (ifjump-test gvm-instr))
(opnds (ifjump-opnds gvm-instr))
(true (ifjump-true gvm-instr))
(false (ifjump-false gvm-instr))
(fs (frame-size (gvm-instr-frame gvm-instr))))
(let ((proc (proc-obj-test test)))
(if (not proc)
(compiler-internal-error
"scan-gvm-instr, unknown 'test'" test)
(univ-if-then-else
ctx
(proc ctx opnds)
(jump-to-label ctx true fs)
(jump-to-label ctx false fs))))))
((switch)
;; TODO
;; (switch-opnd gvm-instr)
;; (switch-cases gvm-instr)
;; (switch-poll? gvm-instr)
;; (switch-default gvm-instr)
(univ-throw ctx "\"switch GVM instruction unimplemented\""))
((jump)
;; TODO
;; (jump-safe? gvm-instr)
;; test: (jump-poll? gvm-instr)
(gen (let ((nb-args (jump-nb-args gvm-instr)))
(if nb-args
(univ-assign ctx (univ-global ctx (univ-prefix ctx "nargs")) nb-args)
""))
(with-stack-pointer-adjust
ctx
(+ (frame-size (gvm-instr-frame gvm-instr))
(ctx-stack-base-offset ctx))
(lambda (ctx)
(let ((opnd (jump-opnd gvm-instr)))
(univ-return
ctx
(if (jump-poll? gvm-instr)
(gen (univ-prefix ctx "poll") "(" (scan-gvm-opnd ctx opnd) ")")
(scan-gvm-opnd ctx opnd))))))))
(else
(compiler-internal-error
"scan-gvm-instr, unknown 'gvm-instr':"
gvm-instr))))
(define (jump-to-label ctx n jump-fs)
(cond ((and univ-enable-jump-destination-inlining?
(let* ((bb (lbl-num->bb n bbs))
(label-instr (bb-label-instr bb)))
(and (eq? (label-type label-instr) 'simple)
(or (= (length (bb-precedents bb)) 1) ;; sole jump to destination bb?
(= (length (bb-non-branch-instrs bb)) 0))))) ;; very short destination bb?
(let* ((bb (lbl-num->bb n bbs))
(label-instr (bb-label-instr bb))
(label-fs (frame-size (gvm-instr-frame label-instr))))
(with-stack-pointer-adjust
ctx
(+ jump-fs
(ctx-stack-base-offset ctx))
(lambda (ctx)
(with-stack-base-offset
ctx
(- label-fs)
(lambda (ctx)
(scan-bb-all-except-label ctx bb)))))))
(else
(with-stack-pointer-adjust
ctx
(+ jump-fs
(ctx-stack-base-offset ctx))
(lambda (ctx)
(univ-return ctx (scan-gvm-opnd ctx (make-lbl n))))))))
(define (scan-gvm-opnd ctx gvm-opnd)
(if (lbl? gvm-opnd)
(todo-lbl-num! (lbl-num gvm-opnd)))
(translate-gvm-opnd ctx gvm-opnd))
(let ((ctx (make-ctx targ (proc-obj-name p))))
(todo-lbl-num! (bbs-entry-lbl-num bbs))
(let loop ((rev-res '()))
(if (queue-empty? bb-todo)
(reverse rev-res)
(loop (cons (scan-bb ctx (queue-get! bb-todo))
rev-res)))))))
(let ((ctx (make-ctx targ (proc-obj-name p))))
(gen "\n"
(univ-comment
ctx
(gen "-------------------------------- #<"
(if (proc-obj-primitive? p)
"primitive"
"procedure")
" "
(object->string (string->canonical-symbol (proc-obj-name p)))
"> =\n"))
(let ((x (proc-obj-code p)))
(if (bbs? x)
(scan-bbs x)
(gen ""))))))
(for-each scan-obj procs)
(let loop ((rev-res '()))
(if (queue-empty? proc-left)
(univ-display
(reverse rev-res)
port)
(loop (cons (dump-proc (queue-get! proc-left))
rev-res))))))
(define gen vector)
(define (make-ctx target ns)
(vector target ns 0))
(define (ctx-target ctx) (vector-ref ctx 0))
(define (ctx-target-set! ctx x) (vector-set! ctx 0 x))
(define (ctx-ns ctx) (vector-ref ctx 1))
(define (ctx-ns-set! ctx x) (vector-set! ctx 1 x))
(define (ctx-stack-base-offset ctx) (vector-ref ctx 2))
(define (ctx-stack-base-offset-set! ctx x) (vector-set! ctx 2 x))
(define (with-stack-base-offset ctx n proc)
(let ((save (ctx-stack-base-offset ctx)))
(ctx-stack-base-offset-set! ctx n)
(let ((result (proc ctx)))
(ctx-stack-base-offset-set! ctx save)
result)))
(define (with-stack-pointer-adjust ctx n proc)
(gen (if (= n 0)
(gen "")
(univ-increment ctx (univ-global ctx (univ-prefix ctx "sp")) n))
(with-stack-base-offset
ctx
(- (ctx-stack-base-offset ctx) n)
proc)))
(define (translate-gvm-opnd ctx gvm-opnd)
(cond ((not gvm-opnd)
(gen "NO_OPERAND"))
((reg? gvm-opnd)
(gen (univ-global ctx (univ-prefix ctx "reg"))
"["
(reg-num gvm-opnd)
"]"))
((stk? gvm-opnd)
(let ((n (+ (stk-num gvm-opnd) (ctx-stack-base-offset ctx))))
(gen (univ-global ctx (univ-prefix ctx "stack"))
"["
(univ-global ctx (univ-prefix ctx "sp"))
(cond ((= n 0)
(gen ""))
((< n 0)
(gen n))
(else
(gen "+" n)))
"]")))
((glo? gvm-opnd)
(gen (univ-global ctx (univ-prefix ctx "glo"))
"["
(object->string (symbol->string (glo-name gvm-opnd)))
"]"))
((clo? gvm-opnd)
(gen (translate-gvm-opnd ctx (clo-base gvm-opnd))
"["
(clo-index gvm-opnd)
"]"))
((lbl? gvm-opnd)
(translate-lbl ctx gvm-opnd))
((obj? gvm-opnd)
(translate-obj ctx (obj-val gvm-opnd)))
(else
(compiler-internal-error
"translate-gvm-opnd, unknown 'gvm-opnd':"
gvm-opnd))))
(define (translate-obj ctx obj)
(cond ((boolean? obj)
(univ-boolean ctx obj))
((number? obj)
(univ-number ctx obj))
((char? obj)
(univ-char ctx obj))
((string? obj)
(univ-string ctx obj))
((void-object? obj)
(gen "undefined"))
((proc-obj? obj)
(lbl->id ctx 1 (proc-obj-name obj)))
(else
(gen "UNIMPLEMENTED_OBJECT("
(object->string obj)
")"))))
(define (translate-lbl ctx lbl)
(lbl->id ctx (lbl-num lbl) (ctx-ns ctx)))
(define (lbl->id ctx num ns)
(univ-global ctx (univ-prefix ctx (gen "lbl" num "_" (scheme-id->c-id ns)))))
(define (runtime-system targ)
(case (target-name targ)
((js) ;rts js
#<<EOF
function Gambit_heapify_continuation(ra) {
var chain = false;
var prev_frame = false;
var prev_link = 0;
while (Gambit_sp !== 0) { // stack not empty
var fs = ra.fs;
var link = ra.link;
var frame = Gambit_stack.slice(Gambit_sp-fs, Gambit_sp+1);
if (prev_frame === false)
chain = frame;
else
prev_frame[prev_link+1] = frame;
prev_frame = frame;
frame[0] = ra;
Gambit_sp = Gambit_sp-fs;
ra = Gambit_stack[Gambit_sp+link+1];
prev_link = link;
}
if (prev_frame === false)
chain = Gambit_stack[0];
else
prev_frame[prev_link+1] = Gambit_stack[0];
Gambit_stack = [chain];
Gambit_sp = 0;
return Gambit_underflow_handler;
}
function Gambit_underflow_handler() {
var ra = false;
var frame = Gambit_stack[0];
if (frame !== false) { // not end of continuation?
ra = frame[0];
var fs = ra.fs;
var link = ra.link;
Gambit_stack = frame.slice(0, fs+1);
Gambit_sp = fs;
Gambit_stack[0] = frame[link+1];
Gambit_stack[link+1] = Gambit_underflow_handler;
}
return ra;
}
Gambit_underflow_handler.fs = 0;
var Gambit_glo = {};
var Gambit_reg = [Gambit_underflow_handler];
var Gambit_stack = [false];
var Gambit_sp = 0;
var Gambit_nargs = 0;
var Gambit_temp1 = false;
var Gambit_temp2 = false;
var Gambit_poll;
if (this.hasOwnProperty('setTimeout')) {
Gambit_poll = function (wakeup) { setTimeout(function () { Gambit_run(wakeup); }, 1); return false; };
} else {
Gambit_poll = function (wakeup) { return wakeup; };
}
function Gambit_Flonum(val) {
this.val = val;
}
Gambit_Flonum.prototype.toString = function ( ) {
if (parseFloat(this.val) == parseInt(this.val)) {
return this.val + ".";
} else {
return this.val;
}
}
var Gambit_chars = {}
function Gambit_Char(i) {
this.i = i;
}
Gambit_Char.integerToChar = function (i) {
var ch = Gambit_chars[i];
if (!ch) {
Gambit_chars[i] = new Gambit_Char(i);
ch = Gambit_chars[i];
}
return ch;
}
Gambit_Char.prototype.toString = function ( ) {
return String.fromCharCode(this.i);
}
function Gambit_Pair(car, cdr) {
this.car = car;
this.cdr = cdr;
}
function Gambit_String(charray) {
this.charray = charray;
}
Gambit_String.makestring = function ( n, c ) {
var a = new Array(n);
c = c || "";
for (i = 0; i < n; i++) {
a[i] = c.i;
}
return new Gambit_String(a);
}
Gambit_String.prototype.stringlength = function ( ) {
return this.charray.length;
}
// string-ref
Gambit_String.prototype.stringref = function ( n ) {
return this.charray[n];
}
// string-set!
Gambit_String.prototype.stringset = function ( n, c ) {
this.charray[n] = c.i;
}
Gambit_String.prototype.toString = function ( ) {
var s = "";
for (i = 0; i < this.stringlength(); i++) {
s = s.concat(String.fromCharCode(this.stringref(i)));
}
return s;
}
var Gambit_syms = {};
function Gambit_Symbol(s) {
this.symbolToString = function ( ) { return s; }
this.toString = function ( ) { return s; }
}
Gambit_Symbol.stringToSymbol = function ( s ) {
var sym = Gambit_syms[s];
if (!sym) {
Gambit_syms[s] = new Gambit_Symbol(s);
sym = Gambit_syms[s];
}
return sym;
}
var Gambit_kwds = {};
function Gambit_Keyword(s) {
s = s + ":";
this.keywordToString = function( ) { return s.substring(0, s.length-1); }
this.toString = function( ) { return s; }
}
Gambit_Keyword.stringToKeyword = function(s) {
var kwd = Gambit_kwds[s];
if (!kwd) {
Gambit_kwds[s] = new Gambit_Keyword(s);
kwd = Gambit_kwds[s];
}
return kwd;
}
function Gambit_lbl1_println() { // println
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
if (Gambit_reg[1] === false)
print("#f");
else if (Gambit_reg[1] === true)
print("#t");
else if (Gambit_reg[1] instanceof Gambit_Flonum)
print(Gambit_reg[1].toString());
else if (Gambit_reg[1] instanceof Gambit_String)
print(Gambit_reg[1].toString());
else if (Gambit_reg[1] instanceof Gambit_Char)
print(Gambit_reg[1].toString());
else
print(Gambit_reg[1]);
return Gambit_reg[0];
}
Gambit_glo["println"] = Gambit_lbl1_println;
function Gambit_Continuation(frame, denv) {
this.frame = frame;
this.denv = denv;
}
function Gambit_dump_cont(sp, ra) {
print("------------------------");
while (ra !== false) {
print("sp="+Gambit_sp + " fs="+ra.fs + " link="+ra.link);
Gambit_sp = Gambit_sp-ra.fs;
ra = Gambit_stack[Gambit_sp+ra.link+1];
}
print("------------------------");
}
function Gambit_lbl1__23__23_continuation_2d_capture() { // ##continuation-capture
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
Gambit_reg[0] = Gambit_heapify_continuation(Gambit_reg[0]);
var fn = Gambit_reg[1];
Gambit_reg[1] = new Gambit_Continuation(Gambit_stack[0], false);
return fn;
}
Gambit_glo["##continuation-capture"] = Gambit_lbl1__23__23_continuation_2d_capture;
function Gambit_lbl1__23__23_continuation_2d_return() { // ##continuation-return
if (Gambit_nargs !== 2)
throw "wrong number of arguments";
Gambit_sp = 0;
Gambit_stack[0] = Gambit_reg[1].frame;
Gambit_reg[0] = Gambit_underflow_handler;
Gambit_reg[1] = Gambit_reg[2];
return Gambit_reg[0];
}
Gambit_glo["##continuation-return"] = Gambit_lbl1__23__23_continuation_2d_return;
function Gambit_lbl1__23__23_continuation_2d_graft() { // ##continuation-graft
if (Gambit_nargs < 2 || Gambit_nargs > 3)
throw "wrong number of arguments";
Gambit_sp = 0;
Gambit_stack[0] = Gambit_reg[1].frame;
Gambit_reg[0] = Gambit_underflow_handler;
var fn = Gambit_reg[2];
Gambit_reg[1] = Gambit_reg[3]; // copy first argument (if there is one)
Gambit_nargs = Gambit_nargs-2;
return fn;
}
Gambit_glo["##continuation-graft"] = Gambit_lbl1__23__23_continuation_2d_graft;
function Gambit_lbl1__23__23_continuation_3f_() { // ##continuation?
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
Gambit_reg[1] = Gambit_reg[1] instanceof Gambit_Continuation;
return Gambit_reg[0];
}
Gambit_glo["##continuation?"] = Gambit_lbl1__23__23_continuation_3f_;
function Gambit_lbl1__23__23_continuation_2d_frame() { // ##continuation-frame
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
Gambit_reg[1] = Gambit_reg[1].frame;
return Gambit_reg[0];
}
Gambit_glo["##continuation-frame"] = Gambit_lbl1__23__23_continuation_2d_frame;
function Gambit_lbl1__23__23_continuation_2d_denv() { // ##continuation-denv
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
Gambit_reg[1] = Gambit_reg[1].denv;
return Gambit_reg[0];
}
Gambit_glo["##continuation-denv"] = Gambit_lbl1__23__23_continuation_2d_denv;
function Gambit_lbl1__23__23_continuation_2d_fs() { // ##continuation-fs
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
Gambit_reg[1] = Gambit_reg[1].frame[0].fs;
return Gambit_reg[0];
}
Gambit_glo["##continuation-fs"] = Gambit_lbl1__23__23_continuation_2d_fs;
function Gambit_lbl1__23__23_frame_2d_fs() { // ##frame-fs
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
Gambit_reg[1] = Gambit_reg[1][0].fs;
return Gambit_reg[0];
}
Gambit_glo["##frame-fs"] = Gambit_lbl1__23__23_frame_2d_fs;
function Gambit_lbl1__23__23_return_2d_fs() { // ##return-fs
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
Gambit_reg[1] = Gambit_reg[1].fs;
return Gambit_reg[0];
}
Gambit_glo["##return-fs"] = Gambit_lbl1__23__23_return_2d_fs;
function Gambit_lbl1__23__23_continuation_2d_link() { // ##continuation-link
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
Gambit_reg[1] = Gambit_reg[1].frame[0].link;
return Gambit_reg[0];
}
Gambit_glo["##continuation-link"] = Gambit_lbl1__23__23_continuation_2d_link;
function Gambit_lbl1__23__23_frame_2d_link() { // ##frame-link
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
Gambit_reg[1] = Gambit_reg[1][0].link;
return Gambit_reg[0];
}
function Gambit_lbl1__23__23_continuation_2d_ret() { // ##continuation-ret
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
Gambit_reg[1] = Gambit_reg[1].frame[0];
return Gambit_reg[0];
}
Gambit_glo["##continuation-ret"] = Gambit_lbl1__23__23_continuation_2d_ret;
function Gambit_lbl1__23__23_frame_2d_ret() { // ##frame-ret
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
Gambit_reg[1] = Gambit_reg[1][0];
return Gambit_reg[0];
}
Gambit_glo["##frame-ret"] = Gambit_lbl1__23__23_frame_2d_ret;
function Gambit_lbl1__23__23_continuation_2d_ref() { // ##continuation-ref
if (Gambit_nargs !== 2)
throw "wrong number of arguments";
Gambit_reg[1] = Gambit_reg[1].frame[Gambit_reg[2]];
return Gambit_reg[0];
}
Gambit_glo["##continuation-ref"] = Gambit_lbl1__23__23_continuation_2d_ref;
function Gambit_lbl1__23__23_frame_2d_ref() { // ##frame-ref
if (Gambit_nargs !== 2)
throw "wrong number of arguments";
Gambit_reg[1] = Gambit_reg[1][Gambit_reg[2]];
return Gambit_reg[0];
}
Gambit_glo["##frame-ref"] = Gambit_lbl1__23__23_frame_2d_ref;
function Gambit_lbl1__23__23_continuation_2d_slot_2d_live_3f_() { // ##continuation-slot-live?
if (Gambit_nargs !== 2)
throw "wrong number of arguments";
Gambit_reg[1] = true;
return Gambit_reg[0];
}
Gambit_glo["##continuation-slot-live?"] = Gambit_lbl1__23__23_continuation_2d_slot_2d_live_3f_;
function Gambit_lbl1__23__23_frame_2d_slot_2d_live_3f_() { // ##frame-slot-live?
if (Gambit_nargs !== 2)
throw "wrong number of arguments";
Gambit_reg[1] = true;
return Gambit_reg[0];
}
Gambit_glo["##frame-slot-live?"] = Gambit_lbl1__23__23_frame_2d_slot_2d_live_3f_;
function Gambit_lbl1__23__23_continuation_2d_next() { // ##continuation-next
if (Gambit_nargs !== 1)
throw "wrong number of arguments";
var frame = Gambit_reg[1].frame;
var denv = Gambit_reg[1].denv;
var next_frame = frame[frame[0].link+1];
if (next_frame === false)
Gambit_reg[1] = false;
else
Gambit_reg[1] = new Gambit_Continuation(next_frame, denv);
return Gambit_reg[0];
}
Gambit_glo["##continuation-next"] = Gambit_lbl1__23__23_continuation_2d_next;
function Gambit_run(pc)
{
while (pc !== false)
pc = pc();
}
EOF
)
((python) ;rts py
#<<EOF
#! /usr/bin/python
from array import array
import ctypes
Gambit_glo = {}
Gambit_reg = {0:False}
Gambit_stack = {}
Gambit_sp = -1
Gambit_nargs = 0
Gambit_temp1 = False
Gambit_temp2 = False
#
# char
#
class Gambit_Char:
chars = {}
def __init__ ( self, c ):
self.c = c
def __str__ ( self ):
return self.c
# integer->char
def Gambit_integerToChar ( i ):
if Gambit_Char.chars.has_key(i):
return Gambit_Char.chars[i]
else:
Gambit_Char.chars[i] = Gambit_Char(unichr(i))
return Gambit_Char.chars[i]
# char->integer
def Gambit_charToInteger ( c ):
return ord(c.c)
# char?
def Gambit_charp ( c ):
return (isinstance(c, Char))
#
# String
#
class Gambit_String:
def __init__ ( self, *args ):
self.chars = array('u', list(args))
def __getitem__ ( self, n ):
return self.chars[n]
def __setitem__ ( self, n, c ):
self.chars[n] = c.c
def __len__ ( self ):
return len(self.chars)
def __eq__ ( self, s ):
self.chars == s.chars
def __str__ ( self ):
return "".join(self.chars)
def Gambit_makestring ( n, c ):
args = [c.c]*n
return Gambit_String(*args)
def Gambit_stringp ( s ):
return isinstance(s, String)
def Gambit_lbl1_println(): # println
global Gambit_glo, Gambit_reg, Gambit_stack, Gambit_sp, Gambit_nargs, Gambit_temp1, Gambit_temp2
if Gambit_nargs != 1:
raise "wrong number of arguments"
if Gambit_reg[1] is False:
print("#f")
elif Gambit_reg[1] is True:
print("#t")
elif isinstance(Gambit_reg[1], float) and (int(Gambit_reg[1]) == round(Gambit_reg[1])):
print(str(int(Gambit_reg[1])) + '.')
else:
print(Gambit_reg[1])
return Gambit_reg[0]
Gambit_glo["println"] = Gambit_lbl1_println
def Gambit_poll(wakeup):
return wakeup
def Gambit_run(pc):
while pc != False:
pc = pc()
EOF
)
((ruby) ;rts rb
#<<EOF
# encoding: utf-8
$Gambit_glo = {}
$Gambit_reg = {0=>false}
$Gambit_stack = {}
$Gambit_sp = -1
$Gambit_nargs = 0
$Gambit_temp1 = false
$Gambit_temp2 = false
$Gambit_chars = {}
class Gambit_Char
def initialize ( code )
@code = code
end
def code
@code
end
def to_s
@code.chr
end
end
def Gambit_integerToChar ( i )
if $Gambit_chars.has_key?(i)
return $Gambit_chars[i]
else
c = Gambit_Char.new(i)
$Gambit_chars[i] = c
return c
end
end
$Gambit_lbl1_println = lambda { # println
if $Gambit_nargs != 1
raise "wrong number of arguments"
end
if $Gambit_reg[1] == false
print("#f")
elsif $Gambit_reg[1] == true
print("#t")
elsif $Gambit_reg[1].equal?(nil)
print("'()")
elsif $Gambit_reg[1].class == Float && $Gambit_reg[1] == $Gambit_reg[1].round
print($Gambit_reg[1].round.to_s() + ".")
else
print($Gambit_reg[1])
end
print("\n")
return $Gambit_reg[0]
}
$Gambit_glo["println"] = $Gambit_lbl1_println
def Gambit_poll(wakeup)
return wakeup
end
def Gambit_run(pc)
while pc != false
pc = pc.call
end
end
EOF
)
((php) ;rts php
#<<EOF
??????????????????????????????????
EOF
)
(else
(compiler-internal-error
"runtime-system, unknown target"))))
(define (entry-point ctx main-proc)
(let ((entry (lbl->id ctx 1 (proc-obj-name main-proc))))
(gen "\n"
(univ-comment ctx "--------------------------------\n")
"\n"
(case (target-name (ctx-target ctx))
((js php)
(gen (univ-prefix ctx "run") "(" entry ");\n"))
((python ruby)
(gen (univ-prefix ctx "run") "(" entry ")\n"))
(else
(compiler-internal-error
"entry-point, unknown target"))))))
;;;----------------------------------------------------------------------------
(define (univ-global ctx name)
(case (target-name (ctx-target ctx))
((js python php) name)
((ruby) (gen "$" name))
(else
(compiler-internal-error
"univ-global, unknown target"))))
(define (univ-function ctx name header body)
(gen "\n"
(case (target-name (ctx-target ctx))
((js php)
(gen "function " name "() {" header body "}\n"))
((python)
(gen "def " name "():\n"
(univ-indent (gen "global "
(univ-prefix ctx "glo") ","
(univ-prefix ctx "reg") ","
(univ-prefix ctx "stack") ","
(univ-prefix ctx "sp") ","
(univ-prefix ctx "nargs") ","
(univ-prefix ctx "temp1") ","
(univ-prefix ctx "temp2")))
header
body))
((ruby)
(univ-assign ctx name (gen "lambda {" header body "}")))
(else
(compiler-internal-error
"univ-function, unknown target")))))
(define (univ-comment ctx comment)
(case (target-name (ctx-target ctx))
((js php)
(gen "// " comment))
((python ruby)
(gen "# " comment))
(else
(compiler-internal-error
"univ-comment, unknown target"))))
(define (univ-return ctx expr)
(case (target-name (ctx-target ctx))
((js php)
(gen "return " expr ";\n"))
((python ruby)
(gen "return " expr "\n"))
(else
(compiler-internal-error
"univ-return, unknown target"))))
(define (univ-throw ctx expr)
(case (target-name (ctx-target ctx))
((js php)
(gen "throw " expr ";\n"))
((python ruby)
(gen "raise " expr "\n"))
(else
(compiler-internal-error
"univ-throw, unknown target"))))
(define (univ-eq ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js)
(gen expr1 " === " expr2))
((python)
(gen expr1 " is " expr2))
((ruby)
(gen expr1 " .equal?(" expr2 ")"))
((php)
(gen expr1 " == " expr2))
(else
(compiler-internal-error
"univ-eq, unknown target"))))
(define (univ-< ctx expr1 expr2)
(gen expr1 " < " expr2))
(define (univ-<= ctx expr1 expr2)
(gen expr1 " <= " expr2))
(define (univ-> ctx expr1 expr2)
(gen expr1 " > " expr2))
(define (univ->= ctx expr1 expr2)
(gen expr1 " >= " expr2))
(define (univ-= ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js)
(gen expr1 " === " expr2))
((python ruby php)
(gen expr1 " == " expr2))
(else
(compiler-internal-error
"univ-=, unknown target"))))
(define (univ-not= ctx expr1 expr2)
(case (target-name (ctx-target ctx))
((js)
(gen expr1 " !== " expr2))
((python ruby php)
(gen expr1 " != " expr2))
(else
(compiler-internal-error
"univ-not=, unknown target"))))
(define (univ-boolean ctx val)
(case (target-name (ctx-target ctx))
((js ruby php)
(gen (if val "true" "false")))
((python)
(gen (if val "True" "False")))
(else
(compiler-internal-error
"univ-boolean, unknown target"))))
(define (univ-assign ctx loc expr)
(case (target-name (ctx-target ctx))
((js php)
(gen loc " = " expr ";\n"))
((python ruby)
(gen loc " = " expr "\n"))
(else
(compiler-internal-error
"univ-assign, unknown target"))))
(define (univ-increment ctx loc expr)
(case (target-name (ctx-target ctx))
((js php)
(gen loc " += " expr ";\n"))
((python ruby)
(gen loc " += " expr "\n"))
(else
(compiler-internal-error
"univ-increment, unknown target"))))
(define (univ-expr ctx expr)
(case (target-name (ctx-target ctx))
((js php)
(gen expr ";\n"))
((python ruby)
(gen expr "\n"))
(else
(compiler-internal-error
"univ-expr, unknown target"))))
(define (univ-if-then ctx test true)
(case (target-name (ctx-target ctx))
((js php)
(gen "if (" test ") {\n"
(univ-indent true)
"}\n"))
((python)
(gen "if " test ":\n"
(univ-indent true)))
((ruby)
(gen "if " test "\n"
(univ-indent true)
"end\n"))
(else
(compiler-internal-error
"univ-if-then, unknown target"))))
(define (univ-if-then-else ctx test true false)
(case (target-name (ctx-target ctx))
((js php)
(gen "if (" test ") {\n"
(univ-indent true)
"} else {\n"
(univ-indent false)
"}\n"))
((python)
(gen "if " test ":\n"
(univ-indent true)
"else:\n"
(univ-indent false)))
((ruby)
(gen "if " test "\n"
(univ-indent true)
"else\n"
(univ-indent false)
"end\n"))
(else
(compiler-internal-error
"univ-if-then-else, unknown target"))))
(define (univ-define-prim name proc-safe? side-effects? apply-gen ifjump-gen)
(let ((prim (univ-prim-info* (string->canonical-symbol name))))
(if apply-gen
(begin
(proc-obj-inlinable?-set!
prim
(lambda (env)
(or proc-safe?
(not (safe? env)))))
(proc-obj-inline-set!
prim
(lambda (ctx opnds loc)
(if loc ;; result is needed?
(univ-assign ctx
(translate-gvm-opnd ctx loc)
(apply-gen ctx opnds))
(if side-effects? ;; only generate code for side-effect
(univ-expr ctx
(apply-gen ctx opnds))
(gen "")))))))
(if ifjump-gen
(begin
(proc-obj-testable?-set!
prim
(lambda (env)
(or proc-safe?
(not (safe? env)))))
(proc-obj-test-set!
prim
(lambda (ctx opnds)
(ifjump-gen ctx opnds)))))))
(define (univ-define-prim-bool name proc-safe? side-effects? prim-gen)
(univ-define-prim name proc-safe? side-effects? prim-gen prim-gen))
(define (univ-number ctx obj)
(if (exact? obj)
(cond ((integer? obj)
(gen obj))
(else
(compiler-internal-error
"translate-obj, unsupported exact number:" obj)))
(cond ((real? obj)
(let ((x
(if (integer? obj)
(gen obj 0)
(gen obj))))
(case (target-name (ctx-target ctx))
((js)
(gen "new " (univ-prefix ctx "Flonum") "(" x ")"))
(else
x))))
(else
(compiler-internal-error
"translate-obj, unsupported inexact number:" obj)))))
(define (univ-char ctx obj)
(let ((code (char->integer obj)))
(case (target-name (ctx-target ctx))
((js)
(gen (univ-prefix ctx "Char.integerToChar")
"("
code
")"))
((python ruby)
(gen (univ-prefix ctx "integerToChar")
"("
code
")"))
((php) (gen code)) ;TODO: complete
(else
(compiler-internal-error
"univ-char, unknown target")))))
(define (univ-string ctx obj)
(define (flatten list)
(cond ((null? list) '())
((list? (car list)) (append (flatten (car list))
(flatten (cdr list))))
(else
(cons (car list) (flatten (cdr list))))))
(define (string->charray s) ; js: "AAA" -> "[65, 65, 65]"
(define (inscomma lst res) ; ("65" "65" "65") -> ("65" ", " "65" ", " "65")
(cond ((null? lst) res)
((= 1 (length lst)) (append res (list (car lst))))
(else (append (list (car lst) ", ")
res
(inscomma (cdr lst) '())))))
(let* ((charlist (string->list s))
(intlist (map char->integer charlist))
(strlist (map number->string intlist))
(charray (inscomma strlist '())))
(apply string-append (flatten (list "[" charray "]")))))
(case (target-name (ctx-target ctx))
((js)
(let ((s (object->string obj)))
(gen "new " (univ-prefix ctx "String")
"("
(string->charray (substring s 1 (- (string-length s) 1)))
")")))
((python)
(gen (univ-prefix ctx "String")
"(*list(unicode("
(object->string obj)
")))"))
((ruby php) ;TODO: complete
(gen (object->string obj)))
(else
(compiler-internal-error
"univ-string, unknown target"))))
;;; Primitive procedures
(univ-define-prim-bool "##not" #t #f
(lambda (ctx opnds)
(univ-eq ctx
(translate-gvm-opnd ctx (list-ref opnds 0))
(univ-boolean ctx #f))))
(univ-define-prim-bool "##eq?" #t #f
(lambda (ctx opnds)
(univ-eq ctx
(translate-gvm-opnd ctx (list-ref opnds 0))
(translate-gvm-opnd ctx (list-ref opnds 1)))))
(univ-define-prim "##fx+" #f #f
(lambda (ctx opnds)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
" + "
(translate-gvm-opnd ctx (list-ref opnds 1))))
#f)
(univ-define-prim "##fx-" #f #f
(lambda (ctx opnds)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
" - "
(translate-gvm-opnd ctx (list-ref opnds 1))))
#f)
(univ-define-prim "##fx*" #f #f
(lambda (ctx opnds)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
" * "
(translate-gvm-opnd ctx (list-ref opnds 1))))
#f)
(univ-define-prim-bool "##fx<" #f #f
(lambda (ctx opnds)
(univ-< ctx
(translate-gvm-opnd ctx (list-ref opnds 0))
(translate-gvm-opnd ctx (list-ref opnds 1)))))
(univ-define-prim-bool "##fx<=" #f #f
(lambda (ctx opnds)
(univ-<= ctx
(translate-gvm-opnd ctx (list-ref opnds 0))
(translate-gvm-opnd ctx (list-ref opnds 1)))))
(univ-define-prim-bool "##fx>" #f #f
(lambda (ctx opnds)
(univ-> ctx
(translate-gvm-opnd ctx (list-ref opnds 0))
(translate-gvm-opnd ctx (list-ref opnds 1)))))
(univ-define-prim-bool "##fx>=" #f #f
(lambda (ctx opnds)
(univ->= ctx
(translate-gvm-opnd ctx (list-ref opnds 0))
(translate-gvm-opnd ctx (list-ref opnds 1)))))
(univ-define-prim-bool "##fx=" #f #f
(lambda (ctx opnds)
(univ-= ctx
(translate-gvm-opnd ctx (list-ref opnds 0))
(translate-gvm-opnd ctx (list-ref opnds 1)))))
(univ-define-prim "##fx+?" #f #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen "(temp2 = (temp1 = "
(translate-gvm-opnd ctx (list-ref opnds 0))
" + "
(translate-gvm-opnd ctx (list-ref opnds 1))
")<<"
univ-tag-bits
">>"
univ-tag-bits
") === temp1 && temp2"))
((python)
(gen "(lambda temp1: (lambda temp2: temp1 == temp2 and temp2)(ctypes.c_int32(temp1<<"
univ-tag-bits
").value>>"
univ-tag-bits
"))("
(translate-gvm-opnd ctx (list-ref opnds 0))
" + "
(translate-gvm-opnd ctx (list-ref opnds 1))
")"))
((ruby php)
(gen "(temp2 = (((temp1 = "
(translate-gvm-opnd ctx (list-ref opnds 0))
" + "
(translate-gvm-opnd ctx (list-ref opnds 1))
") + "
(expt 2 (- univ-word-bits (+ 1 univ-tag-bits)))
") & "
(- (expt 2 (- univ-word-bits univ-tag-bits)) 1)
") - "
(expt 2 (- univ-word-bits (+ 1 univ-tag-bits)))
") == temp1 && temp2"))
(else
(compiler-internal-error
"##fx+?, unknown target"))))
#f)
(univ-define-prim "##fx-?" #f #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen "(temp2 = (temp1 = "
(translate-gvm-opnd ctx (list-ref opnds 0))
" - "
(translate-gvm-opnd ctx (list-ref opnds 1))
")<<"
univ-tag-bits
">>"
univ-tag-bits
") === temp1 && temp2"))
((python)
(gen "(lambda temp1: (lambda temp2: temp1 == temp2 and temp2)(ctypes.c_int32(temp1<<"
univ-tag-bits
").value>>"
univ-tag-bits
"))("
(translate-gvm-opnd ctx (list-ref opnds 0))
" - "
(translate-gvm-opnd ctx (list-ref opnds 1))
")"))
((ruby php)
(gen "(temp2 = (((temp1 = "
(translate-gvm-opnd ctx (list-ref opnds 0))
" - "
(translate-gvm-opnd ctx (list-ref opnds 1))
") + "
(expt 2 (- univ-word-bits (+ 1 univ-tag-bits)))
") & "
(- (expt 2 (- univ-word-bits univ-tag-bits)) 1)
") - "
(expt 2 (- univ-word-bits (+ 1 univ-tag-bits)))
") == temp1 && temp2"))
(else
(compiler-internal-error
"##fx-?, unknown target"))))
#f)
(univ-define-prim "##fxwrap+" #f #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen "("
(translate-gvm-opnd ctx (list-ref opnds 0))
" + "
(translate-gvm-opnd ctx (list-ref opnds 1))
")<<"
univ-tag-bits
">>"
univ-tag-bits))
((python)
(gen "ctypes.c_int32(("
(translate-gvm-opnd ctx (list-ref opnds 0))
" + "
(translate-gvm-opnd ctx (list-ref opnds 1))
")<<"
univ-tag-bits
").value>>"
univ-tag-bits))
((ruby php)
(gen "((("
(translate-gvm-opnd ctx (list-ref opnds 0))
" + "
(translate-gvm-opnd ctx (list-ref opnds 1))
") + "
(expt 2 (- univ-word-bits (+ 1 univ-tag-bits)))
") & "
(- (expt 2 (- univ-word-bits univ-tag-bits)) 1)
") - "
(expt 2 (- univ-word-bits (+ 1 univ-tag-bits)))))
(else
(compiler-internal-error
"##fxwrap+, unknown target"))))
#f)
(univ-define-prim "##fxwrap-" #f #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen "("
(translate-gvm-opnd ctx (list-ref opnds 0))
" - "
(translate-gvm-opnd ctx (list-ref opnds 1))
")<<"
univ-tag-bits
">>"
univ-tag-bits))
((python)
(gen "ctypes.c_int32(("
(translate-gvm-opnd ctx (list-ref opnds 0))
" - "
(translate-gvm-opnd ctx (list-ref opnds 1))
")<<"
univ-tag-bits
").value>>"
univ-tag-bits))
((ruby php)
(gen "((("
(translate-gvm-opnd ctx (list-ref opnds 0))
" - "
(translate-gvm-opnd ctx (list-ref opnds 1))
") + "
(expt 2 (- univ-word-bits (+ 1 univ-tag-bits)))
") & "
(- (expt 2 (- univ-word-bits univ-tag-bits)) 1)
") - "
(expt 2 (- univ-word-bits (+ 1 univ-tag-bits)))))
(else
(compiler-internal-error
"##fxwrap-, unknown target"))))
#f)
(univ-define-prim "##fxwrap*" #f #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
;; TODO: fix this JS code, which does not work when the result of the multiplication is more than 52 bits (due to JS's use of 64 IEEE floats)
;; idea: detect the special case of a constant in either operands that is less than 22 bits (because a multiplication of a 30 bit fixnum integer and 22 bit integer will fit in 52 bits)
(gen "("
(translate-gvm-opnd ctx (list-ref opnds 0))
" * "
(translate-gvm-opnd ctx (list-ref opnds 1))
")<<"
univ-tag-bits
">>"
univ-tag-bits))
((python)
(gen "ctypes.c_int32(("
(translate-gvm-opnd ctx (list-ref opnds 0))
" * "
(translate-gvm-opnd ctx (list-ref opnds 1))
")<<"
univ-tag-bits
").value>>"
univ-tag-bits))
((ruby php)
;; TODO: fix this for PHP which may have 32 or 64 bit ints
;; For ruby it is OK because ruby will use bignums
(gen "((("
(translate-gvm-opnd ctx (list-ref opnds 0))
" * "
(translate-gvm-opnd ctx (list-ref opnds 1))
") + "
(expt 2 (- univ-word-bits (+ 1 univ-tag-bits)))
") & "
(- (expt 2 (- univ-word-bits univ-tag-bits)) 1)
") - "
(expt 2 (- univ-word-bits (+ 1 univ-tag-bits)))))
(else
(compiler-internal-error
"##fxwrap*, unknown target"))))
#f)
(univ-define-prim "##null?" #f #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen "("
(translate-gvm-opnd ctx (list-ref opnds 0))
" === null)"))
((python)
(gen "("
(translate-gvm-opnd ctx (list-ref opnds 0))
" is None)"))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
".equal?(nil)"))
((php) ;TODO: complete
(gen ""))
(else
(compiler-internal-error
"##null?, unknown target"))))
#f)
(univ-define-prim "##cons" #f #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen "new "
(univ-prefix ctx "Pair")
"("
(translate-gvm-opnd ctx (list-ref opnds 0))
", "
(translate-gvm-opnd ctx (list-ref opnds 1))
")"))
;; ((python)
;; (gen ""))
;; ((ruby)
;; (gen ""))
((python ruby php) ;TODO: complete
(gen ""))
(else
(compiler-internal-error
"##cons, unknown target"))))
#f)
(univ-define-prim "##car" #f #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
".car"))
;; ((python)
;; (gen ""))
;; ((ruby)
;; (gen ""))
((python ruby php) ;TODO: complete
(gen ""))
(else
(compiler-internal-error
"##car, unknown target"))))
#f)
(univ-define-prim "##cdr" #f #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
".cdr"))
;; ((python)
;; (gen ""))
;; ((ruby)
;; (gen ""))
((python ruby php) ;TODO: complete
(gen ""))
(else
(compiler-internal-error
"##cdr, unknown target"))))
#f)
(univ-define-prim "##set-car!" #f #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
".car = "
(translate-gvm-opnd ctx (list-ref opnds 1))))
;; ((python)
;; (gen ""))
;; ((ruby)
;; (gen ""))
((python ruby php) ;TODO: complete
(gen ""))
(else
(compiler-internal-error
"##set-car!, unknown target"))))
#f)
(univ-define-prim "##set-cdr!" #f #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
".cdr = "
(translate-gvm-opnd ctx (list-ref opnds 1))))
;; ((python)
;; (gen ""))
;; ((ruby)
;; (gen ""))
((python ruby php) ;TODO: complete
(gen ""))
(else
(compiler-internal-error
"##set-cdr!, unknown target"))))
#f)
(univ-define-prim "##make-string" #f #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen (univ-prefix ctx "String.makestring")
"("
(translate-gvm-opnd ctx (list-ref opnds 0))
", "
(translate-gvm-opnd ctx (list-ref opnds 1))
")"))
((python)
(gen (univ-prefix ctx "makestring")
"("
(translate-gvm-opnd ctx (list-ref opnds 0))
", "
(translate-gvm-opnd ctx (list-ref opnds 1))
")"))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 1))
".code.chr*"
(translate-gvm-opnd ctx (list-ref opnds 0))))
((php) ;TODO: complete
(gen ""))
(else
(compiler-internal-error
"##make-string, unknown target"))))
#f)
(univ-define-prim "##string-set!" #f #t
(lambda (ctx opnds)
(display "##string-set!")(newline)
(case (target-name (ctx-target ctx))
((js)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
".stringset("
(translate-gvm-opnd ctx (list-ref opnds 1))
", "
(translate-gvm-opnd ctx (list-ref opnds 2))
")"))
((python)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
"["
(translate-gvm-opnd ctx (list-ref opnds 1))
"] = "
(translate-gvm-opnd ctx (list-ref opnds 2))))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
"["
(translate-gvm-opnd ctx (list-ref opnds 1))
"] = "
(translate-gvm-opnd ctx (list-ref opnds 2))
".code.chr"))
((php) ;TODO: complete
(gen ""))
(else
(compiler-internal-error
"##string-set!, unknown target"))))
#f)
(univ-define-prim "##string-ref" #f #f
(lambda (ctx opnds)
(display "##string-ref")(newline)
(case (target-name (ctx-target ctx))
((js)
(gen "new "
(univ-prefix ctx "Char")
"("
(translate-gvm-opnd ctx (list-ref opnds 0))
".stringref("
(translate-gvm-opnd ctx (list-ref opnds 1))
"))"))
((python)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
"["
(translate-gvm-opnd ctx (list-ref opnds 1))
"]"))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
"["
(translate-gvm-opnd ctx (list-ref opnds 1))
"].chr"))
((php) ;TODO: complete
(gen ""))
(else
(compiler-internal-error
"##string-ref, unknown target"))))
#f)
(univ-define-prim-bool "##fixnum?" #t #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen "typeof "
(translate-gvm-opnd ctx (list-ref opnds 0))
" == \"number\""))
((python)
(gen "isinstance("
(translate-gvm-opnd ctx (list-ref opnds 0))
", int) and not "
"isinstance("
(translate-gvm-opnd ctx (list-ref opnds 0))
", bool)"))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
".class == Fixnum"))
((php)
(gen "is_int("
(translate-gvm-opnd ctx (list-ref opnds 0))
")"))
(else
(compiler-internal-error
"##fixnum?, unknown target")))))
(univ-define-prim-bool "##flonum?" #t #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
" instanceof "
(univ-prefix ctx "Flonum")))
((python)
(gen "isinstance("
(translate-gvm-opnd ctx (list-ref opnds 0))
", float)"))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
".class == Float"))
((php)
(gen "is_float("
(translate-gvm-opnd ctx (list-ref opnds 0))
")"))
(else
(compiler-internal-error
"##flonum?, unknown target")))))
(univ-define-prim-bool "##char?" #t #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js php)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
" instanceof "
(univ-prefix ctx "Char")))
((python)
(gen "isinstance("
(translate-gvm-opnd ctx (list-ref opnds 0))
", "
(univ-prefix ctx "Char")))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
".class == "
(univ-prefix ctx "Char")))
(else
(compiler-internal-error
"##char?, unknown target")))))
(univ-define-prim-bool "##pair?" #t #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js php)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
" instanceof "
(univ-prefix ctx "Pair")))
((python)
(gen "isinstance("
(translate-gvm-opnd ctx (list-ref opnds 0))
", "
(univ-prefix ctx "Pair")))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
".class == "
(univ-prefix ctx "Pair")))
(else
(compiler-internal-error
"##pair?, unknown target")))))
(univ-define-prim-bool "##string?" #t #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js php)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
" instanceof "
(univ-prefix ctx "String")))
((python)
(gen "isinstance("
(translate-gvm-opnd ctx (list-ref opnds 0))
", "
(univ-prefix ctx "String")))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
".class == "
(univ-prefix ctx "String")))
(else
(compiler-internal-error
"##string?, unknown target")))))
(define univ-tag-bits 2)
(define univ-word-bits 32)
;;;============================================================================
Jump to Line
Something went wrong with that request. Please try again.