diff --git a/builtin.c b/builtin.c index 3e6c3d2..e1557d7 100644 --- a/builtin.c +++ b/builtin.c @@ -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; diff --git a/builtin.h b/builtin.h index bb1e22a..7bb1462 100644 --- a/builtin.h +++ b/builtin.h @@ -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 diff --git a/doc/bytecode.txt b/doc/bytecode.txt index 432c6ca..e2280c1 100644 --- a/doc/bytecode.txt +++ b/doc/bytecode.txt @@ -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 diff --git a/interp.c b/interp.c index 03bfd05..953001a 100644 --- a/interp.c +++ b/interp.c @@ -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); diff --git a/libcompiler/mapper.scm b/libcompiler/mapper.scm index 52c5a14..5a92e46 100644 --- a/libcompiler/mapper.scm +++ b/libcompiler/mapper.scm @@ -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: diff --git a/libcompiler/optimizer.scm b/libcompiler/optimizer.scm index 168c74b..8b3ff13 100644 --- a/libcompiler/optimizer.scm +++ b/libcompiler/optimizer.scm @@ -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)) diff --git a/libcompiler/primitives.scm b/libcompiler/primitives.scm index 850eb58..8bef366 100644 --- a/libcompiler/primitives.scm +++ b/libcompiler/primitives.scm @@ -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)) diff --git a/libcompiler/reader.scm b/libcompiler/reader.scm index 6eff65a..8554911 100644 --- a/libcompiler/reader.scm +++ b/libcompiler/reader.scm @@ -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)] diff --git a/libcompiler/simplifier.scm b/libcompiler/simplifier.scm index 98483e8..df08033 100644 --- a/libcompiler/simplifier.scm +++ b/libcompiler/simplifier.scm @@ -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: diff --git a/libcompiler/utilities.scm b/libcompiler/utilities.scm index 0fa05a9..4fef50a 100644 --- a/libcompiler/utilities.scm +++ b/libcompiler/utilities.scm @@ -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]) diff --git a/libcompiler/writer.scm b/libcompiler/writer.scm index 26742d5..e3459bb 100644 --- a/libcompiler/writer.scm +++ b/libcompiler/writer.scm @@ -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)))])) diff --git a/reader.c b/reader.c index 6d83803..45f29fd 100644 --- a/reader.c +++ b/reader.c @@ -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 diff --git a/src/lib/primitives.rls b/src/lib/primitives.rls index 8824a63..bfd8bb3 100644 --- a/src/lib/primitives.rls +++ b/src/lib/primitives.rls @@ -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: