From ce516ac92664a14653795c6bcf44abafb47a3dc1 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 31 Jul 2008 17:44:12 -0400 Subject: [PATCH] Exposed a few type-checking primitives from the library. General cleanup. --- library.scm | 40 ++++++++------- picobit-vm.c | 9 +++- picobit.scm | 155 ++++++++++++++++++++++++++++++++--------------------------- 3 files changed, 110 insertions(+), 94 deletions(-) diff --git a/library.scm b/library.scm index 8ba45bd..1b14f73 100644 --- a/library.scm +++ b/library.scm @@ -184,6 +184,14 @@ (define #%box-set! (lambda (a b) (#%set-car! a b))) +(define symbol? + (lambda (x) + (#%symbol? x))) + +(define string? + (lambda (x) + (#%string? x))) + (define string (lambda chars (#%list->string chars))) @@ -196,7 +204,7 @@ (lambda (chars) (#%list->string chars))) -(define string-length ;; TODO are all these string operations efficient ? they all convert to lists. use true vectors when we have them ? +(define string-length (lambda (str) (length (#%string->list str)))) @@ -223,6 +231,10 @@ (#%cons (#%car lst) (#%substring-aux2 (#%cdr lst) (#%- n 1))) '()))) +(define boolean? + (lambda (x) + (#%boolean? x))) + (define map (lambda (f lst) (if (#%pair? lst) @@ -358,6 +370,8 @@ (#%write-list (#%cdr x)))) ((#%symbol? x) (display "#")) + ((#%boolean? x) + (display (if x "#t" "#f"))) (else (display "#"))))) ;; TODO have vectors and co ? @@ -447,14 +461,14 @@ (lambda (x y) (let ((lx (#%u8vector-length x))) (if (#%= lx (#%u8vector-length y)) - (u8vector-equal?-loop x y lx) + (u8vector-equal?-loop x y (- lx 1)) #f)))) (define u8vector-equal?-loop (lambda (x y l) (if (#%= l 0) #t (and (#%= (#%u8vector-ref x l) (#%u8vector-ref y l)) - (u8vector-equal?-loop x y (#%- l 1)))))) ;; TODO test this + (u8vector-equal?-loop x y (#%- l 1)))))) (define assoc (lambda (t l) @@ -465,7 +479,6 @@ (else (assoc t (#%cdr l)))))) -;; TODO ordinary vectors are never more that 6 elements long in the stack, so implementing them as lists is acceptable (define vector list) (define vector-ref list-ref) (define vector-set! list-set!) @@ -475,12 +488,12 @@ ;; TODO add bitwise-and ? bitwise-not ? (define current-time (lambda () (#%clock))) -(define time->seconds (lambda (t) (#%quotient t 100))) ;; TODO no floats, is that a problem ? +(define time->seconds (lambda (t) (#%quotient t 100))) (define u8vector (lambda x (list->u8vector x))) -(define list->u8vector ;; TODO not used except for server +(define list->u8vector (lambda (x) (let* ((n (length x)) (v (#%make-u8vector n 0))) @@ -494,24 +507,9 @@ (define u8vector-length (lambda (x) (#%u8vector-length x))) (define u8vector-ref (lambda (x y) (#%u8vector-ref x y))) (define u8vector-set! (lambda (x y z) (#%u8vector-set! x y z))) -;; (define make-u8vector -;; (lambda (n x) -;; (let ((v (#%make-u8vector n))) -;; (make-u8vector-loop v (#%- n 1) x) -;; v))) (define make-u8vector (lambda (n x) (#%make-u8vector n x))) -;; (define make-u8vector-loop -;; (lambda (v n x) -;; ;;; (display "ok:") -;; ;;; (display n) -;; ;;; (display "\n") -;; (if (>= n 0) (#%u8vector-set! v n x)) ;; TODO safety, should not be needed -;; (if (#%> n 0) -;; (begin ;; (display "loop\n") -;; (make-u8vector-loop v (#%- n 1) x))))) -;; ;; TODO with named lets ? (define u8vector-copy! (lambda (source source-start target target-start n) (#%u8vector-copy! source source-start target target-start n))) diff --git a/picobit-vm.c b/picobit-vm.c index 168b745..7641a32 100644 --- a/picobit-vm.c +++ b/picobit-vm.c @@ -1594,6 +1594,11 @@ void prim_list2string (void) 0); } +void prim_booleanp (void) +{ + arg1 = encode_bool (arg1 < 2); +} + /*---------------------------------------------------------------------------*/ @@ -2172,7 +2177,7 @@ char *prim_name[64] = "shift", "pop", "return", - "prim 48", + "prim #%boolean?", "prim 49", "prim 50", "prim 51", @@ -2877,6 +2882,8 @@ void interpreter (void) switch (bytecode_lo4) { case 0: + /* prim #%boolean? */ + arg1 = POP(); prim_booleanp (); PUSH_ARG1(); break; break; case 1: break; diff --git a/picobit.scm b/picobit.scm index d333adf..5687aa6 100644 --- a/picobit.scm +++ b/picobit.scm @@ -202,56 +202,57 @@ (define make-global-env (lambda () - (list (make-var '#%number? #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%+ #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%- #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%* #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%quotient #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%remainder #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%neg #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%= #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%< #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%ior #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED - (make-var '#%> #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%xor #t '() '() '() #f (make-primitive 2 #f #f)) ;; ADDED - (make-var '#%pair? #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%cons #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%car #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%cdr #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%set-car! #t '() '() '() #f (make-primitive 2 #f #t)) - (make-var '#%set-cdr! #t '() '() '() #f (make-primitive 2 #f #t)) - (make-var '#%null? #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%eq? #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%not #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%get-cont #t '() '() '() #f (make-primitive 0 #f #f)) - (make-var '#%graft-to-cont #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%return-to-cont #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%halt #t '() '() '() #f (make-primitive 0 #f #t)) - (make-var '#%symbol? #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%string? #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%string->list #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%list->string #t '() '() '() #f (make-primitive 1 #f #f)) - - (make-var '#%make-u8vector #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%u8vector-ref #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%u8vector-set! #t '() '() '() #f (make-primitive 3 #f #t)) - - (make-var '#%print #t '() '() '() #f (make-primitive 1 #f #t)) - (make-var '#%clock #t '() '() '() #f (make-primitive 0 #f #f)) - (make-var '#%motor #t '() '() '() #f (make-primitive 2 #f #t)) - (make-var '#%led #t '() '() '() #f (make-primitive 3 #f #t)) - (make-var '#%led2-color #t '() '() '() #f (make-primitive 1 #f #t)) - (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%putchar #t '() '() '() #f (make-primitive 2 #f #t)) - (make-var '#%beep #t '() '() '() #f (make-primitive 2 #f #f)) - (make-var '#%adc #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%u8vector? #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED, was dac - (make-var '#%sernum #t '() '() '() #f (make-primitive 0 #f #f)) - (make-var '#%u8vector-length #t '() '() '() #f (make-primitive 1 #f #f)) - (make-var '#%u8vector-copy! #t '() '() '() #f (make-primitive 5 #f #t)) - - (make-var '#%readyq #t '() '() '() #f #f) - ))) + (list + (make-var '#%number? #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%+ #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%- #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%* #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%quotient #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%remainder #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%neg #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%= #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%< #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%ior #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%> #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%xor #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%pair? #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%cons #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%car #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%cdr #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%set-car! #t '() '() '() #f (make-primitive 2 #f #t)) + (make-var '#%set-cdr! #t '() '() '() #f (make-primitive 2 #f #t)) + (make-var '#%null? #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%eq? #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%not #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%get-cont #t '() '() '() #f (make-primitive 0 #f #f)) + (make-var '#%graft-to-cont #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%return-to-cont #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%halt #t '() '() '() #f (make-primitive 0 #f #t)) + (make-var '#%symbol? #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%string? #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%string->list #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%list->string #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%make-u8vector #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%u8vector-ref #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%u8vector-set! #t '() '() '() #f (make-primitive 3 #f #t)) + (make-var '#%print #t '() '() '() #f (make-primitive 1 #f #t)) + (make-var '#%clock #t '() '() '() #f (make-primitive 0 #f #f)) + (make-var '#%motor #t '() '() '() #f (make-primitive 2 #f #t)) + (make-var '#%led #t '() '() '() #f (make-primitive 3 #f #t)) + (make-var '#%led2-color #t '() '() '() #f (make-primitive 1 #f #t)) + (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%putchar #t '() '() '() #f (make-primitive 2 #f #t)) + (make-var '#%beep #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%adc #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%u8vector? #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%sernum #t '() '() '() #f (make-primitive 0 #f #f)) + (make-var '#%u8vector-length #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%u8vector-copy! #t '() '() '() #f (make-primitive 5 #f #t)) + (make-var '#%boolean? #t '() '() '() #f (make-primitive 1 #f #f)) + + (make-var '#%readyq #t '() '() '() #f #f) + ;; TODO put in a meaningful order + ))) ;; list of primitives that can be safely substituted for the equivalent ;; function when it is called. @@ -275,6 +276,8 @@ (eq? . #%eq?) (not . #%not) (modulo . #%remainder) + (symbol? . #%symbol?) + (string? . #%string?) (string->list . #%string->list) (list->string . #%list->string) (clock . #%clock) @@ -292,6 +295,7 @@ (u8vector-set! . #%u8vector-set!) (make-u8vector . #%make-u8vector) (u8vector-copy! . #%u8vector-copy!) + (boolean? . #%boolean?) )) (define env-lookup @@ -600,7 +604,6 @@ (cons (cdr prim) (cdr expr)) env))) ;; binary arthimetic operations can use primitives directly - ;; TODO if more than one arg, unroll ? would save calls ((and (pair? expr) (= (length (cdr expr)) 2) (assoc (car expr) '((+ . #%+) (- . #%-) (* . #%*)))) @@ -858,7 +861,9 @@ (if (>= i 0) (gen-push-stack i ctx) (gen-push-stack - (+ 1 ;; TODO the +1 was added because closures are not really pairs anymore, they only have a cdr + ;; this +1 is needed because closures are in the environment, but + ;; don't contain a value, and must therefore be skipped + (+ 1 (- -1 i) (length (stack-slots (env-local (context-env ctx))))) ctx))))) @@ -1105,7 +1110,7 @@ (cst? val)) ;; immutable global, counted as cst (gen-push-constant (cst-val val) ctx) (gen-push-global (var-id var) ctx)))) - (gen-push-local-var (var-id var) ctx)))) ;; TODO globals as csts seem to work (but only for constant-values ones, like it probably should) + (gen-push-local-var (var-id var) ctx)))) ((or (def? node) (set? node)) @@ -1196,7 +1201,6 @@ (gen-push-constant '() ctx)) (gen-closure label-entry (build vars ctx)))) -;; TODO the last branch was changed because since pointers are now larger, there is not a pointer-sized free space in each closure, which could make it behave like a pair. now, everything is in the env, and closures only have a cdr (define comp-prc (lambda (node closure? ctx) @@ -1267,17 +1271,21 @@ (use-result (if (primitive-inliner primitive) ((primitive-inliner primitive) ctx) - (if (not (= nargs prim-nargs)) - (compiler-error "primitive called with wrong number of arguments" id) - (gen-prim - id - prim-nargs - (primitive-unspecified-result? primitive) - ctx)))))) - - + (if + (not (= nargs prim-nargs)) + (compiler-error + "primitive called with wrong number of arguments" + id) + (gen-prim + id + prim-nargs + (primitive-unspecified-result? primitive) + ctx)))))) + + ((and (ref? op) - (toplevel-prc-with-non-rest-correct-calls? (ref-var op))) + (toplevel-prc-with-non-rest-correct-calls? + (ref-var op))) => (lambda (prc) (cond ((eq? reason 'tail) @@ -1423,7 +1431,8 @@ ;; globals that obey the following conditions are considered ;; to be constants (not (and (not (mutable-var? var)) - (> (length (var-defs var)) 0) ;; TODO to catch errors for primitives + ;; to weed out primitives, which have no definitions + (> (length (var-defs var)) 0) (cst? (child1 (car (var-defs var))))))) (begin (var-needed?-set! var #t) @@ -2622,7 +2631,7 @@ (let ((e (encode-direct o))) (if e e - (let ((x (assoc o constants))) ;; TODO was assq + (let ((x (assoc o constants))) (if x (vector-ref (cdr x) 0) (compiler-error "unknown object" obj))))))) @@ -2632,7 +2641,7 @@ (let ((e (encode-direct o))) (if e (cont constants) - (let ((x (assoc o constants))) ;; TODO was assq + (let ((x (assoc o constants))) (if x (begin (if from-code? @@ -2659,7 +2668,7 @@ new-constants #f cont))) - ((vector? o) + ((vector? o) ; ordinary vectors are stored as lists (let ((elems (vector->list o))) (vector-set! descr 3 elems) (add-constant elems @@ -2892,13 +2901,14 @@ (define (prim.putchar) (prim 38)) (define (prim.beep) (prim 39)) (define (prim.adc) (prim 40)) - (define (prim.u8vector?) (prim 41)) ;; TODO was dac - (define (prim.sernum) (prim 42)) ;; TODO necessary ? + (define (prim.u8vector?) (prim 41)) + (define (prim.sernum) (prim 42)) (define (prim.u8vector-length) (prim 43)) (define (prim.u8vector-copy!) (prim 44)) (define (prim.shift) (prim 45)) (define (prim.pop) (prim 46)) (define (prim.return) (prim 47)) + (define (prim.boolean?) (prim 48)) (define big-endian? #f) @@ -2907,7 +2917,7 @@ (asm-8 #xfb) (asm-8 #xd7) (asm-8 (length constants)) - (asm-8 (length globals)) ;; TODO was 0 + (asm-8 (length globals)) (pp (list constants: constants globals: globals)) ;; TODO debug @@ -2942,7 +2952,7 @@ (asm-8 (bitwise-and obj-enc #xff)) (asm-8 #x40) (asm-8 0))) - ((vector? obj) ;; BREGG change this, we have no ordinary vectors + ((vector? obj) ; ordinary vectors are stored as lists ;; TODO this is the OLD representation, NOT GOOD (but not used) BREGG (let ((obj-enc (encode-constant (vector-ref descr 3) constants))) @@ -3069,6 +3079,7 @@ ((#%sernum) (prim.sernum)) ((#%u8vector-length) (prim.u8vector-length)) ((#%u8vector-copy!) (prim.u8vector-copy!)) + ((#%boolean?) (prim.boolean?)) (else (compiler-error "unknown primitive" (cadr instr))))) -- 2.11.4.GIT