nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Refactor (define) parser to work in (let), (lambda), (begin), etc. 

Add support for (fix=), (list), (and), (or), (cond), (when), and (unless).
Fix a mapper bug which could assign the same frame var to separate variables.
Update make-struct primitive for new structure type layout.
Change primitives to use #% as prefix instead of just %.
Add primitive operations for comparing byte-strings.
This commit is contained in:
Jesse D. McDonald 2010-05-25 22:36:04 -05:00
parent 061364c75c
commit 9e4286b49e
13 changed files with 411 additions and 326 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
builtin.c
View File

@ -97,7 +97,7 @@ static void register_structure(void)
/* Slot 1: List of superclasses, most to least specific */
_get_struct(structure_type_root.value)->slots[SS(SUPERS)] = NIL;
/* Slot 2: Total number of slots (excl. type) */
_get_struct(structure_type_root.value)->slots[SS(SLOTS)] = fixnum_value(STRUCTURE_SLOTS);
_get_struct(structure_type_root.value)->slots[SS(NSLOTS)] = fixnum_value(STRUCTURE_SLOTS);
/* Slot 3: Callable object used as proxy when structure is APPLY'd. */
/* Can be LAMBDA, callable structure instance, builtin, or FALSE_VALUE. */
_get_struct(structure_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
@ -114,7 +114,7 @@ static void register_template(void)
/* Slot 1: List of superclasses, most to least specific */
_get_struct(template_type_root.value)->slots[SS(SUPERS)] = NIL;
/* Slot 2: Total number of slots (excl. type) */
_get_struct(template_type_root.value)->slots[SS(SLOTS)] = fixnum_value(TEMPLATE_SLOTS);
_get_struct(template_type_root.value)->slots[SS(NSLOTS)] = fixnum_value(TEMPLATE_SLOTS);
/* Slot 3: Callable object used as proxy when structure is APPLY'd. */
_get_struct(template_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
@ -129,7 +129,7 @@ static void register_lambda(void)
/* Slot 1: List of superclasses, most to least specific */
_get_struct(lambda_type_root.value)->slots[SS(SUPERS)] = NIL;
/* Slot 2: Total number of slots (excl. type) */
_get_struct(lambda_type_root.value)->slots[SS(SLOTS)] = fixnum_value(LAMBDA_SLOTS);
_get_struct(lambda_type_root.value)->slots[SS(NSLOTS)] = fixnum_value(LAMBDA_SLOTS);
/* Slot 3: Callable object used as proxy when structure is APPLY'd. */
_get_struct(lambda_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;

2
builtin.h
View File

@ -24,7 +24,7 @@
#define _SLOT_VALUE(t,v,s) (_get_struct(v)->slots[t ## _SLOT_ ## s])
#define STRUCTURE_SLOT_SUPERS 0
#define STRUCTURE_SLOT_SLOTS 1
#define STRUCTURE_SLOT_NSLOTS 1
#define STRUCTURE_SLOT_CALLABLE 2
#define STRUCTURE_SLOTS 3

5
doc/bytecode.txt
View File

@ -135,7 +135,10 @@ binary-expr: up to 63 (01..3f), 1 out, 2 in
28 (set! out (remainder in1 in2)) ; float float
29 (set! out (scalb in1 in2)) ; float float
30 (set! out (kind-of? in1 in2)) ; value struct-type
30 (set! out (kind-of? in1 in2)) ; value struct-type
31 (set! out (byte-string= in1 in2))
32 (set! out (byte-string< in1 in2)) ; == (byte-string> in2 in1)
33 (set! out (byte-string>= in1 in2)) ; == (byte-string<= in2 in1)
conditional: 1 out, 3 in
; 0x80 <= AA <= 0xf7 (f0-f119)
AA (set! AA (if in1 in2 in3)) ; in3 if in1 == #f, in2 otherwise

21
interp.c
View File

@ -34,6 +34,8 @@ static void vector_set(value_t v, fixnum_t idx, value_t newval);
static void byte_string_set(value_t v, fixnum_t idx, char newval);
static void struct_set(value_t v, fixnum_t idx, value_t newval);
static int byte_string_cmp(value_t s1, value_t s2);
static value_t make_lambda(interp_state_t *state, value_t templ);
static void translate_callable(interp_state_t *state);
@ -183,6 +185,16 @@ static void struct_set(value_t v, fixnum_t idx, value_t newval)
WRITE_BARRIER(v);
}
static int byte_string_cmp(value_t s1, value_t s2)
{
byte_string_t *str1 = get_byte_string(s1);
byte_string_t *str2 = get_byte_string(s2);
if (str1->size < str2->size) return -1;
else if (str1->size > str2->size) return 1;
else return memcmp(str1->bytes, str2->bytes, str1->size);
}
static value_t make_lambda(interp_state_t *state, value_t templ)
{
gc_root_t templ_root, lambda_root;
@ -365,6 +377,9 @@ static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1,
case 0x28: return make_float(remainder(get_float(ST1), get_float(ST2)));
case 0x29: return make_float(scalb(get_float(ST1), get_float(ST2)));
case 0x30: return boolean_value(struct_is_a(ST1, ST2));
case 0x31: return boolean_value(byte_string_cmp(ST1, ST2) == 0);
case 0x32: return boolean_value(byte_string_cmp(ST1, ST2) < 0);
case 0x33: return boolean_value(byte_string_cmp(ST1, ST2) >= 0);
default: release_assert(NOTREACHED("Invalid byte-code!"));
}
@ -393,10 +408,10 @@ static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uin
case 0x10: return boolean_value(is_builtin_fn(ST1));
case 0x18: return make_box(ST1);
case 0x19: {
vector_t *vec;
fixnum_t nslots;
release_assert(struct_is_a(ST1, get_structure_type()));
vec = get_vector(_SLOT_VALUE(STRUCTURE, ST1, SLOTS));
return make_struct(ST1, vec->size);
nslots = get_fixnum(_SLOT_VALUE(STRUCTURE, ST1, NSLOTS));
return make_struct(ST1, nslots);
}
case 0x1a: return make_float((native_float_t)get_fixnum(ST1));
case 0x1b: return make_lambda(state, ST1);

14
libcompiler/mapper.scm
View File

@ -29,22 +29,26 @@
[inst-var (in-list instance-variables)])
(set! i-vars (append i-vars (list free-var)))
(list free-var inst-var))])
(set! bind (subst-var* var-map bind)))
(define (sv* form) (subst-var* var-map form))
(set! bind `(#%bind ,(subst* var-map (second bind))
,@(map sv* (cddr bind)))))
(for ([bound-var (in-list (second bind))]
[frame-var (in-list frame-variables)])
(set! bind (subst-var bound-var frame-var bind)))
(define (sv form) (subst-var bound-var frame-var form))
(set! bind `(#%bind ,(subst bound-var frame-var (second bind))
,@(map sv (cddr bind)))))
(set! bind (map-form bind
#:lambda (lambda (recurse op inner-g-vars i-vars bind)
`(%make-lambda ,((compose add-g-var map-variables)
`(%template ,inner-g-vars ,i-vars ,bind))))
`(#%make-lambda ,((compose add-g-var map-variables)
`(#%template ,inner-g-vars ,i-vars ,bind))))
#:variable (lambda (recurse kind form)
(if (machine-variable? form) form (add-g-var form)))
#:literal (lambda (recurse kind form)
(if (eq? form '%nil) form (add-g-var form)))))
`(,(if (null? i-vars) '%lambda '%template) ,g-vars ,i-vars
`(,(if (null? i-vars) '#%lambda '#%template) ,g-vars ,i-vars
,bind)))
; vim:set sw=2 expandtab:

56
libcompiler/optimizer.scm
View File

@ -21,7 +21,7 @@
(let* ([reduced-forms (map recurse subforms)]
[ref-vars (remove-duplicates (append-map free-variables reduced-forms))])
(define (referenced? var) (and (memq var ref-vars) #t))
`(%bind ,(filter referenced? vars)
`(#%bind ,(filter referenced? vars)
,@reduced-forms)))
(map-form form #:bind bind-fn))
@ -30,13 +30,13 @@
(define (bind-fn recurse op vars . subforms)
(define (prepend-if-used subform after)
(if (and (pair? subform)
(eq? (first subform) '%set!)
(eq? (first subform) '#%set!)
(or (memq (second subform) vars)
(error "Setting unbound (constant) variable:" subform))
(not (value-used? (second subform) after)))
after
(cons subform after)))
`(%bind ,vars
`(#%bind ,vars
,@(foldr prepend-if-used '() (map recurse subforms))))
(map-form form #:bind bind-fn))
@ -46,79 +46,79 @@
(let* ([form (car forms)]
[after (cdr forms)]
[new-form (case (first form)
[(%set!) (if (eq? (third form) variable)
`(%set! ,(second form) ,value)
[(#%set!) (if (eq? (third form) variable)
`(#%set! ,(second form) ,value)
form)]
[else form])])
(if (or (and (eq? (first (car forms)) '%set!)
(if (or (and (eq? (first (car forms)) '#%set!)
(eq? (second (car forms)) variable))
(invalidates? new-form))
(cons new-form after)
(cons new-form (propogate-value variable value invalidates? after))))))
; Simple values (literals, variables) can replace arguments as well as %set! values.
; Simple values (literals, variables) can replace arguments as well as #%set! values.
(define (propogate-simple-value variable value invalidates? forms)
(if (null? forms)
forms
(let* ([form (car forms)]
[after (cdr forms)]
[new-form (case (first form)
[(%set!)
[(#%set!)
(let ([set-value (if (eq? (third form) variable) value (third form))])
(if (simple-value? set-value)
`(%set! ,(second form) ,set-value)
`(%set! ,(second form)
`(#%set! ,(second form) ,set-value)
`(#%set! ,(second form)
(,(first set-value)
,@(subst variable value (cdr set-value))))))]
[else `(,(first form) ,@(subst variable value (cdr form)))])])
(if (or (and (eq? (first (car forms)) '%set!)
(if (or (and (eq? (first (car forms)) '#%set!)
(eq? (second (car forms)) variable))
(invalidates? new-form))
(cons new-form after)
(cons new-form (propogate-simple-value variable value invalidates? after))))))
; When value of var2 is known, change (%set! var1 var2) to (%set! var1 value).
; When value of var2 is known, change (#%set! var1 var2) to (#%set! var1 value).
; Known values are:
; literals, always
; var, until (%set! var ...)
; (%unbox var), until (%set-box! ...) or (%set! var)
; (%car var), until (%set-car! ...) or (%set! var)
; (%cdr var), until (%set-cdr! ...) or (%set! var)
; var, until (#%set! var ...)
; (#%unbox var), until (#%set-box! ...) or (#%set! var)
; (#%car var), until (#%set-car! ...) or (#%set! var)
; (#%cdr var), until (#%set-cdr! ...) or (#%set! var)
(define (propogate-set! form)
(define (bind-fn recurse op vars . subforms)
(define (prepend subform after)
(cons
subform
(match subform
[`(%set! ,var ,(? simple-value? value))
[`(#%set! ,var ,(? simple-value? value))
(propogate-simple-value var value
(lambda (form)
(and (eq? (first form) '%set!)
(and (eq? (first form) '#%set!)
(eq? (second form) value)))
after)]
[`(%set! ,var ,(and value `(%unbox ,box-var)))
[`(#%set! ,var ,(and value `(#%unbox ,box-var)))
(propogate-value var value
(lambda (form)
(or (and (eq? (first form) '%set!)
(or (and (eq? (first form) '#%set!)
(eq? (second form) box-var))
(eq? (first form) '%set-box!)))
(eq? (first form) '#%set-box!)))
after)]
[`(%set! ,var ,(and value `(%car ,pair-var)))
[`(#%set! ,var ,(and value `(#%car ,pair-var)))
(propogate-value var value
(lambda (form)
(or (and (eq? (first form) '%set!)
(or (and (eq? (first form) '#%set!)
(eq? (second form) pair-var))
(eq? (first form) '%set-car!)))
(eq? (first form) '#%set-car!)))
after)]
[`(%set! ,var ,(and value `(%cdr ,pair-var)))
[`(#%set! ,var ,(and value `(#%cdr ,pair-var)))
(propogate-value var value
(lambda (form)
(or (and (eq? (first form) '%set!)
(or (and (eq? (first form) '#%set!)
(eq? (second form) pair-var))
(eq? (first form) '%set-cdr!)))
(eq? (first form) '#%set-cdr!)))
after)]
[_ after])))
`(%bind ,vars
`(#%bind ,vars
,@(foldr prepend '() (map recurse subforms))))
(map-form form #:bind bind-fn))

231
libcompiler/primitives.scm
View File

@ -20,128 +20,131 @@
machine-variable?)
(define unary-value-primitives
'((%unbox #x02 unbox)
(%car #x03 car)
(%cdr #x04 cdr)
(%boolean? #x08 boolean?)
(%fixnum? #x09 fixnum?)
(%box? #x0a box?)
(%pair? #x0b pair?)
(%vector? #x0c vector?)
(%byte-string? #x0d byte-string?)
(%struct? #x0e struct?)
(%float? #x0f float?)
(%builtin? #x10 builtin?)
(%make-box #x18 make-box)
(%make-struct #x19 make-struct)
(%make-float #x1a make-float)
(%make-lambda #x1b make-lambda)
(%not #x20 not)
(%bit-not #x21 bit-not)
(%fix- #x22 fix-)
(%float- #x23 float-)
(%vector-size #x28 vector-size)
(%byte-string-size #x29 byte-string-size)
(%struct-nslots #x2a struct-nslots)
(%struct-type #x2b struct-type)
(%hash-value #x2c hash-value)
(%acos #x30 acos)
(%asin #x31 asin)
(%atan #x32 atan)
(%cos #x33 cos)
(%sin #x34 sin)
(%tan #x35 tan)
(%cosh #x36 cosh)
(%sinh #x37 sinh)
(%tanh #x38 tanh)
(%exp #x39 exp)
(%frexp #x3a frexp)
(%log #x3b log)
(%log10 #x3c log10)
(%modf #x3d modf)
(%sqrt #x3e sqrt)
(%ceil #x3f ceil)
(%fabs #x40 fabs)
(%floor #x41 floor)
(%erf #x50 erf)
(%erfc #x51 erfc)
(%j0 #x52 j0)
(%j1 #x53 j1)
(%lgamma #x54 lgamma)
(%y0 #x55 y0)
(%y1 #x56 y1)
(%asinh #x57 asinh)
(%acosh #x58 acosh)
(%atanh #x59 atanh)
(%cbrt #x5a cbrt)
(%logb #x5b logb)
(%expm1 #x5c expm1)
(%ilogb #x5d ilogb)
(%log1p #x5e log1p)
(%normal? #x70 normal?)
(%finite? #x71 finite?)
(%subnormal? #x72 subnormal?)
(%infinite? #x73 infinite?)
(%nan? #x74 nan?)))
'((#%unbox #x02 unbox)
(#%car #x03 car)
(#%cdr #x04 cdr)
(#%boolean? #x08 boolean?)
(#%fixnum? #x09 fixnum?)
(#%box? #x0a box?)
(#%pair? #x0b pair?)
(#%vector? #x0c vector?)
(#%byte-string? #x0d byte-string?)
(#%struct? #x0e struct?)
(#%float? #x0f float?)
(#%builtin? #x10 builtin?)
(#%make-box #x18 make-box)
(#%make-struct #x19 make-struct)
(#%make-float #x1a make-float)
(#%make-lambda #x1b make-lambda)
(#%not #x20 not)
(#%bit-not #x21 bit-not)
(#%fix- #x22 fix-)
(#%float- #x23 float-)
(#%vector-size #x28 vector-size)
(#%byte-string-size #x29 byte-string-size)
(#%struct-nslots #x2a struct-nslots)
(#%struct-type #x2b struct-type)
(#%hash-value #x2c hash-value)
(#%acos #x30 acos)
(#%asin #x31 asin)
(#%atan #x32 atan)
(#%cos #x33 cos)
(#%sin #x34 sin)
(#%tan #x35 tan)
(#%cosh #x36 cosh)
(#%sinh #x37 sinh)
(#%tanh #x38 tanh)
(#%exp #x39 exp)
(#%frexp #x3a frexp)
(#%log #x3b log)
(#%log10 #x3c log10)
(#%modf #x3d modf)
(#%sqrt #x3e sqrt)
(#%ceil #x3f ceil)
(#%fabs #x40 fabs)
(#%floor #x41 floor)
(#%erf #x50 erf)
(#%erfc #x51 erfc)
(#%j0 #x52 j0)
(#%j1 #x53 j1)
(#%lgamma #x54 lgamma)
(#%y0 #x55 y0)
(#%y1 #x56 y1)
(#%asinh #x57 asinh)
(#%acosh #x58 acosh)
(#%atanh #x59 atanh)
(#%cbrt #x5a cbrt)
(#%logb #x5b logb)
(#%expm1 #x5c expm1)
(#%ilogb #x5d ilogb)
(#%log1p #x5e log1p)
(#%normal? #x70 normal?)
(#%finite? #x71 finite?)
(#%subnormal? #x72 subnormal?)
(#%infinite? #x73 infinite?)
(#%nan? #x74 nan?)))
(define binary-value-primitives
'((%eq? #x01 eq?)
(%cons #x02 cons)
(%make-vector #x03 make-vector)
(%make-byte-string #x04 make-byte-string)
(%vector-ref #x05 vector-ref)
(%byte-string-ref #x06 byte-string-ref)
(%struct-ref #x07 struct-ref)
(%fix+ #x08 fix+)
(%fix- #x09 fix-)
(%fix* #x0a fix*)
(%fix/ #x0b fix/)
(%fix% #x0c fix%)
(%fix< #x0d fix<)
(%fix>= #x0e fix>=)
(%bit-and #x10 bit-and)
(%bit-or #x11 bit-or)
(%bit-xor #x12 bit-xor)
(%fix<< #x14 fix<<)
(%fix>> #x15 fix>>)
(%fix>>> #x16 fix>>>)
(%float+ #x18 float+)
(%float- #x19 float-)
(%float* #x1a float*)
(%float/ #x1b float/)
(%float= #x1c float=)
(%float< #x1d float<)
(%float>= #x1e float>=)
(%atan2 #x20 atan2)
(%pow #x21 pow)
(%ldexp #x22 ldexp)
(%fmod #x23 fmod)
(%hypot #x24 hypot)
(%jn #x25 jn)
(%yn #x26 yn)
(%nextafter #x27 nextafter)
(%remainder #x28 remainder)
(%scalb #x29 scalb)
(%kind-of? #x30 kind-of?)))
'((#%eq? #x01 eq?)
(#%cons #x02 cons)
(#%make-vector #x03 make-vector)
(#%make-byte-string #x04 make-byte-string)
(#%vector-ref #x05 vector-ref)
(#%byte-string-ref #x06 byte-string-ref)
(#%struct-ref #x07 struct-ref)
(#%fix+ #x08 fix+)
(#%fix- #x09 fix-)
(#%fix* #x0a fix*)
(#%fix/ #x0b fix/)
(#%fix% #x0c fix%)
(#%fix< #x0d fix<)
(#%fix>= #x0e fix>=)
(#%bit-and #x10 bit-and)
(#%bit-or #x11 bit-or)
(#%bit-xor #x12 bit-xor)
(#%fix<< #x14 fix<<)
(#%fix>> #x15 fix>>)
(#%fix>>> #x16 fix>>>)
(#%float+ #x18 float+)
(#%float- #x19 float-)
(#%float* #x1a float*)
(#%float/ #x1b float/)
(#%float= #x1c float=)
(#%float< #x1d float<)
(#%float>= #x1e float>=)
(#%atan2 #x20 atan2)
(#%pow #x21 pow)
(#%ldexp #x22 ldexp)
(#%fmod #x23 fmod)
(#%hypot #x24 hypot)
(#%jn #x25 jn)
(#%yn #x26 yn)
(#%nextafter #x27 nextafter)
(#%remainder #x28 remainder)
(#%scalb #x29 scalb)
(#%kind-of? #x30 kind-of?)
(#%byte-string= #x31 byte-string=)
(#%byte-string< #x32 byte-string<)
(#%byte-string>= #x33 byte-string>=)))
(define unary-statement-primitives
'((%goto-end-if #x40 #f)
(%goto-end-unless #x41 #f)))
'((#%goto-end-if #x40 #f)
(#%goto-end-unless #x41 #f)))
(define binary-statement-primitives
'((%set-box! #x50 set-box!)
(%set-car! #x51 set-car!)
(%set-cdr! #x52 set-cdr!)))
'((#%set-box! #x50 set-box!)
(#%set-car! #x51 set-car!)
(#%set-cdr! #x52 set-cdr!)))
(define ternary-statement-primitives
'((%vector-set! #x60 vector-set!)
(%byte-string-set! #x61 byte-string-set!)
(%struct-set! #x62 struct-set!)))
'((#%vector-set! #x60 vector-set!)
(#%byte-string-set! #x61 byte-string-set!)
(#%struct-set! #x62 struct-set!)))
(define value-primitives
(append unary-value-primitives
binary-value-primitives
(list '(%if #f #f))))
(list '(#%if #f #f))))
(define statement-primitives
(append unary-statement-primitives
@ -153,18 +156,18 @@
(define global-variables
(for/list ([i (in-range 1 64)])
(string->uninterned-symbol (string-append "%g" (number->string i)))))
(string->uninterned-symbol (string-append "#%g" (number->string i)))))
(define instance-variables
(for/list ([i (in-range 0 64)])
(string->uninterned-symbol (string-append "%i" (number->string i)))))
(string->uninterned-symbol (string-append "#%i" (number->string i)))))
(define frame-variables
(for/list ([i (in-range 0 120)])
(string->uninterned-symbol (string-append "%f" (number->string i)))))
(string->uninterned-symbol (string-append "#%f" (number->string i)))))
(define special-variables
'(%nil %self %argv %ctx %k))
'(#%nil #%self #%argv #%ctx #%k))
(define (global-variable? var) (and (memq var global-variables) #t))
(define (instance-variable? var) (and (memq var instance-variables) #t))

21
libcompiler/reader.scm
View File

@ -9,26 +9,7 @@
(define (read-module [port (current-input-port)])
`(lambda *argv*
,@(let iter ([forms (read-forms port)]
[bindings '()])
(match forms
['()
(if (null? bindings)
'()
`((letrec ,(reverse bindings))))]
[`((define (,(? symbol? var) . ,arglist) . ,body) . ,rst)
(iter rst (cons (list var `(lambda ,arglist ,@body)) bindings))]
[`((define ,(? symbol? var) ,expr) . ,rst)
(iter rst (cons (list var expr) bindings))]
[`((define . ,_) . ,_)
(error "Unrecognized define-form:" (first forms))]
[`((begin . ,body) . ,rst)
(iter (append body rst) bindings)]
[`(,form . ,rst)
(if (null? bindings)
(cons form (iter rst '()))
`((letrec ,(reverse bindings)
,@(cons form (iter rst '())))))]))))
,@(read-forms port)))
(define (read-forms [port (current-input-port)])
(let iter ([form (read port)]

298
libcompiler/simplifier.scm
View File

@ -10,42 +10,72 @@
(define (simplify-form form)
(define (same-form recurse . form) form)
(define (reverse-args new-op args)
(simplify-form
(let ([a (gensym)] [b (gensym)])
`(let ([,a ,(first args)]
[,b ,(second args)])
(,new-op ,b ,a)))))
(define (simplify-complex-form recurse op . others)
(case op
[(let) (simplify-let form)]
[(let*) (simplify-let* form)]
[(letrec) (simplify-letrec form)]
[(if) (simplify-if form)]
[(lambda) (simplify-lambda form)]
[(begin) (simplify-form `(let () ,@(cdr form)))]
[(set!) (simplify-set! form)]
[(let/cc) (simplify-form
`(call/cc (lambda (,(second form)) ,@(cddr form))))]
[(fix>) (simplify-form
(let ([a (gensym)] [b (gensym)])
`(let ([,a ,(second form)]
[,b ,(third form)])
(fix< ,b ,a))))]
[(fix<=) (simplify-form
(let ([a (gensym)] [b (gensym)])
`(let ([,a ,(second form)]
[,b ,(third form)])
(fix>= ,b ,a))))]
[(value-list) (simplify-value-list form)]
[(values) (simplify-primitive '%values (cdr form))]
[(apply) (simplify-apply (second form) (cddr form))]
[(call/cc) (simplify-primitive '%call/cc (cdr form))]
[(let) (simplify-let form)]
[(let*) (simplify-let* form)]
[(letrec) (simplify-letrec form)]
[(if) (simplify-if form)]
[(lambda) (simplify-lambda form)]
[(begin) (simplify-form `(let () ,@(cdr form)))]
[(set!) (simplify-set! form)]
[(let/cc) (simplify-form
`(call/cc (lambda (,(second form)) ,@(cddr form))))]
[(fix=) (simplify-form `(eq? ,@(cdr form)))]
[(fix>) (reverse-args 'fix< (cdr form))]
[(fix<=) (reverse-args 'fix>= (cdr form))]
[(float>) (reverse-args 'float< (cdr form))]
[(float<=) (reverse-args 'float>= (cdr form))]
[(byte-string>) (reverse-args 'byte-string< (cdr form))]
[(byte-string<=) (reverse-args 'byte-string>= (cdr form))]
[(value-list) (simplify-value-list form)]
[(values) (simplify-primitive '#%values (cdr form))]
[(list) (simplify-form `(value-list (values ,@(cdr form))))]
[(apply) (simplify-apply (second form) (cddr form))]
[(call/cc) (simplify-primitive '#%call/cc (cdr form))]
[(call-with-values)
(simplify-form
`(apply ,(third form)
(value-list (,(second form)))))]
[(and)
(simplify-form
(cond
[(null? (cdr form)) '#t]
[(null? (cddr form)) (second form)]
[else (let ([x (gensym)])
`(let ([,x ,(second form)])
(if ,x (and ,@(cddr form)) ,x)))]))]
[(or)
(simplify-form
(cond
[(null? (cdr form)) '#f]
[(null? (cddr form)) (second form)]
[else (let ([x (gensym)])
`(let ([,x ,(second form)])
(if ,x ,x (or ,@(cddr form)))))]))]
[(cond)
(simplify-form
(match (cdr form)
[`() '(values)]
[`([else . ,forms] . ,_) `(begin ,@forms)]
[`([,cond-expr . ,forms] . ,rst) `(if ,cond-expr (begin ,@forms) (cond ,@rst))]
[_ (error "Malformed (cond) form.")]))]
[(when) (simplify-form `(if ,(second form) (begin ,@(cddr form)) (values)))]
[(unless) (simplify-form `(if ,(second form) (values) (begin ,@(cddr form))))]
[else
(let ([primitive (memf (lambda (x) (eq? (third x) (first form)))
all-primitives)])
(if primitive
(simplify-primitive (first (first primitive))
(cdr form))
(simplify-apply (first form) (append (cdr form) '(%nil)))))]))
(simplify-apply (first form) (append (cdr form) '(#%nil)))))]))
(map-form form
#:bind same-form
#:lambda same-form
@ -54,61 +84,81 @@
#:primitive same-form
#:simple (lambda (recurse kind form) form)
#:literal (lambda (recurse kind form)
(if (equal? form '(quote ())) '%nil form))
(if (equal? form '(quote ())) '#%nil form))
#:other simplify-complex-form))
(define (body->forms body)
(let iter ([body body]
[bindings '()])
(match body
['()
(if (null? bindings)
'()
`((letrec ,(reverse bindings))))]
[`((define (,(? symbol? var) . ,arglist) . ,body) . ,rst)
(iter rst (cons (list var `(lambda ,arglist ,@body)) bindings))]
[`((define ,(? symbol? var) ,expr) . ,rst)
(iter rst (cons (list var expr) bindings))]
[`((define . ,_) . ,_)
(error "Unrecognized define-form:" (first body))]
[`(,form . ,rst)
(if (null? bindings)
(cons form (iter rst '()))
`((letrec ,(reverse bindings)
,@(cons form (iter rst '())))))])))
(define (simplify-set! form)
(let ([variable (second form)]
[value-form (simplify-form (third form))])
(match value-form
[`(%bind ,bound-vars . ,subforms)
[`(#%bind ,bound-vars . ,subforms)
(if (memq variable bound-vars)
(let ([tmp (gensym)])
`(%bind (,tmp)
`(#%bind (,tmp)
; guaranteed not to cause unbounded recursion: tmp is unique
,(simplify-set! `(set! ,tmp ,value-form))
(%set! ,variable ,tmp)))
`(%bind ,bound-vars
(#%set! ,variable ,tmp)))
`(#%bind ,bound-vars
,@(foldr (lambda (subform after)
(if (pair? after)
(cons subform after)
(list (simplify-set! `(set! ,variable ,subform)))))
'()
subforms)))]
[`(%values ,first-val . ,other-vals)
`(%set! ,variable ,first-val)]
[`(%values)
[`(#%values ,first-val . ,other-vals)
`(#%set! ,variable ,first-val)]
[`(#%values)
(error "Attempted to set variable to void in:" form)]
[(? value-form?)
`(%set! ,variable ,value-form)]
`(#%set! ,variable ,value-form)]
[else
(error "Attempted to set variable to void in:" form)])))
(define (simplify-value-list form)
(let ([values-form (simplify-form (second form))])
(match values-form
[`(%bind ,bound-vars . ,subforms)
`(%bind ,bound-vars
[`(#%bind ,bound-vars . ,subforms)
`(#%bind ,bound-vars
,@(foldr (lambda (subform after)
(if (pair? after)
(cons subform after)
(list (simplify-value-list `(value-list ,subform)))))
'()
subforms))]
[`(%values . ,simple-vals)
; (%value-list (%values ...)) => (list ...)
[`(#%values . ,simple-vals)
; (#%value-list (#%values ...)) => (list ...)
(let ([tmp (gensym)])
`(%bind (,tmp)
(%set! ,tmp %nil)
`(#%bind (,tmp)
(#%set! ,tmp #%nil)
,@(map (lambda (x) (simplify-set! `(set! ,tmp (cons ,x ,tmp))))
(reverse simple-vals))
,tmp))]
[(or `(%apply _ _)
`(%call/cc _))
`(%value-list ,values-form)]
[(or `(#%apply _ _)
`(#%call/cc _))
`(#%value-list ,values-form)]
[(? value-form?)
(simplify-value-list `(value-list (values ,values-form)))]
[_ '%nil])))
[_ '#%nil])))
(define (simplify-primitive simple-op value-forms)
(define (value->binding value-form)
@ -126,10 +176,10 @@
(,simple-op ,@(map first bindings)))))
; (let ([var expr]...) bodyexpr...) ; first eval exprs, then assign bindings in parallel
; => (%bind (tmp...)
; (%set! tmp ,(simplify-form expr))...
; (%bind (var...)
; (%set! var tmp)...
; => (#%bind (tmp...)
; (#%set! tmp ,(simplify-form expr))...
; (#%bind (var...)
; (#%set! var tmp)...
; bodyexpr...))
(define (simplify-let form)
@ -138,28 +188,28 @@
(list (first binding) (simplify-form (second binding)))
(list binding)))
(define bindings (map simplify-binding (second form)))
(define bodyexprs (cddr form))
(define bodyexprs (body->forms (cddr form)))
(define (has-value? binding) (pair? (cdr binding)))
(define vars (map first bindings))
(define (bound-var? var) (and (memq var vars) #t))
; If the value of any binding refers to one of the variable names being bound...
(if (ormap bound-var? (free-variables `(%bind () ,@(map second (filter has-value? bindings)))))
(if (ormap bound-var? (free-variables `(#%bind () ,@(map second (filter has-value? bindings)))))
; ...then bind the values to temps first, before binding the real names.
(let ([temp-bindings (map (lambda (binding)
(let ([tmp (gensym)])
(list tmp
(simplify-set! `(set! ,tmp ,(second binding)))
`(%set! ,(first binding) ,tmp))))
`(#%set! ,(first binding) ,tmp))))
(filter has-value? bindings))])
`(%bind ,(map first temp-bindings)
`(#%bind ,(map first temp-bindings)
,@(map second temp-bindings)
(%bind ,vars
(#%bind ,vars
,@(map third temp-bindings)
,@(map simplify-form bodyexprs))))
; Otherwise, just bind the real names directly.
`(%bind ,vars
`(#%bind ,vars
,@(map (lambda (binding)
(simplify-set! `(set! ,@binding)))
(filter has-value? bindings))
@ -206,15 +256,15 @@
(if (and (simple-value? true-form)
(simple-value? false-form))
`(let ([,cond-val ,cond-expr])
(%if ,cond-val ,true-form ,false-form))
(#%if ,cond-val ,true-form ,false-form))
(let ([next-fn (gensym)]
[true-fn (gensym)]
[false-fn (gensym)])
`(let ([,cond-val ,cond-expr]
[,true-fn (lambda () ,true-form)]
[,false-fn (lambda () ,false-form)])
(let ([,next-fn (%if ,cond-val ,true-fn ,false-fn)])
(%apply ,next-fn %nil))))))))
(let ([,next-fn (#%if ,cond-val ,true-fn ,false-fn)])
(#%apply ,next-fn #%nil))))))))
; (lambda (required... [optional default-expr]... . rest) bodyexpr...)
; => (lambda argv
@ -225,12 +275,12 @@
; (set! argv-temp (cdr argv-temp)))
; (...
; (let (optional-0)
; (if (eq? argv-temp %nil)
; (if (eq? argv-temp #%nil)
; (set! optional-0 default-expr-0)
; (set! optional-0 (car argv-temp)))
; (set! argv-temp (cdr argv-temp))
; (let (optional-1)
; (if (eq? argv-temp %nil)
; (if (eq? argv-temp #%nil)
; (set! optional-1 default-expr-1)
; (set! optional-1 (car argv-temp)))
; ; TODO: Handle keyword arguments here...
@ -243,20 +293,20 @@
(map-form form
#:bind (lambda (recurse op vars . subforms)
(flatten-binds
`(%bind ,(subst variable variable vars)
`(#%bind ,(subst variable variable vars)
,@(if (memq variable vars)
`((%set! ,variable (%make-box %undef)))
`((#%set! ,variable (#%make-box #%undef)))
'())
,@(map recurse subforms))))
#:set (lambda (recurse op var value)
(let ([new-value (recurse value)])
(if (eq? var variable)
(if (simple-value? new-value)
`(%set-box! ,variable ,new-value)
`(#%set-box! ,variable ,new-value)
(let ([tmp (gensym)])
`(%bind (,tmp)
`(#%bind (,tmp)
,(simplify-set! `(set! ,tmp ,new-value))
(%set-box! ,variable ,tmp))))
(#%set-box! ,variable ,tmp))))
(simplify-set! `(set! ,var ,new-value)))))
#:value-list (lambda (recurse op values-form)
`(,op ,(recurse values-form)))
@ -267,15 +317,15 @@
(if (simple-value? x)
(list x #f)
(let ([tmp (gensym)])
(list tmp `(%set! ,tmp ,x)))))
(list tmp `(#%set! ,tmp ,x)))))
new-args)])
(if (ormap second temps)
`(%bind ,(map first (filter second temps))
`(#%bind ,(map first (filter second temps))
,@(filter-map second temps)
(,op ,@(map first temps)))
`(,op ,@new-args)))))
#:variable (lambda (recurse op var)
(if (eq? var variable) `(%unbox ,variable) var))))
(if (eq? var variable) `(#%unbox ,variable) var))))
(define (is-shared-var? var forms)
(define (set-after-first-capture?)
@ -327,19 +377,19 @@
(second flat-bind))))
(promote-shared-variables
`(%bind ,(remove* extra-bindings (second flat-bind))
`(#%bind ,(remove* extra-bindings (second flat-bind))
,@(map (lambda (subform)
(match subform
[`(%set! ,var (%lambda ,g-vars ,i-vars ,bind))
[`(#%set! ,var (#%lambda ,g-vars ,i-vars ,bind))
(define (free-var? v) (free-variable? v bind))
(define local-binds (filter free-var? extra-bindings))
(if (null? local-binds)
subform
(begin
(set! extra-bindings (remove* local-binds extra-bindings))
`(%set! ,var (%lambda ,g-vars ,i-vars
`(#%set! ,var (#%lambda ,g-vars ,i-vars
,(narrow-binds+promote
`(%bind (,@(second bind) ,@local-binds)
`(#%bind (,@(second bind) ,@local-binds)
,@(cddr bind)))))))]
[_ subform]))
(cddr flat-bind)))))
@ -355,33 +405,33 @@
(define (add-return ctx k nested-bind)
(define flat-bind (flatten-binds nested-bind))
(define argv (gensym))
`(%bind (,@(second flat-bind) ,argv)
`(#%bind (,@(second flat-bind) ,argv)
,@(foldr (lambda (subform after)
(if (pair? after)
(cons subform after)
(match subform
[(? simple-value?)
`((%set! ,argv (%cons ,subform %nil))
(%tail-call ,k ,argv #f #f))]
[`(%apply ,x ,y)
`((%tail-call ,x ,y ,ctx ,k))]
[`(%call/cc ,x)
`((%set! ,argv (%cons %k %nil))
(%tail-call ,x ,argv ,ctx %k))]
[`(%values . ,simple-vals)
`((%set! ,argv %nil)
,@(map (lambda (sv) `(%set! ,argv (%cons ,sv ,argv)))
`((#%set! ,argv (#%cons ,subform #%nil))
(#%tail-call ,k ,argv #f #f))]
[`(#%apply ,x ,y)
`((#%tail-call ,x ,y ,ctx ,k))]
[`(#%call/cc ,x)
`((#%set! ,argv (#%cons #%k #%nil))
(#%tail-call ,x ,argv ,ctx #%k))]
[`(#%values . ,simple-vals)
`((#%set! ,argv #%nil)
,@(map (lambda (sv) `(#%set! ,argv (#%cons ,sv ,argv)))
(reverse simple-vals))
(%tail-call ,k ,argv #f #f))]
(#%tail-call ,k ,argv #f #f))]
[(? value-form?)
`(,(simplify-set! `(set! ,argv ,subform))
(%set! ,argv (%cons ,argv %nil))
(%tail-call ,k ,argv #f #f))]
[`(%tail-call . ,_)
(#%set! ,argv (#%cons ,argv #%nil))
(#%tail-call ,k ,argv #f #f))]
[`(#%tail-call . ,_)
`(,subform)]
[_
`(,subform
(%tail-call ,k %nil #f #f))])))
(#%tail-call ,k #%nil #f #f))])))
'()
(cddr flat-bind))))
@ -389,61 +439,61 @@
(define flat-bind (flatten-binds nested-bind))
(define (cps-prepend subform after)
(match subform
[`(%set! ,v (%value-list (%apply ,x ,y)))
[`(#%set! ,v (#%value-list (#%apply ,x ,y)))
(let ([k (gensym)])
`((%bind (,k)
(%set! ,k ,(simplify-form
`((#%bind (,k)
(#%set! ,k ,(simplify-form
`(lambda ,v
,@after)))
(%tail-call ,x ,y ,ctx ,k))))]
[`(%set! ,v (%apply ,x ,y))
(#%tail-call ,x ,y ,ctx ,k))))]
[`(#%set! ,v (#%apply ,x ,y))
(let ([k (gensym)])
`((%bind (,k)
(%set! ,k ,(simplify-form
`((#%bind (,k)
(#%set! ,k ,(simplify-form
`(lambda (,v . ,(gensym))
,@after)))
(%tail-call ,x ,y ,ctx ,k))))]
[(or `(%value-list (%apply ,x ,y))
`(%apply ,x ,y))
(#%tail-call ,x ,y ,ctx ,k))))]
[(or `(#%value-list (#%apply ,x ,y))
`(#%apply ,x ,y))
(let ([k (gensym)])
`((%bind (,k)
(%set! ,k ,(simplify-form
`((#%bind (,k)
(#%set! ,k ,(simplify-form
`(lambda ,(gensym)
,@after)))
(%tail-call ,x ,y ,ctx ,k))))]
[`(%set! ,v (%value-list (%call/cc ,x)))
(#%tail-call ,x ,y ,ctx ,k))))]
[`(#%set! ,v (#%value-list (#%call/cc ,x)))
(let ([k (gensym)]
[k-argv (gensym)])
`((%bind (,k ,k-argv)
(%set! ,k ,(simplify-form
`((#%bind (,k ,k-argv)
(#%set! ,k ,(simplify-form
`(lambda ,v
,@after)))
(%set! ,k-argv (%cons ,k %nil))
(%tail-call ,x ,k-argv ,ctx ,k))))]
[`(%set! ,v (%call/cc ,x))
(#%set! ,k-argv (#%cons ,k #%nil))
(#%tail-call ,x ,k-argv ,ctx ,k))))]
[`(#%set! ,v (#%call/cc ,x))
(let ([k (gensym)]
[k-argv (gensym)])
`((%bind (,k ,k-argv)
(%set! ,k ,(simplify-form
`((#%bind (,k ,k-argv)
(#%set! ,k ,(simplify-form
`(lambda (,v . ,(gensym))
,@after)))
(%set! ,k-argv (%cons ,k %nil))
(%tail-call ,x ,k-argv ,ctx ,k))))]
[(or `(%value-list (%call/cc ,x))
`(%call/cc ,x))
(#%set! ,k-argv (#%cons ,k #%nil))
(#%tail-call ,x ,k-argv ,ctx ,k))))]
[(or `(#%value-list (#%call/cc ,x))
`(#%call/cc ,x))
(let ([k (gensym)]
[k-argv (gensym)])
`((%bind (,k ,k-argv)
(%set! ,k ,(simplify-form
`((#%bind (,k ,k-argv)
(#%set! ,k ,(simplify-form
`(lambda ,(gensym)
,@after)))
(%set! ,k-argv (%cons ,k %nil))
(%tail-call ,x ,k-argv ,ctx ,k))))]
(#%set! ,k-argv (#%cons ,k #%nil))
(#%tail-call ,x ,k-argv ,ctx ,k))))]
; keep all other forms with side-effects as-is
[(? statement-form?) (cons subform after)]
; discard any form without side-effects
[_ after]))
`(%bind ,(second flat-bind)
`(#%bind ,(second flat-bind)
,@(foldr cps-prepend '() (cddr flat-bind))))
(define (simplify-lambda form)
@ -475,14 +525,14 @@
`(let ([,rest ,argv]) ,@bodyexprs)
`(begin ,@bodyexprs)))
`(%lambda () ()
`(#%lambda () ()
,((compose narrow-binds+promote
(lambda (bind) (transform-to-cps ctx bind))
(lambda (bind) (add-return ctx k bind))
simplify-form)
`(let ([,argv %argv]
[,ctx %ctx]
[,k %k])
`(let ([,argv #%argv]
[,ctx #%ctx]
[,k #%k])
,(foldr add-req
(foldr add-opt
rest+bodyexprs
@ -493,9 +543,9 @@
; => (let ([fn-var fn-expr] arg-var... argv)
; (set! fn-var fn-expr)
; (set! arg-var arg-expr)...
; (set! argv %nil)
; (set! argv #%nil)
; (set! argv (cons arg-var argv))... [reversed]
; (%apply fn-var argv))
; (#%apply fn-var argv))
(define (simplify-apply fn-expr arg-exprs)
(define fn-var (gensym))
@ -511,8 +561,8 @@
arg-exprs))
(simplify-form
`(let ([,fn-var ,fn-expr] ,@(filter second arguments))
,@(map (lambda (x) `(%set! ,argv (%cons ,x ,argv)))
,@(map (lambda (x) `(#%set! ,argv (#%cons ,x ,argv)))
(map first (reverse (drop-right arguments 1))))
(%apply ,fn-var ,argv))))
(#%apply ,fn-var ,argv))))
; vim:set sw=2 expandtab:

42
libcompiler/utilities.scm
View File

@ -101,13 +101,13 @@
(define (variable-value? form)
(and (symbol? form)
(not (eq? form '%undef))))
(not (eq? form '#%undef))))
(define (literal-value? form)
(and (not (variable-value? form))
(or (not (pair? form))
(eq? (first form) 'quote)
(eq? (first form) '%template))))
(eq? (first form) '#%template))))
(define (simple-value? form)
(or (variable-value? form)
@ -116,14 +116,14 @@
; A value-form is any simple form which can appear on the right-hand side of a (set! ...).
; If there are any side-effect they occur before the variable is updated.
(define (value-form? form)
(define complex-values '(%bind %lambda %apply %call/cc %values %value-list))
(define complex-values '(#%bind #%lambda #%apply #%call/cc #%values #%value-list))
(or (simple-value? form)
(memq (first form) complex-values)
(memq (first form) (map first value-primitives))))
; A statement-form is any simple form which has, or may have, side-effects.
(define (statement-form? form)
(define complex-statements '(%set! %apply %call/cc %tail-call))
(define complex-statements '(#%set! #%apply #%call/cc #%tail-call))
(and (not (simple-value? form))
(or (memq (first form) complex-statements)
(memq (first form) (map first statement-primitives)))))
@ -137,7 +137,7 @@
(not (statement-form? form))))
(define (bind-form? form)
(and (pair? form) (eq? (first form) '%bind)))
(and (pair? form) (eq? (first form) '#%bind)))
(define (traverse-form form
#:bind [bind-fn (lambda (recurse op vars . subforms)
@ -168,14 +168,14 @@
[(literal-value? subform) (literal-fn recurse 'literal subform)]
[else
(let ([handler (case (first subform)
[(%bind) bind-fn]
[(%lambda) lambda-fn]
[(%set!) set-fn]
[(%value-list) value-list-fn]
[(%values) values-fn]
[(%apply) apply-fn]
[(%call/cc) call/cc-fn]
[(%tail-call) tail-call-fn]
[(#%bind) bind-fn]
[(#%lambda) lambda-fn]
[(#%set!) set-fn]
[(#%value-list) value-list-fn]
[(#%values) values-fn]
[(#%apply) apply-fn]
[(#%call/cc) call/cc-fn]
[(#%tail-call) tail-call-fn]
[else (if (primitive-form? subform)
primitive-fn
other-fn)])])
@ -261,7 +261,9 @@
(define (subst-var old-var new-var form)
(map-form form
#:bind (lambda (recurse op vars . subforms)
`(%bind ,(subst old-var new-var vars) ,@(map recurse subforms)))
(if (memq old-var vars)
`(,op ,vars ,@subforms)
`(#%bind ,vars ,@(map recurse subforms))))
#:set (lambda (recurse op var value)
`(,op ,(if (eq? var old-var) new-var var) ,(recurse value)))
#:variable (lambda (recurse op var)
@ -270,7 +272,12 @@
(define (subst-var* var-map form)
(map-form form
#:bind (lambda (recurse op vars . subforms)
`(%bind ,(subst* var-map vars) ,@(map recurse subforms)))
(let ([unbound-map (filter (lambda (item) (not (memq (car item) vars)))
var-map)])
(if (null? unbound-map)
`(,op ,vars ,@subforms)
`(#%bind ,vars ,@(map (lambda (sf) (subst-var* unbound-map sf))
subforms)))))
#:set (lambda (recurse op var value)
(let ([item (assoc var var-map)])
`(,op ,(if item (second item) var) ,(recurse value))))
@ -284,7 +291,8 @@
(define (make-binding-unique var bind)
(let* ([prefix (string-append (symbol->string var) "->g")]
[unique-var (gensym prefix)])
(subst-var var unique-var bind)))
`(#%bind ,(subst var unique-var (second bind))
,@(map (lambda (sf) (subst-var var unique-var sf))))))
(foldr make-binding-unique bind (filter needs-rename? (second bind))))
(map-form form
@ -302,7 +310,7 @@
(cddr unique-form))
(list subform)))
(let ([subforms (append-map form->list original-subforms)])
`(%bind ,bound-vars ,@subforms)))
`(#%bind ,bound-vars ,@subforms)))
#:lambda (lambda (recurse . form) form)))
(define (free-variables form [input? #t] [output? #t])

22
libcompiler/writer.scm
View File

@ -55,14 +55,14 @@
(let-values ([(line col pos) (port-next-location port)])
(parameterize ([current-indent col])
(write-char #\" port)
(if (eq? (first (first forms)) '%tail-call)
(if (eq? (first (first forms)) '#%tail-call)
(begin
(write-char #\" port)
(write-tail-call (first forms)))
(let iter ([forms forms])
(map (lambda (x) (write-hex-char x port))
(statement->code (car forms)))
(if (eq? (first (second forms)) '%tail-call)
(if (eq? (first (second forms)) '#%tail-call)
(begin
(write-string "\"; " port)
(write (car forms) port)
@ -75,11 +75,11 @@
(iter (cdr forms)))))))))
(define (write-rla-function value port)
(define template? (eq? (first value) '%template))
(define template? (eq? (first value) '#%template))
(let-values ([(line col pos) (port-next-location port)])
(parameterize ([current-indent col])
(write-string "#S(" port)
(if (eq? (first value) '%template)
(if (eq? (first value) '#%template)
(write-string "#=\"template\"" port)
(write-string "#=\"lambda\"" port))
(parameterize ([current-indent (+ (current-indent-step) (current-indent))])
@ -115,7 +115,7 @@
(port-count-lines! port)
(void
(cond
[(eq? value '%undef)
[(eq? value '#%undef)
(write-string "#=\"undefined\"" port)]
[(symbol? value)
(write-string "#=\"" port)
@ -123,9 +123,11 @@
(write-string "\"" port)]
[(or (boolean? value) (number? value))
(write value port)]
[(char? value)
(write (char->integer value) port)]
[(string? value)
(write-rla-string value port)]
[(and (pair? value) (memq (first value) '(%lambda %template)))
[(and (pair? value) (memq (first value) '(#%lambda #%template)))
(write-rla-function value port)]
[(vector? value)
(write-string "#(" port)
@ -154,19 +156,19 @@
[else (error "Don't know how to write Rosella syntax for:" value)])))
(define (variable->code var)
(or (and (eq? var '%nil) #x00)
(or (and (eq? var '#%nil) #x00)
(let ([index (find var global-variables)])
(and index (+ #x01 index)))
(let ([index (find var instance-variables)])
(and index (+ #x40 index)))
(let ([index (find var frame-variables)])
(and index (+ #x80 index)))
(let ([index (find var '(%self %argv %ctx %k))])
(let ([index (find var '(#%self #%argv #%ctx #%k))])
(and index (+ #xfc index)))
(error "No bytecode for variable:" var)))
(define (statement->code form)
(if (eq? (first form) '%set!)
(if (eq? (first form) '#%set!)
(let ([out (variable->code (second form))]
[value (third form)])
(cond
@ -179,7 +181,7 @@
(list* (second (assoc (first value) binary-value-primitives))
out (map variable->code (cdr value)))]
[else
(unless (and (eq? (first value) '%if)
(unless (and (eq? (first value) '#%if)
(eq? (length (cdr value)) 3))
(error "Unsupported ternary form:" form))
(list* out (map variable->code (cdr value)))]))

7
reader.c
View File

@ -712,8 +712,15 @@ static value_t read_placeholder(reader_state_t *state)
{
char *name = value_to_string(read_string(state));
value_t bi = lookup_builtin(name);
if (bi == FALSE_VALUE)
{
fprintf(stderr, "Unable to locate \"%s\" builtin.\n", name);
}
free(name);
release_assert(bi != FALSE_VALUE);
return bi;
}
else

12
src/lib/primitives.rls
View File

@ -78,8 +78,11 @@
(define (fix* x y) (fix* x y))
(define (fix/ x y) (fix/ x y))
(define (fix% x y) (fix% x y))
(define (fix= x y) (fix= x y))
(define (fix< x y) (fix< x y))
(define (fix> x y) (fix> x y))
(define (fix>= x y) (fix>= x y))
(define (fix<= x y) (fix<= x y))
(define (bit-and x y) (bit-and x y))
(define (bit-or x y) (bit-or x y))
(define (bit-xor x y) (bit-xor x y))
@ -92,7 +95,9 @@
(define (float/ x y) (float/ x y))
(define (float= x y) (float= x y))
(define (float< x y) (float< x y))
(define (float> x y) (float> x y))
(define (float>= x y) (float>= x y))
(define (float<= x y) (float<= x y))
(define (atan2 x y) (atan2 x y))
(define (pow x y) (pow x y))
(define (ldexp x y) (ldexp x y))
@ -104,6 +109,11 @@
(define (remainder x y) (remainder x y))
(define (scalb x y) (scalb x y))
(define (kind-of? x y) (kind-of? x y))
(define (byte-string= x y) (byte-string= x y))
(define (byte-string< x y) (byte-string< x y))
(define (byte-string> x y) (byte-string> x y))
(define (byte-string>= x y) (byte-string>= x y))
(define (byte-string<= x y) (byte-string<= x y))
; Binary statement primitives
(define (set-box! x y) (set-box! x y))
@ -115,4 +125,6 @@
(define (byte-string-set! x y z) (byte-string-set! x y z))
(define (struct-set! x y z) (struct-set! x y z))
(define (list . lst) lst)
; vim:set sw=2 expandtab: