conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

change dictionary interface. 

use #undefined object as sentinel
This commit is contained in:
Yuichi Nishiwaki 2015-06-09 17:06:19 +09:00
parent 2a1b7cf287
commit 448bbf679d
6 changed files with 172 additions and 191 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
contrib/10.srfi/srfi/17.scm
View File

@ -16,11 +16,10 @@
(define setter (define setter
(letrec ((setter (letrec ((setter
(lambda (proc) (lambda (proc)
(receive (setter exists) (dictionary-ref (attribute proc) (let ((setter (dictionary-ref (attribute proc) '@@setter)))
'@@setter) (if (undefined? setter)
(if exists (error "no setter found")
setter setter))))
(error "No setter found")))))
(set-setter! (set-setter!
(lambda (proc setter) (lambda (proc setter)
(dictionary-set! (attribute proc) '@@setter setter)))) (dictionary-set! (attribute proc) '@@setter setter))))

10
docs/libs.rst
View File

@ -101,9 +101,7 @@ Technically, picrin's array is implemented as a ring-buffer, effective double-en
(picrin dictionary) (picrin dictionary)
------------------- -------------------
Object-to-object table. Internally it is implemented on hash-table. Equivalence is tested with equal? procedure. Symbol-to-object hash table.
Note that dictionary is not a weak map; if you are going to make a highly memory-consuming program with dictionaries, you should know that dictionaries keep their bound objects and never let them free until you explicitly deletes bindings.
- **(make-dictionary)** - **(make-dictionary)**
@ -119,15 +117,13 @@ Note that dictionary is not a weak map; if you are going to make a highly memory
- **(dictionary-ref dict key)** - **(dictionary-ref dict key)**
Look up dictionary dict for a value associated with key. It returns two values: first is the associated value if exists, and second is a boolean of lookup result. Look up dictionary dict for a value associated with key. If dict has a slot for key `key`, the value stored in the slot is returned. Otherwise `#undefined` is returned.
- **(dictionary-set! dict key obj)** - **(dictionary-set! dict key obj)**
If there is no value already associated with key, this function newly creates a binding of key with obj. Otherwise, updates the existing binding with given obj. If there is no value already associated with key, this function newly creates a binding of key with obj. Otherwise, updates the existing binding with given obj.
- **(dictionary-delete dict key)** If obj is `#undefined`, this procedure behaves like a deleter: it will remove the key/value slot with the name `key` from the dictionary. When no slot is associated with `key`, it will do nothing.
Deletes the binding associated with key from dict. If no binding on dict is associated with key, an error will be raised.
- **(dictionary-size dict)** - **(dictionary-size dict)**

278
extlib/benz/boot.c
View File

@ -14,14 +14,13 @@ my $src = <<'EOL';
"memoize on symbols" "memoize on symbols"
(define cache (make-dictionary)) (define cache (make-dictionary))
(lambda (sym) (lambda (sym)
(call-with-values (lambda () (dictionary-ref cache sym)) (define value (dictionary-ref cache sym))
(lambda (value exists) (if (not (undefined? value))
(if exists
value value
(begin (begin
(define val (f sym)) (define val (f sym))
(dictionary-set! cache sym val) (dictionary-set! cache sym val)
val)))))) val))))
(define (er-macro-transformer f) (define (er-macro-transformer f)
(lambda (mac-env) (lambda (mac-env)
@ -395,147 +394,146 @@ EOL
const char pic_boot[][80] = { const char pic_boot[][80] = {
"\n(define-library (picrin base)\n\n (define (memoize f)\n \"memoize on symbols\"\n ", "\n(define-library (picrin base)\n\n (define (memoize f)\n \"memoize on symbols\"\n ",
" (define cache (make-dictionary))\n (lambda (sym)\n (call-with-values (l", " (define cache (make-dictionary))\n (lambda (sym)\n (define value (dicti",
"ambda () (dictionary-ref cache sym))\n (lambda (value exists)\n (i", "onary-ref cache sym))\n (if (not (undefined? value))\n value\n ",
"f exists\n value\n (begin\n (define val (f", " (begin\n (define val (f sym))\n (dictionary-set! cache sy",
" sym))\n (dictionary-set! cache sym val)\n val))))))", "m val)\n val))))\n\n (define (er-macro-transformer f)\n (lambda (mac-",
"\n\n (define (er-macro-transformer f)\n (lambda (mac-env)\n (lambda (expr u", "env)\n (lambda (expr use-env)\n\n (define rename\n (memoize\n ",
"se-env)\n\n (define rename\n (memoize\n (lambda (sym)\n ", " (lambda (sym)\n (make-identifier sym mac-env))))\n\n (de",
" (make-identifier sym mac-env))))\n\n (define (compare x y)\n ", "fine (compare x y)\n (if (not (symbol? x))\n #f\n ",
" (if (not (symbol? x))\n #f\n (if (not (symbol? y))\n ", " (if (not (symbol? y))\n #f\n (identifier=? use",
" #f\n (identifier=? use-env x use-env y))))\n\n ", "-env x use-env y))))\n\n (f expr rename compare))))\n\n (define-syntax synta",
" (f expr rename compare))))\n\n (define-syntax syntax-error\n (er-macro-tran", "x-error\n (er-macro-transformer\n (lambda (expr rename compare)\n (app",
"sformer\n (lambda (expr rename compare)\n (apply error (cdr expr)))))\n\n ", "ly error (cdr expr)))))\n\n (define-syntax define-auxiliary-syntax\n (er-macro-",
" (define-syntax define-auxiliary-syntax\n (er-macro-transformer\n (lambda (", "transformer\n (lambda (expr r c)\n (list (r 'define-syntax) (cadr expr)\n",
"expr r c)\n (list (r 'define-syntax) (cadr expr)\n (list (r 'lam", " (list (r 'lambda) '_\n (list (r 'lambda) '_\n ",
"bda) '_\n (list (r 'lambda) '_\n (list (", " (list (r 'error) (list (r 'string-append) \"invalid use of aux",
"r 'error) (list (r 'string-append) \"invalid use of auxiliary syntax: '\" (symbol-", "iliary syntax: '\" (symbol->string (cadr expr)) \"'\"))))))))\n\n (define-auxiliary-",
">string (cadr expr)) \"'\"))))))))\n\n (define-auxiliary-syntax else)\n (define-aux", "syntax else)\n (define-auxiliary-syntax =>)\n (define-auxiliary-syntax unquote)\n",
"iliary-syntax =>)\n (define-auxiliary-syntax unquote)\n (define-auxiliary-syntax", " (define-auxiliary-syntax unquote-splicing)\n\n (define-syntax let\n (er-macro",
" unquote-splicing)\n\n (define-syntax let\n (er-macro-transformer\n (lambda ", "-transformer\n (lambda (expr r compare)\n (if (symbol? (cadr expr))\n ",
"(expr r compare)\n (if (symbol? (cadr expr))\n (begin\n ", " (begin\n (define name (car (cdr expr)))\n (defi",
" (define name (car (cdr expr)))\n (define bindings (car (cdr (cdr", "ne bindings (car (cdr (cdr expr))))\n (define body (cdr (cdr (cdr",
" expr))))\n (define body (cdr (cdr (cdr expr))))\n (li", " expr))))\n (list (r 'let) '()\n (list (r 'define) n",
"st (r 'let) '()\n (list (r 'define) name\n ", "ame\n (cons (r 'lambda) (cons (map car bindings) body)))\n",
" (cons (r 'lambda) (cons (map car bindings) body)))\n (cons n", " (cons name (map cadr bindings))))\n (begin\n ",
"ame (map cadr bindings))))\n (begin\n (set! bindings (cadr e", " (set! bindings (cadr expr))\n (set! body (cddr expr))\n ",
"xpr))\n (set! body (cddr expr))\n (cons (cons (r 'lambda) ", " (cons (cons (r 'lambda) (cons (map car bindings) body))\n (ma",
"(cons (map car bindings) body))\n (map cadr bindings)))))))\n\n ", "p cadr bindings)))))))\n\n (define-syntax cond\n (er-macro-transformer\n (la",
"(define-syntax cond\n (er-macro-transformer\n (lambda (expr r compare)\n ", "mbda (expr r compare)\n (let ((clauses (cdr expr)))\n (if (null? cla",
" (let ((clauses (cdr expr)))\n (if (null? clauses)\n #f\n ", "uses)\n #f\n (begin\n (define clause (car cla",
" (begin\n (define clause (car clauses))\n (if ", "uses))\n (if (compare (r 'else) (car clause))\n (c",
"(compare (r 'else) (car clause))\n (cons (r 'begin) (cdr clause", "ons (r 'begin) (cdr clause))\n (if (if (>= (length clause) 2)\n ",
"))\n (if (if (>= (length clause) 2)\n ", " (compare (r '=>) (list-ref clause 1))\n ",
"(compare (r '=>) (list-ref clause 1))\n #f)\n ", " #f)\n (list (r 'let) (list (list (r 'x) (car cla",
" (list (r 'let) (list (list (r 'x) (car clause)))\n ", "use)))\n (list (r 'if) (r 'x)\n ",
" (list (r 'if) (r 'x)\n (list (list-re", " (list (list-ref clause 2) (r 'x))\n ",
"f clause 2) (r 'x))\n (cons (r 'cond) (cdr clau", " (cons (r 'cond) (cdr clauses))))\n (list (r 'if) (car clau",
"ses))))\n (list (r 'if) (car clause)\n ", "se)\n (cons (r 'begin) (cdr clause))\n ",
" (cons (r 'begin) (cdr clause))\n (cons (r 'con", " (cons (r 'cond) (cdr clauses)))))))))))\n\n (define-syntax and\n (",
"d) (cdr clauses)))))))))))\n\n (define-syntax and\n (er-macro-transformer\n ",
"(lambda (expr r compare)\n (let ((exprs (cdr expr)))\n (cond\n ",
" ((null? exprs)\n #t)\n ((= (length exprs) 1)\n (car",
" exprs))\n (else\n (list (r 'let) (list (list (r 'it) (car expr",
"s)))\n (list (r 'if) (r 'it)\n (cons (r 'and",
") (cdr exprs))\n (r 'it)))))))))\n\n (define-syntax or\n (",
"er-macro-transformer\n (lambda (expr r compare)\n (let ((exprs (cdr expr", "er-macro-transformer\n (lambda (expr r compare)\n (let ((exprs (cdr expr",
")))\n (cond\n ((null? exprs)\n #t)\n ((= (length", ")))\n (cond\n ((null? exprs)\n #t)\n ((= (length",
" exprs) 1)\n (car exprs))\n (else\n (list (r 'let) (li", " exprs) 1)\n (car exprs))\n (else\n (list (r 'let) (li",
"st (list (r 'it) (car exprs)))\n (list (r 'if) (r 'it)\n ", "st (list (r 'it) (car exprs)))\n (list (r 'if) (r 'it)\n ",
" (r 'it)\n (cons (r 'or) (cdr exprs))))))))))\n\n", " (cons (r 'and) (cdr exprs))\n (r 'it)))))))))\n",
" (define-syntax quasiquote\n (er-macro-transformer\n (lambda (form rename ", "\n (define-syntax or\n (er-macro-transformer\n (lambda (expr r compare)\n ",
"compare)\n\n (define (quasiquote? form)\n (and (pair? form) (compare ", " (let ((exprs (cdr expr)))\n (cond\n ((null? exprs)\n ",
"(car form) (rename 'quasiquote))))\n\n (define (unquote? form)\n (and", " #t)\n ((= (length exprs) 1)\n (car exprs))\n (else\n ",
" (pair? form) (compare (car form) (rename 'unquote))))\n\n (define (unquote-", " (list (r 'let) (list (list (r 'it) (car exprs)))\n (list ",
"splicing? form)\n (and (pair? form) (pair? (car form))\n (com", "(r 'if) (r 'it)\n (r 'it)\n (cons (r '",
"pare (car (car form)) (rename 'unquote-splicing))))\n\n (define (qq depth ex", "or) (cdr exprs))))))))))\n\n (define-syntax quasiquote\n (er-macro-transformer\n",
"pr)\n (cond\n ;; unquote\n ((unquote? expr)\n (i", " (lambda (form rename compare)\n\n (define (quasiquote? form)\n (",
"f (= depth 1)\n (car (cdr expr))\n (list (rename 'list", "and (pair? form) (compare (car form) (rename 'quasiquote))))\n\n (define (un",
")\n (list (rename 'quote) (rename 'unquote))\n ", "quote? form)\n (and (pair? form) (compare (car form) (rename 'unquote))))",
" (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ", "\n\n (define (unquote-splicing? form)\n (and (pair? form) (pair? (car",
" ((unquote-splicing? expr)\n (if (= depth 1)\n (list (ren", " form))\n (compare (car (car form)) (rename 'unquote-splicing))))\n\n ",
"ame 'append)\n (car (cdr (car expr)))\n (q", " (define (qq depth expr)\n (cond\n ;; unquote\n ((un",
"q depth (cdr expr)))\n (list (rename 'cons)\n (l", "quote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ",
"ist (rename 'list)\n (list (rename 'quote) (rename 'unq", " (list (rename 'list)\n (list (rename 'quote) (rename '",
"uote-splicing))\n (qq (- depth 1) (car (cdr (car expr))", "unquote))\n (qq (- depth 1) (car (cdr expr))))))\n ;;",
")))\n (qq depth (cdr expr)))))\n ;; quasiquote\n ", " unquote-splicing\n ((unquote-splicing? expr)\n (if (= depth 1)",
" ((quasiquote? expr)\n (list (rename 'list)\n (list (", "\n (list (rename 'append)\n (car (cdr (car expr)",
"rename 'quote) (rename 'quasiquote))\n (qq (+ depth 1) (car (cdr ", "))\n (qq depth (cdr expr)))\n (list (rename 'con",
"expr)))))\n ;; list\n ((pair? expr)\n (list (rename 'co", "s)\n (list (rename 'list)\n (list (r",
"ns)\n (qq depth (car expr))\n (qq depth (cdr expr)", "ename 'quote) (rename 'unquote-splicing))\n (qq (- dept",
")))\n ;; vector\n ((vector? expr)\n (list (rename 'list", "h 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ",
"->vector) (qq depth (vector->list expr))))\n ;; simple datum\n (", " ;; quasiquote\n ((quasiquote? expr)\n (list (rename 'list",
"else\n (list (rename 'quote) expr))))\n\n (let ((x (cadr form)))\n ", ")\n (list (rename 'quote) (rename 'quasiquote))\n ",
" (qq 1 x)))))\n\n (define-syntax let*\n (er-macro-transformer\n (lambd", "(qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n ",
"a (form r compare)\n (let ((bindings (cadr form))\n (body (cddr ", " (list (rename 'cons)\n (qq depth (car expr))\n ",
"form)))\n (if (null? bindings)\n `(,(r 'let) () ,@body)\n ", " (qq depth (cdr expr))))\n ;; vector\n ((vector? expr)\n ",
" `(,(r 'let) ((,(caar bindings)\n ,@(cdar binding", " (list (rename 'list->vector) (qq depth (vector->list expr))))\n ;",
"s)))\n (,(r 'let*) (,@(cdr bindings))\n ,@body)))))))", "; simple datum\n (else\n (list (rename 'quote) expr))))\n\n ",
"\n\n (define-syntax letrec*\n (er-macro-transformer\n (lambda (form r compar", " (let ((x (cadr form)))\n (qq 1 x)))))\n\n (define-syntax let*\n (er-mac",
"e)\n (let ((bindings (cadr form))\n (body (cddr form)))\n ", "ro-transformer\n (lambda (form r compare)\n (let ((bindings (cadr form))",
" (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))\n (ini", "\n (body (cddr form)))\n (if (null? bindings)\n `(,",
"tials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))\n `(,(r 'let) (,@", "(r 'let) () ,@body)\n `(,(r 'let) ((,(caar bindings)\n ",
"vars)\n ,@initials\n ,@body))))))\n\n (define-syntax letrec", " ,@(cdar bindings)))\n (,(r 'let*) (,@(cdr bindings))\n ",
"\n (er-macro-transformer\n (lambda (form rename compare)\n `(,(rename ", " ,@body)))))))\n\n (define-syntax letrec*\n (er-macro-transformer\n ",
"'letrec*) ,@(cdr form)))))\n\n (define-syntax let*-values\n (er-macro-transform", " (lambda (form r compare)\n (let ((bindings (cadr form))\n (b",
"er\n (lambda (form r c)\n (let ((formals (cadr form)))\n (if (nul", "ody (cddr form)))\n (let ((vars (map (lambda (v) `(,v #f)) (map car bindi",
"l? formals)\n `(,(r 'let) () ,@(cddr form))\n `(,(r 'call-", "ngs)))\n (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))\n",
"with-values) (,(r 'lambda) () ,@(cdar formals))\n (,(r 'lambda) (,@", " `(,(r 'let) (,@vars)\n ,@initials\n ,@body)))))",
"(caar formals))\n (,(r 'let*-values) (,@(cdr formals))\n ", ")\n\n (define-syntax letrec\n (er-macro-transformer\n (lambda (form rename c",
" ,@(cddr form)))))))))\n\n (define-syntax let-values\n (er-macro-transform", "ompare)\n `(,(rename 'letrec*) ,@(cdr form)))))\n\n (define-syntax let*-valu",
"er\n (lambda (form r c)\n `(,(r 'let*-values) ,@(cdr form)))))\n\n (defin", "es\n (er-macro-transformer\n (lambda (form r c)\n (let ((formals (cadr",
"e-syntax define-values\n (er-macro-transformer\n (lambda (form r compare)\n ", " form)))\n (if (null? formals)\n `(,(r 'let) () ,@(cddr form))",
" (let ((formal (cadr form))\n (exprs (cddr form)))\n `(,", "\n `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))\n ",
"(r 'begin)\n ,@(let loop ((formal formal))\n (if (not (p", " (,(r 'lambda) (,@(caar formals))\n (,(r 'let*-values) (,@",
"air? formal))\n (if (symbol? formal)\n `", "(cdr formals))\n ,@(cddr form)))))))))\n\n (define-syntax let-valu",
"((,(r 'define) ,formal #f))\n '())\n `((", "es\n (er-macro-transformer\n (lambda (form r c)\n `(,(r 'let*-values) ",
",(r 'define) ,(car formal) #f) . ,(loop (cdr formal)))))\n (,(r 'call-", ",@(cdr form)))))\n\n (define-syntax define-values\n (er-macro-transformer\n ",
"with-values) (,(r 'lambda) () ,@exprs)\n (,(r 'lambda) ,(r 'args)\n ", "(lambda (form r compare)\n (let ((formal (cadr form))\n (exprs ",
" ,@(let loop ((formal formal) (args (r 'args)))\n ", "(cddr form)))\n `(,(r 'begin)\n ,@(let loop ((formal formal))\n ",
" (if (not (pair? formal))\n (if (symbol? formal)\n ", " (if (not (pair? formal))\n (if (symbol? formal)",
" `((,(r 'set!) ,formal ,args))\n '()", "\n `((,(r 'define) ,formal #f))\n '(",
")\n `((,(r 'set!) ,(car formal) (,(r 'car) ,args))\n ", "))\n `((,(r 'define) ,(car formal) #f) . ,(loop (cdr formal)))",
" ,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))\n\n (define", "))\n (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)\n (",
"-syntax do\n (er-macro-transformer\n (lambda (form r compare)\n (let (", ",(r 'lambda) ,(r 'args)\n ,@(let loop ((formal formal) (args (r 'a",
"(bindings (car (cdr form)))\n (finish (car (cdr (cdr form))))\n ", "rgs)))\n (if (not (pair? formal))\n (if ",
" (body (cdr (cdr (cdr form)))))\n `(,(r 'let) ,(r 'loop) ,(map", "(symbol? formal)\n `((,(r 'set!) ,formal ,args))\n ",
" (lambda (x)\n (list (car x) (cadr x)))\n ", " '())\n `((,(r 'set!) ,(car formal) ",
" bindings)\n (,(r 'if) ,(car finish)", "(,(r 'car) ,args))\n ,@(loop (cdr formal) `(,(r 'cdr) ,a",
"\n (,(r 'begin) ,@(cdr finish))\n (,(r 'begin) ,@body\n ", "rgs))))))))))))\n\n (define-syntax do\n (er-macro-transformer\n (lambda (for",
" (,(r 'loop) ,@(map (lambda (x)\n (if (nul", "m r compare)\n (let ((bindings (car (cdr form)))\n (finish (ca",
"l? (cddr x))\n (car x)\n ", "r (cdr (cdr form))))\n (body (cdr (cdr (cdr form)))))\n `(",
" (car (cddr x))))\n bindings))))))", ",(r 'let) ,(r 'loop) ,(map (lambda (x)\n (",
")))\n\n (define-syntax when\n (er-macro-transformer\n (lambda (expr rename c", "list (car x) (cadr x)))\n bindings)\n ",
"ompare)\n (let ((test (cadr expr))\n (body (cddr expr)))\n ", " (,(r 'if) ,(car finish)\n (,(r 'begin) ,@(cdr finish))\n ",
" `(,(rename 'if) ,test\n (,(rename 'begin) ,@body)\n #f", "(,(r 'begin) ,@body\n (,(r 'loop) ,@(map (lambda (x)\n ",
")))))\n\n (define-syntax unless\n (er-macro-transformer\n (lambda (expr rena", " (if (null? (cddr x))\n (ca",
"me compare)\n (let ((test (cadr expr))\n (body (cddr expr)))\n ", "r x)\n (car (cddr x))))\n ",
" `(,(rename 'if) ,test\n #f\n (,(rename 'begin) ,@b", " bindings)))))))))\n\n (define-syntax when\n (er-macro-transformer\n ",
"ody))))))\n\n (define-syntax case\n (er-macro-transformer\n (lambda (expr r ", " (lambda (expr rename compare)\n (let ((test (cadr expr))\n (",
"compare)\n (let ((key (cadr expr))\n (clauses (cddr expr)))\n ", "body (cddr expr)))\n `(,(rename 'if) ,test\n (,(rename 'begin",
" `(,(r 'let) ((,(r 'key) ,key))\n ,(let loop ((clauses clauses))\n ", ") ,@body)\n #f)))))\n\n (define-syntax unless\n (er-macro-transform",
" (if (null? clauses)\n #f\n (begi", "er\n (lambda (expr rename compare)\n (let ((test (cadr expr))\n ",
"n\n (define clause (car clauses))\n `(,(r ", " (body (cddr expr)))\n `(,(rename 'if) ,test\n #f\n ",
"'if) ,(if (compare (r 'else) (car clause))\n ", " (,(rename 'begin) ,@body))))))\n\n (define-syntax case\n (er-macro-transfo",
"rmer\n (lambda (expr r compare)\n (let ((key (cadr expr))\n (",
"clauses (cddr expr)))\n `(,(r 'let) ((,(r 'key) ,key))\n ,(let ",
"loop ((clauses clauses))\n (if (null? clauses)\n #",
"f\n (begin\n (define clause (car clauses))\n ",
" `(,(r 'if) ,(if (compare (r 'else) (car clause))\n ",
" '#t\n `(,(r 'or)\n ", " '#t\n `(,(r 'or)\n ",
" ,@(map (lambda (x)\n `(", " ,@(map (lambda (x)\n ",
",(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))\n ", " `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))\n ",
" (car clause))))\n ,(if (compare (r '=>) (list-ref cla", " (car clause))))\n ,(if (com",
"use 1))\n `(,(list-ref clause 2) ,(r 'key))\n ", "pare (r '=>) (list-ref clause 1))\n `(,(list-ref claus",
" `(,(r 'begin) ,@(cdr clause)))\n ,(loop (", "e 2) ,(r 'key))\n `(,(r 'begin) ,@(cdr clause)))\n ",
"cdr clauses)))))))))))\n\n (define-syntax parameterize\n (er-macro-transformer\n", " ,(loop (cdr clauses)))))))))))\n\n (define-syntax parameterize\n",
" (lambda (form r compare)\n (let ((formal (cadr form))\n (bo", " (er-macro-transformer\n (lambda (form r compare)\n (let ((formal (ca",
"dy (cddr form)))\n `(,(r 'with-parameter)\n (lambda ()\n ", "dr form))\n (body (cddr form)))\n `(,(r 'with-parameter)\n ",
" ,@formal\n ,@body))))))\n\n (define-syntax letrec-syntax\n (er-m", " (lambda ()\n ,@formal\n ,@body))))))\n\n (define-synt",
"acro-transformer\n (lambda (form r c)\n (let ((formal (car (cdr form)))\n", "ax letrec-syntax\n (er-macro-transformer\n (lambda (form r c)\n (let (",
" (body (cdr (cdr form))))\n `(let ()\n ,@(map (la", "(formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(let",
"mbda (x)\n `(,(r 'define-syntax) ,(car x) ,(cadr x)))\n ", " ()\n ,@(map (lambda (x)\n `(,(r 'define-syntax) ,(",
" formal)\n ,@body)))))\n\n (define-syntax let-syntax\n (er", "car x) ,(cadr x)))\n formal)\n ,@body)))))\n\n (define",
"-macro-transformer\n (lambda (form r c)\n `(,(r 'letrec-syntax) ,@(cdr f", "-syntax let-syntax\n (er-macro-transformer\n (lambda (form r c)\n `(,(",
"orm)))))\n\n (export let let* letrec letrec*\n let-values let*-values def", "r 'letrec-syntax) ,@(cdr form)))))\n\n (export let let* letrec letrec*\n ",
"ine-values\n quasiquote unquote unquote-splicing\n and or\n ", "let-values let*-values define-values\n quasiquote unquote unquote-splici",
" cond case else =>\n do when unless\n parameterize\n ", "ng\n and or\n cond case else =>\n do when unless\n ",
"let-syntax letrec-syntax\n syntax-error))\n\n", " parameterize\n let-syntax letrec-syntax\n syntax-error))\n\n",
"", "",
"" ""
}; };

29
extlib/benz/dict.c
View File

@ -104,11 +104,10 @@ pic_dict_dictionary_ref(pic_state *pic)
pic_get_args(pic, "dm", &dict, &key); pic_get_args(pic, "dm", &dict, &key);
if (pic_dict_has(pic, dict, key)) { if (! pic_dict_has(pic, dict, key)) {
return pic_values2(pic, pic_dict_ref(pic, dict, key), pic_true_value()); return pic_undef_value();
} else {
return pic_values2(pic, pic_undef_value(), pic_false_value());
} }
return pic_dict_ref(pic, dict, key);
} }
static pic_value static pic_value
@ -120,21 +119,14 @@ pic_dict_dictionary_set(pic_state *pic)
pic_get_args(pic, "dmo", &dict, &key, &val); pic_get_args(pic, "dmo", &dict, &key, &val);
pic_dict_set(pic, dict, key, val); if (pic_undef_p(val)) {
if (pic_dict_has(pic, dict, key)) {
return pic_undef_value();
}
static pic_value
pic_dict_dictionary_del(pic_state *pic)
{
struct pic_dict *dict;
pic_sym *key;
pic_get_args(pic, "dm", &dict, &key);
pic_dict_del(pic, dict, key); pic_dict_del(pic, dict, key);
}
}
else {
pic_dict_set(pic, dict, key, val);
}
return pic_undef_value(); return pic_undef_value();
} }
@ -319,7 +311,6 @@ pic_init_dict(pic_state *pic)
pic_defun(pic, "dictionary", pic_dict_dictionary); pic_defun(pic, "dictionary", pic_dict_dictionary);
pic_defun(pic, "dictionary-ref", pic_dict_dictionary_ref); pic_defun(pic, "dictionary-ref", pic_dict_dictionary_ref);
pic_defun(pic, "dictionary-set!", pic_dict_dictionary_set); pic_defun(pic, "dictionary-set!", pic_dict_dictionary_set);
pic_defun(pic, "dictionary-delete!", pic_dict_dictionary_del);
pic_defun(pic, "dictionary-size", pic_dict_dictionary_size); pic_defun(pic, "dictionary-size", pic_dict_dictionary_size);
pic_defun(pic, "dictionary-map", pic_dict_dictionary_map); pic_defun(pic, "dictionary-map", pic_dict_dictionary_map);
pic_defun(pic, "dictionary-for-each", pic_dict_dictionary_for_each); pic_defun(pic, "dictionary-for-each", pic_dict_dictionary_for_each);

1
piclib/picrin/base.scm
View File

@ -178,7 +178,6 @@
dictionary dictionary
dictionary-ref dictionary-ref
dictionary-set! dictionary-set!
dictionary-delete!
dictionary-size dictionary-size
dictionary-map dictionary-map
dictionary-for-each dictionary-for-each

16
piclib/picrin/macro.scm
View File

@ -20,14 +20,13 @@
"memoize on symbols" "memoize on symbols"
(define cache (make-dictionary)) (define cache (make-dictionary))
(lambda (sym) (lambda (sym)
(call-with-values (lambda () (dictionary-ref cache sym)) (define value (dictionary-ref cache sym))
(lambda (value exists) (if (not (undefined? value))
(if exists
value value
(begin (begin
(define val (f sym)) (define val (f sym))
(dictionary-set! cache sym val) (dictionary-set! cache sym val)
val)))))) val))))
(define (make-syntactic-closure env free form) (define (make-syntactic-closure env free form)
@ -105,11 +104,10 @@
(identifier=? mac-env x mac-env y)))) (identifier=? mac-env x mac-env y))))
(walk (lambda (sym) (walk (lambda (sym)
(call-with-values (lambda () (dictionary-ref icache* sym)) (let ((value (dictionary-ref icache* sym)))
(lambda (value exists) (if (undefined? value)
(if exists (rename sym)
value value)))
(rename sym)))))
(f (walk inject expr) inject compare))))) (f (walk inject expr) inject compare)))))
;; (define (strip-syntax form) ;; (define (strip-syntax form)