diff --git a/src/compiler.rls b/src/compiler.rls index da21526..7ee71e3 100644 --- a/src/compiler.rls +++ b/src/compiler.rls @@ -5,15 +5,17 @@ (load "lib/primitive/map.rls") (load "lib/primitive/append.rls") (load "lib/util.rls") -(load "lib/hash-table.rls") -(load "lib/symbols.rls") -(load "lib/keywords.rls") (load "lib/parameters.rls") (load "lib/abort.rls") (load "lib/errors.rls") +(load "lib/hash-table.rls") +(load "lib/names.rls") +(load "lib/symbols.rls") +(load "lib/keywords.rls") (load "lib/port.rls") (load "lib/display.rls") (load "lib/reader.rls") +(load "lib/writer.rls") (define s:evaluation-environment (make-structure '() 2)) @@ -30,37 +32,46 @@ (vector-set! vec i (first lst)) (iter (fix+ i 1) (rest lst)))))) -(define (evaluation-environment-parent-environment env) (struct-ref env 0)) -(define (evaluation-environment-local-variable-values env) (struct-ref env 1)) +(define (evaluation-environment-parent-environment env) + (struct-ref (type-check s:evaluation-environment env) 0)) + +(define (evaluation-environment-local-variable-values env) + (struct-ref (type-check s:evaluation-environment env) 1)) (define s:compilation-environment (make-structure '() 5)) (define (make-compilation-environment parent-env variable-list - [syntax-transformer-list (if parent-env - (compilation-environment-syntax-transformers parent-env) - '())]) + [syntax-transformer-list + (if parent-env + (compilation-environment-syntax-transformers parent-env) + '())]) (let ([env (make-struct s:compilation-environment)]) (struct-set! env 0 parent-env) (struct-set! env 1 (if variable-list (freeze! (list->vector variable-list)) (make-vector 0 #f))) (struct-set! env 2 syntax-transformer-list) - (struct-set! env 3 (if (pair? variable-list) - (let ([n-vars (list-length variable-list)]) - (lambda (eval-env) (make-evaluation-environment eval-env n-vars))) - (lambda (eval-env) eval-env))) - (struct-set! env 4 (if (pair? variable-list) - evaluation-environment-parent-environment - values)) + (struct-set! env 3 (let ([n-vars (list-length variable-list)]) + (lambda (eval-env) (make-evaluation-environment eval-env n-vars)))) + (struct-set! env 4 evaluation-environment-parent-environment) (freeze! env))) -(define (compilation-environment-parent-environment env) (struct-ref env 0)) -(define (compilation-environment-local-variables env) (struct-ref env 1)) -(define (compilation-environment-syntax-transformers env) (struct-ref env 2)) -(define (compilation-environment-eval-constructor env) (struct-ref env 3)) -(define (compilation-environment-eval-parent env) (struct-ref env 4)) +(define (compilation-environment-parent-environment env) + (struct-ref (type-check s:compilation-environment env) 0)) + +(define (compilation-environment-local-variables env) + (struct-ref (type-check s:compilation-environment env) 1)) + +(define (compilation-environment-syntax-transformers env) + (struct-ref (type-check s:compilation-environment env) 2)) + +(define (compilation-environment-eval-constructor env) + (struct-ref (type-check s:compilation-environment env) 3)) + +(define (compilation-environment-eval-parent env) + (struct-ref (type-check s:compilation-environment env) 4)) (define current-compilation-environment (make-parameter #f)) (define current-syntax-compilation-environment (make-parameter #f)) @@ -127,50 +138,49 @@ (lambda () (variable-accessors symbol)) (lambda (get-fn set-fn) set-fn))) -(define (compile form [top-level-bindings '()] [syntax-transformer-list '()]) - (let* ([bound-vars (map car top-level-bindings)] - [initial-vals (map cdr top-level-bindings)] - [comp-env (make-compilation-environment #f bound-vars syntax-transformer-list)] - [syn-comp-env (make-compilation-environment #f bound-vars syntax-transformer-list)] +(define (compile form [syntax-transformer-list '()]) + (let* ([comp-env (make-compilation-environment #f '() syntax-transformer-list)] + [syn-comp-env (make-compilation-environment #f '() syntax-transformer-list)] [eval-env-op (compilation-environment-eval-constructor comp-env)] [syn-eval-env ((compilation-environment-eval-constructor syn-comp-env) #f)]) (call-with-parameters (lambda () - (initialize-evaluation-environment syn-eval-env initial-vals) + (initialize-evaluation-environment syn-eval-env '()) (let ([form-op (compile-form form)]) (lambda () (let ([eval-env (eval-env-op #f)]) - (initialize-evaluation-environment eval-env initial-vals) + (initialize-evaluation-environment eval-env '()) (form-op eval-env))))) (list current-compilation-environment comp-env) (list current-syntax-compilation-environment syn-comp-env) (list current-syntax-evaluation-environment syn-eval-env)))) -(define (compile-form form) +(define (compile-form form [name #f]) + #;(begin (write-string "expanding: ") (display form) (write-char #\Newline)) (let ([expanded-form (syntax-expand/full form)]) + #;(begin (write-string "compiling: ") (display expanded-form) (write-char #\Newline)) (cond [(symbol? expanded-form) (compile-symbol expanded-form)] - [(pair? expanded-form) (compile-list expanded-form)] + [(pair? expanded-form) (compile-list expanded-form name)] [else (lambda (eval-env) expanded-form)]))) (define (compile-symbol form) (variable-getter form)) -(define (compile-list form) +(define (compile-list form [name #f]) (let* ([first-form (first form)]) - ((cond - [(eq? first-form 'quote) compile-quote-form] - [(eq? first-form 'begin) compile-begin-form] - [(eq? first-form 'if) compile-if-form] - [(eq? first-form 'set!) compile-set!-form] - [(eq? first-form 'lambda) compile-lambda-form] - [(eq? first-form 'let) compile-let-form] - [(eq? first-form 'letrec) compile-letrec-form] - [(eq? first-form 'let-syntax) compile-let-syntax-form] - [(eq? first-form 'let-for-syntax) compile-let-for-syntax-form] - [(eq? first-form 'letrec-for-syntax) compile-letrec-for-syntax-form] - [else compile-function-call-form]) - form))) + (cond + [(eq? first-form 'quote) (compile-quote-form form)] + [(eq? first-form 'begin) (compile-begin-form form)] + [(eq? first-form 'if) (compile-if-form form)] + [(eq? first-form 'set!) (compile-set!-form form)] + [(eq? first-form 'lambda) (compile-lambda-form form name)] + [(eq? first-form 'let) (compile-let-form form)] + [(eq? first-form 'letrec) (compile-letrec-form form)] + [(eq? first-form 'let-syntax) (compile-let-syntax-form form)] + [(eq? first-form 'let-for-syntax) (compile-let-for-syntax-form form)] + [(eq? first-form 'letrec-for-syntax) (compile-letrec-for-syntax-form form)] + [else (compile-function-call-form form)]))) (define (compile-quote-form form) (let ([vals (rest form)]) @@ -182,7 +192,7 @@ (let ([first-op (compile-form (first forms))]) (if (null? (rest forms)) first-op - (let ([rest-op (compile-body-forms (rest forms))]) + (let ([rest-op (compile-forms (rest forms))]) (lambda (eval-env) (first-op eval-env) (rest-op eval-env))))))) ; (letrec-for-syntax (deferred-for-syntax-defines... @@ -381,7 +391,7 @@ (if (and (pair? bind) (pair? (rest bind))) (let* ([bind-vars (binding->symbols bind)] [values-op (call-with-parameters - (lambda () (compile-form (second bind))) + (lambda () (compile-form (second bind) (first bind))) (list current-compilation-environment value-comp-env))] [init-op (call-with-parameters (lambda () (generate-init-function bind-vars next-bind-op)) @@ -525,6 +535,9 @@ (let ([fn-op (compile-form (first form))] [args-op (compile-args (rest form))]) (lambda (eval-env) + #;(begin + (display form (current-error-port)) + (write-char #\Newline (current-error-port))) (apply (fn-op eval-env) (args-op eval-env))))) (define (arguments->symbols arglist) @@ -596,7 +609,7 @@ (setter eval-env (first vals)) (next-op eval-env (rest vals))))))])) -(define (compile-lambda-form form) +(define (compile-lambda-form form [name #f]) (let* ([bound-vars (arguments->symbols (second form))] [comp-env (make-compilation-environment (current-compilation-environment) bound-vars)] [eval-env-op (compilation-environment-eval-constructor comp-env)]) @@ -605,19 +618,41 @@ (lambda () (let ([args-op (compile-arguments (second form))] [body-op (compile-body-forms (rest (rest form)))]) - (lambda (eval-env) - (lambda argv - (let ([inner-eval-env (eval-env-op eval-env)]) - (args-op inner-eval-env argv) - (body-op inner-eval-env)))))) + (if name + (lambda (eval-env) + (attach-name name + (lambda argv + (let ([inner-eval-env (eval-env-op eval-env)]) + (args-op inner-eval-env argv) + (body-op inner-eval-env))))) + (lambda (eval-env) + (lambda argv + (let ([inner-eval-env (eval-env-op eval-env)]) + (args-op inner-eval-env argv) + (body-op inner-eval-env))))))) (list current-compilation-environment comp-env)))) -(define *top-level-bindings* '()) (define *top-level-syntax-transformers* '()) +(define *top-level-variables* (make-hash-table eq?)) -(define (register-top-level-binding sym val) - (set! *top-level-bindings* - (cons (cons sym val) *top-level-bindings*))) +(define (add-top-level-variable symbol [value undefined] [value-given? (not (eq? value undefined))]) + (define (report-use-before-set) + (write-string "Warning: Variable " (current-error-port)) + (display symbol (current-error-port)) + (write-string " was not set before first use.\n" (current-error-port)) + undefined) + (letrec ([accessors (list (if value-given? + (lambda () value) + report-use-before-set) + (lambda (val) (set-car! accessors (lambda () val))))]) + (hash-table-insert *top-level-variables* symbol accessors) + (apply values accessors))) + +(define (register-top-level-binding symbol value) + (register-symbols (list symbol)) + (add-top-level-variable symbol value #t) + (attach-name symbol value) + (values)) (define (register-top-level-syntax symbol fn) (set! *top-level-syntax-transformers* @@ -765,10 +800,14 @@ (register-top-level-binding 'freeze! (#%builtin "freeze!")) (register-top-level-binding 'immutable? (#%builtin "immutable?")) (register-top-level-binding 'string->number (#%builtin "string->number")) +(register-top-level-binding 'string->builtin (#%builtin "string->builtin")) +(register-top-level-binding 'builtin->string (#%builtin "builtin->string")) (register-top-level-binding 'builtin-display (#%builtin "display")) (register-top-level-binding 'register-finalizer (#%builtin "register-finalizer")) (register-top-level-binding 'current-context (#%builtin "current-context")) (register-top-level-binding 'call-with-context (#%builtin "call-with-context")) +(register-top-level-binding 'exit (#%builtin "exit")) +(register-top-level-binding 'float->string (#%builtin "float->string")) (register-top-level-binding 'posix-open (#%builtin "posix-open")) (register-top-level-binding 'posix-dup (#%builtin "posix-dup")) (register-top-level-binding 'posix-dup2 (#%builtin "posix-dup2")) @@ -825,13 +864,15 @@ )) ((lambda () +(register-top-level-binding 'make-hash-table make-hash-table) (register-top-level-binding 'hash-table? hash-table?) -(register-top-level-binding 'hash-table-hash-function hash-table-hash-function) (register-top-level-binding 'hash-table-eq-function hash-table-eq-function) +(register-top-level-binding 'hash-table-hash-function hash-table-hash-function) (register-top-level-binding 'hash-table-entries hash-table-entries) (register-top-level-binding 'hash-table-lookup hash-table-lookup) (register-top-level-binding 'hash-table-insert hash-table-insert) (register-top-level-binding 'hash-table-remove hash-table-remove) +(register-top-level-binding 'hash-table-remove-if hash-table-remove-if) (register-top-level-binding 'make-symbol make-symbol) (register-top-level-binding 'symbol? symbol?) @@ -915,7 +956,11 @@ (register-top-level-binding 'symbol-char? symbol-char?) (register-top-level-binding 'digit->integer digit->integer) +(register-top-level-binding 'write-rla write-rla) + (register-top-level-binding 'compile compile) +(register-top-level-binding 'attach-name attach-name) +(register-top-level-binding 'object->name object->name) (register-top-level-binding 'current-duplicate-binding-handler current-duplicate-binding-handler) (register-top-level-binding 'current-missing-argument-handler current-missing-argument-handler) (register-top-level-binding 'current-extra-argument-handler current-extra-argument-handler) @@ -1007,25 +1052,17 @@ mod)) (list current-input-port port)))) -(define *extra-variables* (make-hash-table)) - -(define (add-extra-variable symbol) - (let ([box (make-box undefined)]) - (hash-table-insert *extra-variables* symbol box) - box)) - -(define (extra-variable-accessors symbol) - (let ([box (hash-table-lookup *extra-variables* symbol - (lambda () (add-extra-variable symbol)))]) - (values (lambda () (unbox box)) - (lambda (val) (set-box! box val))))) +(define (top-level-variable-accessors symbol) + (apply values + (hash-table-lookup + *top-level-variables* + symbol + (lambda () (add-top-level-variable symbol))))) (define (do-compile form) (call-with-parameters - (lambda () (compile form *top-level-bindings* *top-level-syntax-transformers*)) - (list current-unbound-variable-handler extra-variable-accessors))) - -(register-symbols (map car *top-level-bindings*)) + (lambda () (compile form *top-level-syntax-transformers*)) + (list current-unbound-variable-handler top-level-variable-accessors))) (register-symbols '(quote begin if set! lambda let letrec let-syntax let-for-syntax letrec-for-syntax @@ -1035,19 +1072,31 @@ unquote-splicing load absolute relative from-end input output binary buffered posix)) -(call-with-abort-handler +(call-with-parameters (lambda () - (let* ([module-form (if (pair? *argv*) - (read-module-from-path (car *argv*)) - (read-module))] - [module-fn (do-compile module-form)]) - (let iter ([vals (values->list (module-fn))]) - (when (pair? vals) - (display (first vals)) - (write-char #\Newline) - (iter (rest vals)))))) - (lambda (abort-values-fn) - (write-string "Fatal error\b" (current-error-port)) - (values))) + (call-with-abort-handler + (lambda () + (let* ([module-form (if (pair? *argv*) + (read-module-from-path (car *argv*)) + (read-module))] + [module-fn (do-compile module-form)]) + (let iter ([vals (values->list (module-fn))]) + (when (pair? vals) + (display (first vals)) + (write-char #\Newline) + (iter (rest vals)))))) + (lambda (abort-values-fn) + (write-string "Fatal error\n" (current-error-port)) + (exit)))) + (list current-argument-error-handler + (lambda (name val) + (display (list name val "argument error") (current-error-port)) + (write-char #\Newline (current-error-port)) + (exit))) + (list current-type-error-handler + (lambda (type val) + (display (list type val "type error") (current-error-port)) + (write-char #\Newline (current-error-port)) + (exit)))) ; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/display.rls b/src/lib/display.rls index 798dd34..c247a70 100644 --- a/src/lib/display.rls +++ b/src/lib/display.rls @@ -16,6 +16,22 @@ (write-char #\" port) (values)) +(define (display-procedure proc port) + (write-string "#name proc)]) + (when name + (write-char #\: port) + (display name port))) + (write-char #\> port)) + +(define (display-structure s port) + (write-string "#name (struct-type s))]) + (when name + (write-string "::" port) + (display name port))) + (write-char #\> port)) + (define (display form [port (current-output-port)]) (define (finish-list lst) (cond @@ -38,14 +54,15 @@ [(symbol? form) (write-string (symbol->string form) port)] [(keyword? form) (write-string "#:" port) (write-string (keyword->string form) port)] + [(procedure? form) (display-procedure form port)] + [(struct? form) (display-structure form port)] [(fixnum? form) (write-string (number->string form) port)] + [(float? form) (write-string (float->string form) port)] + [(vector? form) (write-string "#" port)] [(eq? form '()) (write-string "()" port)] [(eq? form #f) (write-string "#f" port)] [(eq? form #t) (write-string "#t" port)] [(eq? form undefined) (write-string "#" port)] - [(procedure? form) (write-string "#" port)] - [(struct? form) (write-string "#" port)] - [(vector? form) (write-string "#" port)] [else (write-string "#" port)]) (values)) diff --git a/src/lib/hash-table.rls b/src/lib/hash-table.rls index 5d21ae8..570de50 100644 --- a/src/lib/hash-table.rls +++ b/src/lib/hash-table.rls @@ -6,24 +6,23 @@ (define @minimum-buckets@ 17) (define s:hash-table (make-structure '() 4)) -(define (make-hash-table [hash-fn (lambda (x) (hash-value x))] - [eq-fn (lambda (x y) (equal? x y))]) +(define (make-hash-table [eq-fn (lambda (x y) (equal? x y))] + [hash-fn (lambda (x) (hash-value x))]) (let ([ht (make-struct s:hash-table)]) - (struct-set! ht 0 hash-fn) - (struct-set! ht 1 eq-fn) + (struct-set! ht 0 eq-fn) + (struct-set! ht 1 hash-fn) (struct-set! ht 2 0) (struct-set! ht 3 (make-vector @minimum-buckets@ '())) ht)) (define (hash-table? x) (kind-of? x s:hash-table)) -(define (hash-table-hash-function ht) (struct-ref ht 0)) -(define (hash-table-eq-function ht) (struct-ref ht 1)) -(define (hash-table-entries ht) (struct-ref ht 2)) -(define (hash-table-buckets ht) (struct-ref ht 3)) - -(define (set-hash-table-entries! ht v) (struct-set! ht 2 v)) -(define (set-hash-table-buckets! ht v) (struct-set! ht 3 v)) +(define (hash-table-eq-function ht) (struct-ref (type-check s:hash-table ht) 0)) +(define (hash-table-hash-function ht) (struct-ref (type-check s:hash-table ht) 1)) +(define (hash-table-entries ht) (struct-ref (type-check s:hash-table ht) 2)) +(define (set-hash-table-entries! ht v) (struct-set! (type-check s:hash-table ht) 2 v)) +(define (hash-table-buckets ht) (struct-ref (type-check s:hash-table ht) 3)) +(define (set-hash-table-buckets! ht v) (struct-set! (type-check s:hash-table ht) 3 v)) (define (hash-table-key->index ht key) (let* ([hash ((hash-table-hash-function ht) key)] @@ -46,29 +45,54 @@ [(eq-fn (caar bucket) key) (cdar bucket)] [else (search (cdr bucket))])))) -;; TODO: Halve buckets if entries/buckets < 3/4 and buckets >= 2*min_buckets -;; Double buckets if entries/buckets >= 2 -(define (rehash-if-needed ht)) +;; Halve buckets if entries/buckets < 3/4 and buckets >= 2*min_buckets +;; Double buckets if entries/buckets >= 2 +(define (rehash-if-needed ht) + (let* ([n-entries (hash-table-entries ht)] + [n-buckets (vector-size (hash-table-buckets ht))]) + (define (rehash new-size) + (let ([old-buckets (hash-table-buckets ht)]) + (set-hash-table-buckets! ht (make-vector new-size '())) + (let outer ([index 0]) + (when (fix< index n-buckets) + (let inner ([entries (vector-ref old-buckets index)]) + (when (pair? entries) + (%hash-table-insert% ht (caar entries) (cdar entries) values) + (inner (cdr entries)))) + (outer (fix+ index 1)))))) + (cond + [(and (fix< (fix* n-entries 4) (fix* n-buckets 3)) + (fix>= n-buckets (fix* @minimum-buckets@ 2))) + (rehash (fix/ n-buckets 2)) + #t] + [(fix>= n-entries (fix* n-buckets 2)) + (rehash (fix* n-buckets 2)) + #t] + [else + #f]))) -(define (hash-table-insert ht key val [collision (lambda (oldv) val)]) +(define (%hash-table-insert% ht key val collision) (let* ([eq-fn (hash-table-eq-function ht)] [index (hash-table-key->index ht key)] [buckets (hash-table-buckets ht)]) - (define (insert-new-entry) - (vector-set! buckets index - (cons (cons key val) - (vector-ref buckets index))) - (set-hash-table-entries! ht (fix+ 1 (hash-table-entries ht))) - (rehash-if-needed ht)) - (if (eq? (vector-ref buckets index) '()) - (insert-new-entry) - (let search ([bucket (vector-ref buckets index)]) - (cond - [(eq-fn (caar bucket) key) - (set-cdr! (car bucket) (collision (cdar bucket)))] - [(eq? (cdr bucket) '()) (insert-new-entry)] - [else (search (cdr bucket))])))) - (values)) + (let search ([bucket (vector-ref buckets index)] + [set-op (lambda (x) (vector-set! buckets index x))]) + (cond + [(eq? bucket '()) + (set-op (cons (cons key val) '())) + (set-hash-table-entries! ht (fix+ 1 (hash-table-entries ht))) + (values #f #f)] + [(eq-fn (caar bucket) key) + (let ([old-val (cdar bucket)]) + (set-cdr! (car bucket) (collision old-val)) + (values old-val #t))] + [else + (search (cdr bucket) (lambda (x) (set-cdr! bucket x)))])))) + +(define (hash-table-insert ht key val [collision (lambda (oldv) val)]) + (let ([result (values->list (%hash-table-insert% ht key val collision))]) + (rehash-if-needed ht) + (apply values result))) (define (hash-table-remove ht key [not-found (lambda () #f)]) (let* ([eq-fn (hash-table-eq-function ht)] @@ -96,4 +120,22 @@ [(eq? (cdr next-bucket) '()) (not-found)] [else (search next-bucket (cdr next-bucket))]))]))) +; Scan the entire hash table, and remove any entries for which (proc key value) is not #f. +(define (hash-table-remove-if ht proc) + (let* ([buckets (hash-table-buckets ht)] + [n-buckets (vector-size buckets)]) + (let outer ([index 0]) + (when (fix< index n-buckets) + (let inner ([entries (vector-ref buckets index)] + [set-op (lambda (x) (vector-set! buckets index x))]) + (when (pair? entries) + (if (proc (caar entries) (cdar entries)) + (begin + (set-op (cdr entries)) + (set-hash-table-entries! ht (fix- (hash-table-entries ht) 1)) + (inner (cdr entries) set-op)) + (inner (cdr entries) (lambda (x) (set-cdr! entries x)))))) + (outer (fix+ index 1))))) + (rehash-if-needed ht)) + ; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/keywords.rls b/src/lib/keywords.rls index afe0ab2..fa68407 100644 --- a/src/lib/keywords.rls +++ b/src/lib/keywords.rls @@ -2,26 +2,26 @@ (define *keywords* (make-hash-table)) (define (make-keyword name) - (let ([sym (make-struct s:keyword)]) - (struct-set! sym 0 (freeze! (copy-byte-string name))) - (freeze! sym))) + (let ([kw (make-struct s:keyword)]) + (struct-set! kw 0 (freeze! (copy-byte-string name))) + (freeze! kw))) (define (keyword? x) (and (struct? x) (eq? (struct-type x) s:keyword))) -(define (keyword->string sym) - (struct-ref sym 0)) +(define (keyword->string kw) + (struct-ref (type-check s:keyword kw) 0)) (define (string->keyword name) (or (hash-table-lookup *keywords* name) - (let ([sym (make-keyword name)]) - (hash-table-insert *keywords* name sym) - sym))) + (let ([kw (make-keyword name)]) + (hash-table-insert *keywords* name kw) + kw))) -(define (register-keywords syms) - (when (pair? syms) - (let ([sym (car syms)]) - (hash-table-insert *keywords* (keyword->string sym) sym)) - (register-keywords (cdr syms)))) +(define (register-keywords kws) + (when (pair? kws) + (let ([kw (car kws)]) + (hash-table-insert *keywords* (keyword->string kw) kw)) + (register-keywords (cdr kws)))) ; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/names.rls b/src/lib/names.rls new file mode 100644 index 0000000..dc2a712 --- /dev/null +++ b/src/lib/names.rls @@ -0,0 +1,36 @@ +;(load "lib/primitives.rls") +;(load "lib/primitive/foldl.rls") +;(load "lib/primitive/foldr.rls") +;(load "lib/primitive/reverse.rls") +;(load "lib/primitive/map.rls") +;(load "lib/primitive/append.rls") +;(load "lib/util.rls") +;(load "lib/parameters.rls") +;(load "lib/abort.rls") +;(load "lib/errors.rls") +;(load "lib/hash-table.rls") + +(define (weak-eq? wb1 wb2) + (let ([v1 (weak-unbox wb1)]) + (and v1 (eq? v1 (weak-unbox wb2))))) + +(define (weak-hash-value wb) + (hash-value (weak-unbox wb))) + +(define *name-table* (make-hash-table weak-eq? weak-hash-value)) + +(define (attach-name name obj) + (when (or (struct? obj) + (vector? obj)) + (if name + (hash-table-insert *name-table* (make-weak-box obj) name) + (hash-table-remove *name-table* (make-weak-box obj)))) + (hash-table-remove-if *name-table* (lambda (k v) (eq? (weak-unbox k) #f))) + obj) + +(define (object->name obj) + (and (or (struct? obj) + (vector? obj)) + (hash-table-lookup *name-table* (make-weak-box obj)))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/parameters.rls b/src/lib/parameters.rls index 16a16b6..2aa1a98 100644 --- a/src/lib/parameters.rls +++ b/src/lib/parameters.rls @@ -14,8 +14,11 @@ (struct-set! new-env 0 (struct-ref env 0)) new-env)) -(define (dynamic-environment-parameters env) (struct-ref env 0)) -(define (set-dynamic-environment-parameters! env lst) (struct-set! env 0 lst)) +(define (dynamic-environment-parameters env) + (struct-ref env 0)) + +(define (set-dynamic-environment-parameters! env lst) + (struct-set! env 0 lst)) (define (parameter-callable param . rst) (define param-hash (hash-value param)) @@ -44,9 +47,9 @@ (define (parameter? x) (kind-of? x s:parameter)) -(define (parameter-value param) (struct-ref param 0)) +(define (parameter-value param) (struct-ref param 0)) (define (set-parameter-value! param val) (struct-set! param 0 val)) -(define (parameter-guard-function param) (struct-ref param 1)) +(define (parameter-guard-function param) (struct-ref param 1)) (define s:parameter-binding (make-structure '() 4)) diff --git a/src/lib/port.rls b/src/lib/port.rls index e7a996a..f8e48e1 100644 --- a/src/lib/port.rls +++ b/src/lib/port.rls @@ -6,12 +6,16 @@ (define EOF (make-marker "EOF")) (define (eof? x) (eq? x EOF)) -(define (default-port-error-handler p) (abort)) +(define (default-port-error-handler p) (values)) (define (default-port-eof-handler p) EOF) (define current-port-error-handler (make-parameter default-port-error-handler)) (define current-port-eof-handler (make-parameter default-port-eof-handler)) +(define (raise-port-error port) + ((current-port-error-handler) port) + (abort)) + (define s:port (make-structure '() 11)) (define (port? x) (kind-of? x s:port)) @@ -48,23 +52,23 @@ (define (port-read p [limit 1]) (let ([fn (port-read-procedure p)]) - (if fn (fn limit) ((current-port-error-handler))))) + (if fn (fn limit) (raise-port-error p)))) (define (port-unread p data) (let ([fn (port-unread-procedure p)]) - (if fn (fn data) ((current-port-error-handler))))) + (if fn (fn data) (raise-port-error p)))) (define (port-write p data) (let ([fn (port-write-procedure p)]) - (if fn (fn data) ((current-port-error-handler))))) + (if fn (fn data) (raise-port-error p)))) (define (port-seek p offset [whence 'absolute]) (let ([fn (port-seek-procedure p)]) - (if fn (fn offset whence) ((current-port-error-handler))))) + (if fn (fn offset whence) (raise-port-error p)))) (define (port-tell p) (let ([fn (port-tell-procedure p)]) - (if fn (fn) ((current-port-error-handler))))) + (if fn (fn) (raise-port-error p)))) (define (port-flush p) (let ([fn (port-flush-procedure p)]) @@ -80,7 +84,7 @@ (define (port-position p) (let ([fn (port-position-procedure p)]) - (if fn (fn) ((current-port-error-handler))))) + (if fn (fn) (raise-port-error p)))) (define (input-port? x) (and (port? x) (memq? 'input (port-flags x)))) (define (output-port? x) (and (port? x) (memq? 'output (port-flags x)))) @@ -92,23 +96,23 @@ (and (posix-port? p) (port-data p))) ; open() flags -(define O_RDONLY 00000000) -(define O_WRONLY 00000001) -(define O_RDWR 00000002) -(define O_CREAT 00000100) -(define O_EXCL 00000200) -(define O_NOCTTY 00000400) -(define O_TRUNC 00001000) -(define O_APPEND 00002000) -(define O_NONBLOCK 00004000) -(define O_DSYNC 00010000) -(define FASYNC 00020000) -(define O_DIRECT 00040000) -(define O_LARGEFILE 00100000) -(define O_DIRECTORY 00200000) -(define O_NOFOLLOW 00400000) -(define O_NOATIME 01000000) -(define O_CLOEXEC 02000000) +(define O_RDONLY #o0000000) +(define O_WRONLY #o0000001) +(define O_RDWR #o0000002) +(define O_CREAT #o0000100) +(define O_EXCL #o0000200) +(define O_NOCTTY #o0000400) +(define O_TRUNC #o0001000) +(define O_APPEND #o0002000) +(define O_NONBLOCK #o0004000) +(define O_DSYNC #o0010000) +(define FASYNC #o0020000) +(define O_DIRECT #o0040000) +(define O_LARGEFILE #o0100000) +(define O_DIRECTORY #o0200000) +(define O_NOFOLLOW #o0400000) +(define O_NOATIME #o1000000) +(define O_CLOEXEC #o2000000) ; whence enumeration for lseek() (define SEEK_SET 0) @@ -119,7 +123,8 @@ (let ([closed? #f] [unread-list '()] [line 1] - [column 0]) + [column 0] + port) (define (update-position str) (let ([size (byte-string-size str)]) (let iter ([i 0]) @@ -134,7 +139,7 @@ (define (posix-port-read limit) (cond [closed? - ((current-port-error-handler))] + (raise-port-error)] [(pair? unread-list) (let ([str (list->string (take limit unread-list))]) (set! unread-list (drop limit unread-list)) @@ -142,10 +147,10 @@ [else (let* ([buffer (make-byte-string limit 0)] [result (posix-read fd buffer limit)] - [str (cond [(fix= result limit) buffer] - [(fix> result 0) (byte-substring buffer 0 result)] + [str (cond [(not result) (raise-port-error)] [(fix= result 0) ((current-port-eof-handler))] - [else ((current-port-error-handler))])]) + [(fix= result limit) buffer] + [else (byte-substring buffer 0 result)])]) (update-position str) str)])) @@ -166,18 +171,19 @@ (define (posix-port-write str) (if closed? - ((current-port-error-handler)) + (raise-port-error) (let ([result (posix-write fd str)] [len (byte-string-size str)]) (cond - [(fix= result len) (update-position str)] - [(fix> result 0) (update-position (byte-substring str 0 result)) - (posix-port-write (byte-substring str result))] - [else ((current-port-error-handler))])))) + [(or (not result) + (fix= result 0)) (raise-port-error)] + [(fix= result len) (update-position str)] + [else (update-position (byte-substring str 0 result)) + (posix-port-write (byte-substring str result))])))) (define (posix-port-seek offset whence) (if closed? - ((current-port-error-handler)) + (raise-port-error) (let* ([whence-idx (cond [(eq? whence 'absolute) SEEK_SET] [(eq? whence 'relative) SEEK_CUR] [(eq? whence 'from-end) SEEK_END] @@ -186,20 +192,19 @@ (set! line 1 column 0) (set! line #f column #f)) (or (posix-lseek fd offset whence-idx) - ((current-port-error-handler)))))) + (raise-port-error))))) (define (posix-port-tell) (if closed? - ((current-port-error-handler)) + (raise-port-error) (or (posix-lseek fd 0 SEEK_CUR) - ((current-port-error-handler))))) + (raise-port-error)))) (define (posix-port-close) (unless closed? - (let ([result (posix-close fd)]) - (if (fix= result 0) - (set! closed? #t) - ((current-port-error-handler)))))) + (if (posix-close fd) + (set! closed? #t) + (raise-port-error)))) (define (posix-port-closed?) closed?) @@ -225,17 +230,17 @@ (define (open-posix-input-port path) (let ([fd (posix-open path O_RDONLY)]) - (if (fix< fd 0) - ((current-port-error-handler)) - (make-posix-port fd #t #t #f)))) + (if fd + (make-posix-port fd #t #t #f) + (raise-port-error)))) (define open-posix-output-port (let ([default-output-bits (foldl bit-or 0 (list O_WRONLY O_CREAT O_TRUNC))]) (lambda (path) - (let ([fd (posix-open path default-output-bits)]) - (if (fix< fd 0) - ((current-port-error-handler)) - (make-posix-port fd #t #f #t)))))) + (let ([fd (posix-open path default-output-bits #o666)]) + (if fd + (make-posix-port fd #t #f #t) + (raise-port-error)))))) (define posix-standard-input-port (make-posix-port 0 #f #t #f)) (define posix-standard-output-port (make-posix-port 1 #f #f #t)) diff --git a/src/lib/primitives.rls b/src/lib/primitives.rls index 1c9a40c..e961872 100644 --- a/src/lib/primitives.rls +++ b/src/lib/primitives.rls @@ -168,6 +168,10 @@ (define current-context (#%builtin "current-context")) (define call-with-context (#%builtin "call-with-context")) +(define exit (#%builtin "exit")) + +(define float->string (#%builtin "float->string")) + (define posix-open (#%builtin "posix-open")) ;(define posix-openat (#%builtin "posix-openat")) (define posix-dup (#%builtin "posix-dup")) diff --git a/src/lib/symbols.rls b/src/lib/symbols.rls index 544b4c0..a4a0ab7 100644 --- a/src/lib/symbols.rls +++ b/src/lib/symbols.rls @@ -1,5 +1,5 @@ -(define s:symbol (struct-type 'a)) -(define *symbols* (make-hash-table)) ; hash-value eq?)) +(define s:symbol (struct-type 's:symbol)) +(define *symbols* (make-hash-table)) (define (make-symbol name) (let ([sym (make-struct s:symbol)]) @@ -10,7 +10,7 @@ (and (struct? x) (eq? (struct-type x) s:symbol))) (define (symbol->string sym) - (struct-ref sym 0)) + (struct-ref (type-check s:symbol sym) 0)) (define (string->symbol name) (or (hash-table-lookup *symbols* name) diff --git a/src/lib/writer.rls b/src/lib/writer.rls index a191dfe..346fbd1 100644 --- a/src/lib/writer.rls +++ b/src/lib/writer.rls @@ -6,11 +6,11 @@ ;(load "lib/primitive/append.rls") ;(load "lib/util.rls") ;(load "lib/hash-table.rls") -;(load "lib/symbols.rls") -;(load "lib/keywords.rls") ;(load "lib/parameters.rls") ;(load "lib/abort.rls") ;(load "lib/errors.rls") +;(load "lib/symbols.rls") +;(load "lib/keywords.rls") ;(load "lib/port.rls") ;(load "lib/display.rls") @@ -24,16 +24,16 @@ (define (write-rla value [port (current-output-port)]) (call-with-parameters - (lambda () - (identify-backrefs value) - (write-rla-value value)) + (lambda () + (identify-backrefs value) + (write-rla-value value)) (list current-output-port port) - (list current-reference-table (make-hash-table hash-value eq?)) + (list current-reference-table (make-hash-table eq?)) (list next-reference-number 0))) (define (identify-backrefs value) (cond - [(or (boolean? value) (fixnum? value) (float? value) (builtin->string value)) void] + [(or (boolean? value) (fixnum? value) (float? value) (builtin->string value)) (values)] [else (let ([new? #t]) (hash-table-insert (current-reference-table) value #f @@ -72,7 +72,7 @@ [(eq? value #t) (write-string "#t")] [(eq? value '()) (write-string "()")] [(fixnum? value) (write-string (number->string value))] - [(float? value) (write-string "#")] + [(float? value) (write-string (float->string value))] [else (let ([builtin-name (builtin->string value)]) (if builtin-name (write-builtin builtin-name) @@ -107,7 +107,8 @@ (write-char #\=)) (define (write-rla-object obj) - (when (immutable? obj) (write-string "#@")) + (when (immutable? obj) + (write-string "#@")) (cond [(box? obj) (write-string "#&") (write-rla-value (unbox obj))] @@ -167,12 +168,13 @@ (define (write-rla-vector obj) (write-string "#(") (let ([size (vector-size obj)]) - (let iter ([n 0]) + (when (fix> size 0) + (write-rla-value (vector-ref obj 0)) + (let iter ([n 1]) (when (fix< n size) - (when (fix> n 0) - (write-char #\Space)) + (write-char #\Space) (write-rla-value (vector-ref obj n)) - (iter (fix+ n 1))))) + (iter (fix+ n 1)))))) (write-char #\))) ; vim:set syntax=scheme sw=2 expandtab: