Miscellaneous improvements to the self-hosting compiler.
This commit is contained in:
parent
4a98f4eb21
commit
b4be240d6f
187
src/compiler.rls
187
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,15 +32,19 @@
|
|||
(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
|
||||
[syntax-transformer-list
|
||||
(if parent-env
|
||||
(compilation-environment-syntax-transformers parent-env)
|
||||
'())])
|
||||
(let ([env (make-struct s:compilation-environment)])
|
||||
|
|
@ -47,20 +53,25 @@
|
|||
(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)))])
|
||||
(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))))))
|
||||
(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,7 +1072,9 @@
|
|||
unquote-splicing load absolute relative from-end
|
||||
input output binary buffered posix))
|
||||
|
||||
(call-with-abort-handler
|
||||
(call-with-parameters
|
||||
(lambda ()
|
||||
(call-with-abort-handler
|
||||
(lambda ()
|
||||
(let* ([module-form (if (pair? *argv*)
|
||||
(read-module-from-path (car *argv*))
|
||||
|
|
@ -1047,7 +1086,17 @@
|
|||
(write-char #\Newline)
|
||||
(iter (rest vals))))))
|
||||
(lambda (abort-values-fn)
|
||||
(write-string "Fatal error\b" (current-error-port))
|
||||
(values)))
|
||||
(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:
|
||||
|
|
|
|||
|
|
@ -16,6 +16,22 @@
|
|||
(write-char #\" port)
|
||||
(values))
|
||||
|
||||
(define (display-procedure proc port)
|
||||
(write-string "#<procedure" port)
|
||||
(let ([name (object->name proc)])
|
||||
(when name
|
||||
(write-char #\: port)
|
||||
(display name port)))
|
||||
(write-char #\> port))
|
||||
|
||||
(define (display-structure s port)
|
||||
(write-string "#<struct" port)
|
||||
(let ([name (object->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 "#<vector>" 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 "#<undefined>" port)]
|
||||
[(procedure? form) (write-string "#<procedure>" port)]
|
||||
[(struct? form) (write-string "#<struct>" port)]
|
||||
[(vector? form) (write-string "#<vector>" port)]
|
||||
[else (write-string "#<other>" port)])
|
||||
(values))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;; Halve buckets if entries/buckets < 3/4 and buckets >= 2*min_buckets
|
||||
;; Double buckets if entries/buckets >= 2
|
||||
(define (rehash-if-needed ht))
|
||||
(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)])
|
||||
(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)
|
||||
(set-cdr! (car bucket) (collision (cdar bucket)))]
|
||||
[(eq? (cdr bucket) '()) (insert-new-entry)]
|
||||
[else (search (cdr bucket))]))))
|
||||
(values))
|
||||
(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:
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[(or (not result)
|
||||
(fix= result 0)) (raise-port-error)]
|
||||
[(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))]))))
|
||||
[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)
|
||||
(if (posix-close fd)
|
||||
(set! closed? #t)
|
||||
((current-port-error-handler))))))
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
||||
|
|
@ -28,12 +28,12 @@
|
|||
(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>")]
|
||||
[(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:
|
||||
|
|
|
|||
Loading…
Reference in New Issue