From 448bbf679d3395acae6b7193f02d5799308f5c4a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 9 Jun 2015 17:06:19 +0900 Subject: [PATCH] change dictionary interface. use #undefined object as sentinel --- contrib/10.srfi/srfi/17.scm | 9 +- docs/libs.rst | 10 +- extlib/benz/boot.c | 288 ++++++++++++++++++------------------ extlib/benz/dict.c | 31 ++-- piclib/picrin/base.scm | 1 - piclib/picrin/macro.scm | 24 ++- 6 files changed, 172 insertions(+), 191 deletions(-) diff --git a/contrib/10.srfi/srfi/17.scm b/contrib/10.srfi/srfi/17.scm index fe1a85fe..0a7bdbad 100644 --- a/contrib/10.srfi/srfi/17.scm +++ b/contrib/10.srfi/srfi/17.scm @@ -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)))) diff --git a/docs/libs.rst b/docs/libs.rst index b67ea145..232dcdaa 100644 --- a/docs/libs.rst +++ b/docs/libs.rst @@ -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)** diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index a65f4c7b..59eb736b 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -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", "", "" }; diff --git a/extlib/benz/dict.c b/extlib/benz/dict.c index 8a3d0ce7..ca5d042d 100644 --- a/extlib/benz/dict.c +++ b/extlib/benz/dict.c @@ -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); diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index 2aa6a42b..c81744a2 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -178,7 +178,6 @@ dictionary dictionary-ref dictionary-set! - dictionary-delete! dictionary-size dictionary-map dictionary-for-each diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index e0942dd3..985b5d94 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -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)