register now returns #f or a pair
This commit is contained in:
Yuichi Nishiwaki
parent
238f5999bc
commit
3739387160
|
|
@ -44,11 +44,11 @@
|
|||
((wrap (let ((register (make-register)))
|
||||
(lambda (var)
|
||||
(let ((id (register var)))
|
||||
(if (undefined? id)
|
||||
(if id
|
||||
(cdr id)
|
||||
(let ((id (make-identifier var env)))
|
||||
(register var id)
|
||||
id)
|
||||
id)))))
|
||||
id))))))
|
||||
(walk (lambda (f form)
|
||||
(cond
|
||||
((variable? form)
|
||||
|
|
@ -106,11 +106,11 @@
|
|||
((rename (let ((register (make-register)))
|
||||
(lambda (var)
|
||||
(let ((id (register var)))
|
||||
(if (undefined? id)
|
||||
(if id
|
||||
(cdr id)
|
||||
(let ((id (make-identifier var mac-env)))
|
||||
(register var id)
|
||||
id)
|
||||
id)))))
|
||||
id))))))
|
||||
(compare (lambda (x y)
|
||||
(variable=?
|
||||
(make-identifier x use-env)
|
||||
|
|
@ -124,25 +124,25 @@
|
|||
(letrec
|
||||
((inject (lambda (var1)
|
||||
(let ((var2 (register1 var1)))
|
||||
(if (undefined? var2)
|
||||
(if var2
|
||||
(cdr var2)
|
||||
(let ((var2 (make-identifier var1 use-env)))
|
||||
(register1 var1 var2)
|
||||
(register2 var2 var1)
|
||||
var2)
|
||||
var2))))
|
||||
var2)))))
|
||||
(rename (let ((register (make-register)))
|
||||
(lambda (var)
|
||||
(let ((id (register var)))
|
||||
(if (undefined? id)
|
||||
(if id
|
||||
(cdr id)
|
||||
(let ((id (make-identifier var mac-env)))
|
||||
(register var id)
|
||||
id)
|
||||
id)))))
|
||||
id))))))
|
||||
(flip (lambda (var2) ; unwrap if injected, wrap if not injected
|
||||
(let ((var1 (register2 var2)))
|
||||
(if (undefined? var1)
|
||||
(rename var2)
|
||||
var1))))
|
||||
(if var1
|
||||
(cdr var1)
|
||||
(rename var2)))))
|
||||
(walk (lambda (f form)
|
||||
(cond
|
||||
((variable? form)
|
||||
|
|
|
|||
|
|
@ -350,11 +350,12 @@
|
|||
(letrec
|
||||
((#,'rename (let ((reg (make-register)))
|
||||
(lambda (x)
|
||||
(if (undefined? (reg x))
|
||||
(let ((id (make-identifier x env)))
|
||||
(reg x id)
|
||||
id)
|
||||
(reg x))))))
|
||||
(let ((y (reg x)))
|
||||
(if y
|
||||
(cdr y)
|
||||
(let ((id (make-identifier x env)))
|
||||
(reg x id)
|
||||
id)))))))
|
||||
(lambda #,'it
|
||||
#,(compile-rules rules))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -489,17 +489,17 @@ my $src = <<'EOL';
|
|||
(letrec
|
||||
((wrap (lambda (var1)
|
||||
(let ((var2 (register1 var1)))
|
||||
(if (undefined? var2)
|
||||
(if var2
|
||||
(cdr var2)
|
||||
(let ((var2 (make-identifier var1 env)))
|
||||
(register1 var1 var2)
|
||||
(register2 var2 var1)
|
||||
var2)
|
||||
var2))))
|
||||
var2)))))
|
||||
(unwrap (lambda (var2)
|
||||
(let ((var1 (register2 var2)))
|
||||
(if (undefined? var1)
|
||||
var2
|
||||
var1))))
|
||||
(if var1
|
||||
(cdr var1)
|
||||
var2))))
|
||||
(walk (lambda (f form)
|
||||
(cond
|
||||
((variable? form)
|
||||
|
|
@ -923,85 +923,85 @@ const char pic_boot[][80] = {
|
|||
"ap cdr renames)\n ,body))))))\n\n(define (transformer f)\n (lambda (form",
|
||||
" env)\n (let ((register1 (make-register))\n (register2 (make-register)",
|
||||
"))\n (letrec\n ((wrap (lambda (var1)\n (let ((var2 ",
|
||||
"(register1 var1)))\n (if (undefined? var2)\n ",
|
||||
" (let ((var2 (make-identifier var1 env)))\n (regi",
|
||||
"ster1 var1 var2)\n (register2 var2 var1)\n ",
|
||||
" var2)\n var2))))\n (unwrap (lambda ",
|
||||
"(var2)\n (let ((var1 (register2 var2)))\n ",
|
||||
" (if (undefined? var1)\n var2\n ",
|
||||
" var1))))\n (walk (lambda (f form)\n (cond\n ",
|
||||
" ((variable? form)\n (f form))\n ",
|
||||
"((pair? form)\n (cons (walk f (car form)) (walk f (cdr form))",
|
||||
"))\n ((vector? form)\n (list->vector (walk ",
|
||||
"f (vector->list form))))\n (else\n form))))",
|
||||
")\n (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap fo",
|
||||
"rm))))))))\n\n(define-macro define-syntax\n (lambda (form env)\n (let ((formal (",
|
||||
"car (cdr form)))\n (body (cdr (cdr form))))\n (if (pair? formal)\n ",
|
||||
" `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body",
|
||||
"))\n `(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body",
|
||||
")))))))\n\n(define-macro letrec-syntax\n (lambda (form env)\n (let ((formal (car",
|
||||
" (cdr form)))\n (body (cdr (cdr form))))\n `(let ()\n ,@(ma",
|
||||
"p (lambda (x)\n `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n ",
|
||||
" formal)\n ,@body))))\n\n(define-macro let-syntax\n (lambda (fo",
|
||||
"rm env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(d",
|
||||
"efine-macro define-library\n (lambda (form _)\n (let ((name (cadr form))\n ",
|
||||
" (body (cddr form)))\n (let ((old-library (current-library))\n ",
|
||||
" (new-library (or (find-library name) (make-library name))))\n (let ((env ",
|
||||
"(library-environment new-library)))\n (current-library new-library)\n ",
|
||||
" (for-each (lambda (expr) (eval expr env)) body)\n (current-library",
|
||||
" old-library))))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ",
|
||||
" ((test (lambda (form)\n (or\n (eq? form 'els",
|
||||
"e)\n (and (symbol? form)\n (memq form (feat",
|
||||
"ures)))\n (and (pair? form)\n (case (car fo",
|
||||
"rm)\n ((library) (find-library (cadr form)))\n ",
|
||||
" ((not) (not (test (cadr form))))\n ((and) (l",
|
||||
"et loop ((form (cdr form)))\n (or (null? form)\n ",
|
||||
" (and (test (car form)) (loop (cdr form)))))",
|
||||
")\n ((or) (let loop ((form (cdr form)))\n ",
|
||||
" (and (pair? form)\n (or (tes",
|
||||
"t (car form)) (loop (cdr form))))))\n (else #f)))))))\n ",
|
||||
" (let loop ((clauses (cdr form)))\n (if (null? clauses)\n #und",
|
||||
"efined\n (if (test (caar clauses))\n `(,the-begin ,@(cda",
|
||||
"r clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import\n (",
|
||||
"lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n ",
|
||||
" (prefix\n (lambda (prefix symbol)\n (string->symbol\n",
|
||||
" (string-append\n (symbol->string prefix)\n ",
|
||||
" (symbol->string symbol))))))\n (letrec\n ((extract\n (l",
|
||||
"ambda (spec)\n (case (car spec)\n ((only rename prefix",
|
||||
" except)\n (extract (cadr spec)))\n (else\n ",
|
||||
" (or (find-library spec) (error \"library not found\" spec))))))\n ",
|
||||
" (collect\n (lambda (spec)\n (case (car spec)\n ",
|
||||
" ((only)\n (let ((alist (collect (cadr spec))))\n ",
|
||||
" (map (lambda (var) (assq var alist)) (cddr spec))))\n ((renam",
|
||||
"e)\n (let ((alist (collect (cadr spec)))\n (",
|
||||
"renames (map (lambda (x) `((car x) . (cadr x))) (cddr spec))))\n ",
|
||||
" (map (lambda (s) (or (assq (car s) renames) s)) alist)))\n ((pre",
|
||||
"fix)\n (let ((alist (collect (cadr spec))))\n (m",
|
||||
"ap (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ",
|
||||
" ((except)\n (let ((alist (collect (cadr spec))))\n ",
|
||||
" (let loop ((alist alist))\n (if (null? alist)\n ",
|
||||
" '()\n (if (memq (caar alist) (cddr spe",
|
||||
"c))\n (loop (cdr alist))\n ",
|
||||
" (cons (car alist) (loop (cdr alist))))))))\n (else\n ",
|
||||
" (let ((lib (or (find-library spec) (error \"library not found\" spec))))\n ",
|
||||
" (map (lambda (x) (cons x x)) (library-exports lib))))))))\n (",
|
||||
"letrec\n ((import\n (lambda (spec)\n (let ",
|
||||
"((lib (extract spec))\n (alist (collect spec)))\n ",
|
||||
" (for-each\n (lambda (slot)\n (libr",
|
||||
"ary-import lib (cdr slot) (car slot)))\n alist)))))\n ",
|
||||
"(for-each import (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (",
|
||||
"letrec\n ((collect\n (lambda (spec)\n (cond\n ",
|
||||
" ((symbol? spec)\n `(,spec . ,spec))\n ((and (list? spec)",
|
||||
" (= (length spec) 3) (eq? (car spec) 'rename))\n `(,(list-ref spec 1",
|
||||
") . ,(list-ref spec 2)))\n (else\n (error \"malformed expo",
|
||||
"rt\")))))\n (export\n (lambda (spec)\n (let ((slot (co",
|
||||
"llect spec)))\n (library-export (car slot) (cdr slot))))))\n (f",
|
||||
"or-each export (cdr form)))))\n\n(export define lambda quote set! if begin define-",
|
||||
"macro\n let let* letrec letrec*\n let-values let*-values define-valu",
|
||||
"es\n quasiquote unquote unquote-splicing\n and or\n cond case ",
|
||||
"else =>\n do when unless\n parameterize\n define-syntax\n ",
|
||||
" syntax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n",
|
||||
" let-syntax letrec-syntax\n syntax-error)\n\n\n",
|
||||
"(register1 var1)))\n (if var2\n (cdr v",
|
||||
"ar2)\n (let ((var2 (make-identifier var1 env)))\n ",
|
||||
" (register1 var1 var2)\n (register2 va",
|
||||
"r2 var1)\n var2)))))\n (unwrap (lambda (var2)\n",
|
||||
" (let ((var1 (register2 var2)))\n (if v",
|
||||
"ar1\n (cdr var1)\n var2))))\n ",
|
||||
" (walk (lambda (f form)\n (cond\n ((v",
|
||||
"ariable? form)\n (f form))\n ((pair? form)\n",
|
||||
" (cons (walk f (car form)) (walk f (cdr form))))\n ",
|
||||
" ((vector? form)\n (list->vector (walk f (vector->lis",
|
||||
"t form))))\n (else\n form)))))\n (let",
|
||||
" ((form (cdr form)))\n (walk unwrap (apply f (walk wrap form))))))))\n\n(d",
|
||||
"efine-macro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)",
|
||||
"))\n (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(t",
|
||||
"he 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `",
|
||||
"(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(defi",
|
||||
"ne-macro letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n",
|
||||
" (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n",
|
||||
" `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n f",
|
||||
"ormal)\n ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(",
|
||||
",(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro de",
|
||||
"fine-library\n (lambda (form _)\n (let ((name (cadr form))\n (body (cd",
|
||||
"dr form)))\n (let ((old-library (current-library))\n (new-library ",
|
||||
"(or (find-library name) (make-library name))))\n (let ((env (library-envir",
|
||||
"onment new-library)))\n (current-library new-library)\n (for-eac",
|
||||
"h (lambda (expr) (eval expr env)) body)\n (current-library old-library))",
|
||||
"))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ((test (l",
|
||||
"ambda (form)\n (or\n (eq? form 'else)\n ",
|
||||
" (and (symbol? form)\n (memq form (features)))\n ",
|
||||
" (and (pair? form)\n (case (car form)\n ",
|
||||
" ((library) (find-library (cadr form)))\n (",
|
||||
"(not) (not (test (cadr form))))\n ((and) (let loop ((form",
|
||||
" (cdr form)))\n (or (null? form)\n ",
|
||||
" (and (test (car form)) (loop (cdr form))))))\n ",
|
||||
" ((or) (let loop ((form (cdr form)))\n ",
|
||||
" (and (pair? form)\n (or (test (car form)) ",
|
||||
"(loop (cdr form))))))\n (else #f)))))))\n (let loop (",
|
||||
"(clauses (cdr form)))\n (if (null? clauses)\n #undefined\n ",
|
||||
" (if (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ",
|
||||
" (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _",
|
||||
")\n (let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefi",
|
||||
"x\n (lambda (prefix symbol)\n (string->symbol\n ",
|
||||
"(string-append\n (symbol->string prefix)\n (symbol->st",
|
||||
"ring symbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ",
|
||||
" (case (car spec)\n ((only rename prefix except)\n ",
|
||||
" (extract (cadr spec)))\n (else\n (or (f",
|
||||
"ind-library spec) (error \"library not found\" spec))))))\n (collect\n ",
|
||||
" (lambda (spec)\n (case (car spec)\n ((only)\n ",
|
||||
" (let ((alist (collect (cadr spec))))\n (map (lam",
|
||||
"bda (var) (assq var alist)) (cddr spec))))\n ((rename)\n ",
|
||||
" (let ((alist (collect (cadr spec)))\n (renames (map (",
|
||||
"lambda (x) `((car x) . (cadr x))) (cddr spec))))\n (map (lambda",
|
||||
" (s) (or (assq (car s) renames) s)) alist)))\n ((prefix)\n ",
|
||||
" (let ((alist (collect (cadr spec))))\n (map (lambda (s)",
|
||||
" (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ((except",
|
||||
")\n (let ((alist (collect (cadr spec))))\n (let ",
|
||||
"loop ((alist alist))\n (if (null? alist)\n ",
|
||||
" '()\n (if (memq (caar alist) (cddr spec))\n ",
|
||||
" (loop (cdr alist))\n (cons (car al",
|
||||
"ist) (loop (cdr alist))))))))\n (else\n (let ((lib ",
|
||||
"(or (find-library spec) (error \"library not found\" spec))))\n (",
|
||||
"map (lambda (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ",
|
||||
" ((import\n (lambda (spec)\n (let ((lib (extract",
|
||||
" spec))\n (alist (collect spec)))\n (for-e",
|
||||
"ach\n (lambda (slot)\n (library-import lib",
|
||||
" (cdr slot) (car slot)))\n alist)))))\n (for-each impo",
|
||||
"rt (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ",
|
||||
" ((collect\n (lambda (spec)\n (cond\n ((symbol? spe",
|
||||
"c)\n `(,spec . ,spec))\n ((and (list? spec) (= (length sp",
|
||||
"ec) 3) (eq? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref",
|
||||
" spec 2)))\n (else\n (error \"malformed export\")))))\n ",
|
||||
" (export\n (lambda (spec)\n (let ((slot (collect spec)))\n",
|
||||
" (library-export (car slot) (cdr slot))))))\n (for-each export",
|
||||
" (cdr form)))))\n\n(export define lambda quote set! if begin define-macro\n ",
|
||||
"let let* letrec letrec*\n let-values let*-values define-values\n qua",
|
||||
"siquote unquote unquote-splicing\n and or\n cond case else =>\n ",
|
||||
" do when unless\n parameterize\n define-syntax\n syntax-quote",
|
||||
" syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n let-sy",
|
||||
"ntax letrec-syntax\n syntax-error)\n\n\n",
|
||||
"",
|
||||
""
|
||||
};
|
||||
|
|
|
|||
|
|
@ -66,9 +66,9 @@ static pic_value
|
|||
reg_get(pic_state *pic, struct pic_reg *reg, void *key)
|
||||
{
|
||||
if (! pic_reg_has(pic, reg, key)) {
|
||||
return pic_undef_value();
|
||||
return pic_false_value();
|
||||
}
|
||||
return pic_reg_ref(pic, reg, key);
|
||||
return pic_cons(pic, pic_obj_value(key), pic_reg_ref(pic, reg, key));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
|
|
|||
Loading…
Reference in New Issue