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
(letrec ((setter
(lambda (proc)
(receive (setter exists) (dictionary-ref (attribute proc)
'@@setter)
(if exists
setter
(error "No setter found")))))
(let ((setter (dictionary-ref (attribute proc) '@@setter)))
(if (undefined? setter)
(error "no setter found")
setter))))
(set-setter!
(lambda (proc 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)
-------------------
Object-to-object table. Internally it is implemented on hash-table. Equivalence is tested with equal? procedure.
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.
Symbol-to-object hash table.
- **(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)**
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)**
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)**
Deletes the binding associated with key from dict. If no binding on dict is associated with key, an error will be raised.
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.
- **(dictionary-size dict)**

288
extlib/benz/boot.c
View File

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

31
extlib/benz/dict.c
View File

@ -104,11 +104,10 @@ pic_dict_dictionary_ref(pic_state *pic)
pic_get_args(pic, "dm", &dict, &key);
if (pic_dict_has(pic, dict, key)) {
return pic_values2(pic, pic_dict_ref(pic, dict, key), pic_true_value());
} else {
return pic_values2(pic, pic_undef_value(), pic_false_value());
if (! pic_dict_has(pic, dict, key)) {
return pic_undef_value();
}
return pic_dict_ref(pic, dict, key);
}
static pic_value
@ -120,21 +119,14 @@ pic_dict_dictionary_set(pic_state *pic)
pic_get_args(pic, "dmo", &dict, &key, &val);
pic_dict_set(pic, dict, key, val);
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);
if (pic_undef_p(val)) {
if (pic_dict_has(pic, dict, key)) {
pic_dict_del(pic, dict, key);
}
}
else {
pic_dict_set(pic, dict, key, val);
}
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-ref", pic_dict_dictionary_ref);
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-map", pic_dict_dictionary_map);
pic_defun(pic, "dictionary-for-each", pic_dict_dictionary_for_each);

1
piclib/picrin/base.scm
View File

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

24
piclib/picrin/macro.scm
View File

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