From 48d9b40b9d0d5dd58db2792481c1a03e76bcc382 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 12 Jan 2002 04:28:38 +0000 Subject: [PATCH 01/54] (script_sources): Add autofrisk. --- scripts/Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/scripts/Makefile.am b/scripts/Makefile.am index 4bcc3f257..3e21a0a7a 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -24,6 +24,7 @@ AUTOMAKE_OPTIONS = gnu # These should be installed and distributed. scripts_sources = \ PROGRAM \ + autofrisk \ display-commentary \ doc-snarf \ frisk \ From f528ebcdf1d2f44aeef9fc9c9f69d13d58fbc43e Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 12 Jan 2002 04:30:34 +0000 Subject: [PATCH 02/54] *** empty log message *** --- scripts/ChangeLog | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/scripts/ChangeLog b/scripts/ChangeLog index ad1e2248a..c936eaefd 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,21 @@ +2002-01-11 Thien-Thi Nguyen + + * Makefile.am (scripts_sources): Add autofrisk. + + * autofrisk: New script. + + * frisk: Fix typo in commentary; nfc. + + * use2dot: Autoload module (ice-9 getopt-long). + Use module (srfi srfi-13). + Export `use2dot'. + + (string-append/separator, mapconcat): Delete. + (vv): Now take list of pairs, and return the mapping.. + (>>header): Use `string-join'. + (>>): New proc. + (use2dot): Use `getopt-long'. Use `>>'. + 2002-01-08 Thien-Thi Nguyen * Makefile.am (scripts_sources): Add frisk. From f5259dd399f80572d787cb1095d956fdea2b90eb Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 12 Jan 2002 17:47:44 +0000 Subject: [PATCH 03/54] (generic-write): New per-line-prefix argument. (pretty-print): Check whether the new keyword argument style is used and dispatch to pretty-print-with-keys accordingly. --- ice-9/pretty-print.scm | 40 ++++++++++++++++++++++++++++++++-------- 1 file changed, 32 insertions(+), 8 deletions(-) diff --git a/ice-9/pretty-print.scm b/ice-9/pretty-print.scm index cc32c8917..c323488bd 100644 --- a/ice-9/pretty-print.scm +++ b/ice-9/pretty-print.scm @@ -42,6 +42,7 @@ ;;;; If you do not wish that, delete this exception notice. ;;;; (define-module (ice-9 pretty-print) + :use-module (ice-9 optargs) :export (pretty-print)) ;; From SLIB. @@ -53,7 +54,7 @@ (define genwrite:newline-str (make-string 1 #\newline)) -(define (generic-write obj display? width output) +(define (generic-write obj display? width per-line-prefix output) (define (read-macro? l) (define (length1? l) (and (pair? l) (null? (cdr l)))) @@ -137,14 +138,16 @@ (define (indent to col) (and col (if (< to col) - (and (out genwrite:newline-str col) (spaces to 0)) + (and (out genwrite:newline-str col) + (out per-line-prefix 0) + (spaces to 0)) (spaces (- to col) col)))) (define (pr obj col extra pp-pair) (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines (let ((result '()) (left (min (+ (- (- width col) extra) 1) max-expr-width))) - (generic-write obj display? #f + (generic-write obj display? #f "" (lambda (str) (set! result (cons str result)) (set! left (- left (string-length str))) @@ -287,6 +290,7 @@ (pr obj col 0 pp-expr)) + (out per-line-prefix 0) (if width (out genwrite:newline-str (pp obj 0)) (wr obj 0)) @@ -312,9 +316,29 @@ (rev-string-append l 0)) -;"pp.scm" Pretty-Print -(define (pretty-print obj . opt) - (let ((port (if (pair? opt) (car opt) (current-output-port)))) - (generic-write obj #f 79 - (lambda (s) (display s port) #t)))) +(define (pretty-print obj . opts) + "Pretty-print OBJ on PORT, which is a keyword argument defaulting to +the current output port. Formatting can be controlled by a number of +keyword arguments: Each line in the output is preceded by the string +PER-LINE-PREFIX, which is empty by default. The output lines will be +at most WIDTH characters wide; the default is 79. If DISPLAY? is +true, display rather than write representation will be used. +Instead of with a keyword argument, you can also specify the output +port directly after OBJ, like (pretty-print OBJ PORT)." + (if (pair? opts) + (if (keyword? (car opts)) + (apply pretty-print-with-keys obj opts) + (apply pretty-print-with-keys obj #:port (car opts) (cdr opts))) + (pretty-print-with-keys obj))) + +(define* (pretty-print-with-keys obj + #:key + (port (current-output-port)) + (width 79) + (display? #f) + (per-line-prefix "")) + (generic-write obj display? + (- width (string-length per-line-prefix)) + per-line-prefix + (lambda (s) (display s port) #t))) From 0e6f77756c0ddcc7d19f95ba073e0e210bb40342 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sat, 12 Jan 2002 17:52:34 +0000 Subject: [PATCH 04/54] *** empty log message *** --- NEWS | 6 ++++++ ice-9/ChangeLog | 12 ++++++++++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index c881afff6..69e639cb3 100644 --- a/NEWS +++ b/NEWS @@ -20,6 +20,12 @@ debugging evaluator gives better error messages. * Changes to Scheme functions and syntax +** pretty-print has more options. + +The function pretty-print from the (ice-9 pretty-print) module can now +also be invoked with keyword arguments that control things like +maximum output width. See its online documentation. + ** Variables have no longer a special behavior for `equal?'. Previously, comparing two variables with `equal?' would recursivly diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 7c08c7472..94548f586 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,7 +1,15 @@ +2002-01-12 Marius Vollmer + + More options for pretty-print. Thanks to Matthias Köppe! + + * pretty-print.scm (generic-write): New per-line-prefix argument. + (pretty-print): Check whether the new keyword argument style is + used and dispatch to pretty-print-with-keys accordingly. + 2001-11-27 Marius Vollmer - * format.scm (string-index, list-head): Removed, we already these - in the core. + * format.scm (string-index, list-head): Removed, we already have + these in the core. 2001-11-06 Marius Vollmer From c514c5d1c7082b7e6e6b0d425c381b5221da3aab Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 14 Jan 2002 18:10:19 +0000 Subject: [PATCH 05/54] (autoconf-macros.texi): Also set GUILE_LOAD_PATH when invoking the uninstalled guile executable. --- doc/ref/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 5aab26a26..1f42fcc80 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -43,7 +43,7 @@ GUILE = $(top_builddir)/libguile/guile autoconf.texi: autoconf-macros.texi autoconf-macros.texi: $(top_srcdir)/guile-config/guile.m4 - GUILE=$(GUILE) \ + GUILE=$(GUILE) GUILE_LOAD_PATH=$(top_srcdir) \ $(top_srcdir)/scripts/snarf-guile-m4-docs $< > $(srcdir)/$@ # Optionally support building an HTML version of the reference manual. From 68cf83e034528f19953f8a2622d3cf88c6ecbde9 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 14 Jan 2002 18:10:30 +0000 Subject: [PATCH 06/54] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 9c00d7c48..176e0ff04 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2002-01-14 Marius Vollmer + + * Makefile.am (autoconf-macros.texi): Also set GUILE_LOAD_PATH + when invoking the uninstalled guile executable. + 2002-01-09 Thien-Thi Nguyen * Makefile.am (autoconf-macros.texi): Fix build bug: From 1f463efc1cb2168dd33a6651f8860b261f5f9520 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 14 Jan 2002 20:41:30 +0000 Subject: [PATCH 07/54] (datum->syntax-object): Removed assertion in datum->syntax-object that checked if the first argument, a syntax-object, is an identifier. This was a unconvenient and unnecessary restriction. Thanks to Dorai Sitaram! --- ice-9/psyntax.pp | 22 +++++++++++----------- ice-9/psyntax.ss | 1 - 2 files changed, 11 insertions(+), 12 deletions(-) diff --git a/ice-9/psyntax.pp b/ice-9/psyntax.pp index 8f90b9a55..48e1f7156 100644 --- a/ice-9/psyntax.pp +++ b/ice-9/psyntax.pp @@ -1,11 +1,11 @@ -(letrec ((lambda-var-list116 (lambda (vars323) (let lvl324 ((vars325 vars323) (ls326 (quote ())) (w327 (quote (())))) (cond ((pair? vars325) (lvl324 (cdr vars325) (cons (wrap95 (car vars325) w327) ls326) w327)) ((id?67 vars325) (cons (wrap95 vars325 w327) ls326)) ((null? vars325) ls326) ((syntax-object?53 vars325) (lvl324 (syntax-object-expression54 vars325) ls326 (join-wraps86 w327 (syntax-object-wrap55 vars325)))) ((annotation?42 vars325) (lvl324 (annotation-expression vars325) ls326 w327)) (else (cons vars325 ls326)))))) (gen-var115 (lambda (id328) (let ((id329 (if (syntax-object?53 id328) (syntax-object-expression54 id328) id328))) (if (annotation?42 id329) (gensym (symbol->string (annotation-expression id329))) (gensym (symbol->string id329)))))) (strip114 (lambda (x330 w331) (if (memq (quote top) (wrap-marks70 w331)) (if (or (annotation?42 x330) (and (pair? x330) (annotation?42 (car x330)))) (strip-annotation113 x330 (quote #f)) x330) (let f332 ((x333 x330)) (cond ((syntax-object?53 x333) (strip114 (syntax-object-expression54 x333) (syntax-object-wrap55 x333))) ((pair? x333) (let ((a334 (f332 (car x333))) (d335 (f332 (cdr x333)))) (if (and (eq? a334 (car x333)) (eq? d335 (cdr x333))) x333 (cons a334 d335)))) ((vector? x333) (let ((old336 (vector->list x333))) (let ((new337 (map f332 old336))) (if (andmap eq? old336 new337) x333 (list->vector new337))))) (else x333)))))) (strip-annotation113 (lambda (x338 parent339) (cond ((pair? x338) (let ((new340 (cons (quote #f) (quote #f)))) (begin (when parent339 (set-annotation-stripped! parent339 new340)) (set-car! new340 (strip-annotation113 (car x338) (quote #f))) (set-cdr! new340 (strip-annotation113 (cdr x338) (quote #f))) new340))) ((annotation?42 x338) (or (annotation-stripped x338) (strip-annotation113 (annotation-expression x338) x338))) ((vector? x338) (let ((new341 (make-vector (vector-length x338)))) (begin (when parent339 (set-annotation-stripped! parent339 new341)) (let loop342 ((i343 (- (vector-length x338) (quote 1)))) (unless (fx<41 i343 (quote 0)) (vector-set! new341 i343 (strip-annotation113 (vector-ref x338 i343) (quote #f))) (loop342 (fx-39 i343 (quote 1))))) new341))) (else x338)))) (ellipsis?112 (lambda (x344) (and (nonsymbol-id?66 x344) (free-id=?90 x344 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void111 (lambda () (list (quote void)))) (eval-local-transformer110 (lambda (expanded345) (let ((p346 (local-eval-hook44 expanded345))) (if (procedure? p346) p346 (syntax-error p346 (quote "nonprocedure transfomer")))))) (chi-local-syntax109 (lambda (rec?347 e348 r349 w350 s351 k352) ((lambda (tmp353) ((lambda (tmp354) (if tmp354 (apply (lambda (_355 id356 val357 e1358 e2359) (let ((ids360 id356)) (if (not (valid-bound-ids?92 ids360)) (syntax-error e348 (quote "duplicate bound keyword in")) (let ((labels362 (gen-labels73 ids360))) (let ((new-w363 (make-binding-wrap84 ids360 labels362 w350))) (k352 (cons e1358 e2359) (extend-env61 labels362 (let ((w365 (if rec?347 new-w363 w350)) (trans-r366 (macros-only-env63 r349))) (map (lambda (x367) (cons (quote macro) (eval-local-transformer110 (chi103 x367 trans-r366 w365)))) val357)) r349) new-w363 s351)))))) tmp354) ((lambda (_369) (syntax-error (source-wrap96 e348 w350 s351))) tmp353))) (syntax-dispatch tmp353 (quote (any #(each (any any)) any . each-any))))) e348))) (chi-lambda-clause108 (lambda (e370 c371 r372 w373 k374) ((lambda (tmp375) ((lambda (tmp376) (if tmp376 (apply (lambda (id377 e1378 e2379) (let ((ids380 id377)) (if (not (valid-bound-ids?92 ids380)) (syntax-error e370 (quote "invalid parameter list in")) (let ((labels382 (gen-labels73 ids380)) (new-vars383 (map gen-var115 ids380))) (k374 new-vars383 (chi-body107 (cons e1378 e2379) e370 (extend-var-env62 labels382 new-vars383 r372) (make-binding-wrap84 ids380 labels382 w373))))))) tmp376) ((lambda (tmp385) (if tmp385 (apply (lambda (ids386 e1387 e2388) (let ((old-ids389 (lambda-var-list116 ids386))) (if (not (valid-bound-ids?92 old-ids389)) (syntax-error e370 (quote "invalid parameter list in")) (let ((labels390 (gen-labels73 old-ids389)) (new-vars391 (map gen-var115 old-ids389))) (k374 (let f392 ((ls1393 (cdr new-vars391)) (ls2394 (car new-vars391))) (if (null? ls1393) ls2394 (f392 (cdr ls1393) (cons (car ls1393) ls2394)))) (chi-body107 (cons e1387 e2388) e370 (extend-var-env62 labels390 new-vars391 r372) (make-binding-wrap84 old-ids389 labels390 w373))))))) tmp385) ((lambda (_396) (syntax-error e370)) tmp375))) (syntax-dispatch tmp375 (quote (any any . each-any)))))) (syntax-dispatch tmp375 (quote (each-any any . each-any))))) c371))) (chi-body107 (lambda (body397 outer-form398 r399 w400) (let ((r401 (cons (quote ("placeholder" placeholder)) r399))) (let ((ribcage402 (make-ribcage74 (quote ()) (quote ()) (quote ())))) (let ((w403 (make-wrap69 (wrap-marks70 w400) (cons ribcage402 (wrap-subst71 w400))))) (let parse404 ((body405 (map (lambda (x411) (cons r401 (wrap95 x411 w403))) body397)) (ids406 (quote ())) (labels407 (quote ())) (vars408 (quote ())) (vals409 (quote ())) (bindings410 (quote ()))) (if (null? body405) (syntax-error outer-form398 (quote "no expressions in body")) (let ((e412 (cdar body405)) (er413 (caar body405))) (call-with-values (lambda () (syntax-type101 e412 er413 (quote (())) (quote #f) ribcage402)) (lambda (type414 value415 e416 w417 s418) (let ((t419 type414)) (if (memv t419 (quote (define-form))) (let ((id420 (wrap95 value415 w417)) (label421 (gen-label72))) (let ((var422 (gen-var115 id420))) (begin (extend-ribcage!83 ribcage402 id420 label421) (parse404 (cdr body405) (cons id420 ids406) (cons label421 labels407) (cons var422 vars408) (cons (cons er413 (wrap95 e416 w417)) vals409) (cons (cons (quote lexical) var422) bindings410))))) (if (memv t419 (quote (define-syntax-form))) (let ((id423 (wrap95 value415 w417)) (label424 (gen-label72))) (begin (extend-ribcage!83 ribcage402 id423 label424) (parse404 (cdr body405) (cons id423 ids406) (cons label424 labels407) vars408 vals409 (cons (cons (quote macro) (cons er413 (wrap95 e416 w417))) bindings410)))) (if (memv t419 (quote (begin-form))) ((lambda (tmp425) ((lambda (tmp426) (if tmp426 (apply (lambda (_427 e1428) (parse404 (let f429 ((forms430 e1428)) (if (null? forms430) (cdr body405) (cons (cons er413 (wrap95 (car forms430) w417)) (f429 (cdr forms430))))) ids406 labels407 vars408 vals409 bindings410)) tmp426) (syntax-error tmp425))) (syntax-dispatch tmp425 (quote (any . each-any))))) e416) (if (memv t419 (quote (local-syntax-form))) (chi-local-syntax109 value415 e416 er413 w417 s418 (lambda (forms432 er433 w434 s435) (parse404 (let f436 ((forms437 forms432)) (if (null? forms437) (cdr body405) (cons (cons er433 (wrap95 (car forms437) w434)) (f436 (cdr forms437))))) ids406 labels407 vars408 vals409 bindings410))) (if (null? ids406) (build-sequence48 (quote #f) (map (lambda (x438) (chi103 (cdr x438) (car x438) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417 s418)) (cdr body405)))) (begin (if (not (valid-bound-ids?92 ids406)) (syntax-error outer-form398 (quote "invalid or duplicate identifier in definition"))) (let loop439 ((bs440 bindings410) (er-cache441 (quote #f)) (r-cache442 (quote #f))) (if (not (null? bs440)) (let ((b443 (car bs440))) (if (eq? (car b443) (quote macro)) (let ((er444 (cadr b443))) (let ((r-cache445 (if (eq? er444 er-cache441) r-cache442 (macros-only-env63 er444)))) (begin (set-cdr! b443 (eval-local-transformer110 (chi103 (cddr b443) r-cache445 (quote (()))))) (loop439 (cdr bs440) er444 r-cache445)))) (loop439 (cdr bs440) er-cache441 r-cache442))))) (set-cdr! r401 (extend-env61 labels407 bindings410 (cdr r401))) (build-letrec51 (quote #f) vars408 (map (lambda (x446) (chi103 (cdr x446) (car x446) (quote (())))) vals409) (build-sequence48 (quote #f) (map (lambda (x447) (chi103 (cdr x447) (car x447) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417 s418)) (cdr body405)))))))))))))))))))))) (chi-macro106 (lambda (p448 e449 r450 w451 rib452) (letrec ((rebuild-macro-output453 (lambda (x454 m455) (cond ((pair? x454) (cons (rebuild-macro-output453 (car x454) m455) (rebuild-macro-output453 (cdr x454) m455))) ((syntax-object?53 x454) (let ((w456 (syntax-object-wrap55 x454))) (let ((ms457 (wrap-marks70 w456)) (s458 (wrap-subst71 w456))) (make-syntax-object52 (syntax-object-expression54 x454) (if (and (pair? ms457) (eq? (car ms457) (quote #f))) (make-wrap69 (cdr ms457) (if rib452 (cons rib452 (cdr s458)) (cdr s458))) (make-wrap69 (cons m455 ms457) (if rib452 (cons rib452 (cons (quote shift) s458)) (cons (quote shift) s458)))))))) ((vector? x454) (let ((n459 (vector-length x454))) (let ((v460 (make-vector n459))) (let doloop461 ((i462 (quote 0))) (if (fx=40 i462 n459) v460 (begin (vector-set! v460 i462 (rebuild-macro-output453 (vector-ref x454 i462) m455)) (doloop461 (fx+38 i462 (quote 1))))))))) ((symbol? x454) (syntax-error x454 (quote "encountered raw symbol in macro output"))) (else x454))))) (rebuild-macro-output453 (p448 (wrap95 e449 (anti-mark82 w451))) (string (quote #\m)))))) (chi-application105 (lambda (x463 e464 r465 w466 s467) ((lambda (tmp468) ((lambda (tmp469) (if tmp469 (apply (lambda (e0470 e1471) (cons x463 (map (lambda (e472) (chi103 e472 r465 w466)) e1471))) tmp469) (syntax-error tmp468))) (syntax-dispatch tmp468 (quote (any . each-any))))) e464))) (chi-expr104 (lambda (type474 value475 e476 r477 w478 s479) (let ((t480 type474)) (if (memv t480 (quote (lexical))) value475 (if (memv t480 (quote (core))) (value475 e476 r477 w478 s479) (if (memv t480 (quote (lexical-call))) (chi-application105 value475 e476 r477 w478 s479) (if (memv t480 (quote (global-call))) (chi-application105 value475 e476 r477 w478 s479) (if (memv t480 (quote (constant))) (list (quote quote) (strip114 (source-wrap96 e476 w478 s479) (quote (())))) (if (memv t480 (quote (global))) value475 (if (memv t480 (quote (call))) (chi-application105 (chi103 (car e476) r477 w478) e476 r477 w478 s479) (if (memv t480 (quote (begin-form))) ((lambda (tmp481) ((lambda (tmp482) (if tmp482 (apply (lambda (_483 e1484 e2485) (chi-sequence97 (cons e1484 e2485) r477 w478 s479)) tmp482) (syntax-error tmp481))) (syntax-dispatch tmp481 (quote (any any . each-any))))) e476) (if (memv t480 (quote (local-syntax-form))) (chi-local-syntax109 value475 e476 r477 w478 s479 chi-sequence97) (if (memv t480 (quote (eval-when-form))) ((lambda (tmp487) ((lambda (tmp488) (if tmp488 (apply (lambda (_489 x490 e1491 e2492) (let ((when-list493 (chi-when-list100 e476 x490 w478))) (if (memq (quote eval) when-list493) (chi-sequence97 (cons e1491 e2492) r477 w478 s479) (chi-void111)))) tmp488) (syntax-error tmp487))) (syntax-dispatch tmp487 (quote (any each-any any . each-any))))) e476) (if (memv t480 (quote (define-form define-syntax-form))) (syntax-error (wrap95 value475 w478) (quote "invalid context for definition of")) (if (memv t480 (quote (syntax))) (syntax-error (source-wrap96 e476 w478 s479) (quote "reference to pattern variable outside syntax form")) (if (memv t480 (quote (displaced-lexical))) (syntax-error (source-wrap96 e476 w478 s479) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap96 e476 w478 s479)))))))))))))))))) (chi103 (lambda (e496 r497 w498) (call-with-values (lambda () (syntax-type101 e496 r497 w498 (quote #f) (quote #f))) (lambda (type499 value500 e501 w502 s503) (chi-expr104 type499 value500 e501 r497 w502 s503))))) (chi-top102 (lambda (e504 r505 w506 m507 esew508) (call-with-values (lambda () (syntax-type101 e504 r505 w506 (quote #f) (quote #f))) (lambda (type515 value516 e517 w518 s519) (let ((t520 type515)) (if (memv t520 (quote (begin-form))) ((lambda (tmp521) ((lambda (tmp522) (if tmp522 (apply (lambda (_523) (chi-void111)) tmp522) ((lambda (tmp524) (if tmp524 (apply (lambda (_525 e1526 e2527) (chi-top-sequence98 (cons e1526 e2527) r505 w518 s519 m507 esew508)) tmp524) (syntax-error tmp521))) (syntax-dispatch tmp521 (quote (any any . each-any)))))) (syntax-dispatch tmp521 (quote (any))))) e517) (if (memv t520 (quote (local-syntax-form))) (chi-local-syntax109 value516 e517 r505 w518 s519 (lambda (body529 r530 w531 s532) (chi-top-sequence98 body529 r530 w531 s532 m507 esew508))) (if (memv t520 (quote (eval-when-form))) ((lambda (tmp533) ((lambda (tmp534) (if tmp534 (apply (lambda (_535 x536 e1537 e2538) (let ((when-list539 (chi-when-list100 e517 x536 w518)) (body540 (cons e1537 e2538))) (cond ((eq? m507 (quote e)) (if (memq (quote eval) when-list539) (chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval))) (chi-void111))) ((memq (quote load) when-list539) (if (or (memq (quote compile) when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539))) (chi-top-sequence98 body540 r505 w518 s519 (quote c&e) (quote (compile load))) (if (memq m507 (quote (c c&e))) (chi-top-sequence98 body540 r505 w518 s519 (quote c) (quote (load))) (chi-void111)))) ((or (memq (quote compile) when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539))) (top-level-eval-hook43 (chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval)))) (chi-void111)) (else (chi-void111))))) tmp534) (syntax-error tmp533))) (syntax-dispatch tmp533 (quote (any each-any any . each-any))))) e517) (if (memv t520 (quote (define-syntax-form))) (let ((n543 (id-var-name89 value516 w518)) (r544 (macros-only-env63 r505))) (let ((t545 m507)) (if (memv t545 (quote (c))) (if (memq (quote compile) esew508) (let ((e546 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin (top-level-eval-hook43 e546) (if (memq (quote load) esew508) e546 (chi-void111)))) (if (memq (quote load) esew508) (chi-install-global99 n543 (chi103 e517 r544 w518)) (chi-void111))) (if (memv t545 (quote (c&e))) (let ((e547 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin (top-level-eval-hook43 e547) e547)) (begin (if (memq (quote eval) esew508) (top-level-eval-hook43 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (chi-void111)))))) (if (memv t520 (quote (define-form))) (let ((n548 (id-var-name89 value516 w518))) (let ((t549 (binding-type59 (lookup64 n548 r505)))) (if (memv t549 (quote (global))) (let ((x550 (list (quote define) n548 (chi103 e517 r505 w518)))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x550)) x550)) (if (memv t549 (quote (displaced-lexical))) (syntax-error (wrap95 value516 w518) (quote "identifier out of context")) (syntax-error (wrap95 value516 w518) (quote "cannot define keyword at top level")))))) (let ((x551 (chi-expr104 type515 value516 e517 r505 w518 s519))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x551)) x551)))))))))))) (syntax-type101 (lambda (e552 r553 w554 s555 rib556) (cond ((symbol? e552) (let ((n557 (id-var-name89 e552 w554))) (let ((b558 (lookup64 n557 r553))) (let ((type559 (binding-type59 b558))) (let ((t560 type559)) (if (memv t560 (quote (lexical))) (values type559 (binding-value60 b558) e552 w554 s555) (if (memv t560 (quote (global))) (values type559 n557 e552 w554 s555) (if (memv t560 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60 b558) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (values type559 (binding-value60 b558) e552 w554 s555))))))))) ((pair? e552) (let ((first561 (car e552))) (if (id?67 first561) (let ((n562 (id-var-name89 first561 w554))) (let ((b563 (lookup64 n562 r553))) (let ((type564 (binding-type59 b563))) (let ((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call) (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (global))) (values (quote global-call) n562 e552 w554 s555) (if (memv t565 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60 b563) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (if (memv t565 (quote (core))) (values type564 (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (begin))) (values (quote begin-form) (quote #f) e552 w554 s555) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e552 w554 s555) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?67 name569)) tmp567) (quote #f)) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w554 s555)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?67 name576) (valid-bound-ids?92 (lambda-var-list116 args577)))) tmp574) (quote #f)) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap95 name581 w554) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap95 (cons args582 (cons e1583 e2584)) w554)) (quote (())) s555)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?67 name588)) tmp586) (quote #f)) (apply (lambda (_589 name590) (values (quote define-form) (wrap95 name590 w554) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s555)) tmp586) (syntax-error tmp566))) (syntax-dispatch tmp566 (quote (any any)))))) (syntax-dispatch tmp566 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp566 (quote (any any any))))) e552) (if (memv t565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?67 name594)) tmp592) (quote #f)) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w554 s555)) tmp592) (syntax-error tmp591))) (syntax-dispatch tmp591 (quote (any any any))))) e552) (values (quote call) (quote #f) e552 w554 s555)))))))))))))) (values (quote call) (quote #f) e552 w554 s555)))) ((syntax-object?53 e552) (syntax-type101 (syntax-object-expression54 e552) r553 (join-wraps86 w554 (syntax-object-wrap55 e552)) (quote #f) rib556)) ((annotation?42 e552) (syntax-type101 (annotation-expression e552) r553 w554 (annotation-source e552) rib556)) ((let ((x599 e552)) (or (boolean? x599) (number? x599) (string? x599) (char? x599) (null? x599) (keyword? x599))) (values (quote constant) (quote #f) e552 w554 s555)) (else (values (quote other) (quote #f) e552 w554 s555))))) (chi-when-list100 (lambda (e600 when-list601 w602) (let f603 ((when-list604 when-list601) (situations605 (quote ()))) (if (null? when-list604) situations605 (f603 (cdr when-list604) (cons (let ((x606 (car when-list604))) (cond ((free-id=?90 x606 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=?90 x606 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=?90 x606 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap95 x606 w602) (quote "invalid eval-when situation"))))) situations605)))))) (chi-install-global99 (lambda (name607 e608) (list (quote install-global-transformer) (list (quote quote) name607) e608))) (chi-top-sequence98 (lambda (body609 r610 w611 s612 m613 esew614) (build-sequence48 s612 (let dobody615 ((body616 body609) (r617 r610) (w618 w611) (m619 m613) (esew620 esew614)) (if (null? body616) (quote ()) (let ((first621 (chi-top102 (car body616) r617 w618 m619 esew620))) (cons first621 (dobody615 (cdr body616) r617 w618 m619 esew620)))))))) (chi-sequence97 (lambda (body622 r623 w624 s625) (build-sequence48 s625 (let dobody626 ((body627 body622) (r628 r623) (w629 w624)) (if (null? body627) (quote ()) (let ((first630 (chi103 (car body627) r628 w629))) (cons first630 (dobody626 (cdr body627) r628 w629)))))))) (source-wrap96 (lambda (x631 w632 s633) (wrap95 (if s633 (make-annotation x631 s633 (quote #f)) x631) w632))) (wrap95 (lambda (x634 w635) (cond ((and (null? (wrap-marks70 w635)) (null? (wrap-subst71 w635))) x634) ((syntax-object?53 x634) (make-syntax-object52 (syntax-object-expression54 x634) (join-wraps86 w635 (syntax-object-wrap55 x634)))) ((null? x634) x634) (else (make-syntax-object52 x634 w635))))) (bound-id-member?94 (lambda (x636 list637) (and (not (null? list637)) (or (bound-id=?91 x636 (car list637)) (bound-id-member?94 x636 (cdr list637)))))) (distinct-bound-ids?93 (lambda (ids638) (let distinct?639 ((ids640 ids638)) (or (null? ids640) (and (not (bound-id-member?94 (car ids640) (cdr ids640))) (distinct?639 (cdr ids640))))))) (valid-bound-ids?92 (lambda (ids641) (and (let all-ids?642 ((ids643 ids641)) (or (null? ids643) (and (id?67 (car ids643)) (all-ids?642 (cdr ids643))))) (distinct-bound-ids?93 ids641)))) (bound-id=?91 (lambda (i644 j645) (if (and (syntax-object?53 i644) (syntax-object?53 j645)) (and (eq? (let ((e646 (syntax-object-expression54 i644))) (if (annotation?42 e646) (annotation-expression e646) e646)) (let ((e647 (syntax-object-expression54 j645))) (if (annotation?42 e647) (annotation-expression e647) e647))) (same-marks?88 (wrap-marks70 (syntax-object-wrap55 i644)) (wrap-marks70 (syntax-object-wrap55 j645)))) (eq? (let ((e648 i644)) (if (annotation?42 e648) (annotation-expression e648) e648)) (let ((e649 j645)) (if (annotation?42 e649) (annotation-expression e649) e649)))))) (free-id=?90 (lambda (i650 j651) (and (eq? (let ((x652 i650)) (let ((e653 (if (syntax-object?53 x652) (syntax-object-expression54 x652) x652))) (if (annotation?42 e653) (annotation-expression e653) e653))) (let ((x654 j651)) (let ((e655 (if (syntax-object?53 x654) (syntax-object-expression54 x654) x654))) (if (annotation?42 e655) (annotation-expression e655) e655)))) (eq? (id-var-name89 i650 (quote (()))) (id-var-name89 j651 (quote (()))))))) (id-var-name89 (lambda (id656 w657) (letrec ((search-vector-rib660 (lambda (sym666 subst667 marks668 symnames669 ribcage670) (let ((n671 (vector-length symnames669))) (let f672 ((i673 (quote 0))) (cond ((fx=40 i673 n671) (search658 sym666 (cdr subst667) marks668)) ((and (eq? (vector-ref symnames669 i673) sym666) (same-marks?88 marks668 (vector-ref (ribcage-marks77 ribcage670) i673))) (values (vector-ref (ribcage-labels78 ribcage670) i673) marks668)) (else (f672 (fx+38 i673 (quote 1))))))))) (search-list-rib659 (lambda (sym674 subst675 marks676 symnames677 ribcage678) (let f679 ((symnames680 symnames677) (i681 (quote 0))) (cond ((null? symnames680) (search658 sym674 (cdr subst675) marks676)) ((and (eq? (car symnames680) sym674) (same-marks?88 marks676 (list-ref (ribcage-marks77 ribcage678) i681))) (values (list-ref (ribcage-labels78 ribcage678) i681) marks676)) (else (f679 (cdr symnames680) (fx+38 i681 (quote 1)))))))) (search658 (lambda (sym682 subst683 marks684) (if (null? subst683) (values (quote #f) marks684) (let ((fst685 (car subst683))) (if (eq? fst685 (quote shift)) (search658 sym682 (cdr subst683) (cdr marks684)) (let ((symnames686 (ribcage-symnames76 fst685))) (if (vector? symnames686) (search-vector-rib660 sym682 subst683 marks684 symnames686 fst685) (search-list-rib659 sym682 subst683 marks684 symnames686 fst685))))))))) (cond ((symbol? id656) (or (call-with-values (lambda () (search658 id656 (wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x688 . ignore687) x688)) id656)) ((syntax-object?53 id656) (let ((id689 (let ((e691 (syntax-object-expression54 id656))) (if (annotation?42 e691) (annotation-expression e691) e691))) (w1690 (syntax-object-wrap55 id656))) (let ((marks692 (join-marks87 (wrap-marks70 w657) (wrap-marks70 w1690)))) (call-with-values (lambda () (search658 id689 (wrap-subst71 w657) marks692)) (lambda (new-id693 marks694) (or new-id693 (call-with-values (lambda () (search658 id689 (wrap-subst71 w1690) marks694)) (lambda (x696 . ignore695) x696)) id689)))))) ((annotation?42 id656) (let ((id697 (let ((e698 id656)) (if (annotation?42 e698) (annotation-expression e698) e698)))) (or (call-with-values (lambda () (search658 id697 (wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x700 . ignore699) x700)) id697))) (else (error-hook45 (quote id-var-name) (quote "invalid id") id656)))))) (same-marks?88 (lambda (x701 y702) (or (eq? x701 y702) (and (not (null? x701)) (not (null? y702)) (eq? (car x701) (car y702)) (same-marks?88 (cdr x701) (cdr y702)))))) (join-marks87 (lambda (m1703 m2704) (smart-append85 m1703 m2704))) (join-wraps86 (lambda (w1705 w2706) (let ((m1707 (wrap-marks70 w1705)) (s1708 (wrap-subst71 w1705))) (if (null? m1707) (if (null? s1708) w2706 (make-wrap69 (wrap-marks70 w2706) (smart-append85 s1708 (wrap-subst71 w2706)))) (make-wrap69 (smart-append85 m1707 (wrap-marks70 w2706)) (smart-append85 s1708 (wrap-subst71 w2706))))))) (smart-append85 (lambda (m1709 m2710) (if (null? m2710) m1709 (append m1709 m2710)))) (make-binding-wrap84 (lambda (ids711 labels712 w713) (if (null? ids711) w713 (make-wrap69 (wrap-marks70 w713) (cons (let ((labelvec714 (list->vector labels712))) (let ((n715 (vector-length labelvec714))) (let ((symnamevec716 (make-vector n715)) (marksvec717 (make-vector n715))) (begin (let f718 ((ids719 ids711) (i720 (quote 0))) (if (not (null? ids719)) (call-with-values (lambda () (id-sym-name&marks68 (car ids719) w713)) (lambda (symname721 marks722) (begin (vector-set! symnamevec716 i720 symname721) (vector-set! marksvec717 i720 marks722) (f718 (cdr ids719) (fx+38 i720 (quote 1)))))))) (make-ribcage74 symnamevec716 marksvec717 labelvec714))))) (wrap-subst71 w713)))))) (extend-ribcage!83 (lambda (ribcage723 id724 label725) (begin (set-ribcage-symnames!79 ribcage723 (cons (let ((e726 (syntax-object-expression54 id724))) (if (annotation?42 e726) (annotation-expression e726) e726)) (ribcage-symnames76 ribcage723))) (set-ribcage-marks!80 ribcage723 (cons (wrap-marks70 (syntax-object-wrap55 id724)) (ribcage-marks77 ribcage723))) (set-ribcage-labels!81 ribcage723 (cons label725 (ribcage-labels78 ribcage723)))))) (anti-mark82 (lambda (w727) (make-wrap69 (cons (quote #f) (wrap-marks70 w727)) (cons (quote shift) (wrap-subst71 w727))))) (set-ribcage-labels!81 (lambda (x728 update729) (vector-set! x728 (quote 3) update729))) (set-ribcage-marks!80 (lambda (x730 update731) (vector-set! x730 (quote 2) update731))) (set-ribcage-symnames!79 (lambda (x732 update733) (vector-set! x732 (quote 1) update733))) (ribcage-labels78 (lambda (x734) (vector-ref x734 (quote 3)))) (ribcage-marks77 (lambda (x735) (vector-ref x735 (quote 2)))) (ribcage-symnames76 (lambda (x736) (vector-ref x736 (quote 1)))) (ribcage?75 (lambda (x737) (and (vector? x737) (= (vector-length x737) (quote 4)) (eq? (vector-ref x737 (quote 0)) (quote ribcage))))) (make-ribcage74 (lambda (symnames738 marks739 labels740) (vector (quote ribcage) symnames738 marks739 labels740))) (gen-labels73 (lambda (ls741) (if (null? ls741) (quote ()) (cons (gen-label72) (gen-labels73 (cdr ls741)))))) (gen-label72 (lambda () (string (quote #\i)))) (wrap-subst71 cdr) (wrap-marks70 car) (make-wrap69 cons) (id-sym-name&marks68 (lambda (x742 w743) (if (syntax-object?53 x742) (values (let ((e744 (syntax-object-expression54 x742))) (if (annotation?42 e744) (annotation-expression e744) e744)) (join-marks87 (wrap-marks70 w743) (wrap-marks70 (syntax-object-wrap55 x742)))) (values (let ((e745 x742)) (if (annotation?42 e745) (annotation-expression e745) e745)) (wrap-marks70 w743))))) (id?67 (lambda (x746) (cond ((symbol? x746) (quote #t)) ((syntax-object?53 x746) (symbol? (let ((e747 (syntax-object-expression54 x746))) (if (annotation?42 e747) (annotation-expression e747) e747)))) ((annotation?42 x746) (symbol? (annotation-expression x746))) (else (quote #f))))) (nonsymbol-id?66 (lambda (x748) (and (syntax-object?53 x748) (symbol? (let ((e749 (syntax-object-expression54 x748))) (if (annotation?42 e749) (annotation-expression e749) e749)))))) (global-extend65 (lambda (type750 sym751 val752) (put-global-definition-hook46 sym751 (cons type750 val752)))) (lookup64 (lambda (x753 r754) (cond ((assq x753 r754) => cdr) ((symbol? x753) (or (get-global-definition-hook47 x753) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env63 (lambda (r755) (if (null? r755) (quote ()) (let ((a756 (car r755))) (if (eq? (cadr a756) (quote macro)) (cons a756 (macros-only-env63 (cdr r755))) (macros-only-env63 (cdr r755))))))) (extend-var-env62 (lambda (labels757 vars758 r759) (if (null? labels757) r759 (extend-var-env62 (cdr labels757) (cdr vars758) (cons (cons (car labels757) (cons (quote lexical) (car vars758))) r759))))) (extend-env61 (lambda (labels760 bindings761 r762) (if (null? labels760) r762 (extend-env61 (cdr labels760) (cdr bindings761) (cons (cons (car labels760) (car bindings761)) r762))))) (binding-value60 cdr) (binding-type59 car) (source-annotation58 (lambda (x763) (cond ((annotation?42 x763) (annotation-source x763)) ((syntax-object?53 x763) (source-annotation58 (syntax-object-expression54 x763))) (else (quote #f))))) (set-syntax-object-wrap!57 (lambda (x764 update765) (vector-set! x764 (quote 2) update765))) (set-syntax-object-expression!56 (lambda (x766 update767) (vector-set! x766 (quote 1) update767))) (syntax-object-wrap55 (lambda (x768) (vector-ref x768 (quote 2)))) (syntax-object-expression54 (lambda (x769) (vector-ref x769 (quote 1)))) (syntax-object?53 (lambda (x770) (and (vector? x770) (= (vector-length x770) (quote 3)) (eq? (vector-ref x770 (quote 0)) (quote syntax-object))))) (make-syntax-object52 (lambda (expression771 wrap772) (vector (quote syntax-object) expression771 wrap772))) (build-letrec51 (lambda (src773 vars774 val-exps775 body-exp776) (if (null? vars774) body-exp776 (list (quote letrec) (map list vars774 val-exps775) body-exp776)))) (build-named-let50 (lambda (src777 vars778 val-exps779 body-exp780) (if (null? vars778) body-exp780 (list (quote let) (car vars778) (map list (cdr vars778) val-exps779) body-exp780)))) (build-let49 (lambda (src781 vars782 val-exps783 body-exp784) (if (null? vars782) body-exp784 (list (quote let) (map list vars782 val-exps783) body-exp784)))) (build-sequence48 (lambda (src785 exps786) (if (null? (cdr exps786)) (car exps786) (cons (quote begin) exps786)))) (get-global-definition-hook47 (lambda (symbol787) (getprop symbol787 (quote *sc-expander*)))) (put-global-definition-hook46 (lambda (symbol788 binding789) (putprop symbol788 (quote *sc-expander*) binding789))) (error-hook45 (lambda (who790 why791 what792) (error who790 (quote "~a ~s") why791 what792))) (local-eval-hook44 (lambda (x793) (eval (list noexpand37 x793) (interaction-environment)))) (top-level-eval-hook43 (lambda (x794) (eval (list noexpand37 x794) (interaction-environment)))) (annotation?42 (lambda (x795) (quote #f))) (fx<41 <) (fx=40 =) (fx-39 -) (fx+38 +) (noexpand37 (quote "noexpand"))) (begin (global-extend65 (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend65 (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend65 (quote core) (quote fluid-let-syntax) (lambda (e796 r797 w798 s799) ((lambda (tmp800) ((lambda (tmp801) (if (if tmp801 (apply (lambda (_802 var803 val804 e1805 e2806) (valid-bound-ids?92 var803)) tmp801) (quote #f)) (apply (lambda (_808 var809 val810 e1811 e2812) (let ((names813 (map (lambda (x814) (id-var-name89 x814 w798)) var809))) (begin (for-each (lambda (id816 n817) (let ((t818 (binding-type59 (lookup64 n817 r797)))) (if (memv t818 (quote (displaced-lexical))) (syntax-error (source-wrap96 id816 w798 s799) (quote "identifier out of context"))))) var809 names813) (chi-body107 (cons e1811 e2812) (source-wrap96 e796 w798 s799) (extend-env61 names813 (let ((trans-r821 (macros-only-env63 r797))) (map (lambda (x822) (cons (quote macro) (eval-local-transformer110 (chi103 x822 trans-r821 w798)))) val810)) r797) w798)))) tmp801) ((lambda (_824) (syntax-error (source-wrap96 e796 w798 s799))) tmp800))) (syntax-dispatch tmp800 (quote (any #(each (any any)) any . each-any))))) e796))) (global-extend65 (quote core) (quote quote) (lambda (e825 r826 w827 s828) ((lambda (tmp829) ((lambda (tmp830) (if tmp830 (apply (lambda (_831 e832) (list (quote quote) (strip114 e832 w827))) tmp830) ((lambda (_833) (syntax-error (source-wrap96 e825 w827 s828))) tmp829))) (syntax-dispatch tmp829 (quote (any any))))) e825))) (global-extend65 (quote core) (quote syntax) (letrec ((regen841 (lambda (x842) (let ((t843 (car x842))) (if (memv t843 (quote (ref))) (cadr x842) (if (memv t843 (quote (primitive))) (cadr x842) (if (memv t843 (quote (quote))) (list (quote quote) (cadr x842)) (if (memv t843 (quote (lambda))) (list (quote lambda) (cadr x842) (regen841 (caddr x842))) (if (memv t843 (quote (map))) (let ((ls844 (map regen841 (cdr x842)))) (cons (if (fx=40 (length ls844) (quote 2)) (quote map) (quote map)) ls844)) (cons (car x842) (map regen841 (cdr x842))))))))))) (gen-vector840 (lambda (x845) (cond ((eq? (car x845) (quote list)) (cons (quote vector) (cdr x845))) ((eq? (car x845) (quote quote)) (list (quote quote) (list->vector (cadr x845)))) (else (list (quote list->vector) x845))))) (gen-append839 (lambda (x846 y847) (if (equal? y847 (quote (quote ()))) x846 (list (quote append) x846 y847)))) (gen-cons838 (lambda (x848 y849) (let ((t850 (car y849))) (if (memv t850 (quote (quote))) (if (eq? (car x848) (quote quote)) (list (quote quote) (cons (cadr x848) (cadr y849))) (if (eq? (cadr y849) (quote ())) (list (quote list) x848) (list (quote cons) x848 y849))) (if (memv t850 (quote (list))) (cons (quote list) (cons x848 (cdr y849))) (list (quote cons) x848 y849)))))) (gen-map837 (lambda (e851 map-env852) (let ((formals853 (map cdr map-env852)) (actuals854 (map (lambda (x855) (list (quote ref) (car x855))) map-env852))) (cond ((eq? (car e851) (quote ref)) (car actuals854)) ((andmap (lambda (x856) (and (eq? (car x856) (quote ref)) (memq (cadr x856) formals853))) (cdr e851)) (cons (quote map) (cons (list (quote primitive) (car e851)) (map (let ((r857 (map cons formals853 actuals854))) (lambda (x858) (cdr (assq (cadr x858) r857)))) (cdr e851))))) (else (cons (quote map) (cons (list (quote lambda) formals853 e851) actuals854))))))) (gen-mappend836 (lambda (e859 map-env860) (list (quote apply) (quote (primitive append)) (gen-map837 e859 map-env860)))) (gen-ref835 (lambda (src861 var862 level863 maps864) (if (fx=40 level863 (quote 0)) (values var862 maps864) (if (null? maps864) (syntax-error src861 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref835 src861 var862 (fx-39 level863 (quote 1)) (cdr maps864))) (lambda (outer-var865 outer-maps866) (let ((b867 (assq outer-var865 (car maps864)))) (if b867 (values (cdr b867) maps864) (let ((inner-var868 (gen-var115 (quote tmp)))) (values inner-var868 (cons (cons (cons outer-var865 inner-var868) (car maps864)) outer-maps866))))))))))) (gen-syntax834 (lambda (src869 e870 r871 maps872 ellipsis?873) (if (id?67 e870) (let ((label874 (id-var-name89 e870 (quote (()))))) (let ((b875 (lookup64 label874 r871))) (if (eq? (binding-type59 b875) (quote syntax)) (call-with-values (lambda () (let ((var.lev876 (binding-value60 b875))) (gen-ref835 src869 (car var.lev876) (cdr var.lev876) maps872))) (lambda (var877 maps878) (values (list (quote ref) var877) maps878))) (if (ellipsis?873 e870) (syntax-error src869 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e870) maps872))))) ((lambda (tmp879) ((lambda (tmp880) (if (if tmp880 (apply (lambda (dots881 e882) (ellipsis?873 dots881)) tmp880) (quote #f)) (apply (lambda (dots883 e884) (gen-syntax834 src869 e884 r871 maps872 (lambda (x885) (quote #f)))) tmp880) ((lambda (tmp886) (if (if tmp886 (apply (lambda (x887 dots888 y889) (ellipsis?873 dots888)) tmp886) (quote #f)) (apply (lambda (x890 dots891 y892) (let f893 ((y894 y892) (k895 (lambda (maps896) (call-with-values (lambda () (gen-syntax834 src869 x890 r871 (cons (quote ()) maps896) ellipsis?873)) (lambda (x897 maps898) (if (null? (car maps898)) (syntax-error src869 (quote "extra ellipsis in syntax form")) (values (gen-map837 x897 (car maps898)) (cdr maps898)))))))) ((lambda (tmp899) ((lambda (tmp900) (if (if tmp900 (apply (lambda (dots901 y902) (ellipsis?873 dots901)) tmp900) (quote #f)) (apply (lambda (dots903 y904) (f893 y904 (lambda (maps905) (call-with-values (lambda () (k895 (cons (quote ()) maps905))) (lambda (x906 maps907) (if (null? (car maps907)) (syntax-error src869 (quote "extra ellipsis in syntax form")) (values (gen-mappend836 x906 (car maps907)) (cdr maps907)))))))) tmp900) ((lambda (_908) (call-with-values (lambda () (gen-syntax834 src869 y894 r871 maps872 ellipsis?873)) (lambda (y909 maps910) (call-with-values (lambda () (k895 maps910)) (lambda (x911 maps912) (values (gen-append839 x911 y909) maps912)))))) tmp899))) (syntax-dispatch tmp899 (quote (any . any))))) y894))) tmp886) ((lambda (tmp913) (if tmp913 (apply (lambda (x914 y915) (call-with-values (lambda () (gen-syntax834 src869 x914 r871 maps872 ellipsis?873)) (lambda (x916 maps917) (call-with-values (lambda () (gen-syntax834 src869 y915 r871 maps917 ellipsis?873)) (lambda (y918 maps919) (values (gen-cons838 x916 y918) maps919)))))) tmp913) ((lambda (tmp920) (if tmp920 (apply (lambda (e1921 e2922) (call-with-values (lambda () (gen-syntax834 src869 (cons e1921 e2922) r871 maps872 ellipsis?873)) (lambda (e924 maps925) (values (gen-vector840 e924) maps925)))) tmp920) ((lambda (_926) (values (list (quote quote) e870) maps872)) tmp879))) (syntax-dispatch tmp879 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp879 (quote (any . any)))))) (syntax-dispatch tmp879 (quote (any any . any)))))) (syntax-dispatch tmp879 (quote (any any))))) e870))))) (lambda (e927 r928 w929 s930) (let ((e931 (source-wrap96 e927 w929 s930))) ((lambda (tmp932) ((lambda (tmp933) (if tmp933 (apply (lambda (_934 x935) (call-with-values (lambda () (gen-syntax834 e931 x935 r928 (quote ()) ellipsis?112)) (lambda (e936 maps937) (regen841 e936)))) tmp933) ((lambda (_938) (syntax-error e931)) tmp932))) (syntax-dispatch tmp932 (quote (any any))))) e931))))) (global-extend65 (quote core) (quote lambda) (lambda (e939 r940 w941 s942) ((lambda (tmp943) ((lambda (tmp944) (if tmp944 (apply (lambda (_945 c946) (chi-lambda-clause108 (source-wrap96 e939 w941 s942) c946 r940 w941 (lambda (vars947 body948) (list (quote lambda) vars947 body948)))) tmp944) (syntax-error tmp943))) (syntax-dispatch tmp943 (quote (any . any))))) e939))) (global-extend65 (quote core) (quote let) (letrec ((chi-let949 (lambda (e950 r951 w952 s953 constructor954 ids955 vals956 exps957) (if (not (valid-bound-ids?92 ids955)) (syntax-error e950 (quote "duplicate bound variable in")) (let ((labels958 (gen-labels73 ids955)) (new-vars959 (map gen-var115 ids955))) (let ((nw960 (make-binding-wrap84 ids955 labels958 w952)) (nr961 (extend-var-env62 labels958 new-vars959 r951))) (constructor954 s953 new-vars959 (map (lambda (x962) (chi103 x962 r951 w952)) vals956) (chi-body107 exps957 (source-wrap96 e950 nw960 s953) nr961 nw960)))))))) (lambda (e963 r964 w965 s966) ((lambda (tmp967) ((lambda (tmp968) (if tmp968 (apply (lambda (_969 id970 val971 e1972 e2973) (chi-let949 e963 r964 w965 s966 build-let49 id970 val971 (cons e1972 e2973))) tmp968) ((lambda (tmp977) (if (if tmp977 (apply (lambda (_978 f979 id980 val981 e1982 e2983) (id?67 f979)) tmp977) (quote #f)) (apply (lambda (_984 f985 id986 val987 e1988 e2989) (chi-let949 e963 r964 w965 s966 build-named-let50 (cons f985 id986) val987 (cons e1988 e2989))) tmp977) ((lambda (_993) (syntax-error (source-wrap96 e963 w965 s966))) tmp967))) (syntax-dispatch tmp967 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp967 (quote (any #(each (any any)) any . each-any))))) e963)))) (global-extend65 (quote core) (quote letrec) (lambda (e994 r995 w996 s997) ((lambda (tmp998) ((lambda (tmp999) (if tmp999 (apply (lambda (_1000 id1001 val1002 e11003 e21004) (let ((ids1005 id1001)) (if (not (valid-bound-ids?92 ids1005)) (syntax-error e994 (quote "duplicate bound variable in")) (let ((labels1007 (gen-labels73 ids1005)) (new-vars1008 (map gen-var115 ids1005))) (let ((w1009 (make-binding-wrap84 ids1005 labels1007 w996)) (r1010 (extend-var-env62 labels1007 new-vars1008 r995))) (build-letrec51 s997 new-vars1008 (map (lambda (x1011) (chi103 x1011 r1010 w1009)) val1002) (chi-body107 (cons e11003 e21004) (source-wrap96 e994 w1009 s997) r1010 w1009))))))) tmp999) ((lambda (_1014) (syntax-error (source-wrap96 e994 w996 s997))) tmp998))) (syntax-dispatch tmp998 (quote (any #(each (any any)) any . each-any))))) e994))) (global-extend65 (quote core) (quote set!) (lambda (e1015 r1016 w1017 s1018) ((lambda (tmp1019) ((lambda (tmp1020) (if (if tmp1020 (apply (lambda (_1021 id1022 val1023) (id?67 id1022)) tmp1020) (quote #f)) (apply (lambda (_1024 id1025 val1026) (let ((val1027 (chi103 val1026 r1016 w1017)) (n1028 (id-var-name89 id1025 w1017))) (let ((b1029 (lookup64 n1028 r1016))) (let ((t1030 (binding-type59 b1029))) (if (memv t1030 (quote (lexical))) (list (quote set!) (binding-value60 b1029) val1027) (if (memv t1030 (quote (global))) (list (quote set!) n1028 val1027) (if (memv t1030 (quote (displaced-lexical))) (syntax-error (wrap95 id1025 w1017) (quote "identifier out of context")) (syntax-error (source-wrap96 e1015 w1017 s1018))))))))) tmp1020) ((lambda (tmp1031) (if tmp1031 (apply (lambda (_1032 getter1033 arg1034 val1035) (cons (chi103 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) getter1033) r1016 w1017) (map (lambda (e1036) (chi103 e1036 r1016 w1017)) (append arg1034 (list val1035))))) tmp1031) ((lambda (_1038) (syntax-error (source-wrap96 e1015 w1017 s1018))) tmp1019))) (syntax-dispatch tmp1019 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp1019 (quote (any any any))))) e1015))) (global-extend65 (quote begin) (quote begin) (quote ())) (global-extend65 (quote define) (quote define) (quote ())) (global-extend65 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend65 (quote eval-when) (quote eval-when) (quote ())) (global-extend65 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1042 (lambda (x1043 keys1044 clauses1045 r1046) (if (null? clauses1045) (list (quote syntax-error) x1043) ((lambda (tmp1047) ((lambda (tmp1048) (if tmp1048 (apply (lambda (pat1049 exp1050) (if (and (id?67 pat1049) (andmap (lambda (x1051) (not (free-id=?90 pat1049 x1051))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys1044))) (let ((labels1052 (list (gen-label72))) (var1053 (gen-var115 pat1049))) (list (list (quote lambda) (list var1053) (chi103 exp1050 (extend-env61 labels1052 (list (cons (quote syntax) (cons var1053 (quote 0)))) r1046) (make-binding-wrap84 (list pat1049) labels1052 (quote (()))))) x1043)) (gen-clause1041 x1043 keys1044 (cdr clauses1045) r1046 pat1049 (quote #t) exp1050))) tmp1048) ((lambda (tmp1054) (if tmp1054 (apply (lambda (pat1055 fender1056 exp1057) (gen-clause1041 x1043 keys1044 (cdr clauses1045) r1046 pat1055 fender1056 exp1057)) tmp1054) ((lambda (_1058) (syntax-error (car clauses1045) (quote "invalid syntax-case clause"))) tmp1047))) (syntax-dispatch tmp1047 (quote (any any any)))))) (syntax-dispatch tmp1047 (quote (any any))))) (car clauses1045))))) (gen-clause1041 (lambda (x1059 keys1060 clauses1061 r1062 pat1063 fender1064 exp1065) (call-with-values (lambda () (convert-pattern1039 pat1063 keys1060)) (lambda (p1066 pvars1067) (cond ((not (distinct-bound-ids?93 (map car pvars1067))) (syntax-error pat1063 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x1068) (not (ellipsis?112 (car x1068)))) pvars1067)) (syntax-error pat1063 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y1069 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list y1069) (let ((y1070 y1069)) (list (quote if) ((lambda (tmp1071) ((lambda (tmp1072) (if tmp1072 (apply (lambda () y1070) tmp1072) ((lambda (_1073) (list (quote if) y1070 (build-dispatch-call1040 pvars1067 fender1064 y1070 r1062) (list (quote quote) (quote #f)))) tmp1071))) (syntax-dispatch tmp1071 (quote #(atom #t))))) fender1064) (build-dispatch-call1040 pvars1067 exp1065 y1070 r1062) (gen-syntax-case1042 x1059 keys1060 clauses1061 r1062)))) (if (eq? p1066 (quote any)) (list (quote list) x1059) (list (quote syntax-dispatch) x1059 (list (quote quote) p1066))))))))))) (build-dispatch-call1040 (lambda (pvars1074 exp1075 y1076 r1077) (let ((ids1078 (map car pvars1074)) (levels1079 (map cdr pvars1074))) (let ((labels1080 (gen-labels73 ids1078)) (new-vars1081 (map gen-var115 ids1078))) (list (quote apply) (list (quote lambda) new-vars1081 (chi103 exp1075 (extend-env61 labels1080 (map (lambda (var1082 level1083) (cons (quote syntax) (cons var1082 level1083))) new-vars1081 (map cdr pvars1074)) r1077) (make-binding-wrap84 ids1078 labels1080 (quote (()))))) y1076))))) (convert-pattern1039 (lambda (pattern1084 keys1085) (let cvt1086 ((p1087 pattern1084) (n1088 (quote 0)) (ids1089 (quote ()))) (if (id?67 p1087) (if (bound-id-member?94 p1087 keys1085) (values (vector (quote free-id) p1087) ids1089) (values (quote any) (cons (cons p1087 n1088) ids1089))) ((lambda (tmp1090) ((lambda (tmp1091) (if (if tmp1091 (apply (lambda (x1092 dots1093) (ellipsis?112 dots1093)) tmp1091) (quote #f)) (apply (lambda (x1094 dots1095) (call-with-values (lambda () (cvt1086 x1094 (fx+38 n1088 (quote 1)) ids1089)) (lambda (p1096 ids1097) (values (if (eq? p1096 (quote any)) (quote each-any) (vector (quote each) p1096)) ids1097)))) tmp1091) ((lambda (tmp1098) (if tmp1098 (apply (lambda (x1099 y1100) (call-with-values (lambda () (cvt1086 y1100 n1088 ids1089)) (lambda (y1101 ids1102) (call-with-values (lambda () (cvt1086 x1099 n1088 ids1102)) (lambda (x1103 ids1104) (values (cons x1103 y1101) ids1104)))))) tmp1098) ((lambda (tmp1105) (if tmp1105 (apply (lambda () (values (quote ()) ids1089)) tmp1105) ((lambda (tmp1106) (if tmp1106 (apply (lambda (x1107) (call-with-values (lambda () (cvt1086 x1107 n1088 ids1089)) (lambda (p1109 ids1110) (values (vector (quote vector) p1109) ids1110)))) tmp1106) ((lambda (x1111) (values (vector (quote atom) (strip114 p1087 (quote (())))) ids1089)) tmp1090))) (syntax-dispatch tmp1090 (quote #(vector each-any)))))) (syntax-dispatch tmp1090 (quote ()))))) (syntax-dispatch tmp1090 (quote (any . any)))))) (syntax-dispatch tmp1090 (quote (any any))))) p1087)))))) (lambda (e1112 r1113 w1114 s1115) (let ((e1116 (source-wrap96 e1112 w1114 s1115))) ((lambda (tmp1117) ((lambda (tmp1118) (if tmp1118 (apply (lambda (_1119 val1120 key1121 m1122) (if (andmap (lambda (x1123) (and (id?67 x1123) (not (ellipsis?112 x1123)))) key1121) (let ((x1125 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list x1125) (gen-syntax-case1042 x1125 key1121 m1122 r1113)) (chi103 val1120 r1113 (quote (()))))) (syntax-error e1116 (quote "invalid literals list in")))) tmp1118) (syntax-error tmp1117))) (syntax-dispatch tmp1117 (quote (any any each-any . each-any))))) e1116))))) (set! sc-expand (let ((m1128 (quote e)) (esew1129 (quote (eval)))) (lambda (x1130) (if (and (pair? x1130) (equal? (car x1130) noexpand37)) (cadr x1130) (chi-top102 x1130 (quote ()) (quote ((top))) m1128 esew1129))))) (set! sc-expand3 (let ((m1131 (quote e)) (esew1132 (quote (eval)))) (lambda (x1134 . rest1133) (if (and (pair? x1134) (equal? (car x1134) noexpand37)) (cadr x1134) (chi-top102 x1134 (quote ()) (quote ((top))) (if (null? rest1133) m1131 (car rest1133)) (if (or (null? rest1133) (null? (cdr rest1133))) esew1132 (cadr rest1133))))))) (set! identifier? (lambda (x1135) (nonsymbol-id?66 x1135))) (set! datum->syntax-object (lambda (id1136 datum1137) (begin (let ((x1138 id1136)) (if (not (nonsymbol-id?66 x1138)) (error-hook45 (quote datum->syntax-object) (quote "invalid argument") x1138))) (make-syntax-object52 datum1137 (syntax-object-wrap55 id1136))))) (set! syntax-object->datum (lambda (x1139) (strip114 x1139 (quote (()))))) (set! generate-temporaries (lambda (ls1140) (begin (let ((x1141 ls1140)) (if (not (list? x1141)) (error-hook45 (quote generate-temporaries) (quote "invalid argument") x1141))) (map (lambda (x1142) (wrap95 (gensym) (quote ((top))))) ls1140)))) (set! free-identifier=? (lambda (x1143 y1144) (begin (let ((x1145 x1143)) (if (not (nonsymbol-id?66 x1145)) (error-hook45 (quote free-identifier=?) (quote "invalid argument") x1145))) (let ((x1146 y1144)) (if (not (nonsymbol-id?66 x1146)) (error-hook45 (quote free-identifier=?) (quote "invalid argument") x1146))) (free-id=?90 x1143 y1144)))) (set! bound-identifier=? (lambda (x1147 y1148) (begin (let ((x1149 x1147)) (if (not (nonsymbol-id?66 x1149)) (error-hook45 (quote bound-identifier=?) (quote "invalid argument") x1149))) (let ((x1150 y1148)) (if (not (nonsymbol-id?66 x1150)) (error-hook45 (quote bound-identifier=?) (quote "invalid argument") x1150))) (bound-id=?91 x1147 y1148)))) (set! syntax-error (lambda (object1152 . messages1151) (begin (for-each (lambda (x1153) (let ((x1154 x1153)) (if (not (string? x1154)) (error-hook45 (quote syntax-error) (quote "invalid argument") x1154)))) messages1151) (let ((message1155 (if (null? messages1151) (quote "invalid syntax") (apply string-append messages1151)))) (error-hook45 (quote #f) message1155 (strip114 object1152 (quote (())))))))) (set! install-global-transformer (lambda (sym1156 v1157) (begin (let ((x1158 sym1156)) (if (not (symbol? x1158)) (error-hook45 (quote define-syntax) (quote "invalid argument") x1158))) (let ((x1159 v1157)) (if (not (procedure? x1159)) (error-hook45 (quote define-syntax) (quote "invalid argument") x1159))) (global-extend65 (quote macro) sym1156 v1157)))) (letrec ((match1164 (lambda (e1165 p1166 w1167 r1168) (cond ((not r1168) (quote #f)) ((eq? p1166 (quote any)) (cons (wrap95 e1165 w1167) r1168)) ((syntax-object?53 e1165) (match*1163 (let ((e1169 (syntax-object-expression54 e1165))) (if (annotation?42 e1169) (annotation-expression e1169) e1169)) p1166 (join-wraps86 w1167 (syntax-object-wrap55 e1165)) r1168)) (else (match*1163 (let ((e1170 e1165)) (if (annotation?42 e1170) (annotation-expression e1170) e1170)) p1166 w1167 r1168))))) (match*1163 (lambda (e1171 p1172 w1173 r1174) (cond ((null? p1172) (and (null? e1171) r1174)) ((pair? p1172) (and (pair? e1171) (match1164 (car e1171) (car p1172) w1173 (match1164 (cdr e1171) (cdr p1172) w1173 r1174)))) ((eq? p1172 (quote each-any)) (let ((l1175 (match-each-any1161 e1171 w1173))) (and l1175 (cons l1175 r1174)))) (else (let ((t1176 (vector-ref p1172 (quote 0)))) (if (memv t1176 (quote (each))) (if (null? e1171) (match-empty1162 (vector-ref p1172 (quote 1)) r1174) (let ((l1177 (match-each1160 e1171 (vector-ref p1172 (quote 1)) w1173))) (and l1177 (let collect1178 ((l1179 l1177)) (if (null? (car l1179)) r1174 (cons (map car l1179) (collect1178 (map cdr l1179)))))))) (if (memv t1176 (quote (free-id))) (and (id?67 e1171) (free-id=?90 (wrap95 e1171 w1173) (vector-ref p1172 (quote 1))) r1174) (if (memv t1176 (quote (atom))) (and (equal? (vector-ref p1172 (quote 1)) (strip114 e1171 w1173)) r1174) (if (memv t1176 (quote (vector))) (and (vector? e1171) (match1164 (vector->list e1171) (vector-ref p1172 (quote 1)) w1173 r1174))))))))))) (match-empty1162 (lambda (p1180 r1181) (cond ((null? p1180) r1181) ((eq? p1180 (quote any)) (cons (quote ()) r1181)) ((pair? p1180) (match-empty1162 (car p1180) (match-empty1162 (cdr p1180) r1181))) ((eq? p1180 (quote each-any)) (cons (quote ()) r1181)) (else (let ((t1182 (vector-ref p1180 (quote 0)))) (if (memv t1182 (quote (each))) (match-empty1162 (vector-ref p1180 (quote 1)) r1181) (if (memv t1182 (quote (free-id atom))) r1181 (if (memv t1182 (quote (vector))) (match-empty1162 (vector-ref p1180 (quote 1)) r1181))))))))) (match-each-any1161 (lambda (e1183 w1184) (cond ((annotation?42 e1183) (match-each-any1161 (annotation-expression e1183) w1184)) ((pair? e1183) (let ((l1185 (match-each-any1161 (cdr e1183) w1184))) (and l1185 (cons (wrap95 (car e1183) w1184) l1185)))) ((null? e1183) (quote ())) ((syntax-object?53 e1183) (match-each-any1161 (syntax-object-expression54 e1183) (join-wraps86 w1184 (syntax-object-wrap55 e1183)))) (else (quote #f))))) (match-each1160 (lambda (e1186 p1187 w1188) (cond ((annotation?42 e1186) (match-each1160 (annotation-expression e1186) p1187 w1188)) ((pair? e1186) (let ((first1189 (match1164 (car e1186) p1187 w1188 (quote ())))) (and first1189 (let ((rest1190 (match-each1160 (cdr e1186) p1187 w1188))) (and rest1190 (cons first1189 rest1190)))))) ((null? e1186) (quote ())) ((syntax-object?53 e1186) (match-each1160 (syntax-object-expression54 e1186) p1187 (join-wraps86 w1188 (syntax-object-wrap55 e1186)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e1191 p1192) (cond ((eq? p1192 (quote any)) (list e1191)) ((syntax-object?53 e1191) (match*1163 (let ((e1193 (syntax-object-expression54 e1191))) (if (annotation?42 e1193) (annotation-expression e1193) e1193)) p1192 (syntax-object-wrap55 e1191) (quote ()))) (else (match*1163 (let ((e1194 e1191)) (if (annotation?42 e1194) (annotation-expression e1194) e1194)) p1192 (quote (())) (quote ()))))))))) -(install-global-transformer (quote with-syntax) (lambda (x1195) ((lambda (tmp1196) ((lambda (tmp1197) (if tmp1197 (apply (lambda (_1198 e11199 e21200) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11199 e21200))) tmp1197) ((lambda (tmp1202) (if tmp1202 (apply (lambda (_1203 out1204 in1205 e11206 e21207) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in1205 (quote ()) (list out1204 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11206 e21207))))) tmp1202) ((lambda (tmp1209) (if tmp1209 (apply (lambda (_1210 out1211 in1212 e11213 e21214) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in1212) (quote ()) (list out1211 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11213 e21214))))) tmp1209) (syntax-error tmp1196))) (syntax-dispatch tmp1196 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp1196 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp1196 (quote (any () any . each-any))))) x1195))) -(install-global-transformer (quote syntax-rules) (lambda (x1218) ((lambda (tmp1219) ((lambda (tmp1220) (if tmp1220 (apply (lambda (_1221 k1222 keyword1223 pattern1224 template1225) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons k1222 (map (lambda (tmp1228 tmp1227) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1227) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1228))) template1225 pattern1224)))))) tmp1220) (syntax-error tmp1219))) (syntax-dispatch tmp1219 (quote (any each-any . #(each ((any . any) any))))))) x1218))) -(install-global-transformer (quote let*) (lambda (x1229) ((lambda (tmp1230) ((lambda (tmp1231) (if (if tmp1231 (apply (lambda (let*1232 x1233 v1234 e11235 e21236) (andmap identifier? x1233)) tmp1231) (quote #f)) (apply (lambda (let*1238 x1239 v1240 e11241 e21242) (let f1243 ((bindings1244 (map list x1239 v1240))) (if (null? bindings1244) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons e11241 e21242))) ((lambda (tmp1248) ((lambda (tmp1249) (if tmp1249 (apply (lambda (body1250 binding1251) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list binding1251) body1250)) tmp1249) (syntax-error tmp1248))) (syntax-dispatch tmp1248 (quote (any any))))) (list (f1243 (cdr bindings1244)) (car bindings1244)))))) tmp1231) (syntax-error tmp1230))) (syntax-dispatch tmp1230 (quote (any #(each (any any)) any . each-any))))) x1229))) -(install-global-transformer (quote do) (lambda (orig-x1252) ((lambda (tmp1253) ((lambda (tmp1254) (if tmp1254 (apply (lambda (_1255 var1256 init1257 step1258 e01259 e11260 c1261) ((lambda (tmp1262) ((lambda (tmp1263) (if tmp1263 (apply (lambda (step1264) ((lambda (tmp1265) ((lambda (tmp1266) (if tmp1266 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var1256 init1257) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e01259) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c1261 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step1264))))))) tmp1266) ((lambda (tmp1271) (if tmp1271 (apply (lambda (e11272 e21273) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var1256 init1257) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e01259 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons e11272 e21273)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c1261 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step1264))))))) tmp1271) (syntax-error tmp1265))) (syntax-dispatch tmp1265 (quote (any . each-any)))))) (syntax-dispatch tmp1265 (quote ())))) e11260)) tmp1263) (syntax-error tmp1262))) (syntax-dispatch tmp1262 (quote each-any)))) (map (lambda (v1280 s1281) ((lambda (tmp1282) ((lambda (tmp1283) (if tmp1283 (apply (lambda () v1280) tmp1283) ((lambda (tmp1284) (if tmp1284 (apply (lambda (e1285) e1285) tmp1284) ((lambda (_1286) (syntax-error orig-x1252)) tmp1282))) (syntax-dispatch tmp1282 (quote (any)))))) (syntax-dispatch tmp1282 (quote ())))) s1281)) var1256 step1258))) tmp1254) (syntax-error tmp1253))) (syntax-dispatch tmp1253 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1252))) -(install-global-transformer (quote quasiquote) (letrec ((quasicons1289 (lambda (x1293 y1294) ((lambda (tmp1295) ((lambda (tmp1296) (if tmp1296 (apply (lambda (x1297 y1298) ((lambda (tmp1299) ((lambda (tmp1300) (if tmp1300 (apply (lambda (dy1301) ((lambda (tmp1302) ((lambda (tmp1303) (if tmp1303 (apply (lambda (dx1304) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons dx1304 dy1301))) tmp1303) ((lambda (_1305) (if (null? dy1301) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1297) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1297 y1298))) tmp1302))) (syntax-dispatch tmp1302 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) x1297)) tmp1300) ((lambda (tmp1306) (if tmp1306 (apply (lambda (stuff1307) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons x1297 stuff1307))) tmp1306) ((lambda (else1308) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1297 y1298)) tmp1299))) (syntax-dispatch tmp1299 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch tmp1299 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) y1298)) tmp1296) (syntax-error tmp1295))) (syntax-dispatch tmp1295 (quote (any any))))) (list x1293 y1294)))) (quasiappend1290 (lambda (x1309 y1310) ((lambda (tmp1311) ((lambda (tmp1312) (if tmp1312 (apply (lambda (x1313 y1314) ((lambda (tmp1315) ((lambda (tmp1316) (if tmp1316 (apply (lambda () x1313) tmp1316) ((lambda (_1317) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1313 y1314)) tmp1315))) (syntax-dispatch tmp1315 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) y1314)) tmp1312) (syntax-error tmp1311))) (syntax-dispatch tmp1311 (quote (any any))))) (list x1309 y1310)))) (quasivector1291 (lambda (x1318) ((lambda (tmp1319) ((lambda (x1320) ((lambda (tmp1321) ((lambda (tmp1322) (if tmp1322 (apply (lambda (x1323) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector x1323))) tmp1322) ((lambda (tmp1325) (if tmp1325 (apply (lambda (x1326) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1326)) tmp1325) ((lambda (_1328) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1320)) tmp1321))) (syntax-dispatch tmp1321 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch tmp1321 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) x1320)) tmp1319)) x1318))) (quasi1292 (lambda (p1329 lev1330) ((lambda (tmp1331) ((lambda (tmp1332) (if tmp1332 (apply (lambda (p1333) (if (= lev1330 (quote 0)) p1333 (quasicons1289 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi1292 (list p1333) (- lev1330 (quote 1)))))) tmp1332) ((lambda (tmp1334) (if tmp1334 (apply (lambda (p1335 q1336) (if (= lev1330 (quote 0)) (quasiappend1290 p1335 (quasi1292 q1336 lev1330)) (quasicons1289 (quasicons1289 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi1292 (list p1335) (- lev1330 (quote 1)))) (quasi1292 q1336 lev1330)))) tmp1334) ((lambda (tmp1337) (if tmp1337 (apply (lambda (p1338) (quasicons1289 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi1292 (list p1338) (+ lev1330 (quote 1))))) tmp1337) ((lambda (tmp1339) (if tmp1339 (apply (lambda (p1340 q1341) (quasicons1289 (quasi1292 p1340 lev1330) (quasi1292 q1341 lev1330))) tmp1339) ((lambda (tmp1342) (if tmp1342 (apply (lambda (x1343) (quasivector1291 (quasi1292 x1343 lev1330))) tmp1342) ((lambda (p1345) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) p1345)) tmp1331))) (syntax-dispatch tmp1331 (quote #(vector each-any)))))) (syntax-dispatch tmp1331 (quote (any . any)))))) (syntax-dispatch tmp1331 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch tmp1331 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch tmp1331 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) p1329)))) (lambda (x1346) ((lambda (tmp1347) ((lambda (tmp1348) (if tmp1348 (apply (lambda (_1349 e1350) (quasi1292 e1350 (quote 0))) tmp1348) (syntax-error tmp1347))) (syntax-dispatch tmp1347 (quote (any any))))) x1346)))) -(install-global-transformer (quote include) (lambda (x1351) (letrec ((read-file1352 (lambda (fn1353 k1354) (let ((p1355 (open-input-file fn1353))) (let f1356 ((x1357 (read p1355))) (if (eof-object? x1357) (begin (close-input-port p1355) (quote ())) (cons (datum->syntax-object k1354 x1357) (f1356 (read p1355))))))))) ((lambda (tmp1358) ((lambda (tmp1359) (if tmp1359 (apply (lambda (k1360 filename1361) (let ((fn1362 (syntax-object->datum filename1361))) ((lambda (tmp1363) ((lambda (tmp1364) (if tmp1364 (apply (lambda (exp1365) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) exp1365)) tmp1364) (syntax-error tmp1363))) (syntax-dispatch tmp1363 (quote each-any)))) (read-file1352 fn1362 k1360)))) tmp1359) (syntax-error tmp1358))) (syntax-dispatch tmp1358 (quote (any any))))) x1351)))) -(install-global-transformer (quote unquote) (lambda (x1367) ((lambda (tmp1368) ((lambda (tmp1369) (if tmp1369 (apply (lambda (_1370 e1371) (error (quote unquote) (quote "expression ,~s not valid outside of quasiquote") (syntax-object->datum e1371))) tmp1369) (syntax-error tmp1368))) (syntax-dispatch tmp1368 (quote (any any))))) x1367))) -(install-global-transformer (quote unquote-splicing) (lambda (x1372) ((lambda (tmp1373) ((lambda (tmp1374) (if tmp1374 (apply (lambda (_1375 e1376) (error (quote unquote-splicing) (quote "expression ,@~s not valid outside of quasiquote") (syntax-object->datum e1376))) tmp1374) (syntax-error tmp1373))) (syntax-dispatch tmp1373 (quote (any any))))) x1372))) -(install-global-transformer (quote case) (lambda (x1377) ((lambda (tmp1378) ((lambda (tmp1379) (if tmp1379 (apply (lambda (_1380 e1381 m11382 m21383) ((lambda (tmp1384) ((lambda (body1385) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1381)) body1385)) tmp1384)) (let f1386 ((clause1387 m11382) (clauses1388 m21383)) (if (null? clauses1388) ((lambda (tmp1390) ((lambda (tmp1391) (if tmp1391 (apply (lambda (e11392 e21393) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11392 e21393))) tmp1391) ((lambda (tmp1395) (if tmp1395 (apply (lambda (k1396 e11397 e21398) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1396)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11397 e21398)))) tmp1395) ((lambda (_1401) (syntax-error x1377)) tmp1390))) (syntax-dispatch tmp1390 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1390 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) clause1387) ((lambda (tmp1402) ((lambda (rest1403) ((lambda (tmp1404) ((lambda (tmp1405) (if tmp1405 (apply (lambda (k1406 e11407 e21408) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1406)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11407 e21408)) rest1403)) tmp1405) ((lambda (_1411) (syntax-error x1377)) tmp1404))) (syntax-dispatch tmp1404 (quote (each-any any . each-any))))) clause1387)) tmp1402)) (f1386 (car clauses1388) (cdr clauses1388))))))) tmp1379) (syntax-error tmp1378))) (syntax-dispatch tmp1378 (quote (any any any . each-any))))) x1377))) -(install-global-transformer (quote identifier-syntax) (lambda (x1412) ((lambda (tmp1413) ((lambda (tmp1414) (if tmp1414 (apply (lambda (_1415 e1416) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1416)) (list (cons _1415 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1416 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) tmp1414) (syntax-error tmp1413))) (syntax-dispatch tmp1413 (quote (any any))))) x1412))) +(letrec ((lambda-var-list116 (lambda (vars323) (let lvl324 ((vars325 vars323) (ls326 (quote ())) (w327 (quote (())))) (cond ((pair? vars325) (lvl324 (cdr vars325) (cons (wrap95 (car vars325) w327) ls326) w327)) ((id?67 vars325) (cons (wrap95 vars325 w327) ls326)) ((null? vars325) ls326) ((syntax-object?53 vars325) (lvl324 (syntax-object-expression54 vars325) ls326 (join-wraps86 w327 (syntax-object-wrap55 vars325)))) ((annotation?42 vars325) (lvl324 (annotation-expression vars325) ls326 w327)) (else (cons vars325 ls326)))))) (gen-var115 (lambda (id328) (let ((id329 (if (syntax-object?53 id328) (syntax-object-expression54 id328) id328))) (if (annotation?42 id329) (gensym (symbol->string (annotation-expression id329))) (gensym (symbol->string id329)))))) (strip114 (lambda (x330 w331) (if (memq (quote top) (wrap-marks70 w331)) (if (or (annotation?42 x330) (and (pair? x330) (annotation?42 (car x330)))) (strip-annotation113 x330 (quote #f)) x330) (let f332 ((x333 x330)) (cond ((syntax-object?53 x333) (strip114 (syntax-object-expression54 x333) (syntax-object-wrap55 x333))) ((pair? x333) (let ((a334 (f332 (car x333))) (d335 (f332 (cdr x333)))) (if (and (eq? a334 (car x333)) (eq? d335 (cdr x333))) x333 (cons a334 d335)))) ((vector? x333) (let ((old336 (vector->list x333))) (let ((new337 (map f332 old336))) (if (andmap eq? old336 new337) x333 (list->vector new337))))) (else x333)))))) (strip-annotation113 (lambda (x338 parent339) (cond ((pair? x338) (let ((new340 (cons (quote #f) (quote #f)))) (begin (when parent339 (set-annotation-stripped! parent339 new340)) (set-car! new340 (strip-annotation113 (car x338) (quote #f))) (set-cdr! new340 (strip-annotation113 (cdr x338) (quote #f))) new340))) ((annotation?42 x338) (or (annotation-stripped x338) (strip-annotation113 (annotation-expression x338) x338))) ((vector? x338) (let ((new341 (make-vector (vector-length x338)))) (begin (when parent339 (set-annotation-stripped! parent339 new341)) (let loop342 ((i343 (- (vector-length x338) (quote 1)))) (unless (fx<41 i343 (quote 0)) (vector-set! new341 i343 (strip-annotation113 (vector-ref x338 i343) (quote #f))) (loop342 (fx-39 i343 (quote 1))))) new341))) (else x338)))) (ellipsis?112 (lambda (x344) (and (nonsymbol-id?66 x344) (free-id=?90 x344 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (chi-void111 (lambda () (list (quote void)))) (eval-local-transformer110 (lambda (expanded345) (let ((p346 (local-eval-hook44 expanded345))) (if (procedure? p346) p346 (syntax-error p346 (quote "nonprocedure transfomer")))))) (chi-local-syntax109 (lambda (rec?347 e348 r349 w350 s351 k352) ((lambda (tmp353) ((lambda (tmp354) (if tmp354 (apply (lambda (_355 id356 val357 e1358 e2359) (let ((ids360 id356)) (if (not (valid-bound-ids?92 ids360)) (syntax-error e348 (quote "duplicate bound keyword in")) (let ((labels362 (gen-labels73 ids360))) (let ((new-w363 (make-binding-wrap84 ids360 labels362 w350))) (k352 (cons e1358 e2359) (extend-env61 labels362 (let ((w365 (if rec?347 new-w363 w350)) (trans-r366 (macros-only-env63 r349))) (map (lambda (x367) (cons (quote macro) (eval-local-transformer110 (chi103 x367 trans-r366 w365)))) val357)) r349) new-w363 s351)))))) tmp354) ((lambda (_369) (syntax-error (source-wrap96 e348 w350 s351))) tmp353))) (syntax-dispatch tmp353 (quote (any #(each (any any)) any . each-any))))) e348))) (chi-lambda-clause108 (lambda (e370 c371 r372 w373 k374) ((lambda (tmp375) ((lambda (tmp376) (if tmp376 (apply (lambda (id377 e1378 e2379) (let ((ids380 id377)) (if (not (valid-bound-ids?92 ids380)) (syntax-error e370 (quote "invalid parameter list in")) (let ((labels382 (gen-labels73 ids380)) (new-vars383 (map gen-var115 ids380))) (k374 new-vars383 (chi-body107 (cons e1378 e2379) e370 (extend-var-env62 labels382 new-vars383 r372) (make-binding-wrap84 ids380 labels382 w373))))))) tmp376) ((lambda (tmp385) (if tmp385 (apply (lambda (ids386 e1387 e2388) (let ((old-ids389 (lambda-var-list116 ids386))) (if (not (valid-bound-ids?92 old-ids389)) (syntax-error e370 (quote "invalid parameter list in")) (let ((labels390 (gen-labels73 old-ids389)) (new-vars391 (map gen-var115 old-ids389))) (k374 (let f392 ((ls1393 (cdr new-vars391)) (ls2394 (car new-vars391))) (if (null? ls1393) ls2394 (f392 (cdr ls1393) (cons (car ls1393) ls2394)))) (chi-body107 (cons e1387 e2388) e370 (extend-var-env62 labels390 new-vars391 r372) (make-binding-wrap84 old-ids389 labels390 w373))))))) tmp385) ((lambda (_396) (syntax-error e370)) tmp375))) (syntax-dispatch tmp375 (quote (any any . each-any)))))) (syntax-dispatch tmp375 (quote (each-any any . each-any))))) c371))) (chi-body107 (lambda (body397 outer-form398 r399 w400) (let ((r401 (cons (quote ("placeholder" placeholder)) r399))) (let ((ribcage402 (make-ribcage74 (quote ()) (quote ()) (quote ())))) (let ((w403 (make-wrap69 (wrap-marks70 w400) (cons ribcage402 (wrap-subst71 w400))))) (let parse404 ((body405 (map (lambda (x411) (cons r401 (wrap95 x411 w403))) body397)) (ids406 (quote ())) (labels407 (quote ())) (vars408 (quote ())) (vals409 (quote ())) (bindings410 (quote ()))) (if (null? body405) (syntax-error outer-form398 (quote "no expressions in body")) (let ((e412 (cdar body405)) (er413 (caar body405))) (call-with-values (lambda () (syntax-type101 e412 er413 (quote (())) (quote #f) ribcage402)) (lambda (type414 value415 e416 w417 s418) (let ((t419 type414)) (if (memv t419 (quote (define-form))) (let ((id420 (wrap95 value415 w417)) (label421 (gen-label72))) (let ((var422 (gen-var115 id420))) (begin (extend-ribcage!83 ribcage402 id420 label421) (parse404 (cdr body405) (cons id420 ids406) (cons label421 labels407) (cons var422 vars408) (cons (cons er413 (wrap95 e416 w417)) vals409) (cons (cons (quote lexical) var422) bindings410))))) (if (memv t419 (quote (define-syntax-form))) (let ((id423 (wrap95 value415 w417)) (label424 (gen-label72))) (begin (extend-ribcage!83 ribcage402 id423 label424) (parse404 (cdr body405) (cons id423 ids406) (cons label424 labels407) vars408 vals409 (cons (cons (quote macro) (cons er413 (wrap95 e416 w417))) bindings410)))) (if (memv t419 (quote (begin-form))) ((lambda (tmp425) ((lambda (tmp426) (if tmp426 (apply (lambda (_427 e1428) (parse404 (let f429 ((forms430 e1428)) (if (null? forms430) (cdr body405) (cons (cons er413 (wrap95 (car forms430) w417)) (f429 (cdr forms430))))) ids406 labels407 vars408 vals409 bindings410)) tmp426) (syntax-error tmp425))) (syntax-dispatch tmp425 (quote (any . each-any))))) e416) (if (memv t419 (quote (local-syntax-form))) (chi-local-syntax109 value415 e416 er413 w417 s418 (lambda (forms432 er433 w434 s435) (parse404 (let f436 ((forms437 forms432)) (if (null? forms437) (cdr body405) (cons (cons er433 (wrap95 (car forms437) w434)) (f436 (cdr forms437))))) ids406 labels407 vars408 vals409 bindings410))) (if (null? ids406) (build-sequence48 (quote #f) (map (lambda (x438) (chi103 (cdr x438) (car x438) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417 s418)) (cdr body405)))) (begin (if (not (valid-bound-ids?92 ids406)) (syntax-error outer-form398 (quote "invalid or duplicate identifier in definition"))) (let loop439 ((bs440 bindings410) (er-cache441 (quote #f)) (r-cache442 (quote #f))) (if (not (null? bs440)) (let ((b443 (car bs440))) (if (eq? (car b443) (quote macro)) (let ((er444 (cadr b443))) (let ((r-cache445 (if (eq? er444 er-cache441) r-cache442 (macros-only-env63 er444)))) (begin (set-cdr! b443 (eval-local-transformer110 (chi103 (cddr b443) r-cache445 (quote (()))))) (loop439 (cdr bs440) er444 r-cache445)))) (loop439 (cdr bs440) er-cache441 r-cache442))))) (set-cdr! r401 (extend-env61 labels407 bindings410 (cdr r401))) (build-letrec51 (quote #f) vars408 (map (lambda (x446) (chi103 (cdr x446) (car x446) (quote (())))) vals409) (build-sequence48 (quote #f) (map (lambda (x447) (chi103 (cdr x447) (car x447) (quote (())))) (cons (cons er413 (source-wrap96 e416 w417 s418)) (cdr body405)))))))))))))))))))))) (chi-macro106 (lambda (p448 e449 r450 w451 rib452) (letrec ((rebuild-macro-output453 (lambda (x454 m455) (cond ((pair? x454) (cons (rebuild-macro-output453 (car x454) m455) (rebuild-macro-output453 (cdr x454) m455))) ((syntax-object?53 x454) (let ((w456 (syntax-object-wrap55 x454))) (let ((ms457 (wrap-marks70 w456)) (s458 (wrap-subst71 w456))) (make-syntax-object52 (syntax-object-expression54 x454) (if (and (pair? ms457) (eq? (car ms457) (quote #f))) (make-wrap69 (cdr ms457) (if rib452 (cons rib452 (cdr s458)) (cdr s458))) (make-wrap69 (cons m455 ms457) (if rib452 (cons rib452 (cons (quote shift) s458)) (cons (quote shift) s458)))))))) ((vector? x454) (let ((n459 (vector-length x454))) (let ((v460 (make-vector n459))) (let doloop461 ((i462 (quote 0))) (if (fx=40 i462 n459) v460 (begin (vector-set! v460 i462 (rebuild-macro-output453 (vector-ref x454 i462) m455)) (doloop461 (fx+38 i462 (quote 1))))))))) ((symbol? x454) (syntax-error x454 (quote "encountered raw symbol in macro output"))) (else x454))))) (rebuild-macro-output453 (p448 (wrap95 e449 (anti-mark82 w451))) (string (quote #\m)))))) (chi-application105 (lambda (x463 e464 r465 w466 s467) ((lambda (tmp468) ((lambda (tmp469) (if tmp469 (apply (lambda (e0470 e1471) (cons x463 (map (lambda (e472) (chi103 e472 r465 w466)) e1471))) tmp469) (syntax-error tmp468))) (syntax-dispatch tmp468 (quote (any . each-any))))) e464))) (chi-expr104 (lambda (type474 value475 e476 r477 w478 s479) (let ((t480 type474)) (if (memv t480 (quote (lexical))) value475 (if (memv t480 (quote (core))) (value475 e476 r477 w478 s479) (if (memv t480 (quote (lexical-call))) (chi-application105 value475 e476 r477 w478 s479) (if (memv t480 (quote (global-call))) (chi-application105 value475 e476 r477 w478 s479) (if (memv t480 (quote (constant))) (list (quote quote) (strip114 (source-wrap96 e476 w478 s479) (quote (())))) (if (memv t480 (quote (global))) value475 (if (memv t480 (quote (call))) (chi-application105 (chi103 (car e476) r477 w478) e476 r477 w478 s479) (if (memv t480 (quote (begin-form))) ((lambda (tmp481) ((lambda (tmp482) (if tmp482 (apply (lambda (_483 e1484 e2485) (chi-sequence97 (cons e1484 e2485) r477 w478 s479)) tmp482) (syntax-error tmp481))) (syntax-dispatch tmp481 (quote (any any . each-any))))) e476) (if (memv t480 (quote (local-syntax-form))) (chi-local-syntax109 value475 e476 r477 w478 s479 chi-sequence97) (if (memv t480 (quote (eval-when-form))) ((lambda (tmp487) ((lambda (tmp488) (if tmp488 (apply (lambda (_489 x490 e1491 e2492) (let ((when-list493 (chi-when-list100 e476 x490 w478))) (if (memq (quote eval) when-list493) (chi-sequence97 (cons e1491 e2492) r477 w478 s479) (chi-void111)))) tmp488) (syntax-error tmp487))) (syntax-dispatch tmp487 (quote (any each-any any . each-any))))) e476) (if (memv t480 (quote (define-form define-syntax-form))) (syntax-error (wrap95 value475 w478) (quote "invalid context for definition of")) (if (memv t480 (quote (syntax))) (syntax-error (source-wrap96 e476 w478 s479) (quote "reference to pattern variable outside syntax form")) (if (memv t480 (quote (displaced-lexical))) (syntax-error (source-wrap96 e476 w478 s479) (quote "reference to identifier outside its scope")) (syntax-error (source-wrap96 e476 w478 s479)))))))))))))))))) (chi103 (lambda (e496 r497 w498) (call-with-values (lambda () (syntax-type101 e496 r497 w498 (quote #f) (quote #f))) (lambda (type499 value500 e501 w502 s503) (chi-expr104 type499 value500 e501 r497 w502 s503))))) (chi-top102 (lambda (e504 r505 w506 m507 esew508) (call-with-values (lambda () (syntax-type101 e504 r505 w506 (quote #f) (quote #f))) (lambda (type515 value516 e517 w518 s519) (let ((t520 type515)) (if (memv t520 (quote (begin-form))) ((lambda (tmp521) ((lambda (tmp522) (if tmp522 (apply (lambda (_523) (chi-void111)) tmp522) ((lambda (tmp524) (if tmp524 (apply (lambda (_525 e1526 e2527) (chi-top-sequence98 (cons e1526 e2527) r505 w518 s519 m507 esew508)) tmp524) (syntax-error tmp521))) (syntax-dispatch tmp521 (quote (any any . each-any)))))) (syntax-dispatch tmp521 (quote (any))))) e517) (if (memv t520 (quote (local-syntax-form))) (chi-local-syntax109 value516 e517 r505 w518 s519 (lambda (body529 r530 w531 s532) (chi-top-sequence98 body529 r530 w531 s532 m507 esew508))) (if (memv t520 (quote (eval-when-form))) ((lambda (tmp533) ((lambda (tmp534) (if tmp534 (apply (lambda (_535 x536 e1537 e2538) (let ((when-list539 (chi-when-list100 e517 x536 w518)) (body540 (cons e1537 e2538))) (cond ((eq? m507 (quote e)) (if (memq (quote eval) when-list539) (chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval))) (chi-void111))) ((memq (quote load) when-list539) (if (or (memq (quote compile) when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539))) (chi-top-sequence98 body540 r505 w518 s519 (quote c&e) (quote (compile load))) (if (memq m507 (quote (c c&e))) (chi-top-sequence98 body540 r505 w518 s519 (quote c) (quote (load))) (chi-void111)))) ((or (memq (quote compile) when-list539) (and (eq? m507 (quote c&e)) (memq (quote eval) when-list539))) (top-level-eval-hook43 (chi-top-sequence98 body540 r505 w518 s519 (quote e) (quote (eval)))) (chi-void111)) (else (chi-void111))))) tmp534) (syntax-error tmp533))) (syntax-dispatch tmp533 (quote (any each-any any . each-any))))) e517) (if (memv t520 (quote (define-syntax-form))) (let ((n543 (id-var-name89 value516 w518)) (r544 (macros-only-env63 r505))) (let ((t545 m507)) (if (memv t545 (quote (c))) (if (memq (quote compile) esew508) (let ((e546 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin (top-level-eval-hook43 e546) (if (memq (quote load) esew508) e546 (chi-void111)))) (if (memq (quote load) esew508) (chi-install-global99 n543 (chi103 e517 r544 w518)) (chi-void111))) (if (memv t545 (quote (c&e))) (let ((e547 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (begin (top-level-eval-hook43 e547) e547)) (begin (if (memq (quote eval) esew508) (top-level-eval-hook43 (chi-install-global99 n543 (chi103 e517 r544 w518)))) (chi-void111)))))) (if (memv t520 (quote (define-form))) (let ((n548 (id-var-name89 value516 w518))) (let ((t549 (binding-type59 (lookup64 n548 r505)))) (if (memv t549 (quote (global))) (let ((x550 (list (quote define) n548 (chi103 e517 r505 w518)))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x550)) x550)) (if (memv t549 (quote (displaced-lexical))) (syntax-error (wrap95 value516 w518) (quote "identifier out of context")) (syntax-error (wrap95 value516 w518) (quote "cannot define keyword at top level")))))) (let ((x551 (chi-expr104 type515 value516 e517 r505 w518 s519))) (begin (if (eq? m507 (quote c&e)) (top-level-eval-hook43 x551)) x551)))))))))))) (syntax-type101 (lambda (e552 r553 w554 s555 rib556) (cond ((symbol? e552) (let ((n557 (id-var-name89 e552 w554))) (let ((b558 (lookup64 n557 r553))) (let ((type559 (binding-type59 b558))) (let ((t560 type559)) (if (memv t560 (quote (lexical))) (values type559 (binding-value60 b558) e552 w554 s555) (if (memv t560 (quote (global))) (values type559 n557 e552 w554 s555) (if (memv t560 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60 b558) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (values type559 (binding-value60 b558) e552 w554 s555))))))))) ((pair? e552) (let ((first561 (car e552))) (if (id?67 first561) (let ((n562 (id-var-name89 first561 w554))) (let ((b563 (lookup64 n562 r553))) (let ((type564 (binding-type59 b563))) (let ((t565 type564)) (if (memv t565 (quote (lexical))) (values (quote lexical-call) (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (global))) (values (quote global-call) n562 e552 w554 s555) (if (memv t565 (quote (macro))) (syntax-type101 (chi-macro106 (binding-value60 b563) e552 r553 w554 rib556) r553 (quote (())) s555 rib556) (if (memv t565 (quote (core))) (values type564 (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value60 b563) e552 w554 s555) (if (memv t565 (quote (begin))) (values (quote begin-form) (quote #f) e552 w554 s555) (if (memv t565 (quote (eval-when))) (values (quote eval-when-form) (quote #f) e552 w554 s555) (if (memv t565 (quote (define))) ((lambda (tmp566) ((lambda (tmp567) (if (if tmp567 (apply (lambda (_568 name569 val570) (id?67 name569)) tmp567) (quote #f)) (apply (lambda (_571 name572 val573) (values (quote define-form) name572 val573 w554 s555)) tmp567) ((lambda (tmp574) (if (if tmp574 (apply (lambda (_575 name576 args577 e1578 e2579) (and (id?67 name576) (valid-bound-ids?92 (lambda-var-list116 args577)))) tmp574) (quote #f)) (apply (lambda (_580 name581 args582 e1583 e2584) (values (quote define-form) (wrap95 name581 w554) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (wrap95 (cons args582 (cons e1583 e2584)) w554)) (quote (())) s555)) tmp574) ((lambda (tmp586) (if (if tmp586 (apply (lambda (_587 name588) (id?67 name588)) tmp586) (quote #f)) (apply (lambda (_589 name590) (values (quote define-form) (wrap95 name590 w554) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) s555)) tmp586) (syntax-error tmp566))) (syntax-dispatch tmp566 (quote (any any)))))) (syntax-dispatch tmp566 (quote (any (any . any) any . each-any)))))) (syntax-dispatch tmp566 (quote (any any any))))) e552) (if (memv t565 (quote (define-syntax))) ((lambda (tmp591) ((lambda (tmp592) (if (if tmp592 (apply (lambda (_593 name594 val595) (id?67 name594)) tmp592) (quote #f)) (apply (lambda (_596 name597 val598) (values (quote define-syntax-form) name597 val598 w554 s555)) tmp592) (syntax-error tmp591))) (syntax-dispatch tmp591 (quote (any any any))))) e552) (values (quote call) (quote #f) e552 w554 s555)))))))))))))) (values (quote call) (quote #f) e552 w554 s555)))) ((syntax-object?53 e552) (syntax-type101 (syntax-object-expression54 e552) r553 (join-wraps86 w554 (syntax-object-wrap55 e552)) (quote #f) rib556)) ((annotation?42 e552) (syntax-type101 (annotation-expression e552) r553 w554 (annotation-source e552) rib556)) ((let ((x599 e552)) (or (boolean? x599) (number? x599) (string? x599) (char? x599) (null? x599) (keyword? x599))) (values (quote constant) (quote #f) e552 w554 s555)) (else (values (quote other) (quote #f) e552 w554 s555))))) (chi-when-list100 (lambda (e600 when-list601 w602) (let f603 ((when-list604 when-list601) (situations605 (quote ()))) (if (null? when-list604) situations605 (f603 (cdr when-list604) (cons (let ((x606 (car when-list604))) (cond ((free-id=?90 x606 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((free-id=?90 x606 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((free-id=?90 x606 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (wrap95 x606 w602) (quote "invalid eval-when situation"))))) situations605)))))) (chi-install-global99 (lambda (name607 e608) (list (quote install-global-transformer) (list (quote quote) name607) e608))) (chi-top-sequence98 (lambda (body609 r610 w611 s612 m613 esew614) (build-sequence48 s612 (let dobody615 ((body616 body609) (r617 r610) (w618 w611) (m619 m613) (esew620 esew614)) (if (null? body616) (quote ()) (let ((first621 (chi-top102 (car body616) r617 w618 m619 esew620))) (cons first621 (dobody615 (cdr body616) r617 w618 m619 esew620)))))))) (chi-sequence97 (lambda (body622 r623 w624 s625) (build-sequence48 s625 (let dobody626 ((body627 body622) (r628 r623) (w629 w624)) (if (null? body627) (quote ()) (let ((first630 (chi103 (car body627) r628 w629))) (cons first630 (dobody626 (cdr body627) r628 w629)))))))) (source-wrap96 (lambda (x631 w632 s633) (wrap95 (if s633 (make-annotation x631 s633 (quote #f)) x631) w632))) (wrap95 (lambda (x634 w635) (cond ((and (null? (wrap-marks70 w635)) (null? (wrap-subst71 w635))) x634) ((syntax-object?53 x634) (make-syntax-object52 (syntax-object-expression54 x634) (join-wraps86 w635 (syntax-object-wrap55 x634)))) ((null? x634) x634) (else (make-syntax-object52 x634 w635))))) (bound-id-member?94 (lambda (x636 list637) (and (not (null? list637)) (or (bound-id=?91 x636 (car list637)) (bound-id-member?94 x636 (cdr list637)))))) (distinct-bound-ids?93 (lambda (ids638) (let distinct?639 ((ids640 ids638)) (or (null? ids640) (and (not (bound-id-member?94 (car ids640) (cdr ids640))) (distinct?639 (cdr ids640))))))) (valid-bound-ids?92 (lambda (ids641) (and (let all-ids?642 ((ids643 ids641)) (or (null? ids643) (and (id?67 (car ids643)) (all-ids?642 (cdr ids643))))) (distinct-bound-ids?93 ids641)))) (bound-id=?91 (lambda (i644 j645) (if (and (syntax-object?53 i644) (syntax-object?53 j645)) (and (eq? (let ((e646 (syntax-object-expression54 i644))) (if (annotation?42 e646) (annotation-expression e646) e646)) (let ((e647 (syntax-object-expression54 j645))) (if (annotation?42 e647) (annotation-expression e647) e647))) (same-marks?88 (wrap-marks70 (syntax-object-wrap55 i644)) (wrap-marks70 (syntax-object-wrap55 j645)))) (eq? (let ((e648 i644)) (if (annotation?42 e648) (annotation-expression e648) e648)) (let ((e649 j645)) (if (annotation?42 e649) (annotation-expression e649) e649)))))) (free-id=?90 (lambda (i650 j651) (and (eq? (let ((x652 i650)) (let ((e653 (if (syntax-object?53 x652) (syntax-object-expression54 x652) x652))) (if (annotation?42 e653) (annotation-expression e653) e653))) (let ((x654 j651)) (let ((e655 (if (syntax-object?53 x654) (syntax-object-expression54 x654) x654))) (if (annotation?42 e655) (annotation-expression e655) e655)))) (eq? (id-var-name89 i650 (quote (()))) (id-var-name89 j651 (quote (()))))))) (id-var-name89 (lambda (id656 w657) (letrec ((search-vector-rib660 (lambda (sym666 subst667 marks668 symnames669 ribcage670) (let ((n671 (vector-length symnames669))) (let f672 ((i673 (quote 0))) (cond ((fx=40 i673 n671) (search658 sym666 (cdr subst667) marks668)) ((and (eq? (vector-ref symnames669 i673) sym666) (same-marks?88 marks668 (vector-ref (ribcage-marks77 ribcage670) i673))) (values (vector-ref (ribcage-labels78 ribcage670) i673) marks668)) (else (f672 (fx+38 i673 (quote 1))))))))) (search-list-rib659 (lambda (sym674 subst675 marks676 symnames677 ribcage678) (let f679 ((symnames680 symnames677) (i681 (quote 0))) (cond ((null? symnames680) (search658 sym674 (cdr subst675) marks676)) ((and (eq? (car symnames680) sym674) (same-marks?88 marks676 (list-ref (ribcage-marks77 ribcage678) i681))) (values (list-ref (ribcage-labels78 ribcage678) i681) marks676)) (else (f679 (cdr symnames680) (fx+38 i681 (quote 1)))))))) (search658 (lambda (sym682 subst683 marks684) (if (null? subst683) (values (quote #f) marks684) (let ((fst685 (car subst683))) (if (eq? fst685 (quote shift)) (search658 sym682 (cdr subst683) (cdr marks684)) (let ((symnames686 (ribcage-symnames76 fst685))) (if (vector? symnames686) (search-vector-rib660 sym682 subst683 marks684 symnames686 fst685) (search-list-rib659 sym682 subst683 marks684 symnames686 fst685))))))))) (cond ((symbol? id656) (or (call-with-values (lambda () (search658 id656 (wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x688 . ignore687) x688)) id656)) ((syntax-object?53 id656) (let ((id689 (let ((e691 (syntax-object-expression54 id656))) (if (annotation?42 e691) (annotation-expression e691) e691))) (w1690 (syntax-object-wrap55 id656))) (let ((marks692 (join-marks87 (wrap-marks70 w657) (wrap-marks70 w1690)))) (call-with-values (lambda () (search658 id689 (wrap-subst71 w657) marks692)) (lambda (new-id693 marks694) (or new-id693 (call-with-values (lambda () (search658 id689 (wrap-subst71 w1690) marks694)) (lambda (x696 . ignore695) x696)) id689)))))) ((annotation?42 id656) (let ((id697 (let ((e698 id656)) (if (annotation?42 e698) (annotation-expression e698) e698)))) (or (call-with-values (lambda () (search658 id697 (wrap-subst71 w657) (wrap-marks70 w657))) (lambda (x700 . ignore699) x700)) id697))) (else (error-hook45 (quote id-var-name) (quote "invalid id") id656)))))) (same-marks?88 (lambda (x701 y702) (or (eq? x701 y702) (and (not (null? x701)) (not (null? y702)) (eq? (car x701) (car y702)) (same-marks?88 (cdr x701) (cdr y702)))))) (join-marks87 (lambda (m1703 m2704) (smart-append85 m1703 m2704))) (join-wraps86 (lambda (w1705 w2706) (let ((m1707 (wrap-marks70 w1705)) (s1708 (wrap-subst71 w1705))) (if (null? m1707) (if (null? s1708) w2706 (make-wrap69 (wrap-marks70 w2706) (smart-append85 s1708 (wrap-subst71 w2706)))) (make-wrap69 (smart-append85 m1707 (wrap-marks70 w2706)) (smart-append85 s1708 (wrap-subst71 w2706))))))) (smart-append85 (lambda (m1709 m2710) (if (null? m2710) m1709 (append m1709 m2710)))) (make-binding-wrap84 (lambda (ids711 labels712 w713) (if (null? ids711) w713 (make-wrap69 (wrap-marks70 w713) (cons (let ((labelvec714 (list->vector labels712))) (let ((n715 (vector-length labelvec714))) (let ((symnamevec716 (make-vector n715)) (marksvec717 (make-vector n715))) (begin (let f718 ((ids719 ids711) (i720 (quote 0))) (if (not (null? ids719)) (call-with-values (lambda () (id-sym-name&marks68 (car ids719) w713)) (lambda (symname721 marks722) (begin (vector-set! symnamevec716 i720 symname721) (vector-set! marksvec717 i720 marks722) (f718 (cdr ids719) (fx+38 i720 (quote 1)))))))) (make-ribcage74 symnamevec716 marksvec717 labelvec714))))) (wrap-subst71 w713)))))) (extend-ribcage!83 (lambda (ribcage723 id724 label725) (begin (set-ribcage-symnames!79 ribcage723 (cons (let ((e726 (syntax-object-expression54 id724))) (if (annotation?42 e726) (annotation-expression e726) e726)) (ribcage-symnames76 ribcage723))) (set-ribcage-marks!80 ribcage723 (cons (wrap-marks70 (syntax-object-wrap55 id724)) (ribcage-marks77 ribcage723))) (set-ribcage-labels!81 ribcage723 (cons label725 (ribcage-labels78 ribcage723)))))) (anti-mark82 (lambda (w727) (make-wrap69 (cons (quote #f) (wrap-marks70 w727)) (cons (quote shift) (wrap-subst71 w727))))) (set-ribcage-labels!81 (lambda (x728 update729) (vector-set! x728 (quote 3) update729))) (set-ribcage-marks!80 (lambda (x730 update731) (vector-set! x730 (quote 2) update731))) (set-ribcage-symnames!79 (lambda (x732 update733) (vector-set! x732 (quote 1) update733))) (ribcage-labels78 (lambda (x734) (vector-ref x734 (quote 3)))) (ribcage-marks77 (lambda (x735) (vector-ref x735 (quote 2)))) (ribcage-symnames76 (lambda (x736) (vector-ref x736 (quote 1)))) (ribcage?75 (lambda (x737) (and (vector? x737) (= (vector-length x737) (quote 4)) (eq? (vector-ref x737 (quote 0)) (quote ribcage))))) (make-ribcage74 (lambda (symnames738 marks739 labels740) (vector (quote ribcage) symnames738 marks739 labels740))) (gen-labels73 (lambda (ls741) (if (null? ls741) (quote ()) (cons (gen-label72) (gen-labels73 (cdr ls741)))))) (gen-label72 (lambda () (string (quote #\i)))) (wrap-subst71 cdr) (wrap-marks70 car) (make-wrap69 cons) (id-sym-name&marks68 (lambda (x742 w743) (if (syntax-object?53 x742) (values (let ((e744 (syntax-object-expression54 x742))) (if (annotation?42 e744) (annotation-expression e744) e744)) (join-marks87 (wrap-marks70 w743) (wrap-marks70 (syntax-object-wrap55 x742)))) (values (let ((e745 x742)) (if (annotation?42 e745) (annotation-expression e745) e745)) (wrap-marks70 w743))))) (id?67 (lambda (x746) (cond ((symbol? x746) (quote #t)) ((syntax-object?53 x746) (symbol? (let ((e747 (syntax-object-expression54 x746))) (if (annotation?42 e747) (annotation-expression e747) e747)))) ((annotation?42 x746) (symbol? (annotation-expression x746))) (else (quote #f))))) (nonsymbol-id?66 (lambda (x748) (and (syntax-object?53 x748) (symbol? (let ((e749 (syntax-object-expression54 x748))) (if (annotation?42 e749) (annotation-expression e749) e749)))))) (global-extend65 (lambda (type750 sym751 val752) (put-global-definition-hook46 sym751 (cons type750 val752)))) (lookup64 (lambda (x753 r754) (cond ((assq x753 r754) => cdr) ((symbol? x753) (or (get-global-definition-hook47 x753) (quote (global)))) (else (quote (displaced-lexical)))))) (macros-only-env63 (lambda (r755) (if (null? r755) (quote ()) (let ((a756 (car r755))) (if (eq? (cadr a756) (quote macro)) (cons a756 (macros-only-env63 (cdr r755))) (macros-only-env63 (cdr r755))))))) (extend-var-env62 (lambda (labels757 vars758 r759) (if (null? labels757) r759 (extend-var-env62 (cdr labels757) (cdr vars758) (cons (cons (car labels757) (cons (quote lexical) (car vars758))) r759))))) (extend-env61 (lambda (labels760 bindings761 r762) (if (null? labels760) r762 (extend-env61 (cdr labels760) (cdr bindings761) (cons (cons (car labels760) (car bindings761)) r762))))) (binding-value60 cdr) (binding-type59 car) (source-annotation58 (lambda (x763) (cond ((annotation?42 x763) (annotation-source x763)) ((syntax-object?53 x763) (source-annotation58 (syntax-object-expression54 x763))) (else (quote #f))))) (set-syntax-object-wrap!57 (lambda (x764 update765) (vector-set! x764 (quote 2) update765))) (set-syntax-object-expression!56 (lambda (x766 update767) (vector-set! x766 (quote 1) update767))) (syntax-object-wrap55 (lambda (x768) (vector-ref x768 (quote 2)))) (syntax-object-expression54 (lambda (x769) (vector-ref x769 (quote 1)))) (syntax-object?53 (lambda (x770) (and (vector? x770) (= (vector-length x770) (quote 3)) (eq? (vector-ref x770 (quote 0)) (quote syntax-object))))) (make-syntax-object52 (lambda (expression771 wrap772) (vector (quote syntax-object) expression771 wrap772))) (build-letrec51 (lambda (src773 vars774 val-exps775 body-exp776) (if (null? vars774) body-exp776 (list (quote letrec) (map list vars774 val-exps775) body-exp776)))) (build-named-let50 (lambda (src777 vars778 val-exps779 body-exp780) (if (null? vars778) body-exp780 (list (quote let) (car vars778) (map list (cdr vars778) val-exps779) body-exp780)))) (build-let49 (lambda (src781 vars782 val-exps783 body-exp784) (if (null? vars782) body-exp784 (list (quote let) (map list vars782 val-exps783) body-exp784)))) (build-sequence48 (lambda (src785 exps786) (if (null? (cdr exps786)) (car exps786) (cons (quote begin) exps786)))) (get-global-definition-hook47 (lambda (symbol787) (getprop symbol787 (quote *sc-expander*)))) (put-global-definition-hook46 (lambda (symbol788 binding789) (putprop symbol788 (quote *sc-expander*) binding789))) (error-hook45 (lambda (who790 why791 what792) (error who790 (quote "~a ~s") why791 what792))) (local-eval-hook44 (lambda (x793) (eval (list noexpand37 x793) (interaction-environment)))) (top-level-eval-hook43 (lambda (x794) (eval (list noexpand37 x794) (interaction-environment)))) (annotation?42 (lambda (x795) (quote #f))) (fx<41 <) (fx=40 =) (fx-39 -) (fx+38 +) (noexpand37 (quote "noexpand"))) (begin (global-extend65 (quote local-syntax) (quote letrec-syntax) (quote #t)) (global-extend65 (quote local-syntax) (quote let-syntax) (quote #f)) (global-extend65 (quote core) (quote fluid-let-syntax) (lambda (e796 r797 w798 s799) ((lambda (tmp800) ((lambda (tmp801) (if (if tmp801 (apply (lambda (_802 var803 val804 e1805 e2806) (valid-bound-ids?92 var803)) tmp801) (quote #f)) (apply (lambda (_808 var809 val810 e1811 e2812) (let ((names813 (map (lambda (x814) (id-var-name89 x814 w798)) var809))) (begin (for-each (lambda (id816 n817) (let ((t818 (binding-type59 (lookup64 n817 r797)))) (if (memv t818 (quote (displaced-lexical))) (syntax-error (source-wrap96 id816 w798 s799) (quote "identifier out of context"))))) var809 names813) (chi-body107 (cons e1811 e2812) (source-wrap96 e796 w798 s799) (extend-env61 names813 (let ((trans-r821 (macros-only-env63 r797))) (map (lambda (x822) (cons (quote macro) (eval-local-transformer110 (chi103 x822 trans-r821 w798)))) val810)) r797) w798)))) tmp801) ((lambda (_824) (syntax-error (source-wrap96 e796 w798 s799))) tmp800))) (syntax-dispatch tmp800 (quote (any #(each (any any)) any . each-any))))) e796))) (global-extend65 (quote core) (quote quote) (lambda (e825 r826 w827 s828) ((lambda (tmp829) ((lambda (tmp830) (if tmp830 (apply (lambda (_831 e832) (list (quote quote) (strip114 e832 w827))) tmp830) ((lambda (_833) (syntax-error (source-wrap96 e825 w827 s828))) tmp829))) (syntax-dispatch tmp829 (quote (any any))))) e825))) (global-extend65 (quote core) (quote syntax) (letrec ((regen841 (lambda (x842) (let ((t843 (car x842))) (if (memv t843 (quote (ref))) (cadr x842) (if (memv t843 (quote (primitive))) (cadr x842) (if (memv t843 (quote (quote))) (list (quote quote) (cadr x842)) (if (memv t843 (quote (lambda))) (list (quote lambda) (cadr x842) (regen841 (caddr x842))) (if (memv t843 (quote (map))) (let ((ls844 (map regen841 (cdr x842)))) (cons (if (fx=40 (length ls844) (quote 2)) (quote map) (quote map)) ls844)) (cons (car x842) (map regen841 (cdr x842))))))))))) (gen-vector840 (lambda (x845) (cond ((eq? (car x845) (quote list)) (cons (quote vector) (cdr x845))) ((eq? (car x845) (quote quote)) (list (quote quote) (list->vector (cadr x845)))) (else (list (quote list->vector) x845))))) (gen-append839 (lambda (x846 y847) (if (equal? y847 (quote (quote ()))) x846 (list (quote append) x846 y847)))) (gen-cons838 (lambda (x848 y849) (let ((t850 (car y849))) (if (memv t850 (quote (quote))) (if (eq? (car x848) (quote quote)) (list (quote quote) (cons (cadr x848) (cadr y849))) (if (eq? (cadr y849) (quote ())) (list (quote list) x848) (list (quote cons) x848 y849))) (if (memv t850 (quote (list))) (cons (quote list) (cons x848 (cdr y849))) (list (quote cons) x848 y849)))))) (gen-map837 (lambda (e851 map-env852) (let ((formals853 (map cdr map-env852)) (actuals854 (map (lambda (x855) (list (quote ref) (car x855))) map-env852))) (cond ((eq? (car e851) (quote ref)) (car actuals854)) ((andmap (lambda (x856) (and (eq? (car x856) (quote ref)) (memq (cadr x856) formals853))) (cdr e851)) (cons (quote map) (cons (list (quote primitive) (car e851)) (map (let ((r857 (map cons formals853 actuals854))) (lambda (x858) (cdr (assq (cadr x858) r857)))) (cdr e851))))) (else (cons (quote map) (cons (list (quote lambda) formals853 e851) actuals854))))))) (gen-mappend836 (lambda (e859 map-env860) (list (quote apply) (quote (primitive append)) (gen-map837 e859 map-env860)))) (gen-ref835 (lambda (src861 var862 level863 maps864) (if (fx=40 level863 (quote 0)) (values var862 maps864) (if (null? maps864) (syntax-error src861 (quote "missing ellipsis in syntax form")) (call-with-values (lambda () (gen-ref835 src861 var862 (fx-39 level863 (quote 1)) (cdr maps864))) (lambda (outer-var865 outer-maps866) (let ((b867 (assq outer-var865 (car maps864)))) (if b867 (values (cdr b867) maps864) (let ((inner-var868 (gen-var115 (quote tmp)))) (values inner-var868 (cons (cons (cons outer-var865 inner-var868) (car maps864)) outer-maps866))))))))))) (gen-syntax834 (lambda (src869 e870 r871 maps872 ellipsis?873) (if (id?67 e870) (let ((label874 (id-var-name89 e870 (quote (()))))) (let ((b875 (lookup64 label874 r871))) (if (eq? (binding-type59 b875) (quote syntax)) (call-with-values (lambda () (let ((var.lev876 (binding-value60 b875))) (gen-ref835 src869 (car var.lev876) (cdr var.lev876) maps872))) (lambda (var877 maps878) (values (list (quote ref) var877) maps878))) (if (ellipsis?873 e870) (syntax-error src869 (quote "misplaced ellipsis in syntax form")) (values (list (quote quote) e870) maps872))))) ((lambda (tmp879) ((lambda (tmp880) (if (if tmp880 (apply (lambda (dots881 e882) (ellipsis?873 dots881)) tmp880) (quote #f)) (apply (lambda (dots883 e884) (gen-syntax834 src869 e884 r871 maps872 (lambda (x885) (quote #f)))) tmp880) ((lambda (tmp886) (if (if tmp886 (apply (lambda (x887 dots888 y889) (ellipsis?873 dots888)) tmp886) (quote #f)) (apply (lambda (x890 dots891 y892) (let f893 ((y894 y892) (k895 (lambda (maps896) (call-with-values (lambda () (gen-syntax834 src869 x890 r871 (cons (quote ()) maps896) ellipsis?873)) (lambda (x897 maps898) (if (null? (car maps898)) (syntax-error src869 (quote "extra ellipsis in syntax form")) (values (gen-map837 x897 (car maps898)) (cdr maps898)))))))) ((lambda (tmp899) ((lambda (tmp900) (if (if tmp900 (apply (lambda (dots901 y902) (ellipsis?873 dots901)) tmp900) (quote #f)) (apply (lambda (dots903 y904) (f893 y904 (lambda (maps905) (call-with-values (lambda () (k895 (cons (quote ()) maps905))) (lambda (x906 maps907) (if (null? (car maps907)) (syntax-error src869 (quote "extra ellipsis in syntax form")) (values (gen-mappend836 x906 (car maps907)) (cdr maps907)))))))) tmp900) ((lambda (_908) (call-with-values (lambda () (gen-syntax834 src869 y894 r871 maps872 ellipsis?873)) (lambda (y909 maps910) (call-with-values (lambda () (k895 maps910)) (lambda (x911 maps912) (values (gen-append839 x911 y909) maps912)))))) tmp899))) (syntax-dispatch tmp899 (quote (any . any))))) y894))) tmp886) ((lambda (tmp913) (if tmp913 (apply (lambda (x914 y915) (call-with-values (lambda () (gen-syntax834 src869 x914 r871 maps872 ellipsis?873)) (lambda (x916 maps917) (call-with-values (lambda () (gen-syntax834 src869 y915 r871 maps917 ellipsis?873)) (lambda (y918 maps919) (values (gen-cons838 x916 y918) maps919)))))) tmp913) ((lambda (tmp920) (if tmp920 (apply (lambda (e1921 e2922) (call-with-values (lambda () (gen-syntax834 src869 (cons e1921 e2922) r871 maps872 ellipsis?873)) (lambda (e924 maps925) (values (gen-vector840 e924) maps925)))) tmp920) ((lambda (_926) (values (list (quote quote) e870) maps872)) tmp879))) (syntax-dispatch tmp879 (quote #(vector (any . each-any))))))) (syntax-dispatch tmp879 (quote (any . any)))))) (syntax-dispatch tmp879 (quote (any any . any)))))) (syntax-dispatch tmp879 (quote (any any))))) e870))))) (lambda (e927 r928 w929 s930) (let ((e931 (source-wrap96 e927 w929 s930))) ((lambda (tmp932) ((lambda (tmp933) (if tmp933 (apply (lambda (_934 x935) (call-with-values (lambda () (gen-syntax834 e931 x935 r928 (quote ()) ellipsis?112)) (lambda (e936 maps937) (regen841 e936)))) tmp933) ((lambda (_938) (syntax-error e931)) tmp932))) (syntax-dispatch tmp932 (quote (any any))))) e931))))) (global-extend65 (quote core) (quote lambda) (lambda (e939 r940 w941 s942) ((lambda (tmp943) ((lambda (tmp944) (if tmp944 (apply (lambda (_945 c946) (chi-lambda-clause108 (source-wrap96 e939 w941 s942) c946 r940 w941 (lambda (vars947 body948) (list (quote lambda) vars947 body948)))) tmp944) (syntax-error tmp943))) (syntax-dispatch tmp943 (quote (any . any))))) e939))) (global-extend65 (quote core) (quote let) (letrec ((chi-let949 (lambda (e950 r951 w952 s953 constructor954 ids955 vals956 exps957) (if (not (valid-bound-ids?92 ids955)) (syntax-error e950 (quote "duplicate bound variable in")) (let ((labels958 (gen-labels73 ids955)) (new-vars959 (map gen-var115 ids955))) (let ((nw960 (make-binding-wrap84 ids955 labels958 w952)) (nr961 (extend-var-env62 labels958 new-vars959 r951))) (constructor954 s953 new-vars959 (map (lambda (x962) (chi103 x962 r951 w952)) vals956) (chi-body107 exps957 (source-wrap96 e950 nw960 s953) nr961 nw960)))))))) (lambda (e963 r964 w965 s966) ((lambda (tmp967) ((lambda (tmp968) (if tmp968 (apply (lambda (_969 id970 val971 e1972 e2973) (chi-let949 e963 r964 w965 s966 build-let49 id970 val971 (cons e1972 e2973))) tmp968) ((lambda (tmp977) (if (if tmp977 (apply (lambda (_978 f979 id980 val981 e1982 e2983) (id?67 f979)) tmp977) (quote #f)) (apply (lambda (_984 f985 id986 val987 e1988 e2989) (chi-let949 e963 r964 w965 s966 build-named-let50 (cons f985 id986) val987 (cons e1988 e2989))) tmp977) ((lambda (_993) (syntax-error (source-wrap96 e963 w965 s966))) tmp967))) (syntax-dispatch tmp967 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp967 (quote (any #(each (any any)) any . each-any))))) e963)))) (global-extend65 (quote core) (quote letrec) (lambda (e994 r995 w996 s997) ((lambda (tmp998) ((lambda (tmp999) (if tmp999 (apply (lambda (_1000 id1001 val1002 e11003 e21004) (let ((ids1005 id1001)) (if (not (valid-bound-ids?92 ids1005)) (syntax-error e994 (quote "duplicate bound variable in")) (let ((labels1007 (gen-labels73 ids1005)) (new-vars1008 (map gen-var115 ids1005))) (let ((w1009 (make-binding-wrap84 ids1005 labels1007 w996)) (r1010 (extend-var-env62 labels1007 new-vars1008 r995))) (build-letrec51 s997 new-vars1008 (map (lambda (x1011) (chi103 x1011 r1010 w1009)) val1002) (chi-body107 (cons e11003 e21004) (source-wrap96 e994 w1009 s997) r1010 w1009))))))) tmp999) ((lambda (_1014) (syntax-error (source-wrap96 e994 w996 s997))) tmp998))) (syntax-dispatch tmp998 (quote (any #(each (any any)) any . each-any))))) e994))) (global-extend65 (quote core) (quote set!) (lambda (e1015 r1016 w1017 s1018) ((lambda (tmp1019) ((lambda (tmp1020) (if (if tmp1020 (apply (lambda (_1021 id1022 val1023) (id?67 id1022)) tmp1020) (quote #f)) (apply (lambda (_1024 id1025 val1026) (let ((val1027 (chi103 val1026 r1016 w1017)) (n1028 (id-var-name89 id1025 w1017))) (let ((b1029 (lookup64 n1028 r1016))) (let ((t1030 (binding-type59 b1029))) (if (memv t1030 (quote (lexical))) (list (quote set!) (binding-value60 b1029) val1027) (if (memv t1030 (quote (global))) (list (quote set!) n1028 val1027) (if (memv t1030 (quote (displaced-lexical))) (syntax-error (wrap95 id1025 w1017) (quote "identifier out of context")) (syntax-error (source-wrap96 e1015 w1017 s1018))))))))) tmp1020) ((lambda (tmp1031) (if tmp1031 (apply (lambda (_1032 getter1033 arg1034 val1035) (cons (chi103 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) getter1033) r1016 w1017) (map (lambda (e1036) (chi103 e1036 r1016 w1017)) (append arg1034 (list val1035))))) tmp1031) ((lambda (_1038) (syntax-error (source-wrap96 e1015 w1017 s1018))) tmp1019))) (syntax-dispatch tmp1019 (quote (any (any . each-any) any)))))) (syntax-dispatch tmp1019 (quote (any any any))))) e1015))) (global-extend65 (quote begin) (quote begin) (quote ())) (global-extend65 (quote define) (quote define) (quote ())) (global-extend65 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend65 (quote eval-when) (quote eval-when) (quote ())) (global-extend65 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1042 (lambda (x1043 keys1044 clauses1045 r1046) (if (null? clauses1045) (list (quote syntax-error) x1043) ((lambda (tmp1047) ((lambda (tmp1048) (if tmp1048 (apply (lambda (pat1049 exp1050) (if (and (id?67 pat1049) (andmap (lambda (x1051) (not (free-id=?90 pat1049 x1051))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object self-evaluating? build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) keys1044))) (let ((labels1052 (list (gen-label72))) (var1053 (gen-var115 pat1049))) (list (list (quote lambda) (list var1053) (chi103 exp1050 (extend-env61 labels1052 (list (cons (quote syntax) (cons var1053 (quote 0)))) r1046) (make-binding-wrap84 (list pat1049) labels1052 (quote (()))))) x1043)) (gen-clause1041 x1043 keys1044 (cdr clauses1045) r1046 pat1049 (quote #t) exp1050))) tmp1048) ((lambda (tmp1054) (if tmp1054 (apply (lambda (pat1055 fender1056 exp1057) (gen-clause1041 x1043 keys1044 (cdr clauses1045) r1046 pat1055 fender1056 exp1057)) tmp1054) ((lambda (_1058) (syntax-error (car clauses1045) (quote "invalid syntax-case clause"))) tmp1047))) (syntax-dispatch tmp1047 (quote (any any any)))))) (syntax-dispatch tmp1047 (quote (any any))))) (car clauses1045))))) (gen-clause1041 (lambda (x1059 keys1060 clauses1061 r1062 pat1063 fender1064 exp1065) (call-with-values (lambda () (convert-pattern1039 pat1063 keys1060)) (lambda (p1066 pvars1067) (cond ((not (distinct-bound-ids?93 (map car pvars1067))) (syntax-error pat1063 (quote "duplicate pattern variable in syntax-case pattern"))) ((not (andmap (lambda (x1068) (not (ellipsis?112 (car x1068)))) pvars1067)) (syntax-error pat1063 (quote "misplaced ellipsis in syntax-case pattern"))) (else (let ((y1069 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list y1069) (let ((y1070 y1069)) (list (quote if) ((lambda (tmp1071) ((lambda (tmp1072) (if tmp1072 (apply (lambda () y1070) tmp1072) ((lambda (_1073) (list (quote if) y1070 (build-dispatch-call1040 pvars1067 fender1064 y1070 r1062) (list (quote quote) (quote #f)))) tmp1071))) (syntax-dispatch tmp1071 (quote #(atom #t))))) fender1064) (build-dispatch-call1040 pvars1067 exp1065 y1070 r1062) (gen-syntax-case1042 x1059 keys1060 clauses1061 r1062)))) (if (eq? p1066 (quote any)) (list (quote list) x1059) (list (quote syntax-dispatch) x1059 (list (quote quote) p1066))))))))))) (build-dispatch-call1040 (lambda (pvars1074 exp1075 y1076 r1077) (let ((ids1078 (map car pvars1074)) (levels1079 (map cdr pvars1074))) (let ((labels1080 (gen-labels73 ids1078)) (new-vars1081 (map gen-var115 ids1078))) (list (quote apply) (list (quote lambda) new-vars1081 (chi103 exp1075 (extend-env61 labels1080 (map (lambda (var1082 level1083) (cons (quote syntax) (cons var1082 level1083))) new-vars1081 (map cdr pvars1074)) r1077) (make-binding-wrap84 ids1078 labels1080 (quote (()))))) y1076))))) (convert-pattern1039 (lambda (pattern1084 keys1085) (let cvt1086 ((p1087 pattern1084) (n1088 (quote 0)) (ids1089 (quote ()))) (if (id?67 p1087) (if (bound-id-member?94 p1087 keys1085) (values (vector (quote free-id) p1087) ids1089) (values (quote any) (cons (cons p1087 n1088) ids1089))) ((lambda (tmp1090) ((lambda (tmp1091) (if (if tmp1091 (apply (lambda (x1092 dots1093) (ellipsis?112 dots1093)) tmp1091) (quote #f)) (apply (lambda (x1094 dots1095) (call-with-values (lambda () (cvt1086 x1094 (fx+38 n1088 (quote 1)) ids1089)) (lambda (p1096 ids1097) (values (if (eq? p1096 (quote any)) (quote each-any) (vector (quote each) p1096)) ids1097)))) tmp1091) ((lambda (tmp1098) (if tmp1098 (apply (lambda (x1099 y1100) (call-with-values (lambda () (cvt1086 y1100 n1088 ids1089)) (lambda (y1101 ids1102) (call-with-values (lambda () (cvt1086 x1099 n1088 ids1102)) (lambda (x1103 ids1104) (values (cons x1103 y1101) ids1104)))))) tmp1098) ((lambda (tmp1105) (if tmp1105 (apply (lambda () (values (quote ()) ids1089)) tmp1105) ((lambda (tmp1106) (if tmp1106 (apply (lambda (x1107) (call-with-values (lambda () (cvt1086 x1107 n1088 ids1089)) (lambda (p1109 ids1110) (values (vector (quote vector) p1109) ids1110)))) tmp1106) ((lambda (x1111) (values (vector (quote atom) (strip114 p1087 (quote (())))) ids1089)) tmp1090))) (syntax-dispatch tmp1090 (quote #(vector each-any)))))) (syntax-dispatch tmp1090 (quote ()))))) (syntax-dispatch tmp1090 (quote (any . any)))))) (syntax-dispatch tmp1090 (quote (any any))))) p1087)))))) (lambda (e1112 r1113 w1114 s1115) (let ((e1116 (source-wrap96 e1112 w1114 s1115))) ((lambda (tmp1117) ((lambda (tmp1118) (if tmp1118 (apply (lambda (_1119 val1120 key1121 m1122) (if (andmap (lambda (x1123) (and (id?67 x1123) (not (ellipsis?112 x1123)))) key1121) (let ((x1125 (gen-var115 (quote tmp)))) (list (list (quote lambda) (list x1125) (gen-syntax-case1042 x1125 key1121 m1122 r1113)) (chi103 val1120 r1113 (quote (()))))) (syntax-error e1116 (quote "invalid literals list in")))) tmp1118) (syntax-error tmp1117))) (syntax-dispatch tmp1117 (quote (any any each-any . each-any))))) e1116))))) (set! sc-expand (let ((m1128 (quote e)) (esew1129 (quote (eval)))) (lambda (x1130) (if (and (pair? x1130) (equal? (car x1130) noexpand37)) (cadr x1130) (chi-top102 x1130 (quote ()) (quote ((top))) m1128 esew1129))))) (set! sc-expand3 (let ((m1131 (quote e)) (esew1132 (quote (eval)))) (lambda (x1134 . rest1133) (if (and (pair? x1134) (equal? (car x1134) noexpand37)) (cadr x1134) (chi-top102 x1134 (quote ()) (quote ((top))) (if (null? rest1133) m1131 (car rest1133)) (if (or (null? rest1133) (null? (cdr rest1133))) esew1132 (cadr rest1133))))))) (set! identifier? (lambda (x1135) (nonsymbol-id?66 x1135))) (set! datum->syntax-object (lambda (id1136 datum1137) (make-syntax-object52 datum1137 (syntax-object-wrap55 id1136)))) (set! syntax-object->datum (lambda (x1138) (strip114 x1138 (quote (()))))) (set! generate-temporaries (lambda (ls1139) (begin (let ((x1140 ls1139)) (if (not (list? x1140)) (error-hook45 (quote generate-temporaries) (quote "invalid argument") x1140))) (map (lambda (x1141) (wrap95 (gensym) (quote ((top))))) ls1139)))) (set! free-identifier=? (lambda (x1142 y1143) (begin (let ((x1144 x1142)) (if (not (nonsymbol-id?66 x1144)) (error-hook45 (quote free-identifier=?) (quote "invalid argument") x1144))) (let ((x1145 y1143)) (if (not (nonsymbol-id?66 x1145)) (error-hook45 (quote free-identifier=?) (quote "invalid argument") x1145))) (free-id=?90 x1142 y1143)))) (set! bound-identifier=? (lambda (x1146 y1147) (begin (let ((x1148 x1146)) (if (not (nonsymbol-id?66 x1148)) (error-hook45 (quote bound-identifier=?) (quote "invalid argument") x1148))) (let ((x1149 y1147)) (if (not (nonsymbol-id?66 x1149)) (error-hook45 (quote bound-identifier=?) (quote "invalid argument") x1149))) (bound-id=?91 x1146 y1147)))) (set! syntax-error (lambda (object1151 . messages1150) (begin (for-each (lambda (x1152) (let ((x1153 x1152)) (if (not (string? x1153)) (error-hook45 (quote syntax-error) (quote "invalid argument") x1153)))) messages1150) (let ((message1154 (if (null? messages1150) (quote "invalid syntax") (apply string-append messages1150)))) (error-hook45 (quote #f) message1154 (strip114 object1151 (quote (())))))))) (set! install-global-transformer (lambda (sym1155 v1156) (begin (let ((x1157 sym1155)) (if (not (symbol? x1157)) (error-hook45 (quote define-syntax) (quote "invalid argument") x1157))) (let ((x1158 v1156)) (if (not (procedure? x1158)) (error-hook45 (quote define-syntax) (quote "invalid argument") x1158))) (global-extend65 (quote macro) sym1155 v1156)))) (letrec ((match1163 (lambda (e1164 p1165 w1166 r1167) (cond ((not r1167) (quote #f)) ((eq? p1165 (quote any)) (cons (wrap95 e1164 w1166) r1167)) ((syntax-object?53 e1164) (match*1162 (let ((e1168 (syntax-object-expression54 e1164))) (if (annotation?42 e1168) (annotation-expression e1168) e1168)) p1165 (join-wraps86 w1166 (syntax-object-wrap55 e1164)) r1167)) (else (match*1162 (let ((e1169 e1164)) (if (annotation?42 e1169) (annotation-expression e1169) e1169)) p1165 w1166 r1167))))) (match*1162 (lambda (e1170 p1171 w1172 r1173) (cond ((null? p1171) (and (null? e1170) r1173)) ((pair? p1171) (and (pair? e1170) (match1163 (car e1170) (car p1171) w1172 (match1163 (cdr e1170) (cdr p1171) w1172 r1173)))) ((eq? p1171 (quote each-any)) (let ((l1174 (match-each-any1160 e1170 w1172))) (and l1174 (cons l1174 r1173)))) (else (let ((t1175 (vector-ref p1171 (quote 0)))) (if (memv t1175 (quote (each))) (if (null? e1170) (match-empty1161 (vector-ref p1171 (quote 1)) r1173) (let ((l1176 (match-each1159 e1170 (vector-ref p1171 (quote 1)) w1172))) (and l1176 (let collect1177 ((l1178 l1176)) (if (null? (car l1178)) r1173 (cons (map car l1178) (collect1177 (map cdr l1178)))))))) (if (memv t1175 (quote (free-id))) (and (id?67 e1170) (free-id=?90 (wrap95 e1170 w1172) (vector-ref p1171 (quote 1))) r1173) (if (memv t1175 (quote (atom))) (and (equal? (vector-ref p1171 (quote 1)) (strip114 e1170 w1172)) r1173) (if (memv t1175 (quote (vector))) (and (vector? e1170) (match1163 (vector->list e1170) (vector-ref p1171 (quote 1)) w1172 r1173))))))))))) (match-empty1161 (lambda (p1179 r1180) (cond ((null? p1179) r1180) ((eq? p1179 (quote any)) (cons (quote ()) r1180)) ((pair? p1179) (match-empty1161 (car p1179) (match-empty1161 (cdr p1179) r1180))) ((eq? p1179 (quote each-any)) (cons (quote ()) r1180)) (else (let ((t1181 (vector-ref p1179 (quote 0)))) (if (memv t1181 (quote (each))) (match-empty1161 (vector-ref p1179 (quote 1)) r1180) (if (memv t1181 (quote (free-id atom))) r1180 (if (memv t1181 (quote (vector))) (match-empty1161 (vector-ref p1179 (quote 1)) r1180))))))))) (match-each-any1160 (lambda (e1182 w1183) (cond ((annotation?42 e1182) (match-each-any1160 (annotation-expression e1182) w1183)) ((pair? e1182) (let ((l1184 (match-each-any1160 (cdr e1182) w1183))) (and l1184 (cons (wrap95 (car e1182) w1183) l1184)))) ((null? e1182) (quote ())) ((syntax-object?53 e1182) (match-each-any1160 (syntax-object-expression54 e1182) (join-wraps86 w1183 (syntax-object-wrap55 e1182)))) (else (quote #f))))) (match-each1159 (lambda (e1185 p1186 w1187) (cond ((annotation?42 e1185) (match-each1159 (annotation-expression e1185) p1186 w1187)) ((pair? e1185) (let ((first1188 (match1163 (car e1185) p1186 w1187 (quote ())))) (and first1188 (let ((rest1189 (match-each1159 (cdr e1185) p1186 w1187))) (and rest1189 (cons first1188 rest1189)))))) ((null? e1185) (quote ())) ((syntax-object?53 e1185) (match-each1159 (syntax-object-expression54 e1185) p1186 (join-wraps86 w1187 (syntax-object-wrap55 e1185)))) (else (quote #f)))))) (set! syntax-dispatch (lambda (e1190 p1191) (cond ((eq? p1191 (quote any)) (list e1190)) ((syntax-object?53 e1190) (match*1162 (let ((e1192 (syntax-object-expression54 e1190))) (if (annotation?42 e1192) (annotation-expression e1192) e1192)) p1191 (syntax-object-wrap55 e1190) (quote ()))) (else (match*1162 (let ((e1193 e1190)) (if (annotation?42 e1193) (annotation-expression e1193) e1193)) p1191 (quote (())) (quote ()))))))))) +(install-global-transformer (quote with-syntax) (lambda (x1194) ((lambda (tmp1195) ((lambda (tmp1196) (if tmp1196 (apply (lambda (_1197 e11198 e21199) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11198 e21199))) tmp1196) ((lambda (tmp1201) (if tmp1201 (apply (lambda (_1202 out1203 in1204 e11205 e21206) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in1204 (quote ()) (list out1203 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11205 e21206))))) tmp1201) ((lambda (tmp1208) (if tmp1208 (apply (lambda (_1209 out1210 in1211 e11212 e21213) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) in1211) (quote ()) (list out1210 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11212 e21213))))) tmp1208) (syntax-error tmp1195))) (syntax-dispatch tmp1195 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch tmp1195 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch tmp1195 (quote (any () any . each-any))))) x1194))) +(install-global-transformer (quote syntax-rules) (lambda (x1217) ((lambda (tmp1218) ((lambda (tmp1219) (if tmp1219 (apply (lambda (_1220 k1221 keyword1222 pattern1223 template1224) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons k1221 (map (lambda (tmp1227 tmp1226) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1226) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) tmp1227))) template1224 pattern1223)))))) tmp1219) (syntax-error tmp1218))) (syntax-dispatch tmp1218 (quote (any each-any . #(each ((any . any) any))))))) x1217))) +(install-global-transformer (quote let*) (lambda (x1228) ((lambda (tmp1229) ((lambda (tmp1230) (if (if tmp1230 (apply (lambda (let*1231 x1232 v1233 e11234 e21235) (andmap identifier? x1232)) tmp1230) (quote #f)) (apply (lambda (let*1237 x1238 v1239 e11240 e21241) (let f1242 ((bindings1243 (map list x1238 v1239))) (if (null? bindings1243) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons e11240 e21241))) ((lambda (tmp1247) ((lambda (tmp1248) (if tmp1248 (apply (lambda (body1249 binding1250) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list binding1250) body1249)) tmp1248) (syntax-error tmp1247))) (syntax-dispatch tmp1247 (quote (any any))))) (list (f1242 (cdr bindings1243)) (car bindings1243)))))) tmp1230) (syntax-error tmp1229))) (syntax-dispatch tmp1229 (quote (any #(each (any any)) any . each-any))))) x1228))) +(install-global-transformer (quote do) (lambda (orig-x1251) ((lambda (tmp1252) ((lambda (tmp1253) (if tmp1253 (apply (lambda (_1254 var1255 init1256 step1257 e01258 e11259 c1260) ((lambda (tmp1261) ((lambda (tmp1262) (if tmp1262 (apply (lambda (step1263) ((lambda (tmp1264) ((lambda (tmp1265) (if tmp1265 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var1255 init1256) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e01258) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c1260 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step1263))))))) tmp1265) ((lambda (tmp1270) (if tmp1270 (apply (lambda (e11271 e21272) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list var1255 init1256) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) e01258 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons e11271 e21272)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append c1260 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) step1263))))))) tmp1270) (syntax-error tmp1264))) (syntax-dispatch tmp1264 (quote (any . each-any)))))) (syntax-dispatch tmp1264 (quote ())))) e11259)) tmp1262) (syntax-error tmp1261))) (syntax-dispatch tmp1261 (quote each-any)))) (map (lambda (v1279 s1280) ((lambda (tmp1281) ((lambda (tmp1282) (if tmp1282 (apply (lambda () v1279) tmp1282) ((lambda (tmp1283) (if tmp1283 (apply (lambda (e1284) e1284) tmp1283) ((lambda (_1285) (syntax-error orig-x1251)) tmp1281))) (syntax-dispatch tmp1281 (quote (any)))))) (syntax-dispatch tmp1281 (quote ())))) s1280)) var1255 step1257))) tmp1253) (syntax-error tmp1252))) (syntax-dispatch tmp1252 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1251))) +(install-global-transformer (quote quasiquote) (letrec ((quasicons1288 (lambda (x1292 y1293) ((lambda (tmp1294) ((lambda (tmp1295) (if tmp1295 (apply (lambda (x1296 y1297) ((lambda (tmp1298) ((lambda (tmp1299) (if tmp1299 (apply (lambda (dy1300) ((lambda (tmp1301) ((lambda (tmp1302) (if tmp1302 (apply (lambda (dx1303) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons dx1303 dy1300))) tmp1302) ((lambda (_1304) (if (null? dy1300) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1296) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1296 y1297))) tmp1301))) (syntax-dispatch tmp1301 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) x1296)) tmp1299) ((lambda (tmp1305) (if tmp1305 (apply (lambda (stuff1306) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons x1296 stuff1306))) tmp1305) ((lambda (else1307) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1296 y1297)) tmp1298))) (syntax-dispatch tmp1298 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch tmp1298 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) y1297)) tmp1295) (syntax-error tmp1294))) (syntax-dispatch tmp1294 (quote (any any))))) (list x1292 y1293)))) (quasiappend1289 (lambda (x1308 y1309) ((lambda (tmp1310) ((lambda (tmp1311) (if tmp1311 (apply (lambda (x1312 y1313) ((lambda (tmp1314) ((lambda (tmp1315) (if tmp1315 (apply (lambda () x1312) tmp1315) ((lambda (_1316) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1312 y1313)) tmp1314))) (syntax-dispatch tmp1314 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) y1313)) tmp1311) (syntax-error tmp1310))) (syntax-dispatch tmp1310 (quote (any any))))) (list x1308 y1309)))) (quasivector1290 (lambda (x1317) ((lambda (tmp1318) ((lambda (x1319) ((lambda (tmp1320) ((lambda (tmp1321) (if tmp1321 (apply (lambda (x1322) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector x1322))) tmp1321) ((lambda (tmp1324) (if tmp1324 (apply (lambda (x1325) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1325)) tmp1324) ((lambda (_1327) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) x1319)) tmp1320))) (syntax-dispatch tmp1320 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch tmp1320 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) x1319)) tmp1318)) x1317))) (quasi1291 (lambda (p1328 lev1329) ((lambda (tmp1330) ((lambda (tmp1331) (if tmp1331 (apply (lambda (p1332) (if (= lev1329 (quote 0)) p1332 (quasicons1288 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi1291 (list p1332) (- lev1329 (quote 1)))))) tmp1331) ((lambda (tmp1333) (if tmp1333 (apply (lambda (p1334 q1335) (if (= lev1329 (quote 0)) (quasiappend1289 p1334 (quasi1291 q1335 lev1329)) (quasicons1288 (quasicons1288 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi1291 (list p1334) (- lev1329 (quote 1)))) (quasi1291 q1335 lev1329)))) tmp1333) ((lambda (tmp1336) (if tmp1336 (apply (lambda (p1337) (quasicons1288 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (quasi1291 (list p1337) (+ lev1329 (quote 1))))) tmp1336) ((lambda (tmp1338) (if tmp1338 (apply (lambda (p1339 q1340) (quasicons1288 (quasi1291 p1339 lev1329) (quasi1291 q1340 lev1329))) tmp1338) ((lambda (tmp1341) (if tmp1341 (apply (lambda (x1342) (quasivector1290 (quasi1291 x1342 lev1329))) tmp1341) ((lambda (p1344) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) p1344)) tmp1330))) (syntax-dispatch tmp1330 (quote #(vector each-any)))))) (syntax-dispatch tmp1330 (quote (any . any)))))) (syntax-dispatch tmp1330 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch tmp1330 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch tmp1330 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) p1328)))) (lambda (x1345) ((lambda (tmp1346) ((lambda (tmp1347) (if tmp1347 (apply (lambda (_1348 e1349) (quasi1291 e1349 (quote 0))) tmp1347) (syntax-error tmp1346))) (syntax-dispatch tmp1346 (quote (any any))))) x1345)))) +(install-global-transformer (quote include) (lambda (x1350) (letrec ((read-file1351 (lambda (fn1352 k1353) (let ((p1354 (open-input-file fn1352))) (let f1355 ((x1356 (read p1354))) (if (eof-object? x1356) (begin (close-input-port p1354) (quote ())) (cons (datum->syntax-object k1353 x1356) (f1355 (read p1354))))))))) ((lambda (tmp1357) ((lambda (tmp1358) (if tmp1358 (apply (lambda (k1359 filename1360) (let ((fn1361 (syntax-object->datum filename1360))) ((lambda (tmp1362) ((lambda (tmp1363) (if tmp1363 (apply (lambda (exp1364) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) exp1364)) tmp1363) (syntax-error tmp1362))) (syntax-dispatch tmp1362 (quote each-any)))) (read-file1351 fn1361 k1359)))) tmp1358) (syntax-error tmp1357))) (syntax-dispatch tmp1357 (quote (any any))))) x1350)))) +(install-global-transformer (quote unquote) (lambda (x1366) ((lambda (tmp1367) ((lambda (tmp1368) (if tmp1368 (apply (lambda (_1369 e1370) (error (quote unquote) (quote "expression ,~s not valid outside of quasiquote") (syntax-object->datum e1370))) tmp1368) (syntax-error tmp1367))) (syntax-dispatch tmp1367 (quote (any any))))) x1366))) +(install-global-transformer (quote unquote-splicing) (lambda (x1371) ((lambda (tmp1372) ((lambda (tmp1373) (if tmp1373 (apply (lambda (_1374 e1375) (error (quote unquote-splicing) (quote "expression ,@~s not valid outside of quasiquote") (syntax-object->datum e1375))) tmp1373) (syntax-error tmp1372))) (syntax-dispatch tmp1372 (quote (any any))))) x1371))) +(install-global-transformer (quote case) (lambda (x1376) ((lambda (tmp1377) ((lambda (tmp1378) (if tmp1378 (apply (lambda (_1379 e1380 m11381 m21382) ((lambda (tmp1383) ((lambda (body1384) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1380)) body1384)) tmp1383)) (let f1385 ((clause1386 m11381) (clauses1387 m21382)) (if (null? clauses1387) ((lambda (tmp1389) ((lambda (tmp1390) (if tmp1390 (apply (lambda (e11391 e21392) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11391 e21392))) tmp1390) ((lambda (tmp1394) (if tmp1394 (apply (lambda (k1395 e11396 e21397) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1395)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11396 e21397)))) tmp1394) ((lambda (_1400) (syntax-error x1376)) tmp1389))) (syntax-dispatch tmp1389 (quote (each-any any . each-any)))))) (syntax-dispatch tmp1389 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) clause1386) ((lambda (tmp1401) ((lambda (rest1402) ((lambda (tmp1403) ((lambda (tmp1404) (if tmp1404 (apply (lambda (k1405 e11406 e21407) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) k1405)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e11406 e21407)) rest1402)) tmp1404) ((lambda (_1410) (syntax-error x1376)) tmp1403))) (syntax-dispatch tmp1403 (quote (each-any any . each-any))))) clause1386)) tmp1401)) (f1385 (car clauses1387) (cdr clauses1387))))))) tmp1378) (syntax-error tmp1377))) (syntax-dispatch tmp1377 (quote (any any any . each-any))))) x1376))) +(install-global-transformer (quote identifier-syntax) (lambda (x1411) ((lambda (tmp1412) ((lambda (tmp1413) (if tmp1413 (apply (lambda (_1414 e1415) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) e1415)) (list (cons _1414 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons e1415 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) tmp1413) (syntax-error tmp1412))) (syntax-dispatch tmp1412 (quote (any any))))) x1411))) diff --git a/ice-9/psyntax.ss b/ice-9/psyntax.ss index b14c14f4a..27b23b342 100644 --- a/ice-9/psyntax.ss +++ b/ice-9/psyntax.ss @@ -1901,7 +1901,6 @@ (set! datum->syntax-object (lambda (id datum) - (arg-check nonsymbol-id? id 'datum->syntax-object) (make-syntax-object datum (syntax-object-wrap id)))) (set! syntax-object->datum From dd580bd60256903c59ac334fba331a8d5e23fa29 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 14 Jan 2002 20:41:41 +0000 Subject: [PATCH 08/54] *** empty log message *** --- ice-9/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 94548f586..016ee6e56 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,10 @@ +2002-01-14 Marius Vollmer + + * psyntax.ss (datum->syntax-object): Removed assertion in + datum->syntax-object that checked if the first argument, a + syntax-object, is an identifier. This was a unconvenient and + unnecessary restriction. Thanks to Dorai Sitaram! + 2002-01-12 Marius Vollmer More options for pretty-print. Thanks to Matthias Köppe! From cdd2e6500e09efdf2a52655a1a3750adba686d3b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 14 Jan 2002 20:45:36 +0000 Subject: [PATCH 09/54] Minor edits. --- devel/memory.text | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/devel/memory.text b/devel/memory.text index 50d5a6b6a..0e7912e10 100644 --- a/devel/memory.text +++ b/devel/memory.text @@ -130,7 +130,7 @@ everybody else to systematically review their code. itself. (We don't do this out of lazyness but because it will keep the memory management overhead very low.) -The normal thing to use is scm_gc_malloc / scm_gc_free. +The normal thing to use is scm_gc_malloc, scm_gc_realloc, and scm_gc_free. Cell allocation and initialization From 513a3bd72d5a646f3a0277bf07bce30dc4d91e73 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 21 Jan 2002 01:11:35 +0000 Subject: [PATCH 10/54] (map1): Rewrite to be tail-recursive. Thanks to Panagiotis Vossos for the bug report. --- srfi/srfi-1.scm | 35 ++++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 15 deletions(-) diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index badd967fc..21475e323 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -1,17 +1,17 @@ ;;;; srfi-1.scm --- SRFI-1 procedures for Guile ;;;; ;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; +;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License as ;;;; published by the Free Software Foundation; either version 2, or ;;;; (at your option) any later version. -;;;; +;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, @@ -60,7 +60,7 @@ :use-module (ice-9 session) :use-module (ice-9 receive)) -(export +(export ;;; Constructors ;; cons <= in the core ;; list <= in the core @@ -306,7 +306,7 @@ ((not-pair? hare) #t) (else (let ((hare (cdr hare))) - (cond + (cond ((null? hare) #f) ((not-pair? hare) #t) ((eq? hare tortoise) #f) @@ -315,7 +315,7 @@ (define (null-list? x) (cond - ((proper-list? x) + ((proper-list? x) (null? x)) ((circular-list? x) #f) @@ -375,7 +375,7 @@ s (lp0 (cdr s) (cdr l)))) (lp (- n 1) (cdr l))))) - + (define (drop-right flist i) (let lp ((n i) (l flist)) (if (<= n 0) @@ -390,7 +390,7 @@ '() (let lp ((n (- i 1)) (l x)) (if (<= n 0) - (begin + (begin (set-cdr! l '()) x) (lp (- n 1) (cdr l)))))) @@ -468,7 +468,7 @@ (begin (set-cdr! ntail (car l)) (lp (cdr l) (last-pair ntail)))))))))) - + (define (append-reverse rev-head tail) (let lp ((l rev-head) (acc tail)) @@ -484,7 +484,7 @@ (if (any null? l) (reverse! acc) (lp (map1 cdr l) (cons (map1 car l) acc))))) - + (define (unzip1 l) (map1 first l)) @@ -603,10 +603,15 @@ ;; Internal helper procedure. Map `f' over the single list `ls'. ;; (define (map1 f ls) - (let lp ((l ls)) - (if (null? l) - '() - (cons (f (car l)) (lp (cdr l)))))) + (if (null? ls) + ls + (let ((ret (list (f (car ls))))) + (let lp ((ls (cdr ls)) (p ret)) ; tail pointer + (if (null? ls) + ret + (begin + (set-cdr! p (list (f (car ls)))) + (lp (cdr ls) (cdr p)))))))) ;; This `map' is extended from the standard `map'. It allows argument ;; lists of different length, so that the shortest list determines the @@ -901,7 +906,7 @@ (define (delete-duplicates list . rest) (let ((l= (if (pair? rest) (car rest) equal?))) (let lp ((list list)) - (if (null? list) + (if (null? list) '() (cons (car list) (lp (delete (car list) (cdr list) l=))))))) From c323f1f42e5038c8d3a490c39c35b224d81d5d68 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 21 Jan 2002 01:12:37 +0000 Subject: [PATCH 11/54] *** empty log message *** --- srfi/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 41540976a..44e385b15 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2002-01-20 Thien-Thi Nguyen + + * srfi-1.scm (map1): Rewrite to be tail-recursive. + Thanks to Panagiotis Vossos for the bug report. + 2001-12-16 Marius Vollmer * srfi-11.scm (let-values): Use `gensym' instead of `gentemp'. From 350efb7989756d251a0689c8e805366acf5fed09 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 21 Jan 2002 01:14:19 +0000 Subject: [PATCH 12/54] Add Panagiotis Vossos. --- THANKS | 1 + 1 file changed, 1 insertion(+) diff --git a/THANKS b/THANKS index 831b08968..4a34e7b29 100644 --- a/THANKS +++ b/THANKS @@ -26,4 +26,5 @@ For fixes or providing information which led to a fix: Ken Raeburn Bill Schottstaedt Momchil Velikov + Panagiotis Vossos Keith Wright From e4cb30dff308c62cd177f1830d6b21ba190754ce Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 21 Jan 2002 21:31:34 +0000 Subject: [PATCH 13/54] (count1, take-while): Rewrite to be tail-recursive. Thanks to Panagiotis Vossos. --- srfi/srfi-1.scm | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index 21475e323..1d9dd678c 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -510,11 +510,12 @@ (lp (map1 cdr lists)))))))) (define (count1 pred clist) - (if (null? clist) - 0 - (if (pred (car clist)) - (+ 1 (count1 pred (cdr clist))) - (count1 pred (cdr clist))))) + (let lp ((result 0) (rest clist)) + (if (null? rest) + result + (if (pred (car rest)) + (lp (+ 1 result) (cdr rest)) + (lp result (cdr rest)))))) ;;; Fold, unfold & map @@ -771,12 +772,17 @@ clist (find-tail pred (cdr clist))))) -(define (take-while pred clist) - (if (null? clist) - '() - (if (pred (car clist)) - (cons (car clist) (take-while pred (cdr clist))) - '()))) +(define (take-while pred ls) + (cond ((null? ls) '()) + ((not (pred (car ls))) '()) + (else + (let ((result (list (car ls)))) + (let lp ((ls (cdr ls)) (p result)) + (cond ((null? ls) result) + ((not (pred (car ls))) result) + (else + (set-cdr! p (list (car ls))) + (lp (cdr ls) (cdr p))))))))) (define (take-while! pred clist) (take-while pred clist)) ; XXX:optimize From 229d2c9c076d214457f4f6817f7d3c1db90ed994 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 21 Jan 2002 21:32:37 +0000 Subject: [PATCH 14/54] *** empty log message *** --- srfi/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 44e385b15..28554e78d 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,8 @@ +2002-01-21 Thien-Thi Nguyen + + * srfi-1.scm (count1, take-while): Rewrite to be tail-recursive. + Thanks to Panagiotis Vossos. + 2002-01-20 Thien-Thi Nguyen * srfi-1.scm (map1): Rewrite to be tail-recursive. From c96d76b88dcb7805311d14e6e408d064211fde20 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 22 Jan 2002 23:31:39 +0000 Subject: [PATCH 15/54] * First batch of libguile changes for Elisp support. * Fixed a few typos. * Minor rationalization of macros relating to source breakpoints. --- libguile/ChangeLog | 95 ++++++++++++++++++++++++ libguile/alist.c | 7 +- libguile/async.c | 7 +- libguile/backtrace.c | 2 +- libguile/boolean.c | 5 +- libguile/dynl.c | 3 +- libguile/eval.c | 168 ++++++++++++++++--------------------------- libguile/eval.h | 7 +- libguile/filesys.c | 5 +- libguile/fluids.c | 5 +- libguile/init.c | 2 + libguile/lang.c | 10 +++ libguile/lang.h | 12 +++- libguile/list.c | 33 ++++----- libguile/load.c | 11 +-- libguile/options.c | 5 +- libguile/posix.c | 3 +- libguile/print.c | 19 ++--- libguile/read.c | 2 +- libguile/script.c | 2 +- libguile/sort.c | 31 ++++---- libguile/srcprop.c | 4 +- libguile/srcprop.h | 5 +- libguile/tags.h | 16 ++--- libguile/throw.c | 3 +- libguile/validate.h | 2 + libguile/vectors.c | 3 +- libguile/weaks.c | 3 +- 28 files changed, 275 insertions(+), 195 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index cd72ef097..f28ecbbb0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,98 @@ +2002-01-22 Neil Jerram + + Other changes unrelated to Elisp... + + * eval.c (scm_m_if): Use s_if rather than repeating string literal + "if". + (comments): Fix a few typos. + (scm_for_each): Add parentheses around oddly unparenthesized + if/while conditions. + + * read.c (scm_read_opts): Add full stop at end of doc for + `keywords' option. + + * script.c (scm_compile_shell_switches): Use scm_str2symbol + instead of gh_symbol2scm. + + * srcprop.h (SRCPROPBRK): Return C type rather than SCM. + (SRCBRKP): Use SRCPROPBRK rather than duplicating its logic. + + * srcprop.c (scm_srcprops_to_plist, scm_source_property): Change + SRCPROPBRK (x) to SCM_BOOL (SRCPROPBRK (x)). + + First batch of changes for Elisp support... + + * alist.c, async.c, boolean.c, dynl.c, eval.c, filesys.c, + fluids.c, list.c, load.c, options.c, posix.c, print.c, sort.c, + throw.c, vectors.c, weaks.c: Add #include for lang.h. + + * eval.c, eval.h, init.c, lang.c, lang.h: Use SCM_ENABLE_ELISP to + conditionalize compilation and initialization of Elisp support + function. + + * alist.c (scm_assq, scm_assv, scm_assoc), async.c + (scm_asyncs_pending, scm_run_asyncs, noop), backtrace.c + (scm_set_print_params_x), dynl.c (scm_make_argv_from_stringlist), + filesys.c (fill_select_type, retrieve_select_type), fluids.c + (scm_swap_fluids, scm_swap_fluids_reverse), list.c (scm_null_p, + scm_ilength, scm_append_x, scm_last_pair, scm_reverse, + scm_reverse_x, scm_list_ref, scm_list_set_x, scm_list_cdr_set_x, + scm_c_memq, scm_memv), load.c (scm_search_path), options.c + (change_option_setting, scm_options), posix.c (environ_list_to_c), + print.c (scm_iprlist), throw.c (scm_exit_status), vectors.c + (scm_vector), weaks.c (scm_weak_vector): Use SCM_NULL_OR_NIL_P + instead of SCM_NULLP. + + * boolean.c (scm_not): Use `SCM_FALSEP || SCM_NILP' instead of + just SCM_FALSEP. + + * boolean.c (scm_boolean_p): Use `SCM_BOOLP || SCM_NILP' instead + of just SCM_BOOLP. + + * eval.c (scm_lisp_nil, scm_lisp_t, s_nil_ify, scm_m_nil_ify, + s_t_ify, scm_m_t_ify, s_0_cond, scm_m_0_cond, s_0_ify, + scm_m_0_ify, s_1_ify, scm_m_1_ify): Removed. + (scm_m_atfop): Support function aliasing. Support both function + args, which need transformation, and macro args, which do not. + Add explanatory comments. + (SCM_CEVAL): In switch cases for SCM_IM_AND, SCM_IM_COND, + SCM_IM_DO, SCM_IM_IF and SCM_IM_OR, add `|| SCM_NILP' to existing + checks for SCM_FALSEP. In switch case for SCM_IM_NIL_COND, use + SCM_NULLP || SCM_NILP instead of checks against (removed) + scm_lisp_nil. Removed switch cases for SCM_IM_NIL_IFY, + SCM_IM_T_IFY, SCM_IM_0_COND, SCM_IM_0_IFY, SCM_IM_1_IFY. + + * lang.c (scm_nil_cons, scm_nil_car, scm_nil_cdr, scm_null, + scm_m_while, scm_nil_eq): Commented out; I don't think we need + these, but I don't want to remove them yet, just in case. + (scm_init_lang): Define `%nil' variable on Scheme level to hold + Elisp nil value. + + * lang.h (SCM_NILP): Test against Elisp nil value instead of + against (removed) scm_lisp_nil. + (SCM_NILNULLP, SCM_NIL2EOL, SCM_EOL2NIL): Commented out. + (SCM_NULL_OR_NIL_P): New. + + * list.c (scm_append): Use SCM_VALIDATE_NULL_OR_NIL instead of + SCM_VALIDATE_NULL. + + * print.c (scm_isymnames): Fix comment. Remove #@nil-ify, + #@t-ify, #@0-cond, #@0-ify, #@1-ify. Add #nil (for SCM_ELISP_NIL + value). + + * sort.c (scm_sorted_p, scm_merge, scm_merge_list_x, scm_merge_x, + scm_sort_x, scm_sort, scm_stable_sort_x, scm_stable_sort): Use + SCM_NULL_OR_NIL_P instead of SCM_NULLP. In constructions like `if + (SCM_NULLP (x)) return SCM_EOL;', return x rather than SCM_EOL. + + * tags.h (SCM_IM_NIL_IFY, SCM_IM_T_IFY, SCM_IM_0_COND, + SCM_IM_0_IFY, SCM_IM_1_IFY): Removed. + (SCM_IM_BIND, SCM_IM_DELAY, SCM_IM_CALL_WITH_VALUES, SCM_UNBOUND): + Numbering shifted down accordingly. + (SCM_ELISP_NIL): New IFLAG. + + * validate.h (SCM_VALIDATE_NULL_OR_NIL): New. + 2002-01-10 Dirk Herrmann * eval.c: Removed outdated references to "everr". Improved some diff --git a/libguile/alist.c b/libguile/alist.c index 2dd6057b4..a3cdde604 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -44,6 +44,7 @@ #include "libguile/_scm.h" #include "libguile/eq.h" #include "libguile/list.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/alist.h" @@ -144,7 +145,7 @@ SCM_DEFINE (scm_assq, "assq", 2, 0, 0, if (SCM_EQ_P (SCM_CAR (tmp), key)) return tmp; } - SCM_ASSERT_TYPE (SCM_NULLP (ls), alist, SCM_ARG2, FUNC_NAME, + SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME, "association list"); return SCM_BOOL_F; } @@ -165,7 +166,7 @@ SCM_DEFINE (scm_assv, "assv", 2, 0, 0, if (SCM_NFALSEP (scm_eqv_p (SCM_CAR (tmp), key))) return tmp; } - SCM_ASSERT_TYPE (SCM_NULLP (ls), alist, SCM_ARG2, FUNC_NAME, + SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME, "association list"); return SCM_BOOL_F; } @@ -186,7 +187,7 @@ SCM_DEFINE (scm_assoc, "assoc", 2, 0, 0, if (SCM_NFALSEP (scm_equal_p (SCM_CAR (tmp), key))) return tmp; } - SCM_ASSERT_TYPE (SCM_NULLP (ls), alist, SCM_ARG2, FUNC_NAME, + SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME, "association list"); return SCM_BOOL_F; } diff --git a/libguile/async.c b/libguile/async.c index 5d06c1f77..e3b7d33f3 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -48,6 +48,7 @@ #include "libguile/throw.h" #include "libguile/root.h" #include "libguile/smob.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/async.h" @@ -128,7 +129,7 @@ scm_asyncs_pending () { SCM pos; pos = scm_asyncs; - while (!SCM_NULLP (pos)) + while (!SCM_NULL_OR_NIL_P (pos)) { SCM a = SCM_CAR (pos); if (ASYNC_GOT_IT (a)) @@ -356,7 +357,7 @@ SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, #else scm_asyncs_pending_p = 0; #endif - while (! SCM_NULLP (list_of_a)) + while (! SCM_NULL_OR_NIL_P (list_of_a)) { SCM a; SCM_VALIDATE_CONS (1, list_of_a); @@ -385,7 +386,7 @@ SCM_DEFINE (scm_noop, "noop", 0, 0, 1, #define FUNC_NAME s_scm_noop { SCM_VALIDATE_REST_ARGUMENT (args); - return (SCM_NULLP (args) ? SCM_BOOL_F : SCM_CAR (args)); + return (SCM_NULL_OR_NIL_P (args) ? SCM_BOOL_F : SCM_CAR (args)); } #undef FUNC_NAME diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 803f5aaaa..290627fbb 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -302,7 +302,7 @@ SCM_DEFINE (scm_set_print_params_x, "set-print-params!", 1, 0, 0, print_params_t *new_params; SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, params, n); - for (ls = params; !SCM_NULLP (ls); ls = SCM_CDR (ls)) + for (ls = params; !SCM_NULL_OR_NIL_P (ls); ls = SCM_CDR (ls)) SCM_ASSERT (scm_ilength (SCM_CAR (params)) == 2 && SCM_INUMP (SCM_CAAR (ls)) && SCM_INUM (SCM_CAAR (ls)) >= 0 diff --git a/libguile/boolean.c b/libguile/boolean.c index da56aab54..402fce55d 100644 --- a/libguile/boolean.c +++ b/libguile/boolean.c @@ -46,6 +46,7 @@ #include "libguile/validate.h" #include "libguile/boolean.h" +#include "libguile/lang.h" @@ -54,7 +55,7 @@ SCM_DEFINE (scm_not, "not", 1, 0, 0, "Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}.") #define FUNC_NAME s_scm_not { - return SCM_BOOL(SCM_FALSEP(x)); + return SCM_BOOL(SCM_FALSEP (x) || SCM_NILP (x)); } #undef FUNC_NAME @@ -64,7 +65,7 @@ SCM_DEFINE (scm_boolean_p, "boolean?", 1, 0, 0, "Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}.") #define FUNC_NAME s_scm_boolean_p { - return SCM_BOOL (SCM_BOOLP (obj)); + return SCM_BOOL (SCM_BOOLP (obj) || SCM_NILP (obj)); } #undef FUNC_NAME diff --git a/libguile/dynl.c b/libguile/dynl.c index 136595780..d920b2d7a 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -72,6 +72,7 @@ maybe_drag_in_eprintf () #include "libguile/ports.h" #include "libguile/strings.h" #include "libguile/deprecation.h" +#include "libguile/lang.h" #include "libguile/validate.h" /* Create a new C argv array from a scheme list of strings. */ @@ -97,7 +98,7 @@ scm_make_argv_from_stringlist (SCM args,int *argcp,const char *subr,int argn) argc = scm_ilength (args); SCM_ASSERT (argc >= 0, args, argn, subr); argv = (char **) scm_must_malloc ((argc + 1) * sizeof (char *), subr); - for (i = 0; !SCM_NULLP (args); args = SCM_CDR (args), ++i) { + for (i = 0; !SCM_NULL_OR_NIL_P (args); args = SCM_CDR (args), ++i) { SCM arg = SCM_CAR (args); size_t len; char *dst; diff --git a/libguile/eval.c b/libguile/eval.c index 4138456d7..2fff70468 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -100,6 +100,7 @@ char *alloca (); #include "libguile/validate.h" #include "libguile/eval.h" +#include "libguile/lang.h" @@ -537,7 +538,7 @@ SCM scm_m_if (SCM xorig, SCM env SCM_UNUSED) { long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, "if"); + SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_if); return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); } @@ -1073,10 +1074,7 @@ scm_m_cont (SCM xorig, SCM env SCM_UNUSED) return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); } -/* Multi-language support */ - -SCM_GLOBAL_SYMBOL (scm_lisp_nil, "nil"); -SCM_GLOBAL_SYMBOL (scm_lisp_t, "t"); +#ifdef SCM_ENABLE_ELISP SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); @@ -1088,52 +1086,6 @@ scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED) return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig)); } -SCM_SYNTAX (s_nil_ify, "nil-ify", scm_makmmacro, scm_m_nil_ify); - -SCM -scm_m_nil_ify (SCM xorig, SCM env SCM_UNUSED) -{ - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "nil-ify"); - return scm_cons (SCM_IM_NIL_IFY, SCM_CDR (xorig)); -} - -SCM_SYNTAX (s_t_ify, "t-ify", scm_makmmacro, scm_m_t_ify); - -SCM -scm_m_t_ify (SCM xorig, SCM env SCM_UNUSED) -{ - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "t-ify"); - return scm_cons (SCM_IM_T_IFY, SCM_CDR (xorig)); -} - -SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond); - -SCM -scm_m_0_cond (SCM xorig, SCM env SCM_UNUSED) -{ - long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "0-cond"); - return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig)); -} - -SCM_SYNTAX (s_0_ify, "0-ify", scm_makmmacro, scm_m_0_ify); - -SCM -scm_m_0_ify (SCM xorig, SCM env SCM_UNUSED) -{ - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "0-ify"); - return scm_cons (SCM_IM_0_IFY, SCM_CDR (xorig)); -} - -SCM_SYNTAX (s_1_ify, "1-ify", scm_makmmacro, scm_m_1_ify); - -SCM -scm_m_1_ify (SCM xorig, SCM env SCM_UNUSED) -{ - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "1-ify"); - return scm_cons (SCM_IM_1_IFY, SCM_CDR (xorig)); -} - SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop); SCM @@ -1142,12 +1094,45 @@ scm_m_atfop (SCM xorig, SCM env SCM_UNUSED) SCM x = SCM_CDR (xorig), var; SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop"); var = scm_symbol_fref (SCM_CAR (x)); + /* Passing the symbol name as the `subr' arg here isn't really + right, but without it it can be very difficult to work out from + the error message which function definition was missing. In any + case, we shouldn't really use SCM_ASSYNT here at all, but instead + something equivalent to (signal void-function (list SYM)) in + Elisp. */ SCM_ASSYNT (SCM_VARIABLEP (var), - "Symbol's function definition is void", NULL); + "Symbol's function definition is void", + SCM_SYMBOL_CHARS (SCM_CAR (x))); + /* Support `defalias'. */ + while (SCM_SYMBOLP (SCM_VARIABLE_REF (var))) + { + var = scm_symbol_fref (SCM_VARIABLE_REF (var)); + SCM_ASSYNT (SCM_VARIABLEP (var), + "Symbol's function definition is void", + SCM_SYMBOL_CHARS (SCM_CAR (x))); + } + /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the + former allows for automatically picking up redefinitions of the + corresponding symbol. */ SCM_SETCAR (x, var); + /* If the variable contains a procedure, leave the + `transformer-macro' in place so that the procedure's arguments + get properly transformed, and change the initial @fop to + SCM_IM_APPLY. */ + if (!SCM_MACROP (SCM_VARIABLE_REF (var))) + { + SCM_SETCAR (xorig, SCM_IM_APPLY); + return xorig; + } + /* Otherwise (the variable contains a macro), the arguments should + not be transformed, so cut the `transformer-macro' out and return + the resulting expression starting with the variable. */ + SCM_SETCDR (x, SCM_CDADR (x)); return x; } +#endif /* SCM_ENABLE_ELISP */ + /* (@bind ((var exp) ...) body ...) This will assign the values of the `exp's to the global variables @@ -1158,7 +1143,7 @@ scm_m_atfop (SCM xorig, SCM env SCM_UNUSED) error when a symbol appears more than once among the `var's. All `exp's are evaluated before any `var' is set. - This of this as `let' for dynamic scope. + Think of this as `let' for dynamic scope. It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...). @@ -1325,7 +1310,7 @@ scm_macroexp (SCM x, SCM env) * generating the source for a stackframe in a backtrace, and in * display_expression. * - * Unmemoizing is not a realiable process. You can not in general + * Unmemoizing is not a reliable process. You cannot in general * expect to get the original source back. * * However, GOOPS currently relies on this for method compilation. @@ -2018,7 +2003,7 @@ dispatch: x = SCM_CDR (x); while (!SCM_NULLP (SCM_CDR (x))) { - if (SCM_FALSEP (EVALCAR (x, env))) + if (SCM_FALSEP (t.arg1 = EVALCAR (x, env)) || SCM_NILP (t.arg1)) RETURN (SCM_BOOL_F); else x = SCM_CDR (x); @@ -2129,7 +2114,7 @@ dispatch: goto begin; } t.arg1 = EVALCAR (proc, env); - if (!SCM_FALSEP (t.arg1)) + if (!SCM_FALSEP (t.arg1) && !SCM_NILP (t.arg1)) { x = SCM_CDR (proc); if (SCM_NULLP (x)) @@ -2164,7 +2149,8 @@ dispatch: } env = EXTEND_ENV (SCM_CAR (x), t.arg1, env); x = SCM_CDDR (x); - while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env))) + while (proc = SCM_CAR (x), + SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) || SCM_NILP (t.arg1)) { for (proc = SCM_CADR (x); SCM_NIMP (proc); proc = SCM_CDR (proc)) { @@ -2186,7 +2172,7 @@ dispatch: case SCM_BIT8(SCM_IM_IF): x = SCM_CDR (x); - if (!SCM_FALSEP (EVALCAR (x, env))) + if (!SCM_FALSEP (t.arg1 = EVALCAR (x, env)) && !SCM_NILP (t.arg1)) x = SCM_CDR (x); else if (SCM_IMP (x = SCM_CDDR (x))) RETURN (SCM_UNSPECIFIED); @@ -2249,7 +2235,7 @@ dispatch: while (!SCM_NULLP (SCM_CDR (x))) { SCM val = EVALCAR (x, env); - if (!SCM_FALSEP (val)) + if (!SCM_FALSEP (val) && !SCM_NILP (val)) RETURN (val); else x = SCM_CDR (x); @@ -2477,13 +2463,16 @@ dispatch: SCM_STRUCT_DATA (t.arg1) [SCM_INUM (SCM_CAR (x))] = SCM_UNPACK (EVALCAR (proc, env)); RETURN (SCM_UNSPECIFIED); + +#ifdef SCM_ENABLE_ELISP case (SCM_ISYMNUM (SCM_IM_NIL_COND)): proc = SCM_CDR (x); while (SCM_NIMP (x = SCM_CDR (proc))) { if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) - || SCM_EQ_P (t.arg1, scm_lisp_nil))) + || SCM_NILP (t.arg1) + || SCM_NULLP (t.arg1))) { if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED)) RETURN (t.arg1); @@ -2496,45 +2485,7 @@ dispatch: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; - case (SCM_ISYMNUM (SCM_IM_NIL_IFY)): - x = SCM_CDR (x); - RETURN ((SCM_FALSEP (proc = EVALCAR (x, env)) || SCM_NULLP (proc)) - ? scm_lisp_nil - : proc); - - case (SCM_ISYMNUM (SCM_IM_T_IFY)): - x = SCM_CDR (x); - RETURN (!SCM_FALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil); - - case (SCM_ISYMNUM (SCM_IM_0_COND)): - proc = SCM_CDR (x); - while (SCM_NIMP (x = SCM_CDR (proc))) - { - if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) - || SCM_EQ_P (t.arg1, SCM_INUM0))) - { - if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED)) - RETURN (t.arg1); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto carloop; - } - proc = SCM_CDR (x); - } - x = proc; - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto carloop; - - case (SCM_ISYMNUM (SCM_IM_0_IFY)): - x = SCM_CDR (x); - RETURN (SCM_FALSEP (proc = EVALCAR (x, env)) - ? SCM_INUM0 - : proc); - - case (SCM_ISYMNUM (SCM_IM_1_IFY)): - x = SCM_CDR (x); - RETURN (!SCM_FALSEP (EVALCAR (x, env)) - ? SCM_MAKINUM (1) - : SCM_INUM0); +#endif /* SCM_ENABLE_ELISP */ case (SCM_ISYMNUM (SCM_IM_BIND)): { @@ -2568,7 +2519,7 @@ dispatch: RETURN (proc); } - + case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): { proc = SCM_CDR (x); @@ -3388,7 +3339,11 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, SCM *lloc; SCM_VALIDATE_NONEMPTYLIST (1,lst); lloc = &lst; - while (!SCM_NULLP (SCM_CDR (*lloc))) + while (!SCM_NULLP (SCM_CDR (*lloc))) /* Perhaps should be + SCM_NULL_OR_NIL_P, but not + needed in 99.99% of cases, + and it could seriously hurt + performance. - Neil */ lloc = SCM_CDRLOC (*lloc); SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME); *lloc = SCM_CAR (*lloc); @@ -3846,9 +3801,9 @@ scm_for_each (SCM proc, SCM arg1, SCM args) SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args), SCM_ARG2, s_for_each); SCM_VALIDATE_REST_ARGUMENT (args); - if SCM_NULLP (args) + if (SCM_NULLP (args)) { - while SCM_NIMP (arg1) + while (SCM_NIMP (arg1)) { scm_apply (proc, SCM_CAR (arg1), scm_listofnull); arg1 = SCM_CDR (arg1); @@ -3865,8 +3820,8 @@ scm_for_each (SCM proc, SCM arg1, SCM args) arg1 = SCM_EOL; for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--) { - if SCM_IMP - (ve[i]) return SCM_UNSPECIFIED; + if (SCM_IMP (ve[i])) + return SCM_UNSPECIFIED; arg1 = scm_cons (SCM_CAR (ve[i]), arg1); ve[i] = SCM_CDR (ve[i]); } @@ -4182,9 +4137,6 @@ scm_init_eval () #ifndef SCM_MAGIC_SNARFER #include "libguile/eval.x" #endif - - scm_c_define ("nil", scm_lisp_nil); - scm_c_define ("t", scm_lisp_t); scm_add_feature ("delay"); } diff --git a/libguile/eval.h b/libguile/eval.h index 27f3860db..7d76a9098 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -204,13 +204,10 @@ SCM_API SCM scm_m_letrec (SCM xorig, SCM env); SCM_API SCM scm_m_let (SCM xorig, SCM env); SCM_API SCM scm_m_apply (SCM xorig, SCM env); SCM_API SCM scm_m_cont (SCM xorig, SCM env); +#ifdef SCM_ENABLE_ELISP SCM_API SCM scm_m_nil_cond (SCM xorig, SCM env); -SCM_API SCM scm_m_nil_ify (SCM xorig, SCM env); -SCM_API SCM scm_m_t_ify (SCM xorig, SCM env); -SCM_API SCM scm_m_0_cond (SCM xorig, SCM env); -SCM_API SCM scm_m_0_ify (SCM xorig, SCM env); -SCM_API SCM scm_m_1_ify (SCM xorig, SCM env); SCM_API SCM scm_m_atfop (SCM xorig, SCM env); +#endif /* SCM_ENABLE_ELISP */ SCM_API SCM scm_m_atbind (SCM xorig, SCM env); SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env); SCM_API int scm_badargsp (SCM formals, SCM args); diff --git a/libguile/filesys.c b/libguile/filesys.c index b8a9aadc9..862579c10 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -51,6 +51,7 @@ #include "libguile/iselect.h" #include "libguile/strings.h" #include "libguile/vectors.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/filesys.h" @@ -1032,7 +1033,7 @@ fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM list_or_vec, int pos) } else { - while (!SCM_NULLP (list_or_vec)) + while (!SCM_NULL_OR_NIL_P (list_or_vec)) { int fd = set_element (set, ports_ready, SCM_CAR (list_or_vec), pos); @@ -1092,7 +1093,7 @@ retrieve_select_type (SELECT_TYPE *set, SCM ports_ready, SCM list_or_vec) else { /* list_or_vec must be a list. */ - while (!SCM_NULLP (list_or_vec)) + while (!SCM_NULL_OR_NIL_P (list_or_vec)) { answer_list = get_element (set, SCM_CAR (list_or_vec), answer_list); list_or_vec = SCM_CDR (list_or_vec); diff --git a/libguile/fluids.c b/libguile/fluids.c index 2a8ff9a1f..7901e2231 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -50,6 +50,7 @@ #include "libguile/eval.h" #include "libguile/ports.h" #include "libguile/deprecation.h" +#include "libguile/lang.h" #define INITIAL_FLUIDS 10 #include "libguile/validate.h" @@ -178,7 +179,7 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, void scm_swap_fluids (SCM fluids, SCM vals) { - while (!SCM_NULLP (fluids)) + while (!SCM_NULL_OR_NIL_P (fluids)) { SCM fl = SCM_CAR (fluids); SCM old_val = scm_fluid_ref (fl); @@ -195,7 +196,7 @@ same fluid appears multiple times in the fluids list. */ void scm_swap_fluids_reverse (SCM fluids, SCM vals) { - if (!SCM_NULLP (fluids)) + if (!SCM_NULL_OR_NIL_P (fluids)) { SCM fl, old_val; diff --git a/libguile/init.c b/libguile/init.c index 5c96be4dc..b732165b4 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -560,7 +560,9 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_init_load_path (); scm_init_standard_ports (); /* Requires fports */ scm_init_dynamic_linking (); +#ifdef SCM_ENABLE_ELISP scm_init_lang (); +#endif /* SCM_ENABLE_ELISP */ scm_init_script (); scm_init_goops (); diff --git a/libguile/lang.c b/libguile/lang.c index f022bee77..463cbeb5c 100644 --- a/libguile/lang.c +++ b/libguile/lang.c @@ -62,6 +62,9 @@ * in all data structures. */ +#ifdef SCM_ENABLE_ELISP +#if 0 + SCM_DEFINE (scm_nil_cons, "nil-cons", 2, 0, 0, (SCM x, SCM y), "Create a new cons cell with @var{x} as the car and @var{y} as\n" @@ -145,17 +148,24 @@ SCM_DEFINE1 (scm_nil_eq, "nil-eq", scm_tc7_rpsubr, } #undef FUNC_NAME +#endif /* 0 */ void scm_init_lang () { +#if 0 #ifndef SCM_MAGIC_SNARFER #include "libguile/lang.x" #endif scm_make_synt ("nil-while", scm_makacro, scm_m_while); +#endif + + scm_c_define ("%nil", SCM_ELISP_NIL); } +#endif /* SCM_ENABLE_ELISP */ + /* Local Variables: c-file-style: "gnu" diff --git a/libguile/lang.h b/libguile/lang.h index ae10869b5..dba8a8f28 100644 --- a/libguile/lang.h +++ b/libguile/lang.h @@ -50,10 +50,14 @@ +#ifdef SCM_ENABLE_ELISP + +#define SCM_NILP(x) (SCM_EQ_P ((x), SCM_ELISP_NIL)) + +#if 0 SCM_API SCM scm_lisp_nil; SCM_API SCM scm_lisp_t; -#define SCM_NILP(x) (SCM_EQ_P ((x), scm_lisp_nil)) #define SCM_NILNULLP(x) (SCM_NILP (x) || SCM_NULLP (x)) #define SCM_NIL2EOL(x, tmp) (SCM_EQ_P ((tmp = (x)), scm_lisp_nil) ? SCM_EOL : tmp) #define SCM_EOL2NIL(x, tmp) (SCM_NULLP (tmp = (x)) ? scm_lisp_nil : tmp) @@ -68,7 +72,13 @@ SCM_API SCM scm_nil_cdr (SCM x); SCM_API SCM scm_null (SCM x); SCM_API SCM scm_m_while (SCM exp, SCM env); SCM_API SCM scm_nil_eq (SCM x, SCM y); +#endif /* 0 */ SCM_API void scm_init_lang (void); +#else /* ! SCM_ENABLE_ELISP */ +#define SCM_NILP(x) 0 +#endif /* ! SCM_ENABLE_ELISP */ + +#define SCM_NULL_OR_NIL_P(x) (SCM_NULLP (x) || SCM_NILP (x)) #endif /* SCM_LANG_H */ diff --git a/libguile/list.c b/libguile/list.c index 8d6237d20..2197a61f5 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -43,6 +43,7 @@ #include "libguile/_scm.h" #include "libguile/eq.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/list.h" @@ -165,7 +166,7 @@ SCM_DEFINE (scm_null_p, "null?", 1, 0, 0, "Return @code{#t} iff @var{x} is the empty list, else @code{#f}.") #define FUNC_NAME s_scm_null_p { - return SCM_BOOL (SCM_NULLP (x)); + return SCM_BOOL (SCM_NULL_OR_NIL_P (x)); } #undef FUNC_NAME @@ -192,11 +193,11 @@ scm_ilength(SCM sx) SCM hare = sx; do { - if (SCM_NULLP(hare)) return i; + if (SCM_NULL_OR_NIL_P(hare)) return i; if (SCM_NCONSP(hare)) return -1; hare = SCM_CDR(hare); i++; - if (SCM_NULLP(hare)) return i; + if (SCM_NULL_OR_NIL_P(hare)) return i; if (SCM_NCONSP(hare)) return -1; hare = SCM_CDR(hare); i++; @@ -259,7 +260,7 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1, lloc = SCM_CDRLOC (*lloc); arg = SCM_CDR (arg); } - SCM_VALIDATE_NULL (SCM_ARGn, arg); + SCM_VALIDATE_NULL_OR_NIL (SCM_ARGn, arg); arg = SCM_CAR (args); args = SCM_CDR (args); }; @@ -288,7 +289,7 @@ SCM_DEFINE (scm_append_x, "append!", 0, 0, 1, lists = SCM_CDR (lists); if (SCM_NULLP (lists)) { return arg; - } else if (!SCM_NULLP (arg)) { + } else if (!SCM_NULL_OR_NIL_P (arg)) { SCM_VALIDATE_CONS (SCM_ARG1, arg); SCM_SETCDR (scm_last_pair (arg), scm_append_x (lists)); return arg; @@ -308,8 +309,8 @@ SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0, SCM tortoise = lst; SCM hare = lst; - if (SCM_NULLP (lst)) - return SCM_EOL; + if (SCM_NULL_OR_NIL_P (lst)) + return lst; SCM_VALIDATE_CONS (SCM_ARG1, lst); do { @@ -340,11 +341,11 @@ SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0, SCM hare = lst; do { - if (SCM_NULLP(hare)) return result; + if (SCM_NULL_OR_NIL_P(hare)) return result; SCM_ASSERT(SCM_CONSP(hare), lst, 1, FUNC_NAME); result = scm_cons (SCM_CAR (hare), result); hare = SCM_CDR (hare); - if (SCM_NULLP(hare)) return result; + if (SCM_NULL_OR_NIL_P(hare)) return result; SCM_ASSERT(SCM_CONSP(hare), lst, 1, FUNC_NAME); result = scm_cons (SCM_CAR (hare), result); hare = SCM_CDR (hare); @@ -375,7 +376,7 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, else SCM_VALIDATE_LIST (2, new_tail); - while (SCM_NNULLP (lst)) + while (!SCM_NULL_OR_NIL_P (lst)) { SCM old_tail = SCM_CDR (lst); SCM_SETCDR (lst, new_tail); @@ -406,7 +407,7 @@ SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0, lst = SCM_CDR (lst); } }; - if (SCM_NULLP (lst)) + if (SCM_NULL_OR_NIL_P (lst)) SCM_OUT_OF_RANGE (2, k); else SCM_WRONG_TYPE_ARG (1, list); @@ -431,7 +432,7 @@ SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0, lst = SCM_CDR (lst); } }; - if (SCM_NULLP (lst)) + if (SCM_NULL_OR_NIL_P (lst)) SCM_OUT_OF_RANGE (2, k); else SCM_WRONG_TYPE_ARG (1, list); @@ -479,7 +480,7 @@ SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, lst = SCM_CDR (lst); } }; - if (SCM_NULLP (lst)) + if (SCM_NULL_OR_NIL_P (lst)) SCM_OUT_OF_RANGE (2, k); else SCM_WRONG_TYPE_ARG (1, list); @@ -555,7 +556,7 @@ SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0, SCM scm_c_memq (SCM obj, SCM list) { - for (; !SCM_NULLP (list); list = SCM_CDR (list)) + for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR (list)) { if (SCM_EQ_P (SCM_CAR (list), obj)) return list; @@ -591,7 +592,7 @@ SCM_DEFINE (scm_memv, "memv", 2, 0, 0, #define FUNC_NAME s_scm_memv { SCM_VALIDATE_LIST (2, lst); - for (; !SCM_NULLP (lst); lst = SCM_CDR (lst)) + for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst)) { if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (lst), x))) return lst; @@ -612,7 +613,7 @@ SCM_DEFINE (scm_member, "member", 2, 0, 0, #define FUNC_NAME s_scm_member { SCM_VALIDATE_LIST (2, lst); - for (; !SCM_NULLP (lst); lst = SCM_CDR (lst)) + for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst)) { if (! SCM_FALSEP (scm_equal_p (SCM_CAR (lst), x))) return lst; diff --git a/libguile/load.c b/libguile/load.c index d26f5aca8..0c8011534 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -55,6 +55,7 @@ #include "libguile/root.h" #include "libguile/strings.h" #include "libguile/modules.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/load.h" @@ -300,7 +301,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, SCM walk; max_path_len = 0; - for (walk = path; !SCM_NULLP (walk); walk = SCM_CDR (walk)) + for (walk = path; !SCM_NULL_OR_NIL_P (walk); walk = SCM_CDR (walk)) { SCM elt = SCM_CAR (walk); SCM_ASSERT_TYPE (SCM_STRINGP (elt), path, 1, FUNC_NAME, @@ -338,7 +339,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, SCM walk; max_ext_len = 0; - for (walk = extensions; !SCM_NULLP (walk); walk = SCM_CDR (walk)) + for (walk = extensions; !SCM_NULL_OR_NIL_P (walk); walk = SCM_CDR (walk)) { SCM elt = SCM_CAR (walk); SCM_ASSERT_TYPE (SCM_STRINGP (elt), elt, 3, FUNC_NAME, @@ -356,12 +357,12 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, char *buf = SCM_MUST_MALLOC (buf_size); /* This simplifies the loop below a bit. */ - if (SCM_NULLP (extensions)) + if (SCM_NULL_OR_NIL_P (extensions)) extensions = scm_listofnullstr; /* Try every path element. At this point, we know the path is a proper list of strings. */ - for (; !SCM_NULLP (path); path = SCM_CDR (path)) + for (; !SCM_NULL_OR_NIL_P (path); path = SCM_CDR (path)) { size_t len; SCM dir = SCM_CAR (path); @@ -377,7 +378,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, /* Try every extension. At this point, we know the extension list is a proper, nonempty list of strings. */ - for (exts = extensions; !SCM_NULLP (exts); exts = SCM_CDR (exts)) + for (exts = extensions; !SCM_NULL_OR_NIL_P (exts); exts = SCM_CDR (exts)) { SCM ext = SCM_CAR (exts); size_t ext_len = SCM_STRING_LENGTH (ext); diff --git a/libguile/options.c b/libguile/options.c index e95c12a85..731e62f79 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -47,6 +47,7 @@ #include "libguile/_scm.h" #include "libguile/mallocs.h" #include "libguile/strings.h" +#include "libguile/lang.h" #include "libguile/options.h" @@ -198,7 +199,7 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c flags[i] = options[i].val; } - while (!SCM_NULLP (args)) + while (!SCM_NULL_OR_NIL_P (args)) { SCM name = SCM_CAR (args); int found = 0; @@ -257,7 +258,7 @@ scm_options (SCM args, scm_t_option options[], unsigned int n, const char *s) { if (SCM_UNBNDP (args)) return get_option_setting (options, n); - else if (!SCM_NULLP (args) && !SCM_CONSP (args)) + else if (!SCM_NULL_OR_NIL_P (args) && !SCM_CONSP (args)) /* Dirk:FIXME:: This criterion should be improved. IMO it is better to * demand that args is #t if documentation should be shown than to say * that every argument except a list will print out documentation. */ diff --git a/libguile/posix.c b/libguile/posix.c index 6e2393570..1ef46d1db 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -54,6 +54,7 @@ #include "libguile/feature.h" #include "libguile/strings.h" #include "libguile/vectors.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/posix.h" @@ -916,7 +917,7 @@ environ_list_to_c (SCM envlist, int arg, const char *proc) result = (char **) malloc ((num_strings + 1) * sizeof (char *)); if (result == NULL) scm_memory_error (proc); - for (i = 0; !SCM_NULLP (envlist); ++i, envlist = SCM_CDR (envlist)) + for (i = 0; !SCM_NULL_OR_NIL_P (envlist); ++i, envlist = SCM_CDR (envlist)) { SCM str = SCM_CAR (envlist); int len; diff --git a/libguile/print.c b/libguile/print.c index 64bd23e89..e28284637 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -62,6 +62,7 @@ #include "libguile/strings.h" #include "libguile/strports.h" #include "libguile/vectors.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/print.h" @@ -74,7 +75,7 @@ char *scm_isymnames[] = { - /* This table must agree with the declarations */ + /* This table must agree with the list of SCM_IM_ constants in tags.h */ "#@and", "#@begin", "#@case", @@ -113,17 +114,17 @@ char *scm_isymnames[] = /* Multi-language support */ "#@nil-cond", - "#@nil-ify", - "#@t-ify", - "#@0-cond", - "#@0-ify", - "#@1-ify", "#@bind", "#@delay", "#@call-with-values", - "#" + "#", + + /* Elisp nil value. This is its Scheme name; whenever it's printed + in Elisp, it should appear as the symbol `nil'. */ + + "#nil" }; scm_t_option scm_print_opts[] = { @@ -781,7 +782,7 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) /* CHECK_INTS; */ scm_iprin1 (SCM_CAR (exp), port, pstate); } - if (!SCM_NULLP (exp)) + if (!SCM_NULL_OR_NIL_P (exp)) { scm_puts (" . ", port); scm_iprin1 (exp, port, pstate); @@ -822,7 +823,7 @@ fancy_printing: scm_iprin1 (SCM_CAR (exp), port, pstate); } } - if (!SCM_NULLP (exp)) + if (!SCM_NULL_OR_NIL_P (exp)) { scm_puts (" . ", port); scm_iprin1 (exp, port, pstate); diff --git a/libguile/read.c b/libguile/read.c index 1b8979ce1..33a7e37f0 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -72,7 +72,7 @@ scm_t_option scm_read_opts[] = { { SCM_OPTION_BOOLEAN, "case-insensitive", 0, "Convert symbols to lower case."}, { SCM_OPTION_SCM, "keywords", SCM_UNPACK (SCM_BOOL_F), - "Style of keyword recognition: #f or 'prefix"} + "Style of keyword recognition: #f or 'prefix."} }; SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0, diff --git a/libguile/script.c b/libguile/script.c index 72fc04180..b782dbce7 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -515,7 +515,7 @@ scm_compile_shell_switches (int argc, char **argv) else if (! strcmp (argv[i], "-e")) /* entry point */ { if (++i < argc) - entry_point = gh_symbol2scm (argv[i]); + entry_point = scm_str2symbol (argv[i]); else scm_shell_usage (1, "missing argument to `-e' switch"); } diff --git a/libguile/sort.c b/libguile/sort.c index 05991b7b3..7a3b61ab8 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -86,6 +86,7 @@ char *alloca (); #include "libguile/feature.h" #include "libguile/root.h" #include "libguile/vectors.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/sort.h" @@ -457,7 +458,7 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0, SCM *vp; cmp_fun_t cmp = scm_cmp_function (less); - if (SCM_NULLP (items)) + if (SCM_NULL_OR_NIL_P (items)) return SCM_BOOL_T; SCM_VALIDATE_NIM (2,less); @@ -530,9 +531,9 @@ SCM_DEFINE (scm_merge, "merge", 3, 0, 0, cmp_fun_t cmp = scm_cmp_function (less); SCM_VALIDATE_NIM (3,less); - if (SCM_NULLP (alist)) + if (SCM_NULL_OR_NIL_P (alist)) return blist; - else if (SCM_NULLP (blist)) + else if (SCM_NULL_OR_NIL_P (blist)) return alist; else { @@ -584,9 +585,9 @@ scm_merge_list_x (SCM alist, SCM blist, { SCM build, last; - if (SCM_NULLP (alist)) + if (SCM_NULL_OR_NIL_P (alist)) return blist; - else if (SCM_NULLP (blist)) + else if (SCM_NULL_OR_NIL_P (blist)) return alist; else { @@ -641,9 +642,9 @@ SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0, long alen, blen; /* list lengths */ SCM_VALIDATE_NIM (3,less); - if (SCM_NULLP (alist)) + if (SCM_NULL_OR_NIL_P (alist)) return blist; - else if (SCM_NULLP (blist)) + else if (SCM_NULL_OR_NIL_P (blist)) return alist; else { @@ -715,8 +716,8 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, #define FUNC_NAME s_scm_sort_x { long len; /* list/vector length */ - if (SCM_NULLP(items)) - return SCM_EOL; + if (SCM_NULL_OR_NIL_P (items)) + return items; SCM_VALIDATE_NIM (2,less); @@ -748,8 +749,8 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0, "elements. This is not a stable sort.") #define FUNC_NAME s_scm_sort { - if (SCM_NULLP(items)) - return SCM_EOL; + if (SCM_NULL_OR_NIL_P (items)) + return items; SCM_VALIDATE_NIM (2,less); if (SCM_CONSP (items)) @@ -846,8 +847,8 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, { long len; /* list/vector length */ - if (SCM_NULLP (items)) - return SCM_EOL; + if (SCM_NULL_OR_NIL_P (items)) + return items; SCM_VALIDATE_NIM (2,less); if (SCM_CONSP (items)) @@ -885,8 +886,8 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0, #define FUNC_NAME s_scm_stable_sort { long len; /* list/vector length */ - if (SCM_NULLP (items)) - return SCM_EOL; + if (SCM_NULL_OR_NIL_P (items)) + return items; SCM_VALIDATE_NIM (2,less); if (SCM_CONSP (items)) diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 48df4e6a6..f00828b79 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -161,7 +161,7 @@ scm_srcprops_to_plist (SCM obj) plist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), plist); plist = scm_acons (scm_sym_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist); plist = scm_acons (scm_sym_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist); - plist = scm_acons (scm_sym_breakpoint, SRCPROPBRK (obj), plist); + plist = scm_acons (scm_sym_breakpoint, SCM_BOOL (SRCPROPBRK (obj)), plist); return plist; } @@ -224,7 +224,7 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); if (!SRCPROPSP (p)) goto plist; - if (SCM_EQ_P (scm_sym_breakpoint, key)) p = SRCPROPBRK (p); + if (SCM_EQ_P (scm_sym_breakpoint, key)) p = SCM_BOOL (SRCPROPBRK (p)); else if (SCM_EQ_P (scm_sym_line, key)) p = SCM_MAKINUM (SRCPROPLINE (p)); else if (SCM_EQ_P (scm_sym_column, key)) p = SCM_MAKINUM (SRCPROPCOL (p)); else if (SCM_EQ_P (scm_sym_filename, key)) p = SRCPROPFNAME (p); diff --git a/libguile/srcprop.h b/libguile/srcprop.h index 795aaf435..89f72e5ab 100644 --- a/libguile/srcprop.h +++ b/libguile/srcprop.h @@ -97,8 +97,7 @@ typedef struct scm_t_srcprops_chunk #define SCM_SOURCE_PROPERTY_FLAG_BREAK (1L << 16) #define SRCPROPSP(p) (SCM_TYP16_PREDICATE (scm_tc16_srcprops, p)) -#define SRCPROPBRK(p) \ - (SCM_BOOL (SCM_CELL_WORD_0 (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)) +#define SRCPROPBRK(p) (SCM_CELL_WORD_0 (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK) #define SRCPROPPOS(p) ((scm_t_srcprops *) SCM_CELL_WORD_1 (p))->pos #define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) #define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) @@ -118,7 +117,7 @@ typedef struct scm_t_srcprops_chunk #define SRCBRKP(x) (!SCM_IMP (t.arg1 = scm_whash_lookup (scm_source_whash, (x)))\ && SRCPROPSP (t.arg1)\ - && (SCM_CELL_WORD_0 (t.arg1) & (1L << 16))) + && SRCPROPBRK (t.arg1)) #define PROCTRACEP(x) (!SCM_FALSEP (scm_procedure_property (x, scm_sym_trace))) diff --git a/libguile/tags.h b/libguile/tags.h index 3f937afa1..1e9090ede 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -458,15 +458,10 @@ SCM_API char *scm_isymnames[]; /* defined in print.c */ /* Multi-language support */ #define SCM_IM_NIL_COND SCM_MAKISYM (25) -#define SCM_IM_NIL_IFY SCM_MAKISYM (26) -#define SCM_IM_T_IFY SCM_MAKISYM (27) -#define SCM_IM_0_COND SCM_MAKISYM (28) -#define SCM_IM_0_IFY SCM_MAKISYM (29) -#define SCM_IM_1_IFY SCM_MAKISYM (30) -#define SCM_IM_BIND SCM_MAKISYM (31) +#define SCM_IM_BIND SCM_MAKISYM (26) -#define SCM_IM_DELAY SCM_MAKISYM (32) -#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (33) +#define SCM_IM_DELAY SCM_MAKISYM (27) +#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (28) /* When a variable is unbound this is marked by the SCM_UNDEFINED * value. The following is an unbound value which can be handled on @@ -477,10 +472,13 @@ SCM_API char *scm_isymnames[]; /* defined in print.c */ * used instead. It is not ideal to let this kind of unique and * strange values loose on the Scheme level. */ -#define SCM_UNBOUND SCM_MAKIFLAG (34) +#define SCM_UNBOUND SCM_MAKIFLAG (29) #define SCM_UNBNDP(x) (SCM_EQ_P ((x), SCM_UNDEFINED)) +/* The Elisp nil value. */ +#define SCM_ELISP_NIL SCM_MAKIFLAG (30) + /* Dispatching aids: diff --git a/libguile/throw.c b/libguile/throw.c index 04c5263e1..91f07f61a 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -58,6 +58,7 @@ #include "libguile/stacks.h" #include "libguile/fluids.h" #include "libguile/ports.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/throw.h" @@ -401,7 +402,7 @@ scm_handle_by_proc_catching_all (void *handler_data, SCM tag, SCM throw_args) int scm_exit_status (SCM args) { - if (SCM_NNULLP (args)) + if (!SCM_NULL_OR_NIL_P (args)) { SCM cqa = SCM_CAR (args); diff --git a/libguile/validate.h b/libguile/validate.h index 21aadbe57..9068b8278 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -323,6 +323,8 @@ #define SCM_VALIDATE_NULL(pos, scm) SCM_MAKE_VALIDATE (pos, scm, NULLP) +#define SCM_VALIDATE_NULL_OR_NIL(pos, scm) SCM_MAKE_VALIDATE (pos, scm, NULL_OR_NIL_P) + #define SCM_VALIDATE_CONS(pos, scm) SCM_MAKE_VALIDATE (pos, scm, CONSP) #define SCM_VALIDATE_LIST(pos, lst) \ diff --git a/libguile/vectors.c b/libguile/vectors.c index db9c18669..5868ba4f0 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -46,6 +46,7 @@ #include "libguile/eq.h" #include "libguile/root.h" #include "libguile/strings.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/vectors.h" @@ -101,7 +102,7 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, SCM_VALIDATE_LIST_COPYLEN (1, l, i); res = scm_c_make_vector (i, SCM_UNSPECIFIED); data = SCM_VELTS (res); - while (!SCM_NULLP (l)) + while (!SCM_NULL_OR_NIL_P (l)) { *data++ = SCM_CAR (l); l = SCM_CDR (l); diff --git a/libguile/weaks.c b/libguile/weaks.c index 277b102b3..d5fc5a060 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -44,6 +44,7 @@ #include "libguile/_scm.h" #include "libguile/vectors.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/weaks.h" @@ -144,7 +145,7 @@ SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); data = SCM_VELTS (res); - while (!SCM_NULLP (l)) + while (!SCM_NULL_OR_NIL_P (l)) { *data++ = SCM_CAR (l); l = SCM_CDR (l); From 3d1a89b9eefea52f65358d29c82a0fb51f9afe56 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 22 Jan 2002 23:46:01 +0000 Subject: [PATCH 16/54] * Add non-libguile Elisp support files to CVS trunk. (NB work in progress.) --- ChangeLog | 15 + Makefile.am | 2 +- acconfig.h | 3 + configure.in | 12 + lang/.cvsignore | 2 + lang/Makefile.am | 24 ++ lang/elisp/.cvsignore | 2 + lang/elisp/ChangeLog | 194 +++++++++++++ lang/elisp/Makefile.am | 39 +++ lang/elisp/README | 321 +++++++++++++++++++++ lang/elisp/base.scm | 38 +++ lang/elisp/example.el | 10 + lang/elisp/interface.scm | 122 ++++++++ lang/elisp/internals/.cvsignore | 2 + lang/elisp/internals/Makefile.am | 41 +++ lang/elisp/internals/evaluation.scm | 13 + lang/elisp/internals/format.scm | 62 +++++ lang/elisp/internals/fset.scm | 111 ++++++++ lang/elisp/internals/load.scm | 45 +++ lang/elisp/internals/null.scm | 6 + lang/elisp/internals/set.scm | 9 + lang/elisp/internals/signal.scm | 18 ++ lang/elisp/internals/time.scm | 14 + lang/elisp/internals/trace.scm | 28 ++ lang/elisp/primitives/.cvsignore | 2 + lang/elisp/primitives/Makefile.am | 49 ++++ lang/elisp/primitives/buffers.scm | 16 ++ lang/elisp/primitives/features.scm | 25 ++ lang/elisp/primitives/fns.scm | 45 +++ lang/elisp/primitives/format.scm | 6 + lang/elisp/primitives/guile.scm | 20 ++ lang/elisp/primitives/keymaps.scm | 26 ++ lang/elisp/primitives/lists.scm | 108 ++++++++ lang/elisp/primitives/load.scm | 17 ++ lang/elisp/primitives/match.scm | 68 +++++ lang/elisp/primitives/numbers.scm | 42 +++ lang/elisp/primitives/pure.scm | 8 + lang/elisp/primitives/read.scm | 10 + lang/elisp/primitives/signal.scm | 6 + lang/elisp/primitives/strings.scm | 31 +++ lang/elisp/primitives/symprop.scm | 40 +++ lang/elisp/primitives/system.scm | 14 + lang/elisp/primitives/time.scm | 17 ++ lang/elisp/transform.scm | 414 ++++++++++++++++++++++++++++ lang/elisp/variables.scm | 42 +++ test-suite/Makefile.am | 1 + 46 files changed, 2139 insertions(+), 1 deletion(-) create mode 100644 lang/.cvsignore create mode 100644 lang/Makefile.am create mode 100644 lang/elisp/.cvsignore create mode 100644 lang/elisp/ChangeLog create mode 100644 lang/elisp/Makefile.am create mode 100644 lang/elisp/README create mode 100644 lang/elisp/base.scm create mode 100644 lang/elisp/example.el create mode 100644 lang/elisp/interface.scm create mode 100644 lang/elisp/internals/.cvsignore create mode 100644 lang/elisp/internals/Makefile.am create mode 100644 lang/elisp/internals/evaluation.scm create mode 100644 lang/elisp/internals/format.scm create mode 100644 lang/elisp/internals/fset.scm create mode 100644 lang/elisp/internals/load.scm create mode 100644 lang/elisp/internals/null.scm create mode 100644 lang/elisp/internals/set.scm create mode 100644 lang/elisp/internals/signal.scm create mode 100644 lang/elisp/internals/time.scm create mode 100644 lang/elisp/internals/trace.scm create mode 100644 lang/elisp/primitives/.cvsignore create mode 100644 lang/elisp/primitives/Makefile.am create mode 100644 lang/elisp/primitives/buffers.scm create mode 100644 lang/elisp/primitives/features.scm create mode 100644 lang/elisp/primitives/fns.scm create mode 100644 lang/elisp/primitives/format.scm create mode 100644 lang/elisp/primitives/guile.scm create mode 100644 lang/elisp/primitives/keymaps.scm create mode 100644 lang/elisp/primitives/lists.scm create mode 100644 lang/elisp/primitives/load.scm create mode 100644 lang/elisp/primitives/match.scm create mode 100644 lang/elisp/primitives/numbers.scm create mode 100644 lang/elisp/primitives/pure.scm create mode 100644 lang/elisp/primitives/read.scm create mode 100644 lang/elisp/primitives/signal.scm create mode 100644 lang/elisp/primitives/strings.scm create mode 100644 lang/elisp/primitives/symprop.scm create mode 100644 lang/elisp/primitives/system.scm create mode 100644 lang/elisp/primitives/time.scm create mode 100644 lang/elisp/transform.scm create mode 100644 lang/elisp/variables.scm diff --git a/ChangeLog b/ChangeLog index ce4cc0e6f..4fc82d682 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,18 @@ +2002-01-13 Neil Jerram + + * Makefile.am (SUBDIRS): Added lang. + + * configure.in (AC_CONFIG_FILES): Added Makefiles in lang, + lang/elisp, lang/elisp/internals and lang/elisp/primitives. + +2002-01-11 Neil Jerram + + * acconfig.h (SCM_ENABLE_ELISP): New conditional. + + * configure.in (SCM_ENABLE_ELISP): Define this conditional (or + not) according to absence (or presence) of `--disable-elisp' + in the configure args. + 2001-12-31 Dirk Herrmann * TODO: Added two items. diff --git a/Makefile.am b/Makefile.am index 08f905225..ea26d8692 100644 --- a/Makefile.am +++ b/Makefile.am @@ -21,7 +21,7 @@ SUBDIRS = oop qt libltdl libguile ice-9 guile-config guile-readline \ - scripts srfi doc examples test-suite + scripts srfi doc examples test-suite lang bin_SCRIPTS = guile-tools diff --git a/acconfig.h b/acconfig.h index ac4b6384b..578d76399 100644 --- a/acconfig.h +++ b/acconfig.h @@ -134,6 +134,9 @@ /* Define this if you want support for arrays and uniform arrays. */ #undef HAVE_ARRAYS +/* Define this if you want Elisp support (in addition to Scheme). */ +#undef SCM_ENABLE_ELISP + /* Define this if your IPv6 has sin6_scope_id in sockaddr_in6 struct. */ #undef HAVE_SIN6_SCOPE_ID diff --git a/configure.in b/configure.in index 5a4195f57..9618a9734 100644 --- a/configure.in +++ b/configure.in @@ -129,6 +129,10 @@ dnl a required part of the distribution. AC_DEFINE(DEBUG_EXTENSIONS) AC_DEFINE(READER_EXTENSIONS) +AC_ARG_ENABLE(elisp, + [ --disable-elisp omit Emacs Lisp support],, + enable_elisp=yes) + dnl files which are destined for separate modules. if test "$enable_arrays" = yes; then @@ -150,6 +154,10 @@ if test "$enable_debug_malloc" = yes; then LIBOBJS="$LIBOBJS debug-malloc.o" fi +if test "$enable_elisp" = yes; then + AC_DEFINE(SCM_ENABLE_ELISP) +fi + #-------------------------------------------------------------------- dnl Some more checks for Win32 @@ -660,6 +668,10 @@ AC_CONFIG_FILES([ libguile/guile-snarf-docs-texi libguile/version.h ice-9/Makefile + lang/Makefile + lang/elisp/Makefile + lang/elisp/internals/Makefile + lang/elisp/primitives/Makefile oop/Makefile oop/goops/Makefile scripts/Makefile diff --git a/lang/.cvsignore b/lang/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/lang/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/lang/Makefile.am b/lang/Makefile.am new file mode 100644 index 000000000..4538cb1ff --- /dev/null +++ b/lang/Makefile.am @@ -0,0 +1,24 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2000 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as +## published by the Free Software Foundation; either version 2, or +## (at your option) any later version. +## +## GUILE is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public +## License along with GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +AUTOMAKE_OPTIONS = gnu + +SUBDIRS = elisp diff --git a/lang/elisp/.cvsignore b/lang/elisp/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/lang/elisp/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/lang/elisp/ChangeLog b/lang/elisp/ChangeLog new file mode 100644 index 000000000..8338ab0e8 --- /dev/null +++ b/lang/elisp/ChangeLog @@ -0,0 +1,194 @@ +2001-11-03 Neil Jerram + + * README (Resources): Fill in missing URLs. + +2001-11-02 Neil Jerram + + * Makefile.am (elisp_sources): Added base.scm, example.el, + interface.scm; removed emacs.scm. + + * README: Updated accordingly. + + * internals/load.scm (load): Avoid using `load-path' if the + supplied file name begins with a slash. + + * internals/fset.scm: Support export of defuns, defmacros and + defvars to a module specified by the fluid `elisp-export-module'. + This allows us to automate the importing of Elisp definitions into + Scheme. + + * example.el: New file: example code for `load-elisp-file'. + + * interface.scm: New file - mechanisms to exchange definitions + between Scheme and Elisp. + + Following changes try to make the Elisp evaluation module less + Emacs-dependent; in other words, so that it isn't necessary to try + to load the whole Emacs environment before evaluating basic + non-Emacs-specific Elisp code. + + * variables.scm, internals/evaluation.scm: Changed (lang elisp + emacs) to (lang elisp base). + + * emacs.scm (lang): Removed. + + * base.scm (lang): New file (non-emacs-specific replacement for + emacs.scm). + +2001-10-28 Neil Jerram + + * primitives/symprop.scm (symbol-name): New primitive. + + * primitives/strings.scm (stringp): New primitive. + + * primitives/pure.scm (purify-flag): New variable. + + * primitives/numbers.scm (numberp): New primitive. + + * internals/fset.scm (fset): Set procedure and macro name + properties usefully to match Elisp symbol names. Also bind Elisp + function definition variables to similarly named symbols in the + (lang elisp variables) module. + + * transform.scm (transformer, m-unwind-protect): Added support for + `unwind-protect'. + (m-quasiquote): Use 'quasiquote rather than 'quote. + (transform-lambda, m-defmacro): When no rest arguments, set the + rest parameter to '() rather than #f. It shouldn't make any + difference, but it feels more right. + + * README: Enlarged description of current status. + + * Makefile.am (elisp_sources): Added variables.scm. + + * variables.scm: New file. + +2001-10-26 Neil Jerram + + * buffers.scm, calling.scm: Removed. These should have + disappeared during the reorganization described below, but I + missed them by mistake. + + * primitives/symprop.scm (set, boundp, symbol-value): Changed to + use (module-xx the-elisp-module ...) rather than (local-xx ...). + (symbolp): Accept either symbols or keywords. + (set-default, default-boundp, default-value, + local-variable-if-set-p): New. + + * primitives/match.scm (string-match, match-data): Store last + match data in Emacs rather than Guile form, to simplify + implementation of ... + (set-match-data, store-match-data): New. + + * primitives/load.scm (autoload, current-load-list): New. (But + autoload is just stubbed, not properly implemented.) + + * primitives/lists.scm (nth, listp, consp, nconc): New. + + * primitives/fns.scm (byte-code-function-p, run-hooks): New. + + * transform.scm (transform-application, transformer-macro): New + scheme for transforming procedure arguments while leaving macro + args untransformed. (See also associated change in libguile.) + (m-defconst): Simplified, now uses m-setq. + + * Makefile.am: Changed so that it only deals with files directly + in this directory; otherwise files don't install cleanly. + + * internals/Makefile.am, primitives/Makefile.am, + internals/.cvsignore, primitives/.cvsignore: New files. + +2001-10-26 Neil Jerram + + * transform.scm (transformer): New handling for (1) quasiquoting + syntax like "(` ...)" as well as the more normal "` ..."; (2) + `function'; (3) interactive specification in lambda body. + Simplied handling for `setq'. + (transform-inside-qq): Fixed to handle improper as well as proper + lists. + (transform-lambda/interactive): New; wraps transform-lambda to + handle setting of various procedure properties. + (transform-lambda, m-defmacro): Changed `args' and `num-args' to + `%--args' and `%--num-args' in the hope of avoiding lexical + vs. dynamic name clashes. + (m-and): Use #f instead of '() where a condition fails. + + Plus big hierarchy reorganization, in which most of the previous + occupants of lang/elisp moved to lang/elisp/primitives, with some + internal processing being split out into lang/elisp/internals. + The upshot looks like this: + + * internals/trace.scm, internals/set.scm, internals/load.scm, + internals/fset.scm, internals/signal.scm, internals/time.scm, + internals/format.scm, internals/null.scm, + internals/evaluation.scm, primitives/buffers.scm, + primitives/features.scm, primitives/format.scm, + primitives/time.scm, primitives/guile.scm, primitives/keymaps.scm, + primitives/lists.scm, primitives/load.scm, primitives/match.scm, + primitives/numbers.scm, primitives/pure.scm, primitives/read.scm, + primitives/signal.scm, primitives/strings.scm, + primitives/symprop.scm, primitives/system.scm, primitives/fns.scm: + New files. + + * features.scm, format.scm, fset.scm, guile.scm, keymaps.scm, + lists.scm, load.scm, match.scm, numbers.scm, pure.scm, read.scm, + signal.scm, strings.scm, symprop.scm, system.scm, time.scm, + trace.scm: Removed files. + +2001-10-23 Neil Jerram + + * match.scm (string-match): New implementation using new + `make-emacs-regexp' primitive; old workaround implementation + renamed to `string-match-workaround'. + +2001-10-21 Neil Jerram + + * transform.scm (m-defun, m-defmacro, m-let, m-defvar, + m-defconst): Use more selective tracing mechanism (provided by new + file trace.scm). + + * symprop.scm (get, boundp), transform.scm (transform-lambda, + m-defmacro): Remove unnecessary uses of nil-ify and t-ify. + + * match.scm (string-match): Workaround Guile/libc regex + parenthesis bug. + + * emacs.scm: Move elisp primitive definitions into more specific + files, so that emacs.scm contains only overall code. + + * Makefile.am: Added new files. + + * numbers.scm, trace.scm, time.scm, pure.scm, system.scm, + read.scm, calling.scm, guile.scm: New files. + +2001-10-20 Neil Jerram + + * Makefile.am (elisp_sources): Added match.scm and strings.scm. + + * match.scm, strings.scm: New files. + +2001-10-19 Neil Jerram + + * transform.scm: Replace uses of `nil' by `#f' or `'()'. + + * Makefile.am (elisp_sources): Added lists.scm. + + * load.scm (the-elisp-module): Corrected (lang elisp emacs) module + name. + + * lists.scm (lang): New file containing list-related primitives. + + * emacs.scm: Corrected module name. + +2001-10-19 Neil Jerram + + Initial implementation of an Emacs Lisp translator, based on + transformer code originally written by Mikael Djurfeldt. + + * Makefile.am, .cvsignore: New. + + * ChangeLog, README, buffers.scm, emacs.scm, features.scm, + format.scm, fset.scm, keymaps.scm, load.scm, signal.scm, + symprop.scm, transform.scm: New files. + + diff --git a/lang/elisp/Makefile.am b/lang/elisp/Makefile.am new file mode 100644 index 000000000..ffb095f1b --- /dev/null +++ b/lang/elisp/Makefile.am @@ -0,0 +1,39 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as +## published by the Free Software Foundation; either version 2, or +## (at your option) any later version. +## +## GUILE is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public +## License along with GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +AUTOMAKE_OPTIONS = gnu + +SUBDIRS = internals primitives + +# These should be installed and distributed. + +elisp_sources = \ + base.scm \ + example.el \ + interface.scm \ + transform.scm \ + variables.scm + +subpkgdatadir = $(pkgdatadir)/$(VERSION)/lang/elisp +subpkgdata_DATA = $(elisp_sources) +ETAGS_ARGS = $(subpkgdata_DATA) + +EXTRA_DIST = $(elisp_sources) diff --git a/lang/elisp/README b/lang/elisp/README new file mode 100644 index 000000000..f9218a0c8 --- /dev/null +++ b/lang/elisp/README @@ -0,0 +1,321 @@ + -*- outline -*- + +This directory holds the Scheme side of a translator for Emacs Lisp. + +* Usage + +To load up the base Elisp environment: + + (use-modules (lang elisp base)) + +Then you can switch into this module + + (define-module (lang elisp base)) + +and start typing away in Elisp, or evaluate an individual Elisp +expression from Scheme: + + (eval EXP (resolve-module '(lang elisp base))) + +A more convenient, higher-level interface is provided by (lang elisp +interface): + + (use-modules (lang elisp interface)) + +With this interface, you can evaluate an Elisp expression + + (eval-elisp EXP) + +load an Elisp file with no effect on the Scheme world + + (load-elisp-file "/home/neil/Guile/cvs/guile-core/lang/elisp/example.el") + +load an Elisp file, automatically importing top level definitions into +Scheme + + (use-elisp-file "/home/neil/Guile/cvs/guile-core/lang/elisp/example.el") + +export Scheme objects to Elisp + + (export-to-elisp + - * my-func 'my-var) + +and try to bootstrap a complete Emacs environment: + + (load-emacs) + +* Status + +Please note that this is work in progress; the translator is +incomplete and not yet widely tested. + +** Trying to load a complete Emacs environment. + +To try this, type `(use-modules (lang elisp interface))' and then +`(load-emacs)'. The following output shows how far I get when I try +this. + +guile> (use-modules (lang elisp interface)) +guile> (load-emacs) +Calling loadup.el to clothe the bare Emacs... +Loading /usr/share/emacs/20.7/lisp/loadup.el... +Using load-path ("/usr/share/emacs/20.7/lisp/" "/usr/share/emacs/20.7/lisp/emacs-lisp/") +Loading /usr/share/emacs/20.7/lisp/byte-run.el... +Loading /usr/share/emacs/20.7/lisp/byte-run.el...done +Loading /usr/share/emacs/20.7/lisp/subr.el... +Loading /usr/share/emacs/20.7/lisp/subr.el...done +Loading /usr/share/emacs/20.7/lisp/version.el... +Loading /usr/share/emacs/20.7/lisp/version.el...done +Loading /usr/share/emacs/20.7/lisp/map-ynp.el... +Loading /usr/share/emacs/20.7/lisp/map-ynp.el...done +Loading /usr/share/emacs/20.7/lisp/widget.el... +Loading /usr/share/emacs/20.7/lisp/emacs-lisp/cl.el... +Loading /usr/share/emacs/20.7/lisp/emacs-lisp/cl.el...done +Loading /usr/share/emacs/20.7/lisp/widget.el...done +Loading /usr/share/emacs/20.7/lisp/custom.el... +Loading /usr/share/emacs/20.7/lisp/custom.el...done +Loading /usr/share/emacs/20.7/lisp/cus-start.el... +Note, built-in variable `abbrev-all-caps' not bound + ... [many other variable not bound messages] ... +Loading /usr/share/emacs/20.7/lisp/cus-start.el...done +Loading /usr/share/emacs/20.7/lisp/international/mule.el... +: In procedure make-char-table in expression (@fop make-char-table (# #)): +: Symbol's function definition is void +ABORT: (misc-error) + +Type "(backtrace)" to get more information or "(debug)" to enter the debugger. +guile> + +That's 3279 lines ("wc -l") of Elisp code already, which isn't bad! + +I think that progress beyond this point basically means implementing +multilingual and multibyte strings properly for Guile. Which is a +_lot_ of work and requires IMO a very clear plan for Guile's role with +respect to Emacs. + +* Design + +When thinking about how to implement an Elisp translator for Guile, it +is important to realize that the great power of Emacs does not arise +from Elisp (seen as a language in syntactic terms) alone, but from the +combination of this language with the collection of primitives +provided by the Emacs C source code. Therefore, to be of practical +use, an Elisp translator needs to be more than just a transformer that +translates sexps to Scheme expressions. + +The finished translator should consist of several parts... + +** Syntax transformation + +Although syntax transformation isn't all we need, we do still need it! + +This part is implemented by the (lang elisp transform) module; it is +close to complete and seems to work pretty reliably. + +Note that transformed expressions use the `@fop' and `@bind' macros +provided by... + +** C support for transformed expressions + +For performance and historical reasons (and perhaps necessity - I +haven't thought about it enough yet), some of the transformation +support is written in C. + +*** @fop + +The `@fop' macro is used to dispatch Elisp applications. Its first +argument is a symbol, and this symbol's function slot is examined to +find a procedure or macro to apply to the remaining arguments. `@fop' +also handles aliasing (`defalias'): in this case the function slot +contains another symbol. + +Once `@fop' has found the appropriate procedure or macro to apply, it +returns an application expression in which that procedure or macro +replaces the `@fop' and the original symbol. Hence no Elisp-specific +evaluator support is required to perform the application. + +*** @bind + +Currently, Elisp variables are the same as Scheme variables, so +variable references are effectively untransformed. + +The `@bind' macro does Elisp-style dynamic variable binding. +Basically, it locates the named top level variables, `set!'s them to +new values, evaluates its body, and then uses `set!' again to restore +the original values. + +Because of the body evaluation, `@bind' requires evaluator support. +In fact, the `@bind' macro code does little more than replace itself +with the memoized SCM_IM_BIND. Most of the work is done by the +evaluator when it hits SCM_IM_BIND. + +One theoretical problem with `@bind' is that any local Scheme variable +in the same scope and with the same name as an Elisp variable will +shadow the Elisp variable. But in practice it's difficult to set up +such a situation; an exception is the translator code itself, so there +we mangle the relevant Scheme variable names a bit to avoid the +problem. + +Other possible problems with this approach are that it might not be +possible to implement buffer local variables properly, and that +`@bind' might become too inefficient when we implement full support +for undefining Scheme variables. So we might in future have to +transform Elisp variable references after all. + +*** Truth value stuff + +Lots of stuff to do with providing the special self-evaluating `nil' +and `t' symbols, and macros that convert between Scheme and Elisp +truth values, and so on. + +I'm hoping that most of this will go away, but I need to show that +it's feasible first. + +** Emacs editing primitives + +Buffers, keymaps, text properties, windows, frames etc. etc. + +Basically, everything that is implemented as a primitive in the Emacs +C code needs to be implemented either in Scheme or in C for Guile. + +The Scheme files in the primitives subdirectory implement some of +these primitives in Scheme. Not because that is the right decision, +but because this is a proof of concept and it's quicker to write badly +performing code in Scheme. + +Ultimately, most of these primitive definitions should really come +from the Emacs C code itself, translated or preprocessed in a way that +makes it compile with Guile. I think this is pretty close to the work +that Ken Raeburn has been doing on the Emacs codebase. + +** Reading and printing support + +Elisp is close enough to Scheme that it's convenient to coopt the +existing Guile reader rather than to write a new one from scratch, but +there are a few syntactic differences that will require adding Elisp +support to the reader. + +- Character syntax is `?a' rather than `#\a'. (Not done. More + precisely, `?a' in Elisp isn't character syntax but an alternative + integer syntax. Note that we could support most of the `?a' syntax + simply by doing + + (define ?a (char->integer #\a) + (define ?b (char->integer #\b) + + and so on.) + +- `nil' and `t' should be read (I think) as #f and #t. (Done.) + +- Vector syntax is `[1 2 3]' rather than `#(1 2 3)'. (Not done.) + +Correspondingly, when printing, #f and '() should be written as +`nil'. (Not done.) + +** The Elisp evaluation module (lang elisp base) + +Fundamentally, Guile's module system can't be used to package Elisp +code in the same way it is used for Scheme code, because Elisp +function definitions are stored as symbol properties (in the symbol's +"function slot") and so are global. On the other hand, it is useful +(necessary?) to associate some particular module with Elisp evaluation +because + +- Elisp variables are currently implemented as Scheme variables and so + need to live in some module + +- a syntax transformer is a property of a module. + +Therefore we have the (lang elisp base) module, which acts as the +repository for all Elisp variables and the site of all Elisp +evaluation. + +The initial environment provided by this module is intended to be a +non-Emacs-dependent subset of Elisp. To get the idea, imagine someone +who wants to write an extension function for, say Gnucash, and simply +prefers to write in Elisp rather than in Scheme. He/she therefore +doesn't buffers, keymaps and so on, just the basic language syntax and +core data functions like +, *, concat, length etc., plus specific +functions made available by Gnucash. + +(lang elisp base) achieves this by + +- importing Scheme definitions for some Emacs primitives from the + files in the primitives subdirectory + +- then switching into Elisp syntax. + +After this point, `(eval XXX (resolve-module '(lang elisp base)))' +will evaluate XXX as an Elisp expression in the (lang elisp base) +module. (`eval-elisp' in (lang elisp interface) is a more convenient +wrapper for this.) + +** Full Emacs environment + +The difference between the initial (lang elisp base) environment and a +fully loaded Emacs equivalent is + +- more primitives: buffers, char-tables and many others + +- the bootstrap Elisp code that an undumped Emacs loads during + installation by calling `(load "loadup.el")'. + +We don't have all the missing primitives, but we can already get +through some of loadup.el. The Elisp function `load-emacs' (defined +in (lang elisp base) initiates the loading of loadup.el; (lang elisp +interface) exports `load-emacs' to Scheme. + +`load-emacs' loads so much Elisp code that it's an excellent way to +test the translator. In current practice, it runs for a while and +then fails when it gets to an undefined primitive or a bug in the +translator. Eventually, it should go all the way. (And then we can +worry about adding unexec support to Guile!) For the output that +currently results from calling `(load-emacs)', see above in the Status +section. + +* nil, #f and '() + +For Jim Blandy's notes on this, see the reference at the bottom of +this file. Currently I'm investigating a different approach, which is +better IMO than Jim's proposal because it avoids requiring multiple +false values in the Scheme world. + +According to my approach... + +- `nil' and `t' are read (when in Elisp mode) as #f and #t. + +- `(if x ...)', `(while x ...)' etc. are translated to something + like `(if (and x (not (null? x))) ...)'. + +- Functions which interpret an argument as a list -- + `cons', `setcdr', `memq', etc. -- either convert #f to '(), or + handle the #f case specially. + +- `eq' treats #f and '() as the same. + +- Optionally, functions which produce '() values -- i.e. the reader + and `cdr' -- could convert those immediately to #f. This shouldn't + affect the validity of any Elisp code, but it alters the balance of + #f and '() values swimming around in that code and so affects what + happens if two such values are returned to the Scheme world and then + compared. However, since you can never completely solve this + problem (unless you are prepared to convert arbitrarily deep + structures on entry to the Elisp world, which would kill performance), + I'm inclined not to try to solve it at all. + +* Resources + +** Ken Raeburn's Guile Emacs page + +http://www.mit.edu/~raeburn/guilemacs/ + +** Keisuke Nishida's Gemacs project + +http://gemacs.sourceforge.net + +** Jim Blandy's nil/#f/() notes + +http://sanpietro.red-bean.com/guile/guile/old/3114.html + +** Mikael Djurfeldt's notes on translation + +See file guile-cvs/devel/translation/langtools.text in Guile CVS. diff --git a/lang/elisp/base.scm b/lang/elisp/base.scm new file mode 100644 index 000000000..070be333b --- /dev/null +++ b/lang/elisp/base.scm @@ -0,0 +1,38 @@ +(define-module (lang elisp base)) + +;;; {Elisp Primitives} +;;; +;;; In other words, Scheme definitions of elisp primitives. This +;;; should (ultimately) include everything that Emacs defines in C. + +(use-modules (lang elisp primitives buffers) + (lang elisp primitives features) + (lang elisp primitives format) + (lang elisp primitives fns) + (lang elisp primitives guile) + (lang elisp primitives keymaps) + (lang elisp primitives lists) + (lang elisp primitives load) + (lang elisp primitives match) + (lang elisp primitives numbers) + (lang elisp primitives pure) + (lang elisp primitives read) + (lang elisp primitives signal) + (lang elisp primitives strings) + (lang elisp primitives symprop) + (lang elisp primitives system) + (lang elisp primitives time)) + +;;; Now switch into Emacs Lisp syntax. + +(use-modules (lang elisp transform)) +(read-set! keywords 'prefix) +(read-set! language 'elisp) +(set-module-transformer! (current-module) transformer) + +;;; Everything below here is written in Elisp. + +(defun load-emacs () + (message "Calling loadup.el to clothe the bare Emacs...") + (load "loadup.el") + (message "Guile Emacs now fully clothed")) diff --git a/lang/elisp/example.el b/lang/elisp/example.el new file mode 100644 index 000000000..3379418ff --- /dev/null +++ b/lang/elisp/example.el @@ -0,0 +1,10 @@ + +(defun html-page (title &rest contents) + (concat "\n" + "\n" + "" title "\n" + "\n" + "\n" + (apply 'concat contents) + "\n" + "\n")) diff --git a/lang/elisp/interface.scm b/lang/elisp/interface.scm new file mode 100644 index 000000000..c71366acb --- /dev/null +++ b/lang/elisp/interface.scm @@ -0,0 +1,122 @@ +(define-module (lang elisp interface) + #:use-module (lang elisp internals evaluation) + #:use-module (lang elisp internals fset) + #:use-module ((lang elisp internals load) #:select ((load . elisp:load))) + #:export (eval-elisp + elisp-function + elisp-variable + load-elisp-file + load-elisp-library + use-elisp-file + use-elisp-library + export-to-elisp + load-emacs)) + +;;; This file holds my ideas for the mechanisms that would be useful +;;; to exchange definitions between Scheme and Elisp. + +(define (eval-elisp x) + "Evaluate the Elisp expression @var{x}." + (eval x the-elisp-module)) + +(define (elisp-function sym) + "Return the procedure or macro that implements @var{sym} in Elisp. +If @var{sym} has no Elisp function definition, return @code{#f}." + (fref sym)) + +(define (elisp-variable sym) + "Return the variable that implements @var{sym} in Elisp. +If @var{sym} has no Elisp variable definition, return @code{#f}." + (module-variable the-elisp-module sym)) + +(define (load-elisp-file file-name) + "Load @var{file-name} into the Elisp environment. +@var{file-name} is assumed to name a file containing Elisp code." + ;; This is the same as Elisp's `load-file', so use that if it is + ;; available, otherwise duplicate the definition of `load-file' from + ;; files.el. + (let ((load-file (elisp-function 'load-file))) + (if load-file + (load-file file-name) + (elisp:load file-name #f #f #t)))) + +(define (load-elisp-library library) + "Load library @var{library} into the Elisp environment. +@var{library} should name an Elisp code library that can be found in +one of the directories of @code{load-path}." + ;; This is the same as Elisp's `load-file', so use that if it is + ;; available, otherwise duplicate the definition of `load-file' from + ;; files.el. + (let ((load-library (elisp-function 'load-library))) + (if load-library + (load-library library) + (elisp:load library)))) + +(define export-module-name + (let ((counter 0)) + (lambda () + (set! counter (+ counter 1)) + (list 'lang 'elisp + (string->symbol (string-append "imports:" + (number->string counter))))))) + +(define-macro (use-elisp-file file-name . imports) + "Load Elisp code file @var{file-name} and import its definitions +into the current Scheme module. If any @var{imports} are specified, +they are interpreted as selection and renaming specifiers as per +@code{use-modules}." + (let ((export-module-name (export-module-name))) + `(begin + (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) + (beautify-user-module! (resolve-module ',export-module-name)) + (load-elisp-file ,file-name) + (use-modules (,export-module-name ,@imports)) + (fluid-set! ,elisp-export-module #f)))) + +(define-macro (use-elisp-library library . imports) + "Load Elisp library @var{library} and import its definitions into +the current Scheme module. If any @var{imports} are specified, they +are interpreted as selection and renaming specifiers as per +@code{use-modules}." + (let ((export-module-name (export-module-name))) + `(begin + (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) + (beautify-user-module! (resolve-module ',export-module-name)) + (load-elisp-library ,library) + (use-modules (,export-module-name ,@imports)) + (fluid-set! ,elisp-export-module #f)))) + +(define (export-to-elisp . defs) + "Export procedures and variables specified by @var{defs} to Elisp. +Each @var{def} is either an object, in which case that object must be +a named procedure or macro and is exported to Elisp under its Scheme +name; or a symbol, in which case the variable named by that symbol is +exported under its Scheme name; or a pair @var{(obj . name)}, in which +case @var{obj} must be a procedure, macro or symbol as already +described and @var{name} specifies the name under which that object is +exported to Elisp." + (for-each (lambda (def) + (let ((obj (if (pair? def) (car def) def)) + (name (if (pair? def) (cdr def) #f))) + (cond ((procedure? obj) + (or name + (set! name (procedure-name obj))) + (if name + (fset name obj) + (error "No procedure name specified or deducible:" obj))) + ((macro? obj) + (or name + (set! name (macro-name obj))) + (if name + (fset name obj) + (error "No macro name specified or deducible:" obj))) + ((symbol? obj) + (or name + (set! name symbol)) + (module-add! the-elisp-module name + (module-ref (current-module) obj))) + (else + (error "Can't export this kind of object to Elisp:" obj))))) + defs)) + +(define load-emacs (elisp-function 'load-emacs)) diff --git a/lang/elisp/internals/.cvsignore b/lang/elisp/internals/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/lang/elisp/internals/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/lang/elisp/internals/Makefile.am b/lang/elisp/internals/Makefile.am new file mode 100644 index 000000000..49226038b --- /dev/null +++ b/lang/elisp/internals/Makefile.am @@ -0,0 +1,41 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as +## published by the Free Software Foundation; either version 2, or +## (at your option) any later version. +## +## GUILE is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public +## License along with GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +AUTOMAKE_OPTIONS = gnu + +# These should be installed and distributed. + +elisp_sources = \ + evaluation.scm \ + format.scm \ + fset.scm \ + load.scm \ + null.scm \ + set.scm \ + signal.scm \ + time.scm \ + trace.scm + +subpkgdatadir = $(pkgdatadir)/$(VERSION)/lang/elisp/internals +subpkgdata_DATA = $(elisp_sources) +ETAGS_ARGS = $(subpkgdata_DATA) + +EXTRA_DIST = $(elisp_sources) diff --git a/lang/elisp/internals/evaluation.scm b/lang/elisp/internals/evaluation.scm new file mode 100644 index 000000000..8cbb19462 --- /dev/null +++ b/lang/elisp/internals/evaluation.scm @@ -0,0 +1,13 @@ +(define-module (lang elisp internals evaluation) + #:export (the-elisp-module)) + +;;;; {Elisp Evaluation} + +;;;; All elisp evaluation happens within the same module - namely +;;;; (lang elisp base). This is necessary both because elisp itself +;;;; has no concept of different modules - reflected for example in +;;;; its single argument `eval' function - and because Guile's current +;;;; implementation of elisp stores elisp function definitions in +;;;; slots in global symbol objects. + +(define the-elisp-module (resolve-module '(lang elisp base))) diff --git a/lang/elisp/internals/format.scm b/lang/elisp/internals/format.scm new file mode 100644 index 000000000..6862dab27 --- /dev/null +++ b/lang/elisp/internals/format.scm @@ -0,0 +1,62 @@ +(define-module (lang elisp internals format) + #:pure + #:use-module (ice-9 r5rs) + #:use-module ((ice-9 format) #:select ((format . scheme:format))) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals signal) + #:export (format + message)) + +(define (format control-string . args) + + (define (cons-string str ls) + (let loop ((sl (string->list str)) + (ls ls)) + (if (null? sl) + ls + (loop (cdr sl) (cons (car sl) ls))))) + + (let loop ((input (string->list control-string)) + (args args) + (output '()) + (mid-control #f)) + (if (null? input) + (if mid-control + (error "Format string ends in middle of format specifier") + (list->string (reverse output))) + (if mid-control + (case (car input) + ((#\%) + (loop (cdr input) + args + (cons #\% output) + #f)) + (else + (loop (cdr input) + (cdr args) + (cons-string (case (car input) + ((#\s) (scheme:format #f "~A" (car args))) + ((#\d) (number->string (car args))) + ((#\o) (number->string (car args) 8)) + ((#\x) (number->string (car args) 16)) + ((#\e) (number->string (car args))) ;FIXME + ((#\f) (number->string (car args))) ;FIXME + ((#\g) (number->string (car args))) ;FIXME + ((#\c) (let ((a (car args))) + (if (char? a) + (string a) + (string (integer->char a))))) + ((#\S) (scheme:format #f "~S" (car args))) + (else + (error "Invalid format operation %%%c" (car input)))) + output) + #f))) + (case (car input) + ((#\%) + (loop (cdr input) args output #t)) + (else + (loop (cdr input) args (cons (car input) output) #f))))))) + +(define (message control-string . args) + (display (apply format control-string args)) + (newline)) diff --git a/lang/elisp/internals/fset.scm b/lang/elisp/internals/fset.scm new file mode 100644 index 000000000..885c9e897 --- /dev/null +++ b/lang/elisp/internals/fset.scm @@ -0,0 +1,111 @@ +(define-module (lang elisp internals fset) + #:use-module (lang elisp internals signal) + #:use-module (lang elisp internals evaluation) + #:export (fset + fref + fref/error-if-void + elisp-apply + interactive-specification + not-subr? + elisp-export-module)) + +(define the-variables-module (resolve-module '(lang elisp variables))) + +;; By default, Guile GC's unreachable symbols. So we need to make +;; sure they stay reachable! +(define syms '()) + +;; elisp-export-module, if non-#f, holds a module to which definitions +;; should be exported under their normal symbol names. This is used +;; when importing Elisp definitions into Scheme. +(define elisp-export-module (make-fluid)) + +;; Store the procedure, macro or alias symbol PROC in SYM's function +;; slot. +(define (fset sym proc) + (or (memq sym syms) + (set! syms (cons sym syms))) + (let ((vcell (symbol-fref sym)) + (vsym #f) + (export-module (fluid-ref elisp-export-module))) + ;; Playing around with variables and name properties... For the + ;; reasoning behind this, see the commentary in (lang elisp + ;; variables). + (cond ((procedure? proc) + ;; A procedure created from Elisp will already have a name + ;; property attached, with value of the form + ;; or . Any other + ;; procedure coming through here must be an Elisp primitive + ;; definition, so we give it a name of the form + ;; . + (or (procedure-name proc) + (set-procedure-property! proc + 'name + (symbol-append '))) + (set! vsym (procedure-name proc))) + ((macro? proc) + ;; Macros coming through here must be defmacros, as all + ;; primitive special forms are handled directly by the + ;; transformer. + (set-procedure-property! (macro-transformer proc) + 'name + (symbol-append ')) + (set! vsym (procedure-name (macro-transformer proc)))) + (else + ;; An alias symbol. + (set! vsym (symbol-append ')))) + ;; This is the important bit! + (if (variable? vcell) + (variable-set! vcell proc) + (begin + (set! vcell (make-variable proc)) + (symbol-fset! sym vcell) + ;; Playing with names and variables again - see above. + (module-add! the-variables-module vsym vcell) + (module-export! the-variables-module (list vsym)))) + ;; Export variable to the export module, if non-#f. + (if (and export-module + (or (procedure? proc) + (macro? proc))) + (begin + (module-add! export-module sym vcell) + (module-export! export-module (list sym)))))) + +;; Retrieve the procedure or macro stored in SYM's function slot. +;; Note the asymmetry w.r.t. fset: if fref finds an alias symbol, it +;; recursively calls fref on that symbol. Returns #f if SYM's +;; function slot doesn't contain a valid definition. +(define (fref sym) + (let ((var (symbol-fref sym))) + (if (and var (variable? var)) + (let ((proc (variable-ref var))) + (cond ((symbol? proc) + (fref proc)) + (else + proc))) + #f))) + +;; Same as fref, but signals an Elisp error if SYM's function +;; definition is void. +(define (fref/error-if-void sym) + (or (fref sym) + (signal 'void-function (list sym)))) + +;; Maps a procedure to its (interactive ...) spec. +(define interactive-specification (make-object-property)) + +;; Maps a procedure to #t if it is NOT a built-in. +(define not-subr? (make-object-property)) + +(define (elisp-apply function . args) + (apply apply + (cond ((symbol? function) + (fref/error-if-void function)) + ((procedure? function) + function) + ((and (pair? function) + (eq? (car function) 'lambda)) + (eval function the-elisp-module)) + (else + (signal 'invalid-function (list function)))) + args)) diff --git a/lang/elisp/internals/load.scm b/lang/elisp/internals/load.scm new file mode 100644 index 000000000..88d14b802 --- /dev/null +++ b/lang/elisp/internals/load.scm @@ -0,0 +1,45 @@ +(define-module (lang elisp internals load) + #:use-module (ice-9 optargs) + #:use-module (lang elisp internals signal) + #:use-module (lang elisp internals format) + #:use-module (lang elisp internals evaluation) + #:export (load-path + load)) + +(define load-path '("/usr/share/emacs/20.7/lisp/" + "/usr/share/emacs/20.7/lisp/emacs-lisp/")) + +(define* (load file #:optional noerror nomessage nosuffix must-suffix) + (define (load1 filename) + (let ((pathname (let loop ((dirs (if (char=? (string-ref filename 0) #\/) + '("") + load-path))) + (cond ((null? dirs) #f) + ((file-exists? (string-append (car dirs) + filename)) + (string-append (car dirs) filename)) + (else (loop (cdr dirs))))))) + (if pathname + (begin + (or nomessage + (message "Loading %s..." pathname)) + (with-input-from-file pathname + (lambda () + (let loop ((form (read))) + (or (eof-object? form) + (begin + ;; Note that `eval' already incorporates use + ;; of the specified module's transformer. + (eval form the-elisp-module) + (loop (read))))))) + (or nomessage + (message "Loading %s...done" pathname)) + #t) + #f))) + (or (and (not nosuffix) + (load1 (string-append file ".el"))) + (and (not must-suffix) + (load1 file)) + noerror + (signal 'file-error + (list "Cannot open load file" file)))) diff --git a/lang/elisp/internals/null.scm b/lang/elisp/internals/null.scm new file mode 100644 index 000000000..d574e3424 --- /dev/null +++ b/lang/elisp/internals/null.scm @@ -0,0 +1,6 @@ +(define-module (lang elisp internals null) + #:export (null)) + +(define (null obj) + (or (not obj) + (null? obj))) diff --git a/lang/elisp/internals/set.scm b/lang/elisp/internals/set.scm new file mode 100644 index 000000000..cee332101 --- /dev/null +++ b/lang/elisp/internals/set.scm @@ -0,0 +1,9 @@ +(define-module (lang elisp internals set) + #:use-module (lang elisp internals evaluation) + #:use-module (lang elisp internals signal) + #:export (set)) + +;; Set SYM's variable value to VAL, and return VAL. +(define (set sym val) + (module-define! the-elisp-module sym val) + val) diff --git a/lang/elisp/internals/signal.scm b/lang/elisp/internals/signal.scm new file mode 100644 index 000000000..09e2c05a6 --- /dev/null +++ b/lang/elisp/internals/signal.scm @@ -0,0 +1,18 @@ +(define-module (lang elisp internals signal) + #:use-module (lang elisp internals format) + #:export (signal + error + wta)) + +(define (signal error-symbol data) + (scm-error 'elisp-signal + #f + "Signalling ~A with data ~S" + (list error-symbol data) + #f)) + +(define (error . args) + (signal 'error (list (apply format args)))) + +(define (wta expected actual pos) + (signal 'wrong-type-argument (list expected actual))) diff --git a/lang/elisp/internals/time.scm b/lang/elisp/internals/time.scm new file mode 100644 index 000000000..10ac02ddc --- /dev/null +++ b/lang/elisp/internals/time.scm @@ -0,0 +1,14 @@ +(define-module (lang elisp internals time) + #:use-module (ice-9 optargs) + #:export (format-time-string)) + +(define* (format-time-string format-string #:optional time universal) + (strftime format-string + ((if universal gmtime localtime) + (if time + (+ (ash (car time) 16) + (let ((time-cdr (cdr time))) + (if (pair? time-cdr) + (car time-cdr) + time-cdr))) + (current-time))))) diff --git a/lang/elisp/internals/trace.scm b/lang/elisp/internals/trace.scm new file mode 100644 index 000000000..0dd92ec73 --- /dev/null +++ b/lang/elisp/internals/trace.scm @@ -0,0 +1,28 @@ +(define-module (lang elisp internals trace) + #:export (trc trc-syms trc-all trc-none)) + +(define *syms* #f) + +(define (trc-syms . syms) + (set! *syms* syms)) + +(define (trc-all) + (set! *syms* #f)) + +(define (trc-none) + (set! *syms* '())) + +(define (trc . args) + (let ((sym (car args)) + (args (cdr args))) + (if (or (and *syms* + (memq sym *syms*)) + (not *syms*)) + (begin + (write sym) + (display ": ") + (write args) + (newline))))) + +;; Default to no tracing. +(trc-none) diff --git a/lang/elisp/primitives/.cvsignore b/lang/elisp/primitives/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/lang/elisp/primitives/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/lang/elisp/primitives/Makefile.am b/lang/elisp/primitives/Makefile.am new file mode 100644 index 000000000..f2bd3e919 --- /dev/null +++ b/lang/elisp/primitives/Makefile.am @@ -0,0 +1,49 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as +## published by the Free Software Foundation; either version 2, or +## (at your option) any later version. +## +## GUILE is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU General Public +## License along with GUILE; see the file COPYING. If not, write +## to the Free Software Foundation, Inc., 59 Temple Place, Suite +## 330, Boston, MA 02111-1307 USA + +AUTOMAKE_OPTIONS = gnu + +# These should be installed and distributed. + +elisp_sources = \ + buffers.scm \ + features.scm \ + fns.scm \ + format.scm \ + guile.scm \ + keymaps.scm \ + lists.scm \ + load.scm \ + match.scm \ + numbers.scm \ + pure.scm \ + read.scm \ + signal.scm \ + strings.scm \ + symprop.scm \ + system.scm \ + time.scm + +subpkgdatadir = $(pkgdatadir)/$(VERSION)/lang/elisp/primitives +subpkgdata_DATA = $(elisp_sources) +ETAGS_ARGS = $(subpkgdata_DATA) + +EXTRA_DIST = $(elisp_sources) diff --git a/lang/elisp/primitives/buffers.scm b/lang/elisp/primitives/buffers.scm new file mode 100644 index 000000000..756d4be04 --- /dev/null +++ b/lang/elisp/primitives/buffers.scm @@ -0,0 +1,16 @@ +(define-module (lang elisp primitives buffers) + #:use-module (ice-9 optargs) + #:use-module (lang elisp internals fset)) + +(fset 'buffer-disable-undo + (lambda* (#:optional buffer) + 'unimplemented)) + +(fset 're-search-forward + (lambda* (regexp #:optional bound noerror count) + 'unimplemented)) + +(fset 're-search-backward + (lambda* (regexp #:optional bound noerror count) + 'unimplemented)) + diff --git a/lang/elisp/primitives/features.scm b/lang/elisp/primitives/features.scm new file mode 100644 index 000000000..3d1e468ed --- /dev/null +++ b/lang/elisp/primitives/features.scm @@ -0,0 +1,25 @@ +(define-module (lang elisp primitives features) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals load) + #:use-module (ice-9 optargs)) + +(define-public features '()) + +(fset 'provide + (lambda (feature) + (or (memq feature features) + (set! features (cons feature features))))) + +(fset 'featurep + (lambda (feature) + (memq feature features))) + +(fset 'require + (lambda* (feature #:optional file-name noerror) + (or (memq feature features) + (load (or file-name + (symbol->string feature)) + noerror + #f + #f + #t)))) diff --git a/lang/elisp/primitives/fns.scm b/lang/elisp/primitives/fns.scm new file mode 100644 index 000000000..87b05c7e0 --- /dev/null +++ b/lang/elisp/primitives/fns.scm @@ -0,0 +1,45 @@ +(define-module (lang elisp primitives fns) + #:use-module (lang elisp internals fset)) + +(fset 'fset fset) +(fset 'defalias fset) + +(fset 'apply elisp-apply) + +(fset 'funcall + (lambda (function . args) + (elisp-apply function args))) + +(fset 'interactive-p + (lambda () + #f)) + +(fset 'commandp + (lambda (sym) + (if (interactive-spec (fref sym)) #t #f))) + +(fset 'fboundp + (lambda (sym) + (variable? (symbol-fref sym)))) + +(fset 'symbol-function fref/error-if-void) + +(fset 'macroexpand macroexpand) + +(fset 'subrp + (lambda (obj) + (not (not-subr? obj)))) + +(fset 'byte-code-function-p + (lambda (object) + #f)) + +(fset 'run-hooks + (lambda (hooks) + (cond ((null hooks)) + ((list? hooks) + (for-each (lambda (hook) + (elisp-apply hook '())) + hooks)) + (else + (elisp-apply hooks '()))))) diff --git a/lang/elisp/primitives/format.scm b/lang/elisp/primitives/format.scm new file mode 100644 index 000000000..a7c637880 --- /dev/null +++ b/lang/elisp/primitives/format.scm @@ -0,0 +1,6 @@ +(define-module (lang elisp primitives format) + #:use-module (lang elisp internals format) + #:use-module (lang elisp internals fset)) + +(fset 'format format) +(fset 'message message) diff --git a/lang/elisp/primitives/guile.scm b/lang/elisp/primitives/guile.scm new file mode 100644 index 000000000..059f2bbad --- /dev/null +++ b/lang/elisp/primitives/guile.scm @@ -0,0 +1,20 @@ +(define-module (lang elisp primitives guile) + #:use-module (lang elisp internals fset)) + +;;; {Importing Guile procedures into Elisp} + +;; It may be worthwhile to import some Guile procedures into the Elisp +;; environment. For now, though, we don't do this. + +(if #f + (let ((accessible-procedures + (apropos-fold (lambda (module name var data) + (cons (cons name var) data)) + '() + "" + (apropos-fold-accessible (current-module))))) + (for-each (lambda (name var) + (if (procedure? var) + (fset name var))) + (map car accessible-procedures) + (map cdr accessible-procedures)))) diff --git a/lang/elisp/primitives/keymaps.scm b/lang/elisp/primitives/keymaps.scm new file mode 100644 index 000000000..730d89fbd --- /dev/null +++ b/lang/elisp/primitives/keymaps.scm @@ -0,0 +1,26 @@ +(define-module (lang elisp primitives keymaps) + #:use-module (lang elisp internals fset)) + +(define (make-sparse-keymap) + (list 'keymap)) + +(define (define-key keymap key def) + (set-cdr! keymap + (cons (cons key def) (cdr keymap)))) + +(define global-map (make-sparse-keymap)) +(define esc-map (make-sparse-keymap)) +(define ctl-x-map (make-sparse-keymap)) +(define ctl-x-4-map (make-sparse-keymap)) +(define ctl-x-5-map (make-sparse-keymap)) + +;;; {Elisp Exports} + +(fset 'make-sparse-keymap make-sparse-keymap) +(fset 'define-key define-key) + +(export global-map + esc-map + ctl-x-map + ctl-x-4-map + ctl-x-5-map) diff --git a/lang/elisp/primitives/lists.scm b/lang/elisp/primitives/lists.scm new file mode 100644 index 000000000..be603e2c8 --- /dev/null +++ b/lang/elisp/primitives/lists.scm @@ -0,0 +1,108 @@ +(define-module (lang elisp primitives lists) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals null) + #:use-module (lang elisp internals signal)) + +(fset 'cons + (lambda (x y) + (cons x (or y '())))) + +(fset 'null null) + +(fset 'not null) + +(fset 'car + (lambda (l) + (if (null l) + #f + (car l)))) + +(fset 'cdr + (lambda (l) + (if (null l) + #f + (cdr l)))) + +(fset 'eq + (lambda (x y) + (or (eq? x y) + (and (null x) (null y))))) + +(fset 'equal + (lambda (x y) + (or (equal? x y) + (and (null x) (null y))))) + +(fset 'setcar set-car!) + +(fset 'setcdr + (lambda (cell newcdr) + (set-cdr! cell + (if (null newcdr) + '() + newcdr)))) + +(for-each (lambda (sym proc) + (fset sym + (lambda (elt list) + (if (null list) + #f + (if (null elt) + (or (proc #f list) + (proc '() list)) + (proc elt list)))))) + '( memq member assq assoc) + `(,memq ,member ,assq ,assoc)) + +(fset 'length + (lambda (x) + (cond ((null x) 0) + ((pair? x) (length x)) + ((vector? x) (vector-length x)) + ((string? x) (string-length x)) + (else (wta 'sequencep x 1))))) + +(fset 'copy-sequence + (lambda (x) + (cond ((list? x) (list-copy x)) + ((vector? x) (error "Vector copy not yet implemented")) + ((string? x) (string-copy x)) + (else (wta 'sequencep x 1))))) + +(fset 'elt + (lambda (obj i) + (cond ((pair? obj) (list-ref obj i)) + ((vector? obj) (vector-ref obj i)) + ((string? obj) (char->integer (string-ref obj i)))))) + +(fset 'list list) + +(fset 'mapcar + (lambda (function sequence) + (map (lambda (elt) + (elisp-apply function (list elt))) + (cond ((null sequence) '()) + ((list? sequence) sequence) + ((vector? sequence) (vector->list sequence)) + ((string? sequence) (map char->integer (string->list sequence))) + (else (wta 'sequencep sequence 2)))))) + +(fset 'nth + (lambda (n list) + (if (or (null list) + (>= n (length list))) + #f + (list-ref list n)))) + +(fset 'listp + (lambda (object) + (or (null object) + (list? object)))) + +(fset 'consp pair?) + +(fset 'nconc + (lambda args + (apply append! (map (lambda (arg) + (if arg arg '())) + args)))) diff --git a/lang/elisp/primitives/load.scm b/lang/elisp/primitives/load.scm new file mode 100644 index 000000000..85915f1f7 --- /dev/null +++ b/lang/elisp/primitives/load.scm @@ -0,0 +1,17 @@ +(define-module (lang elisp primitives load) + #:use-module (lang elisp internals load) + #:use-module (lang elisp internals evaluation) + #:use-module (lang elisp internals fset)) + +(fset 'load load) +(re-export load-path) + +(fset 'eval + (lambda (form) + (eval form the-elisp-module))) + +(fset 'autoload + (lambda args + #t)) + +(define-public current-load-list #f) diff --git a/lang/elisp/primitives/match.scm b/lang/elisp/primitives/match.scm new file mode 100644 index 000000000..9b232c1ae --- /dev/null +++ b/lang/elisp/primitives/match.scm @@ -0,0 +1,68 @@ +(define-module (lang elisp primitives match) + #:use-module (lang elisp internals fset) + #:use-module (ice-9 regex) + #:use-module (ice-9 optargs)) + +(define last-match #f) + +(fset 'string-match + (lambda (regexp string . start) + + (define emacs-string-match + + (if (defined? 'make-emacs-regexp) + + ;; This is what we would do if we had an + ;; Emacs-compatible regexp primitive, here called + ;; `make-emacs-regexp'. + (lambda (pattern str . args) + (let ((rx (make-emacs-regexp pattern)) + (start (if (pair? args) (car args) 0))) + (regexp-exec rx str start))) + + ;; But we don't have Emacs-compatible regexps, and I + ;; don't think it's worthwhile at this stage to write + ;; generic regexp conversion code. So work around the + ;; discrepancies between Guile/libc and Emacs regexps by + ;; substituting the regexps that actually occur in the + ;; elisp code that we want to read. + (lambda (pattern str . args) + (let loop ((discrepancies '(("^[0-9]+\\.\\([0-9]+\\)" . + "^[0-9]+\\.([0-9]+)")))) + (or (null? discrepancies) + (if (string=? pattern (caar discrepancies)) + (set! pattern (cdar discrepancies)) + (loop (cdr discrepancies))))) + (apply string-match pattern str args)))) + + (let ((match (apply emacs-string-match regexp string start))) + (set! last-match + (if match + (apply append! + (map (lambda (n) + (list (match:start match n) + (match:end match n))) + (iota (match:count match)))) + #f))) + + (if last-match (car last-match) #f))) + +(fset 'match-beginning + (lambda (subexp) + (list-ref last-match (* 2 subexp)))) + +(fset 'match-end + (lambda (subexp) + (list-ref last-match (+ (* 2 subexp) 1)))) + +(fset 'substring substring) + +(fset 'match-data + (lambda* (#:optional integers reuse) + last-match)) + +(fset 'set-match-data + (lambda (list) + (set! last-match list))) + +(fset 'store-match-data 'set-match-data) diff --git a/lang/elisp/primitives/numbers.scm b/lang/elisp/primitives/numbers.scm new file mode 100644 index 000000000..dd72551dd --- /dev/null +++ b/lang/elisp/primitives/numbers.scm @@ -0,0 +1,42 @@ +(define-module (lang elisp primitives numbers) + #:use-module (lang elisp internals fset)) + +(fset 'logior logior) +(fset 'logand logand) +(fset 'integerp integer?) +(fset '= =) +(fset '< <) +(fset '> >) +(fset '<= <=) +(fset '>= >=) +(fset '* *) +(fset '+ +) +(fset '- -) +(fset '1- 1-) +(fset 'ash ash) + +(fset 'lsh + (let () + (define (lsh num shift) + (cond ((= shift 0) + num) + ((< shift 0) + ;; Logical shift to the right. Do an arithmetic + ;; shift and then mask out the sign bit. + (lsh (logand (ash num -1) most-positive-fixnum) + (+ shift 1))) + (else + ;; Logical shift to the left. Guile's ash will + ;; always preserve the sign of the result, which is + ;; not what we want for lsh, so we need to work + ;; around this. + (let ((new-sign-bit (ash (logand num + (logxor most-positive-fixnum + (ash most-positive-fixnum -1))) + 1))) + (lsh (logxor new-sign-bit + (ash (logand num most-positive-fixnum) 1)) + (- shift 1)))))) + lsh)) + +(fset 'numberp number?) diff --git a/lang/elisp/primitives/pure.scm b/lang/elisp/primitives/pure.scm new file mode 100644 index 000000000..217550c53 --- /dev/null +++ b/lang/elisp/primitives/pure.scm @@ -0,0 +1,8 @@ +(define-module (lang elisp primitives pure) + #:use-module (lang elisp internals fset)) + +;; Purification, unexec etc. are not yet implemented... + +(fset 'purecopy identity) + +(define-public purify-flag #f) diff --git a/lang/elisp/primitives/read.scm b/lang/elisp/primitives/read.scm new file mode 100644 index 000000000..aeacd2c15 --- /dev/null +++ b/lang/elisp/primitives/read.scm @@ -0,0 +1,10 @@ +(define-module (lang elisp primitives read) + #:use-module (lang elisp internals fset)) + +;;; MEGA HACK!!!! + +(fset 'read (lambda (str) + (cond ((string=? str "?\\M-\\^@") + -134217728) + (else + (with-input-from-string str read))))) diff --git a/lang/elisp/primitives/signal.scm b/lang/elisp/primitives/signal.scm new file mode 100644 index 000000000..33168c352 --- /dev/null +++ b/lang/elisp/primitives/signal.scm @@ -0,0 +1,6 @@ +(define-module (lang elisp primitives signal) + #:use-module (lang elisp internals signal) + #:use-module (lang elisp internals fset)) + +(fset 'signal signal) +(fset 'error error) diff --git a/lang/elisp/primitives/strings.scm b/lang/elisp/primitives/strings.scm new file mode 100644 index 000000000..4326aeb93 --- /dev/null +++ b/lang/elisp/primitives/strings.scm @@ -0,0 +1,31 @@ +(define-module (lang elisp primitives strings) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals signal)) + +(fset 'substring substring) + +(fset 'concat + (lambda args + (apply string-append + (map (lambda (arg) + (cond + ((string? arg) arg) + ((list? arg) (list->string arg)) + ((vector? arg) (list->string (vector->list arg))) + (else (error "Wrong type argument for concat")))) + args)))) + +(fset 'string-to-number string->number) + +(fset 'number-to-string number->string) + +(fset 'string-lessp stringinteger (string-ref array idx))) + (else (wta 'arrayp array 1))))) + +(fset 'stringp string?) diff --git a/lang/elisp/primitives/symprop.scm b/lang/elisp/primitives/symprop.scm new file mode 100644 index 000000000..ffdc7e6ae --- /dev/null +++ b/lang/elisp/primitives/symprop.scm @@ -0,0 +1,40 @@ +(define-module (lang elisp primitives symprop) + #:use-module (lang elisp internals set) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals evaluation) + #:use-module (ice-9 optargs)) + +;;; {Elisp Exports} + +(fset 'put set-symbol-property!) + +(fset 'get symbol-property) + +(fset 'set set) + +(fset 'set-default 'set) + +(fset 'boundp + (lambda (sym) + (module-defined? the-elisp-module sym))) + +(fset 'default-boundp 'boundp) + +(fset 'symbol-value + (lambda (sym) + (if (module-defined? the-elisp-module sym) + (module-ref the-elisp-module sym) + (error "Symbol's value as variable is void:" sym)))) + +(fset 'default-value 'symbol-value) + +(fset 'symbolp + (lambda (object) + (or (symbol? object) + (keyword? object)))) + +(fset 'local-variable-if-set-p + (lambda* (variable #:optional buffer) + #f)) + +(fset 'symbol-name symbol->string) diff --git a/lang/elisp/primitives/system.scm b/lang/elisp/primitives/system.scm new file mode 100644 index 000000000..6c659cc13 --- /dev/null +++ b/lang/elisp/primitives/system.scm @@ -0,0 +1,14 @@ +(define-module (lang elisp primitives system) + #:use-module (lang elisp internals fset)) + +(fset 'system-name + (lambda () + (vector-ref (uname) 1))) + +(define-public system-type + (let ((uname (vector-ref (uname) 0))) + (if (string=? uname "Linux") + "gnu/linux" + uname))) + +(define-public system-configuration "i386-suse-linux") ;FIXME diff --git a/lang/elisp/primitives/time.scm b/lang/elisp/primitives/time.scm new file mode 100644 index 000000000..4b2c70c1a --- /dev/null +++ b/lang/elisp/primitives/time.scm @@ -0,0 +1,17 @@ +(define-module (lang elisp primitives time) + #:use-module (lang elisp internals time) + #:use-module (lang elisp internals fset) + #:use-module (ice-9 optargs)) + +(fset 'current-time + (lambda () + (let ((now (current-time))) + (list (ash now -16) + (logand now (- (ash 1 16) 1)) + 0)))) + +(fset 'format-time-string format-time-string) + +(fset 'current-time-string + (lambda* (#:optional specified-time) + (format-time-string "%a %b %e %T %Y" specified-time))) diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm new file mode 100644 index 000000000..2f6ed8db5 --- /dev/null +++ b/lang/elisp/transform.scm @@ -0,0 +1,414 @@ +(define-module (lang elisp transform) + #:use-module (lang elisp internals trace) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals evaluation) + #:use-module (ice-9 session) + #:export (transformer)) + +(define interactive-spec (make-fluid)) + +;;; {S-expressions} +;;; + +(define (syntax-error x) + (error "Syntax error in expression" x)) + +;; Should be made mutating instead of constructing +;; +(define (transformer x) + (cond ((null? x) '()) + ((not (pair? x)) x) + ((and (pair? (car x)) + (eq? (caar x) 'quasiquote)) + (transformer (car x))) + ((symbol? (car x)) + (case (car x) + ((@fop @bind define-module use-modules use-syntax) x) + ; Escape to Scheme syntax + ((scheme) (cons 'begin (cdr x))) + ; Should be handled in reader + ((quote function) (cons 'quote (cars->nil (cdr x)))) + ((quasiquote) (m-quasiquote x '())) + ((nil-cond) (transform-1 x)) + ((let) (m-let x '())) + ((let*) (m-let* x '())) + ((if) (m-if x '())) + ((and) (m-and x '())) + ((or) (m-or x '())) + ((while) (m-while x '())) + ;((while) (cons macro-while (cdr x))) + ((prog1) (m-prog1 x '())) + ((prog2) (m-prog2 x '())) + ((progn begin) (cons 'begin (map transformer (cdr x)))) + ((cond) (m-cond x '())) + ((lambda) (transform-lambda/interactive x ')) + ((defun) (m-defun x '())) + ((defmacro) (m-defmacro x '())) + ((setq) (m-setq x '())) + ((defvar) (m-defvar x '())) + ((defconst) (m-defconst x '())) + ((interactive) (fluid-set! interactive-spec x) #f) + ((unwind-protect) (m-unwind-protect x '())) + (else (transform-application x)))) + (else (syntax-error x)))) + +(define (m-unwind-protect exp env) + (trc 'unwind-protect (cadr exp)) + `(let ((%--throw-args #f)) + (catch #t + (lambda () + ,(transformer (cadr exp))) + (lambda args + (set! %--throw-args args))) + ,@(transform-list (cddr exp)) + (if %--throw-args + (apply throw %--throw-args)))) + +(define (m-quasiquote exp env) + (cons 'quasiquote + (map transform-inside-qq (cdr exp)))) + +(define (transform-inside-qq x) + (trc 'transform-inside-qq x) + (cond ((not (pair? x)) x) + ((symbol? (car x)) + (case (car x) + ((unquote) (list 'unquote (transformer (cadr x)))) + ((unquote-splicing) (list 'unquote-splicing (transformer (cadr x)))) + (else (cons (car x) (map transform-inside-qq (cdr x)))))) + (else + (cons (transform-inside-qq (car x)) (transform-inside-qq (cdr x)))))) + +(define (transform-1 x) + (cons (car x) (map transformer (cdr x)))) + +(define (transform-2 x) + (cons (car x) + (cons (cadr x) + (map transformer (cddr x))))) + +(define (transform-3 x) + (cons (car x) + (cons (cadr x) + (cons (caddr x) + (map transformer (cdddr x)))))) + +(define (transform-list x) + (map transformer x)) + +;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and +;;; returns three values: (i) list of symbols for required arguments, +;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or +;;; #f if there is no rest argument. +(define (parse-formals formals) + (letrec ((do-required + (lambda (required formals) + (if (null? formals) + (values (reverse required) '() #f) + (let ((next-sym (car formals))) + (cond ((not (symbol? next-sym)) + (error "Bad formals (non-symbol in required list)")) + ((eq? next-sym '&optional) + (do-optional required '() (cdr formals))) + ((eq? next-sym '&rest) + (do-rest required '() (cdr formals))) + (else + (do-required (cons next-sym required) + (cdr formals)))))))) + (do-optional + (lambda (required optional formals) + (if (null? formals) + (values (reverse required) (reverse optional) #f) + (let ((next-sym (car formals))) + (cond ((not (symbol? next-sym)) + (error "Bad formals (non-symbol in optional list)")) + ((eq? next-sym '&rest) + (do-rest required optional (cdr formals))) + (else + (do-optional required + (cons next-sym optional) + (cdr formals)))))))) + (do-rest + (lambda (required optional formals) + (if (= (length formals) 1) + (let ((next-sym (car formals))) + (if (symbol? next-sym) + (values (reverse required) (reverse optional) next-sym) + (error "Bad formals (non-symbol rest formal)"))) + (error "Bad formals (more than one rest formal)"))))) + + (do-required '() (cond ((list? formals) + formals) + ((symbol? formals) + (list '&rest formals)) + (else + (error "Bad formals (not a list or a single symbol)")))))) + +(define (transform-lambda/interactive exp name) + (fluid-set! interactive-spec #f) + (let* ((x (transform-lambda exp)) + (is (fluid-ref interactive-spec))) + `(let ((%--lambda ,x)) + (set-procedure-property! %--lambda 'name ',name) + (set! (,not-subr? %--lambda) #t) + ,@(if is + `((set! (,interactive-specification %--lambda) ',is)) + '()) + %--lambda))) + +(define (transform-lambda exp) + (call-with-values (lambda () (parse-formals (cadr exp))) + (lambda (required optional rest) + (let ((num-required (length required)) + (num-optional (length optional))) + `(lambda %--args + (let ((%--num-args (length %--args))) + (cond ((< %--num-args ,num-required) + (error "Wrong number of args (not enough required args)")) + ,@(if rest + '() + `(((> %--num-args ,(+ num-required num-optional)) + (error "Wrong number of args (too many args)")))) + (else + (@bind ,(append (map (lambda (i) + (list (list-ref required i) + `(list-ref %--args ,i))) + (iota num-required)) + (map (lambda (i) + (let ((i+nr (+ i num-required))) + (list (list-ref optional i) + `(if (> %--num-args ,i+nr) + (list-ref %--args ,i+nr) + #f)))) + (iota num-optional)) + (if rest + (list (list rest + `(if (> %--num-args + ,(+ num-required + num-optional)) + (list-tail %--args + ,(+ num-required + num-optional)) + '()))) + '())) + ,@(transform-list (cddr exp))))))) + )))) + +(define (m-defun exp env) + (trc 'defun (cadr exp)) + `(begin (,fset ',(cadr exp) + ,(transform-lambda/interactive (cdr exp) + (symbol-append '))) + ',(cadr exp))) + +(define (m-defmacro exp env) + (trc 'defmacro (cadr exp)) + (call-with-values (lambda () (parse-formals (caddr exp))) + (lambda (required optional rest) + (let ((num-required (length required)) + (num-optional (length optional))) + `(begin (,fset ',(cadr exp) + (procedure->memoizing-macro + (lambda (exp1 env1) + (,trc 'using ',(cadr exp)) + (let* ((%--args (cdr exp1)) + (%--num-args (length %--args))) + (cond ((< %--num-args ,num-required) + (error "Wrong number of args (not enough required args)")) + ,@(if rest + '() + `(((> %--num-args ,(+ num-required num-optional)) + (error "Wrong number of args (too many args)")))) + (else (,transformer + (@bind ,(append (map (lambda (i) + (list (list-ref required i) + `(list-ref %--args ,i))) + (iota num-required)) + (map (lambda (i) + (let ((i+nr (+ i num-required))) + (list (list-ref optional i) + `(if (> %--num-args ,i+nr) + (list-ref %--args ,i+nr) + #f)))) + (iota num-optional)) + (if rest + (list (list rest + `(if (> %--num-args + ,(+ num-required + num-optional)) + (list-tail %--args + ,(+ num-required + num-optional)) + '()))) + '())) + ,@(transform-list (cdddr exp))))))))))))))) + +(define (transform-application x) + `(@fop ,(car x) + (,transformer-macro ,@(cdr x)))) + +(define transformer-macro + (procedure->memoizing-macro + (lambda (exp env) + (cons 'list (map transformer (cdr exp)))))) + +; (cons '@fop +; (cons (car x) +; (map transformer (cdr x))))) + +(define (cars->nil ls) + (cond ((not (pair? ls)) ls) + ((null? (car ls)) (cons '() (cars->nil (cdr ls)))) + (else (cons (cars->nil (car ls)) + (cars->nil (cdr ls)))))) + +;;; {Special forms} +;;; + +(define (m-setq exp env) + (cons 'begin + (let loop ((sets (cdr exp)) (last-sym #f)) + (if (null? sets) + (list last-sym) + (cons `(module-define! ,the-elisp-module + ',(car sets) + ,(transformer (cadr sets))) + (loop (cddr sets) (car sets))))))) + +;(define (m-setq exp env) +; (let* ((binder (car (last-pair env))) +; (varvals (let loop ((ls (cdr exp))) +; (if (null? ls) +; '() +; ;; Ensure existence only at macro expansion time +; (let ((var (or (binder (car ls) #f) +; (binder (car ls) #t)))) +; (if (not (variable-bound? var)) +; (variable-set! var #f)) +; (cons (list 'set! (car ls) (transformer (cadr ls))) +; (loop (cddr ls)))))))) +; (cond ((null? varvals) '()) +; ((null? (cdr varvals)) (car varvals)) +; (else (cons 'begin varvals))))) + +(define (m-let exp env) + `(@bind ,(map (lambda (binding) + (trc 'let binding) + (if (pair? binding) + `(,(car binding) ,(transformer (cadr binding))) + `(,binding #f))) + (cadr exp)) + ,@(transform-list (cddr exp)))) + +(define (m-let* exp env) + (if (null? (cadr exp)) + `(begin ,@(transform-list (cddr exp))) + (car (let loop ((bindings (cadr exp))) + (if (null? bindings) + (transform-list (cddr exp)) + `((@bind (,(let ((binding (car bindings))) + (if (pair? binding) + `(,(car binding) ,(transformer (cadr binding))) + `(,binding #f)))) + ,@(loop (cdr bindings))))))))) + +(define (m-prog1 exp env) + `(,let ((%res1 ,(transformer (cadr exp)))) + ,@(transform-list (cddr exp)) + %res1)) + +(define (m-prog2 exp env) + `(begin ,(transformer (cadr exp)) + (,let ((%res2 ,(transformer (caddr exp)))) + ,@(transform-list (cdddr exp)) + %res2))) + +(define <-- *unspecified*) + +(define (m-if exp env) + (let ((else-case (cdddr exp))) + (cond ((null? else-case) + `(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f)) + ((null? (cdr else-case)) + `(nil-cond ,(transformer (cadr exp)) + ,(transformer (caddr exp)) + ,(transformer (car else-case)))) + (else + `(nil-cond ,(transformer (cadr exp)) + ,(transformer (caddr exp)) + (begin ,@(transform-list else-case))))))) + +(define (m-and exp env) + (cond ((null? (cdr exp)) #t) + ((null? (cddr exp)) (transformer (cadr exp))) + (else + (cons 'nil-cond + (let loop ((args (cdr exp))) + (if (null? (cdr args)) + (list (transformer (car args))) + (cons (list 'not (transformer (car args))) + (cons #f + (loop (cdr args)))))))))) + +(define (m-or exp env) + (cond ((null? (cdr exp)) #f) + ((null? (cddr exp)) (transformer (cadr exp))) + (else + (cons 'nil-cond + (let loop ((args (cdr exp))) + (if (null? (cdr args)) + (list (transformer (car args))) + (cons (transformer (car args)) + (cons <-- + (loop (cdr args)))))))))) + +(define m-cond + (lambda (exp env) + (if (null? (cdr exp)) + #f + (cons + 'nil-cond + (let loop ((clauses (cdr exp))) + (if (null? clauses) + '(#f) + (let ((clause (car clauses))) + (if (eq? (car clause) #t) + (cond ((null? (cdr clause)) '(t)) + ((null? (cddr clause)) + (list (transformer (cadr clause)))) + (else `((begin ,@(transform-list (cdr clause)))))) + (cons (transformer (car clause)) + (cons (cond ((null? (cdr clause)) <--) + ((null? (cddr clause)) + (transformer (cadr clause))) + (else + `(begin ,@(transform-list (cdr clause))))) + (loop (cdr clauses)))))))))))) + +(define (m-while exp env) + `(,let %while () + (nil-cond ,(transformer (cadr exp)) + (begin ,@(transform-list (cddr exp)) (%while)) + #f))) + +(define (m-defvar exp env) + (trc 'defvar (cadr exp)) + (if (null? (cddr exp)) + `',(cadr exp) + `(begin (if (not (defined? ',(cadr exp))) + (,macro-setq ,(cadr exp) ,(caddr exp))) + ',(cadr exp)))) + +(define (m-defconst exp env) + (trc 'defconst (cadr exp)) + `(begin ,(m-setq (list (car exp) (cadr exp) (caddr exp)) env) + ',(cadr exp))) + +;(export-mmacros +; '(setq defun let let* if and or cond while prog1 prog2 progn) +; (list m-setq m-defun m-let m-let* m-if m-and m-or m-cond m-while m-prog1 m-prog2 begin)) + +(define macro-setq (procedure->memoizing-macro m-setq)) +(define macro-while (procedure->memoizing-macro m-while)) diff --git a/lang/elisp/variables.scm b/lang/elisp/variables.scm new file mode 100644 index 000000000..36243739e --- /dev/null +++ b/lang/elisp/variables.scm @@ -0,0 +1,42 @@ +(define-module (lang elisp variables)) + +;;; The only purpose of this module is to provide a place where the +;;; variables holding Elisp function definitions can be bound to +;;; symbols. +;;; +;;; This can be useful when looking at unmemoized procedure source +;;; code for Elisp functions and macros. Elisp function and macro +;;; symbols get memoized into variables. When the unmemoizer tries to +;;; unmemoize a variables, it does so by looking for a symbol that is +;;; bound to that variable, starting from the module in which the +;;; function or macro was defined and then trying the interfaces on +;;; that module's uses list. If it can't find any such symbol, it +;;; returns the symbol '???. +;;; +;;; Normally we don't want to bind Elisp function definition variables +;;; to symbols that are visible from the Elisp evaluation module (lang +;;; elisp base), because they would pollute the namespace available +;;; to Elisp variables. On the other hand, if we are trying to debug +;;; something, and looking at unmemoized source code, it's far more +;;; informative if that code has symbols that indicate the Elisp +;;; function being called than if it just says ??? everywhere. +;;; +;;; So we have a compromise, which achieves a reasonable balance of +;;; correctness (for general operation) and convenience (for +;;; debugging). +;;; +;;; 1. We bind Elisp function definition variables to symbols in this +;;; module (lang elisp variables). +;;; +;;; 2. By default, the Elisp evaluation module (lang elisp base) does +;;; not use (lang elisp variables), so the Elisp variable namespace +;;; stays clean. +;;; +;;; 3. When debugging, a simple (named-module-use! '(lang elisp base) +;;; '(lang elisp variables)) makes the function definition symbols +;;; visible in (lang elisp base) so that the unmemoizer can find +;;; them, which makes the unmemoized source code much easier to read. +;;; +;;; 4. To reduce the effects of namespace pollution even after step 3, +;;; the symbols that we bind are all prefixed with `'. diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 5db5ba0d2..09e8d8a3b 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -5,6 +5,7 @@ SCM_TESTS = tests/alist.test \ tests/c-api.test \ tests/chars.test \ tests/common-list.test \ + tests/elisp.test \ tests/environments.test \ tests/eval.test \ tests/exceptions.test \ From 04bb321a9dff25723f18bdd235d0311338d3c993 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Tue, 22 Jan 2002 23:47:46 +0000 Subject: [PATCH 17/54] * New tests file for Elisp support. --- test-suite/ChangeLog | 6 ++ test-suite/tests/elisp.test | 136 ++++++++++++++++++++++++++++++++++++ 2 files changed, 142 insertions(+) create mode 100644 test-suite/tests/elisp.test diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 7a835df5e..d7e2367b4 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,9 @@ +2002-01-22 Neil Jerram + + * Makefile.am (SCM_TESTS): Added elisp.test. + + * tests/elisp.test: New file. + 2001-11-22 Dirk Herrmann * tests/numbers.test: Added more division by zero tests. diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test new file mode 100644 index 000000000..516f4ced2 --- /dev/null +++ b/test-suite/tests/elisp.test @@ -0,0 +1,136 @@ +;;;; elisp.test --- tests guile's elisp support -*- scheme -*- +;;;; Copyright (C) 2002 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; +;;;; As a special exception, the Free Software Foundation gives permission +;;;; for additional uses of the text contained in its release of GUILE. +;;;; +;;;; The exception is that, if you link the GUILE library with other files +;;;; to produce an executable, this does not by itself cause the +;;;; resulting executable to be covered by the GNU General Public License. +;;;; Your use of that executable is in no way restricted on account of +;;;; linking the GUILE library code into it. +;;;; +;;;; This exception does not however invalidate any other reasons why +;;;; the executable file might be covered by the GNU General Public License. +;;;; +;;;; This exception applies only to the code released by the +;;;; Free Software Foundation under the name GUILE. If you copy +;;;; code from other Free Software Foundation releases into a copy of +;;;; GUILE, as the General Public License permits, the exception does +;;;; not apply to the code that you add in this way. To avoid misleading +;;;; anyone as to the status of such modified files, you must delete +;;;; this exception notice from them. +;;;; +;;;; If you write modifications of your own for GUILE, it is your choice +;;;; whether to permit this exception to apply to your modifications. +;;;; If you do not wish that, delete this exception notice. + +;;; +;;; elisp +;;; + +(if (defined? '%nil) + + (with-test-prefix "scheme" + + (with-test-prefix "nil value is a boolean" + + (pass-if "boolean?" + (boolean? %nil)) + + ) + + (with-test-prefix "nil value is false" + + (pass-if "not" + (eq? (not %nil) #t)) + + (pass-if "if" + (if %nil #f #t)) + + (pass-if "and" + (eq? (and %nil #t) #f)) + + (pass-if "or" + (eq? (or %nil #f) #f)) + + (pass-if "cond" + (cond (%nil #f) (else #t))) + + (pass-if "do" + (call-with-current-continuation + (lambda (exit) + (do ((i 0 (+ i 1))) + (%nil (exit #f)) + (if (> i 10) + (exit #t)))))) + + ) + + (with-test-prefix "nil value as an empty list" + + (pass-if "list?" + (list? %nil)) + + (pass-if "null?" + (null? %nil)) + + (pass-if "sort" + (eq? (sort %nil <) %nil)) + + ) + + (with-test-prefix "lists formed using nil value" + + (pass-if "list?" + (list? (cons 'a %nil))) + + (pass-if "length" + (= (length (cons 'a (cons 'b (cons 'c %nil)))) 3)) + + (pass-if "length (with backquoted list)" + (= (length `(a b c . ,%nil)) 3)) + + (pass-if "write" + (string=? (with-output-to-string + (lambda () (write (cons 'a %nil)))) + "(a)")) + + (pass-if "display" + (string=? (with-output-to-string + (lambda () (display (cons 'a %nil)))) + "(a)")) + + ) + + (with-test-prefix "value preservation" + + (pass-if "car" + (eq? (car (cons %nil 'a)) %nil)) + + (pass-if "cdr" + (eq? (cdr (cons 'a %nil)) %nil)) + + (pass-if "vector-ref" + (eq? (vector-ref (vector %nil) 0) %nil)) + + ) + + )) + +;;; elisp.test ends here From 962b1f0bacacb920e43a2e8d156e51b46b8f5197 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 24 Jan 2002 22:42:02 +0000 Subject: [PATCH 18/54] * More tests for the Elisp nil value. --- test-suite/ChangeLog | 4 +++ test-suite/tests/elisp.test | 70 +++++++++++++++++++++++++++++++++++++ 2 files changed, 74 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index d7e2367b4..b407c1a81 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2002-01-24 Neil Jerram + + * tests/elisp.test: More new tests for the Elisp nil value. + 2002-01-22 Neil Jerram * Makefile.am (SCM_TESTS): Added elisp.test. diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test index 516f4ced2..3d7f3a303 100644 --- a/test-suite/tests/elisp.test +++ b/test-suite/tests/elisp.test @@ -100,6 +100,9 @@ (pass-if "list?" (list? (cons 'a %nil))) + (pass-if "length of %nil" + (= (length %nil) 0)) + (pass-if "length" (= (length (cons 'a (cons 'b (cons 'c %nil)))) 3)) @@ -116,6 +119,73 @@ (lambda () (display (cons 'a %nil)))) "(a)")) + (pass-if "assq" + (and (equal? (assq 1 `((1 one) (2 two) . ,%nil)) + '(1 one)) + (equal? (assq 3 `((1 one) (2 two) . ,%nil)) + #f))) + + (pass-if "assv" + (and (equal? (assv 1 `((1 one) (2 two) . ,%nil)) + '(1 one)) + (equal? (assv 3 `((1 one) (2 two) . ,%nil)) + #f))) + + (pass-if "assoc" + (and (equal? (assoc 1 `((1 one) (2 two) . ,%nil)) + '(1 one)) + (equal? (assoc 3 `((1 one) (2 two) . ,%nil)) + #f))) + + (pass-if "with-fluids*" + (let ((f (make-fluid)) + (g (make-fluid))) + (with-fluids* (cons f (cons g %nil)) + '(3 4) + (lambda () + (and (eq? (fluid-ref f) 3) + (eq? (fluid-ref g) 4)))))) + + (pass-if "append!" + (let ((a (copy-tree '(1 2 3))) + (b (copy-tree `(4 5 6 . ,%nil))) + (c (copy-tree '(7 8 9))) + (d (copy-tree `(a b c . ,%nil)))) + (equal? (append! a b c d) + `(1 2 3 4 5 6 7 8 9 a b c . ,%nil)))) + + (pass-if "last-pair" + (equal? (last-pair `(1 2 3 4 5 . ,%nil)) + (cons 5 %nil))) + + (pass-if "reverse" + (equal? (reverse `(1 2 3 4 5 . ,%nil)) + '(5 4 3 2 1))) ; Hmmm... is this OK, or + ; should it be + ; `(5 4 3 2 1 . ,%nil) ? + + (pass-if "reverse!" + (equal? (reverse! (copy-tree `(1 2 3 4 5 . ,%nil))) + '(5 4 3 2 1))) ; Ditto. + + (pass-if "list-ref" + (eq? (list-ref `(0 1 2 3 4 . ,%nil) 4) 4)) + + (pass-if-exception "list-ref" + exception:out-of-range + (eq? (list-ref `(0 1 2 3 4 . ,%nil) 6) 6)) + + (pass-if "list-set!" + (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) + (list-set! l 4 44) + (= (list-ref l 4) 44))) + + (pass-if-exception "list-set!" + exception:out-of-range + (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) + (list-set! l 6 44) + (= (list-ref l 6) 44))) + ) (with-test-prefix "value preservation" From af68e5e5a6d30dde274191530556b565dead45aa Mon Sep 17 00:00:00 2001 From: Stefan Jahn Date: Mon, 28 Jan 2002 21:15:55 +0000 Subject: [PATCH 19/54] 2002-01-28 Stefan Jahn * configure.in (guile_cv_have_uint32_t): Look also in `stdint.h' for uint32_t. 2002-01-28 Stefan Jahn * symbols.c (scm_c_symbol2str): New function, replacement for `gh_scm2newsymbol()'. * strings.c (scm_c_substring2str): New function. Proper replacement for `gh_get_substr()'. * socket.c: Include `stdint.h' if available for the `uint32_t' declaration. * scmsigs.c (s_scm_sigaction): Initialize `chandler' (inhibits compiler warning). * backtrace.c: Include `lang.h' for GUILE_DEBUG conditional. --- ChangeLog | 5 +++++ configure.in | 7 ++++++- libguile/ChangeLog | 16 ++++++++++++++++ libguile/Makefile.am | 2 +- libguile/backtrace.c | 1 + libguile/scmsigs.c | 2 +- libguile/socket.c | 3 +++ libguile/strings.c | 27 ++++++++++++++++++++++++++- libguile/strings.h | 1 + libguile/symbols.c | 44 ++++++++++++++++++++++++++++++++++++++++++++ libguile/symbols.h | 1 + 11 files changed, 105 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4fc82d682..88b3a520e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2002-01-28 Stefan Jahn + + * configure.in (guile_cv_have_uint32_t): Look also in + `stdint.h' for uint32_t. + 2002-01-13 Neil Jerram * Makefile.am (SUBDIRS): Added lang. diff --git a/configure.in b/configure.in index 9618a9734..4607b4d76 100644 --- a/configure.in +++ b/configure.in @@ -348,7 +348,12 @@ fi AC_MSG_CHECKING(whether uint32_t is defined) AC_CACHE_VAL(guile_cv_have_uint32_t, [AC_TRY_COMPILE([#include - #include ], + #if HAVE_STDINT_H + #include + #endif + #ifndef __MINGW32__ + #include + #endif], [uint32_t a;], guile_cv_have_uint32_t=yes, guile_cv_have_uint32_t=no)]) AC_MSG_RESULT($guile_cv_have_uint32_t) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f28ecbbb0..767002040 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,19 @@ +2002-01-28 Stefan Jahn + + * symbols.c (scm_c_symbol2str): New function, replacement for + `gh_scm2newsymbol()'. + + * strings.c (scm_c_substring2str): New function. Proper + replacement for `gh_get_substr()'. + + * socket.c: Include `stdint.h' if available for the `uint32_t' + declaration. + + * scmsigs.c (s_scm_sigaction): Initialize `chandler' (inhibits + compiler warning). + + * backtrace.c: Include `lang.h' for GUILE_DEBUG conditional. + 2002-01-22 Neil Jerram Other changes unrelated to Elisp... diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 14aae5521..e3bb3b3ea 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -203,7 +203,7 @@ SUFFIXES = .x .doc .c.doc: -(test -n "${AWK+set}" || AWK="@AWK@"; ${AWK} -f ./guile-func-name-check $<) (./guile-snarf-docs $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< | \ - ./guile_filter_doc_snarfage --filter-snarfage) > $@ || { rm $@; false; } + ./guile_filter_doc_snarfage$(EXEEXT) --filter-snarfage) > $@ || { rm $@; false; } $(DOT_X_FILES) $(EXTRA_DOT_DOC_FILES): snarf.h guile-snarf.in diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 290627fbb..baa0e6e1a 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -67,6 +67,7 @@ #include "libguile/strings.h" #include "libguile/validate.h" +#include "libguile/lang.h" #include "libguile/backtrace.h" #include "libguile/filesys.h" diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 97375e8af..da1f93bfe 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -187,7 +187,7 @@ SCM_DEFINE (scm_sigaction, "sigaction", 1, 2, 0, struct sigaction action; struct sigaction old_action; #else - SIGRETTYPE (* chandler) (int); + SIGRETTYPE (* chandler) (int) = SIG_DFL; SIGRETTYPE (* old_chandler) (int); #endif int query_only = 0; diff --git a/libguile/socket.c b/libguile/socket.c index 7dc729ca1..10c064242 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -58,6 +58,9 @@ #include "win32-socket.h" #endif +#ifdef HAVE_STDINT_H +#include +#endif #ifdef HAVE_STRING_H #include #endif diff --git a/libguile/strings.c b/libguile/strings.c index 3aa24958d..6744a58c6 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -350,12 +350,13 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1, determine the length of the returned value. However, the function always copies the complete contents of OBJ, and sets *LENP to the length of the scheme string (if LENP is non-null). */ +#define FUNC_NAME "scm_c_string2str" char * scm_c_string2str (SCM obj, char *str, size_t *lenp) { size_t len; - SCM_ASSERT (SCM_STRINGP (obj), obj, SCM_ARG1, "scm_c_string2str"); + SCM_ASSERT (SCM_STRINGP (obj), obj, SCM_ARG1, FUNC_NAME); len = SCM_STRING_LENGTH (obj); if (str == NULL) @@ -376,6 +377,30 @@ scm_c_string2str (SCM obj, char *str, size_t *lenp) return str; } +#undef FUNC_NAME + + +/* Copy LEN characters at START from the Scheme string OBJ to memory + at STR. START is an index into OBJ; zero means the beginning of + the string. STR has already been allocated by the caller. + + If START + LEN is off the end of OBJ, silently truncate the source + region to fit the string. If truncation occurs, the corresponding + area of STR is left unchanged. */ +#define FUNC_NAME "scm_c_substring2str" +char * +scm_c_substring2str (SCM obj, char *str, size_t start, size_t len) +{ + size_t src_length, effective_length; + + SCM_ASSERT (SCM_STRINGP (obj), obj, SCM_ARG2, FUNC_NAME); + src_length = SCM_STRING_LENGTH (obj); + effective_length = (len + start <= src_length) ? len : src_length - start; + memcpy (str, SCM_STRING_CHARS (obj) + start, effective_length); + scm_remember_upto_here_1 (obj); + return str; +} +#undef FUNC_NAME void diff --git a/libguile/strings.h b/libguile/strings.h index ea1bf7132..aea044dd9 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -79,6 +79,7 @@ SCM_API SCM scm_substring (SCM str, SCM start, SCM end); SCM_API SCM scm_string_append (SCM args); SCM_API void scm_init_strings (void); SCM_API char *scm_c_string2str (SCM obj, char *str, size_t *lenp); +SCM_API char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len); diff --git a/libguile/symbols.c b/libguile/symbols.c index 0a408234b..c3e22c865 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -318,6 +318,50 @@ SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, } #undef FUNC_NAME + +/* Converts the given Scheme symbol OBJ into a C string, containing a copy + of OBJ's content with a trailing null byte. If LENP is non-NULL, set + *LENP to the string's length. + + When STR is non-NULL it receives the copy and is returned by the function, + otherwise new memory is allocated and the caller is responsible for + freeing it via free(). If out of memory, NULL is returned. + + Note that Scheme symbols may contain arbitrary data, including null + characters. This means that null termination is not a reliable way to + determine the length of the returned value. However, the function always + copies the complete contents of OBJ, and sets *LENP to the length of the + scheme symbol (if LENP is non-null). */ +#define FUNC_NAME "scm_c_symbol2str" +char * +scm_c_symbol2str (SCM obj, char *str, size_t *lenp) +{ + size_t len; + + SCM_ASSERT (SCM_SYMBOLP (obj), obj, SCM_ARG1, FUNC_NAME); + len = SCM_SYMBOL_LENGTH (obj); + + if (str == NULL) + { + /* FIXME: Should we use exported wrappers for malloc (and free), which + * allow windows DLLs to call the correct freeing function? */ + str = (char *) malloc ((len + 1) * sizeof (char)); + if (str == NULL) + return NULL; + } + + memcpy (str, SCM_SYMBOL_CHARS (obj), len); + scm_remember_upto_here_1 (obj); + str[len] = '\0'; + + if (lenp != NULL) + *lenp = len; + + return str; +} +#undef FUNC_NAME + + void scm_symbols_prehistory () { diff --git a/libguile/symbols.h b/libguile/symbols.h index 9de355540..e4c624801 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -89,6 +89,7 @@ SCM_API SCM scm_symbol_pset_x (SCM s, SCM val); SCM_API SCM scm_symbol_hash (SCM s); SCM_API SCM scm_gensym (SCM prefix); +SCM_API char *scm_c_symbol2str (SCM obj, char *str, size_t *lenp); SCM_API void scm_symbols_prehistory (void); SCM_API void scm_init_symbols (void); From f74fa0a0fde2a484cbf751b90798c75a15852150 Mon Sep 17 00:00:00 2001 From: Stefan Jahn Date: Tue, 29 Jan 2002 10:46:13 +0000 Subject: [PATCH 20/54] 2002-01-29 Stefan Jahn * gh.texi (scm transition summary): Documented gh equivalents `scm_c_string2str', `scm_c_substring2str' and `scm_c_symbol2str' and removed the appropriate FIXME's. --- doc/ref/ChangeLog | 6 ++++++ doc/ref/gh.texi | 12 +++++++++--- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 176e0ff04..b0f5e2c67 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,9 @@ +2002-01-29 Stefan Jahn + + * gh.texi (scm transition summary): Documented gh equivalents + `scm_c_string2str', `scm_c_substring2str' and `scm_c_symbol2str' + and removed the appropriate FIXME's. + 2002-01-14 Marius Vollmer * Makefile.am (autoconf-macros.texi): Also set GUILE_LOAD_PATH diff --git a/doc/ref/gh.texi b/doc/ref/gh.texi index 7362232fb..9b2e9850e 100644 --- a/doc/ref/gh.texi +++ b/doc/ref/gh.texi @@ -978,13 +978,19 @@ a @code{SCM} value is a character before using @code{SCM_CHAR} to extract the character value, use the @code{SCM_VALIDATE_CHAR} macro. @item @code{gh_scm2newstr} -No direct scm equivalent. [FIXME] +Instead of @code{gh_scm2newstr (@var{obj}, @var{lenp})} use +@code{scm_c_string2str (@var{obj}, @var{str}, @var{lenp})}. With the +additional @var{str} argument the user can pass a pre-allocated memory +chunk or leave it passing NULL. @item @code{gh_get_substr} -No direct scm equivalent. [FIXME] +Use the @code{scm_c_substring2str (@var{obj}, @var{str}, @var{start}, +@var{len})} function instead. @item @code{gh_symbol2newstr} -No direct scm equivalent. [FIXME] +Use the @code{scm_c_symbol2str (@var{obj}, @var{str}, @var{lenp})} function +instead. With the additional @var{str} argument the user can pass a +pre-allocated memory chunk or leave it passing NULL. @item @code{gh_scm2chars} No direct scm equivalent. [FIXME] From bbd26b5ae5a9a595f8a39abe906c46fe3f139da7 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 30 Jan 2002 00:03:40 +0000 Subject: [PATCH 21/54] * Rename `call-with-readline-completion-function' to `with-readline-completion-function'. * More tests for Elisp nil value. * Development work on Elisp translator. --- guile-readline/ChangeLog | 5 + guile-readline/readline.scm | 2 +- lang/elisp/ChangeLog | 41 ++++ lang/elisp/base.scm | 62 ++--- lang/elisp/internals/null.scm | 3 +- lang/elisp/internals/set.scm | 11 +- lang/elisp/primitives/Makefile.am | 1 + lang/elisp/primitives/fns.scm | 24 +- lang/elisp/primitives/lists.scm | 10 +- lang/elisp/primitives/strings.scm | 2 + lang/elisp/primitives/symprop.scm | 4 +- lang/elisp/primitives/syntax.scm | 359 +++++++++++++++++++++++++++ lang/elisp/transform.scm | 387 +++--------------------------- libguile/ChangeLog | 10 +- test-suite/ChangeLog | 8 + test-suite/tests/elisp.test | 80 +++++- test-suite/tests/load.test | 9 + 17 files changed, 606 insertions(+), 412 deletions(-) create mode 100644 lang/elisp/primitives/syntax.scm diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index 374e655e7..e56498535 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,8 @@ +2002-01-29 Neil Jerram + + * readline.scm (with-readline-completion-function): Renamed from + `call-with-readline-completion-function'. + 2001-11-30 Neil Jerram * Makefile.am (EXTRA_DIST): Refer to $(ice9_DATA) rather than diff --git a/guile-readline/readline.scm b/guile-readline/readline.scm index 2afb03513..cae45e30b 100644 --- a/guile-readline/readline.scm +++ b/guile-readline/readline.scm @@ -187,7 +187,7 @@ (set! *readline-completion-function* apropos-completion-function) )) -(define-public (call-with-readline-completion-function completer thunk) +(define-public (with-readline-completion-function completer thunk) "With @var{completer} as readline completion function, call @var{thunk}." (let ((old-completer *readline-completion-function*)) (dynamic-wind diff --git a/lang/elisp/ChangeLog b/lang/elisp/ChangeLog index 8338ab0e8..f1ed71dbb 100644 --- a/lang/elisp/ChangeLog +++ b/lang/elisp/ChangeLog @@ -1,3 +1,44 @@ +2002-01-29 Neil Jerram + + * transform.scm (transform-1, transform-2, transform-3, + transform-list): Removed (unused). + + * transform.scm, primitives/syntax.scm: Add commas everywhere + before use of (guile) primitives in generated code, so that (lang + elisp base) doesn't have to import bindings from (guile). + + * base.scm: Move use-modules expressions inside the define-module, + and add #:pure so that we don't import bindings from (guile). + +2002-01-25 Neil Jerram + + * transform.scm (transform-application): Preserve source + properties of original elisp expression by using cons-source. + + * transform.scm: Don't handle special forms specially in the + translator. Instead, define them as macros in ... + + * primitives/syntax.scm: New file; special form definitions. + + * primitives/fns.scm (run-hooks): Rewritten correctly. + + * primitives/symprop.scm (symbol-value): Use `value'. + + * internals/set.scm (value): New function. + + * primitives/fns.scm: Use (lang elisp internals null), as null is + no longer a primitive. Change generated #f values to %nil. + + * internals/null.scm (null): Handle nil symbol. + + * primitives/lists.scm (memq, member, assq, assoc): Handle all + possible nil values. + + * transform.scm (transformer): Translate `nil' and `t' to #nil and + #t. + + * base.scm: Remove setting of 'language read-option. + 2001-11-03 Neil Jerram * README (Resources): Fill in missing URLs. diff --git a/lang/elisp/base.scm b/lang/elisp/base.scm index 070be333b..c4d2b8d9a 100644 --- a/lang/elisp/base.scm +++ b/lang/elisp/base.scm @@ -1,34 +1,42 @@ -(define-module (lang elisp base)) +(define-module (lang elisp base) -;;; {Elisp Primitives} -;;; -;;; In other words, Scheme definitions of elisp primitives. This -;;; should (ultimately) include everything that Emacs defines in C. + ;; Be pure. Nothing in this module requires most of the standard + ;; Guile builtins, and it creates a problem if this module has + ;; access to them, as @bind can dynamically change their values. + #:pure -(use-modules (lang elisp primitives buffers) - (lang elisp primitives features) - (lang elisp primitives format) - (lang elisp primitives fns) - (lang elisp primitives guile) - (lang elisp primitives keymaps) - (lang elisp primitives lists) - (lang elisp primitives load) - (lang elisp primitives match) - (lang elisp primitives numbers) - (lang elisp primitives pure) - (lang elisp primitives read) - (lang elisp primitives signal) - (lang elisp primitives strings) - (lang elisp primitives symprop) - (lang elisp primitives system) - (lang elisp primitives time)) + ;; But we do need a few builtins - import them here. + #:use-module ((guile) #:select (@fop @bind nil-cond)) -;;; Now switch into Emacs Lisp syntax. + ;; {Elisp Primitives} + ;; + ;; In other words, Scheme definitions of elisp primitives. This + ;; should (ultimately) include everything that Emacs defines in C. + #:use-module (lang elisp primitives buffers) + #:use-module (lang elisp primitives features) + #:use-module (lang elisp primitives format) + #:use-module (lang elisp primitives fns) + #:use-module (lang elisp primitives guile) + #:use-module (lang elisp primitives keymaps) + #:use-module (lang elisp primitives lists) + #:use-module (lang elisp primitives load) + #:use-module (lang elisp primitives match) + #:use-module (lang elisp primitives numbers) + #:use-module (lang elisp primitives pure) + #:use-module (lang elisp primitives read) + #:use-module (lang elisp primitives signal) + #:use-module (lang elisp primitives strings) + #:use-module (lang elisp primitives symprop) + #:use-module (lang elisp primitives syntax) + #:use-module (lang elisp primitives system) + #:use-module (lang elisp primitives time) -(use-modules (lang elisp transform)) -(read-set! keywords 'prefix) -(read-set! language 'elisp) -(set-module-transformer! (current-module) transformer) + ;; Now switch into Emacs Lisp syntax. + #:use-syntax (lang elisp transform)) + +;(use-modules (lang elisp transform)) +;(read-set! keywords 'prefix) +;(set-module-transformer! (current-module) transformer) ;;; Everything below here is written in Elisp. diff --git a/lang/elisp/internals/null.scm b/lang/elisp/internals/null.scm index d574e3424..420278e0c 100644 --- a/lang/elisp/internals/null.scm +++ b/lang/elisp/internals/null.scm @@ -3,4 +3,5 @@ (define (null obj) (or (not obj) - (null? obj))) + (null? obj) + (eq? obj 'nil))) ; Should be removed. diff --git a/lang/elisp/internals/set.scm b/lang/elisp/internals/set.scm index cee332101..8137a6221 100644 --- a/lang/elisp/internals/set.scm +++ b/lang/elisp/internals/set.scm @@ -1,9 +1,18 @@ (define-module (lang elisp internals set) #:use-module (lang elisp internals evaluation) #:use-module (lang elisp internals signal) - #:export (set)) + #:export (set value)) ;; Set SYM's variable value to VAL, and return VAL. (define (set sym val) (module-define! the-elisp-module sym val) val) + +;; Return SYM's variable value. If it has none, signal an error if +;; MUST-EXIST is true, just return #nil otherwise. +(define (value sym must-exist) + (if (module-defined? the-elisp-module sym) + (module-ref the-elisp-module sym) + (if must-exist + (error "Symbol's value as variable is void:" sym) + %nil))) diff --git a/lang/elisp/primitives/Makefile.am b/lang/elisp/primitives/Makefile.am index f2bd3e919..283467a41 100644 --- a/lang/elisp/primitives/Makefile.am +++ b/lang/elisp/primitives/Makefile.am @@ -39,6 +39,7 @@ elisp_sources = \ signal.scm \ strings.scm \ symprop.scm \ + syntax.scm \ system.scm \ time.scm diff --git a/lang/elisp/primitives/fns.scm b/lang/elisp/primitives/fns.scm index 87b05c7e0..ba2b53a79 100644 --- a/lang/elisp/primitives/fns.scm +++ b/lang/elisp/primitives/fns.scm @@ -1,5 +1,7 @@ (define-module (lang elisp primitives fns) - #:use-module (lang elisp internals fset)) + #:use-module (lang elisp internals set) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals null)) (fset 'fset fset) (fset 'defalias fset) @@ -12,11 +14,11 @@ (fset 'interactive-p (lambda () - #f)) + %nil)) (fset 'commandp (lambda (sym) - (if (interactive-spec (fref sym)) #t #f))) + (if (interactive-spec (fref sym)) #t %nil))) (fset 'fboundp (lambda (sym) @@ -32,14 +34,12 @@ (fset 'byte-code-function-p (lambda (object) - #f)) + %nil)) (fset 'run-hooks - (lambda (hooks) - (cond ((null hooks)) - ((list? hooks) - (for-each (lambda (hook) - (elisp-apply hook '())) - hooks)) - (else - (elisp-apply hooks '()))))) + (lambda hooks + (for-each (lambda (hooksym) + (for-each (lambda (fn) + (elisp-apply fn '())) + (value hooksym #f))) + hooks))) diff --git a/lang/elisp/primitives/lists.scm b/lang/elisp/primitives/lists.scm index be603e2c8..43843f811 100644 --- a/lang/elisp/primitives/lists.scm +++ b/lang/elisp/primitives/lists.scm @@ -46,10 +46,16 @@ (fset sym (lambda (elt list) (if (null list) - #f + %nil (if (null elt) (or (proc #f list) - (proc '() list)) + (proc '() list) + (proc %nil list) + (proc 'nil list)) ; 'nil shouldn't be + ; here, as it should + ; have been + ; translated by the + ; transformer. (proc elt list)))))) '( memq member assq assoc) `(,memq ,member ,assq ,assoc)) diff --git a/lang/elisp/primitives/strings.scm b/lang/elisp/primitives/strings.scm index 4326aeb93..08bd8f8de 100644 --- a/lang/elisp/primitives/strings.scm +++ b/lang/elisp/primitives/strings.scm @@ -29,3 +29,5 @@ (else (wta 'arrayp array 1))))) (fset 'stringp string?) + +(fset 'vector vector) diff --git a/lang/elisp/primitives/symprop.scm b/lang/elisp/primitives/symprop.scm index ffdc7e6ae..4ca169226 100644 --- a/lang/elisp/primitives/symprop.scm +++ b/lang/elisp/primitives/symprop.scm @@ -22,9 +22,7 @@ (fset 'symbol-value (lambda (sym) - (if (module-defined? the-elisp-module sym) - (module-ref the-elisp-module sym) - (error "Symbol's value as variable is void:" sym)))) + (value sym #t))) (fset 'default-value 'symbol-value) diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm new file mode 100644 index 000000000..ac0951439 --- /dev/null +++ b/lang/elisp/primitives/syntax.scm @@ -0,0 +1,359 @@ +(define-module (lang elisp primitives syntax) + #:use-module (lang elisp internals evaluation) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals trace) + #:use-module (lang elisp transform)) + +;;; Define Emacs Lisp special forms as macros. This is much more +;;; flexible than handling them specially in the translator: allows +;;; them to be redefined, and hopefully allows better source location +;;; tracking. + +;;; {Variables} + +(define (setq exp env) + (cons begin + (let loop ((sets (cdr exp)) (last-sym #f)) + (if (null? sets) + (list last-sym) + (cons `(,module-define! ,the-elisp-module + (,quote ,(car sets)) + ,(transformer (cadr sets))) + (loop (cddr sets) (car sets))))))) + +(fset 'setq + (procedure->memoizing-macro setq)) + +(fset 'defvar + (procedure->memoizing-macro + (lambda (exp env) + (trc 'defvar (cadr exp)) + (if (null? (cddr exp)) + `(,quote ,(cadr exp)) + `(,begin (,if (,not (,defined? (,quote ,(cadr exp)))) + ,(setq (list (car exp) (cadr exp) (caddr exp)) env)) + ;; (,macro-setq ,(cadr exp) ,(caddr exp))) + (,quote ,(cadr exp))))))) + +(fset 'defconst + (procedure->memoizing-macro + (lambda (exp env) + (trc 'defconst (cadr exp)) + `(,begin ,(setq (list (car exp) (cadr exp) (caddr exp)) env) + (,quote ,(cadr exp)))))) + +;;; {lambda, function and macro definitions} + +;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and +;;; returns three values: (i) list of symbols for required arguments, +;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or +;;; #f if there is no rest argument. +(define (parse-formals formals) + (letrec ((do-required + (lambda (required formals) + (if (null? formals) + (values (reverse required) '() #f) + (let ((next-sym (car formals))) + (cond ((not (symbol? next-sym)) + (error "Bad formals (non-symbol in required list)")) + ((eq? next-sym '&optional) + (do-optional required '() (cdr formals))) + ((eq? next-sym '&rest) + (do-rest required '() (cdr formals))) + (else + (do-required (cons next-sym required) + (cdr formals)))))))) + (do-optional + (lambda (required optional formals) + (if (null? formals) + (values (reverse required) (reverse optional) #f) + (let ((next-sym (car formals))) + (cond ((not (symbol? next-sym)) + (error "Bad formals (non-symbol in optional list)")) + ((eq? next-sym '&rest) + (do-rest required optional (cdr formals))) + (else + (do-optional required + (cons next-sym optional) + (cdr formals)))))))) + (do-rest + (lambda (required optional formals) + (if (= (length formals) 1) + (let ((next-sym (car formals))) + (if (symbol? next-sym) + (values (reverse required) (reverse optional) next-sym) + (error "Bad formals (non-symbol rest formal)"))) + (error "Bad formals (more than one rest formal)"))))) + + (do-required '() (cond ((list? formals) + formals) + ((symbol? formals) + (list '&rest formals)) + (else + (error "Bad formals (not a list or a single symbol)")))))) + +(define (transform-lambda exp) + (call-with-values (lambda () (parse-formals (cadr exp))) + (lambda (required optional rest) + (let ((num-required (length required)) + (num-optional (length optional))) + `(,lambda %--args + (,let ((%--num-args (,length %--args))) + (,cond ((,< %--num-args ,num-required) + (,error "Wrong number of args (not enough required args)")) + ,@(if rest + '() + `(((,> %--num-args ,(+ num-required num-optional)) + (,error "Wrong number of args (too many args)")))) + (else + (@bind ,(append (map (lambda (i) + (list (list-ref required i) + `(,list-ref %--args ,i))) + (iota num-required)) + (map (lambda (i) + (let ((i+nr (+ i num-required))) + (list (list-ref optional i) + `(,if (,> %--num-args ,i+nr) + (,list-ref %--args ,i+nr) + #f)))) + (iota num-optional)) + (if rest + (list (list rest + `(,if (,> %--num-args + ,(+ num-required + num-optional)) + (,list-tail %--args + ,(+ num-required + num-optional)) + '()))) + '())) + ,@(map transformer (cddr exp))))))))))) + +(define interactive-spec (make-fluid)) + +(define (set-not-subr! proc boolean) + (set! (not-subr? proc) boolean)) + +(define (transform-lambda/interactive exp name) + (fluid-set! interactive-spec #f) + (let* ((x (transform-lambda exp)) + (is (fluid-ref interactive-spec))) + `(,let ((%--lambda ,x)) + (,set-procedure-property! %--lambda (,quote name) (,quote ,name)) + (,set-not-subr! %--lambda #t) + ,@(if is + `((,set! (,interactive-spec %--lambda) (,quote ,is))) + '()) + %--lambda))) + +(fset 'lambda + (procedure->memoizing-macro + (lambda (exp env) + (transform-lambda/interactive exp ')))) + +(fset 'defun + (procedure->memoizing-macro + (lambda (exp env) + (trc 'defun (cadr exp)) + `(,begin (,fset (,quote ,(cadr exp)) + ,(transform-lambda/interactive (cdr exp) + (symbol-append '))) + (,quote ,(cadr exp)))))) + +(fset 'interactive + (procedure->memoizing-macro + (lambda (exp env) + (fluid-set! interactive-spec exp) + #f))) + +(fset 'defmacro + (procedure->memoizing-macro + (lambda (exp env) + (trc 'defmacro (cadr exp)) + (call-with-values (lambda () (parse-formals (caddr exp))) + (lambda (required optional rest) + (let ((num-required (length required)) + (num-optional (length optional))) + `(,begin (,fset (,quote ,(cadr exp)) + (,procedure->memoizing-macro + (,lambda (exp1 env1) + (,trc (,quote using) (,quote ,(cadr exp))) + (,let* ((%--args (,cdr exp1)) + (%--num-args (,length %--args))) + (,cond ((,< %--num-args ,num-required) + (,error "Wrong number of args (not enough required args)")) + ,@(if rest + '() + `(((,> %--num-args ,(+ num-required num-optional)) + (,error "Wrong number of args (too many args)")))) + (else (,transformer + (@bind ,(append (map (lambda (i) + (list (list-ref required i) + `(,list-ref %--args ,i))) + (iota num-required)) + (map (lambda (i) + (let ((i+nr (+ i num-required))) + (list (list-ref optional i) + `(,if (,> %--num-args ,i+nr) + (,list-ref %--args ,i+nr) + #f)))) + (iota num-optional)) + (if rest + (list (list rest + `(,if (,> %--num-args + ,(+ num-required + num-optional)) + (,list-tail %--args + ,(+ num-required + num-optional)) + '()))) + '())) + ,@(map transformer (cdddr exp))))))))))))))))) + +;;; {Sequencing} + +(fset 'progn + (procedure->memoizing-macro + (lambda (exp env) + `(,begin ,@(map transformer (cdr exp)))))) + +(fset 'prog1 + (procedure->memoizing-macro + (lambda (exp env) + `(,let ((%res1 ,(transformer (cadr exp)))) + ,@(map transformer (cddr exp)) + %res1)))) + +(fset 'prog2 + (procedure->memoizing-macro + (lambda (exp env) + `(,begin ,(transformer (cadr exp)) + (,let ((%res2 ,(transformer (caddr exp)))) + ,@(map transformer (cdddr exp)) + %res2))))) + +;;; {Conditionals} + +(define <-- *unspecified*) + +(fset 'if + (procedure->memoizing-macro + (lambda (exp env) + (let ((else-case (cdddr exp))) + (cond ((null? else-case) + `(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f)) + ((null? (cdr else-case)) + `(nil-cond ,(transformer (cadr exp)) + ,(transformer (caddr exp)) + ,(transformer (car else-case)))) + (else + `(nil-cond ,(transformer (cadr exp)) + ,(transformer (caddr exp)) + (,begin ,@(map transformer else-case))))))))) + +(fset 'and + (procedure->memoizing-macro + (lambda (exp env) + (cond ((null? (cdr exp)) #t) + ((null? (cddr exp)) (transformer (cadr exp))) + (else + (cons nil-cond + (let loop ((args (cdr exp))) + (if (null? (cdr args)) + (list (transformer (car args))) + (cons (list not (transformer (car args))) + (cons #f + (loop (cdr args)))))))))))) + +(fset 'or + (procedure->memoizing-macro + (lambda (exp env) + (cond ((null? (cdr exp)) #f) + ((null? (cddr exp)) (transformer (cadr exp))) + (else + (cons nil-cond + (let loop ((args (cdr exp))) + (if (null? (cdr args)) + (list (transformer (car args))) + (cons (transformer (car args)) + (cons <-- + (loop (cdr args)))))))))))) + +(fset 'cond + (procedure->memoizing-macro + (lambda (exp env) + (if (null? (cdr exp)) + #f + (cons + nil-cond + (let loop ((clauses (cdr exp))) + (if (null? clauses) + '(#f) + (let ((clause (car clauses))) + (if (eq? (car clause) #t) + (cond ((null? (cdr clause)) '(t)) + ((null? (cddr clause)) + (list (transformer (cadr clause)))) + (else `((,begin ,@(map transformer (cdr clause)))))) + (cons (transformer (car clause)) + (cons (cond ((null? (cdr clause)) <--) + ((null? (cddr clause)) + (transformer (cadr clause))) + (else + `(,begin ,@(map transformer (cdr clause))))) + (loop (cdr clauses))))))))))))) + +(fset 'while + (procedure->memoizing-macro + (lambda (exp env) + `((,letrec ((%--while (,lambda () + (,nil-cond ,(transformer (cadr exp)) + (,begin ,@(map transformer (cddr exp)) + (%--while)) + #f)))) + %--while))))) + +;;; {Local binding} + +(fset 'let + (procedure->memoizing-macro + (lambda (exp env) + `(@bind ,(map (lambda (binding) + (trc 'let binding) + (if (pair? binding) + `(,(car binding) ,(transformer (cadr binding))) + `(,binding #f))) + (cadr exp)) + ,@(map transformer (cddr exp)))))) + +(fset 'let* + (procedure->memoizing-macro + (lambda (exp env) + (if (null? (cadr exp)) + `(begin ,@(map transformer (cddr exp))) + (car (let loop ((bindings (cadr exp))) + (if (null? bindings) + (map transformer (cddr exp)) + `((@bind (,(let ((binding (car bindings))) + (if (pair? binding) + `(,(car binding) ,(transformer (cadr binding))) + `(,binding #f)))) + ,@(loop (cdr bindings))))))))))) + +;;; {Exception handling} + +(fset 'unwind-protect + (procedure->memoizing-macro + (lambda (exp env) + (trc 'unwind-protect (cadr exp)) + `(,let ((%--throw-args #f)) + (,catch #t + (,lambda () + ,(transformer (cadr exp))) + (,lambda args + (,set! %--throw-args args))) + ,@(map transformer (cddr exp)) + (,if %--throw-args + (,apply ,throw %--throw-args)))))) diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm index 2f6ed8db5..ec1639d6e 100644 --- a/lang/elisp/transform.scm +++ b/lang/elisp/transform.scm @@ -3,9 +3,7 @@ #:use-module (lang elisp internals fset) #:use-module (lang elisp internals evaluation) #:use-module (ice-9 session) - #:export (transformer)) - -(define interactive-spec (make-fluid)) + #:export (transformer transform)) ;;; {S-expressions} ;;; @@ -16,7 +14,9 @@ ;; Should be made mutating instead of constructing ;; (define (transformer x) - (cond ((null? x) '()) + (cond ((eq? x 'nil) %nil) + ((eq? x 't) #t) + ((null? x) '()) ((not (pair? x)) x) ((and (pair? (car x)) (eq? (caar x) 'quasiquote)) @@ -27,43 +27,29 @@ ; Escape to Scheme syntax ((scheme) (cons 'begin (cdr x))) ; Should be handled in reader - ((quote function) (cons 'quote (cars->nil (cdr x)))) + ((quote function) `(,quote ,@(cars->nil (cdr x)))) ((quasiquote) (m-quasiquote x '())) - ((nil-cond) (transform-1 x)) - ((let) (m-let x '())) - ((let*) (m-let* x '())) - ((if) (m-if x '())) - ((and) (m-and x '())) - ((or) (m-or x '())) - ((while) (m-while x '())) + ;((nil-cond) (transform-1 x)) + ;((let) (m-let x '())) + ;((let*) (m-let* x '())) + ;((if) (m-if x '())) + ;((and) (m-and x '())) + ;((or) (m-or x '())) + ;((while) (m-while x '())) ;((while) (cons macro-while (cdr x))) - ((prog1) (m-prog1 x '())) - ((prog2) (m-prog2 x '())) - ((progn begin) (cons 'begin (map transformer (cdr x)))) - ((cond) (m-cond x '())) - ((lambda) (transform-lambda/interactive x ')) - ((defun) (m-defun x '())) - ((defmacro) (m-defmacro x '())) - ((setq) (m-setq x '())) - ((defvar) (m-defvar x '())) - ((defconst) (m-defconst x '())) - ((interactive) (fluid-set! interactive-spec x) #f) - ((unwind-protect) (m-unwind-protect x '())) + ;((prog1) (m-prog1 x '())) + ;((prog2) (m-prog2 x '())) + ;((progn) (cons 'begin (map transformer (cdr x)))) + ;((cond) (m-cond x '())) + ;((lambda) (transform-lambda/interactive x ')) + ;((defun) (m-defun x '())) + ;((defmacro) (m-defmacro x '())) + ;((setq) (m-setq x '())) + ;((interactive) (fluid-set! interactive-spec x) #f) + ;((unwind-protect) (m-unwind-protect x '())) (else (transform-application x)))) (else (syntax-error x)))) -(define (m-unwind-protect exp env) - (trc 'unwind-protect (cadr exp)) - `(let ((%--throw-args #f)) - (catch #t - (lambda () - ,(transformer (cadr exp))) - (lambda args - (set! %--throw-args args))) - ,@(transform-list (cddr exp)) - (if %--throw-args - (apply throw %--throw-args)))) - (define (m-quasiquote exp env) (cons 'quasiquote (map transform-inside-qq (cdr exp)))) @@ -78,185 +64,17 @@ (else (cons (car x) (map transform-inside-qq (cdr x)))))) (else (cons (transform-inside-qq (car x)) (transform-inside-qq (cdr x)))))) - -(define (transform-1 x) - (cons (car x) (map transformer (cdr x)))) - -(define (transform-2 x) - (cons (car x) - (cons (cadr x) - (map transformer (cddr x))))) - -(define (transform-3 x) - (cons (car x) - (cons (cadr x) - (cons (caddr x) - (map transformer (cdddr x)))))) - -(define (transform-list x) - (map transformer x)) - -;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and -;;; returns three values: (i) list of symbols for required arguments, -;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or -;;; #f if there is no rest argument. -(define (parse-formals formals) - (letrec ((do-required - (lambda (required formals) - (if (null? formals) - (values (reverse required) '() #f) - (let ((next-sym (car formals))) - (cond ((not (symbol? next-sym)) - (error "Bad formals (non-symbol in required list)")) - ((eq? next-sym '&optional) - (do-optional required '() (cdr formals))) - ((eq? next-sym '&rest) - (do-rest required '() (cdr formals))) - (else - (do-required (cons next-sym required) - (cdr formals)))))))) - (do-optional - (lambda (required optional formals) - (if (null? formals) - (values (reverse required) (reverse optional) #f) - (let ((next-sym (car formals))) - (cond ((not (symbol? next-sym)) - (error "Bad formals (non-symbol in optional list)")) - ((eq? next-sym '&rest) - (do-rest required optional (cdr formals))) - (else - (do-optional required - (cons next-sym optional) - (cdr formals)))))))) - (do-rest - (lambda (required optional formals) - (if (= (length formals) 1) - (let ((next-sym (car formals))) - (if (symbol? next-sym) - (values (reverse required) (reverse optional) next-sym) - (error "Bad formals (non-symbol rest formal)"))) - (error "Bad formals (more than one rest formal)"))))) - - (do-required '() (cond ((list? formals) - formals) - ((symbol? formals) - (list '&rest formals)) - (else - (error "Bad formals (not a list or a single symbol)")))))) - -(define (transform-lambda/interactive exp name) - (fluid-set! interactive-spec #f) - (let* ((x (transform-lambda exp)) - (is (fluid-ref interactive-spec))) - `(let ((%--lambda ,x)) - (set-procedure-property! %--lambda 'name ',name) - (set! (,not-subr? %--lambda) #t) - ,@(if is - `((set! (,interactive-specification %--lambda) ',is)) - '()) - %--lambda))) - -(define (transform-lambda exp) - (call-with-values (lambda () (parse-formals (cadr exp))) - (lambda (required optional rest) - (let ((num-required (length required)) - (num-optional (length optional))) - `(lambda %--args - (let ((%--num-args (length %--args))) - (cond ((< %--num-args ,num-required) - (error "Wrong number of args (not enough required args)")) - ,@(if rest - '() - `(((> %--num-args ,(+ num-required num-optional)) - (error "Wrong number of args (too many args)")))) - (else - (@bind ,(append (map (lambda (i) - (list (list-ref required i) - `(list-ref %--args ,i))) - (iota num-required)) - (map (lambda (i) - (let ((i+nr (+ i num-required))) - (list (list-ref optional i) - `(if (> %--num-args ,i+nr) - (list-ref %--args ,i+nr) - #f)))) - (iota num-optional)) - (if rest - (list (list rest - `(if (> %--num-args - ,(+ num-required - num-optional)) - (list-tail %--args - ,(+ num-required - num-optional)) - '()))) - '())) - ,@(transform-list (cddr exp))))))) - )))) - -(define (m-defun exp env) - (trc 'defun (cadr exp)) - `(begin (,fset ',(cadr exp) - ,(transform-lambda/interactive (cdr exp) - (symbol-append '))) - ',(cadr exp))) - -(define (m-defmacro exp env) - (trc 'defmacro (cadr exp)) - (call-with-values (lambda () (parse-formals (caddr exp))) - (lambda (required optional rest) - (let ((num-required (length required)) - (num-optional (length optional))) - `(begin (,fset ',(cadr exp) - (procedure->memoizing-macro - (lambda (exp1 env1) - (,trc 'using ',(cadr exp)) - (let* ((%--args (cdr exp1)) - (%--num-args (length %--args))) - (cond ((< %--num-args ,num-required) - (error "Wrong number of args (not enough required args)")) - ,@(if rest - '() - `(((> %--num-args ,(+ num-required num-optional)) - (error "Wrong number of args (too many args)")))) - (else (,transformer - (@bind ,(append (map (lambda (i) - (list (list-ref required i) - `(list-ref %--args ,i))) - (iota num-required)) - (map (lambda (i) - (let ((i+nr (+ i num-required))) - (list (list-ref optional i) - `(if (> %--num-args ,i+nr) - (list-ref %--args ,i+nr) - #f)))) - (iota num-optional)) - (if rest - (list (list rest - `(if (> %--num-args - ,(+ num-required - num-optional)) - (list-tail %--args - ,(+ num-required - num-optional)) - '()))) - '())) - ,@(transform-list (cdddr exp))))))))))))))) (define (transform-application x) - `(@fop ,(car x) - (,transformer-macro ,@(cdr x)))) + (cons-source x + '@fop + `(,(car x) (,transformer-macro ,@(cdr x))))) (define transformer-macro (procedure->memoizing-macro - (lambda (exp env) - (cons 'list (map transformer (cdr exp)))))) - -; (cons '@fop -; (cons (car x) -; (map transformer (cdr x))))) + (let ((cdr cdr)) + (lambda (exp env) + (cons 'list (map transformer (cdr exp))))))) (define (cars->nil ls) (cond ((not (pair? ls)) ls) @@ -264,151 +82,4 @@ (else (cons (cars->nil (car ls)) (cars->nil (cdr ls)))))) -;;; {Special forms} -;;; - -(define (m-setq exp env) - (cons 'begin - (let loop ((sets (cdr exp)) (last-sym #f)) - (if (null? sets) - (list last-sym) - (cons `(module-define! ,the-elisp-module - ',(car sets) - ,(transformer (cadr sets))) - (loop (cddr sets) (car sets))))))) - -;(define (m-setq exp env) -; (let* ((binder (car (last-pair env))) -; (varvals (let loop ((ls (cdr exp))) -; (if (null? ls) -; '() -; ;; Ensure existence only at macro expansion time -; (let ((var (or (binder (car ls) #f) -; (binder (car ls) #t)))) -; (if (not (variable-bound? var)) -; (variable-set! var #f)) -; (cons (list 'set! (car ls) (transformer (cadr ls))) -; (loop (cddr ls)))))))) -; (cond ((null? varvals) '()) -; ((null? (cdr varvals)) (car varvals)) -; (else (cons 'begin varvals))))) - -(define (m-let exp env) - `(@bind ,(map (lambda (binding) - (trc 'let binding) - (if (pair? binding) - `(,(car binding) ,(transformer (cadr binding))) - `(,binding #f))) - (cadr exp)) - ,@(transform-list (cddr exp)))) - -(define (m-let* exp env) - (if (null? (cadr exp)) - `(begin ,@(transform-list (cddr exp))) - (car (let loop ((bindings (cadr exp))) - (if (null? bindings) - (transform-list (cddr exp)) - `((@bind (,(let ((binding (car bindings))) - (if (pair? binding) - `(,(car binding) ,(transformer (cadr binding))) - `(,binding #f)))) - ,@(loop (cdr bindings))))))))) - -(define (m-prog1 exp env) - `(,let ((%res1 ,(transformer (cadr exp)))) - ,@(transform-list (cddr exp)) - %res1)) - -(define (m-prog2 exp env) - `(begin ,(transformer (cadr exp)) - (,let ((%res2 ,(transformer (caddr exp)))) - ,@(transform-list (cdddr exp)) - %res2))) - -(define <-- *unspecified*) - -(define (m-if exp env) - (let ((else-case (cdddr exp))) - (cond ((null? else-case) - `(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f)) - ((null? (cdr else-case)) - `(nil-cond ,(transformer (cadr exp)) - ,(transformer (caddr exp)) - ,(transformer (car else-case)))) - (else - `(nil-cond ,(transformer (cadr exp)) - ,(transformer (caddr exp)) - (begin ,@(transform-list else-case))))))) - -(define (m-and exp env) - (cond ((null? (cdr exp)) #t) - ((null? (cddr exp)) (transformer (cadr exp))) - (else - (cons 'nil-cond - (let loop ((args (cdr exp))) - (if (null? (cdr args)) - (list (transformer (car args))) - (cons (list 'not (transformer (car args))) - (cons #f - (loop (cdr args)))))))))) - -(define (m-or exp env) - (cond ((null? (cdr exp)) #f) - ((null? (cddr exp)) (transformer (cadr exp))) - (else - (cons 'nil-cond - (let loop ((args (cdr exp))) - (if (null? (cdr args)) - (list (transformer (car args))) - (cons (transformer (car args)) - (cons <-- - (loop (cdr args)))))))))) - -(define m-cond - (lambda (exp env) - (if (null? (cdr exp)) - #f - (cons - 'nil-cond - (let loop ((clauses (cdr exp))) - (if (null? clauses) - '(#f) - (let ((clause (car clauses))) - (if (eq? (car clause) #t) - (cond ((null? (cdr clause)) '(t)) - ((null? (cddr clause)) - (list (transformer (cadr clause)))) - (else `((begin ,@(transform-list (cdr clause)))))) - (cons (transformer (car clause)) - (cons (cond ((null? (cdr clause)) <--) - ((null? (cddr clause)) - (transformer (cadr clause))) - (else - `(begin ,@(transform-list (cdr clause))))) - (loop (cdr clauses)))))))))))) - -(define (m-while exp env) - `(,let %while () - (nil-cond ,(transformer (cadr exp)) - (begin ,@(transform-list (cddr exp)) (%while)) - #f))) - -(define (m-defvar exp env) - (trc 'defvar (cadr exp)) - (if (null? (cddr exp)) - `',(cadr exp) - `(begin (if (not (defined? ',(cadr exp))) - (,macro-setq ,(cadr exp) ,(caddr exp))) - ',(cadr exp)))) - -(define (m-defconst exp env) - (trc 'defconst (cadr exp)) - `(begin ,(m-setq (list (car exp) (cadr exp) (caddr exp)) env) - ',(cadr exp))) - -;(export-mmacros -; '(setq defun let let* if and or cond while prog1 prog2 progn) -; (list m-setq m-defun m-let m-let* m-if m-and m-or m-cond m-while m-prog1 m-prog2 begin)) - -(define macro-setq (procedure->memoizing-macro m-setq)) -(define macro-while (procedure->memoizing-macro m-while)) +(define transform transformer) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 767002040..bd6395e74 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -53,11 +53,11 @@ (scm_swap_fluids, scm_swap_fluids_reverse), list.c (scm_null_p, scm_ilength, scm_append_x, scm_last_pair, scm_reverse, scm_reverse_x, scm_list_ref, scm_list_set_x, scm_list_cdr_set_x, - scm_c_memq, scm_memv), load.c (scm_search_path), options.c - (change_option_setting, scm_options), posix.c (environ_list_to_c), - print.c (scm_iprlist), throw.c (scm_exit_status), vectors.c - (scm_vector), weaks.c (scm_weak_vector): Use SCM_NULL_OR_NIL_P - instead of SCM_NULLP. + scm_c_memq, scm_memv, scm_member), load.c (scm_search_path), + options.c (change_option_setting, scm_options), posix.c + (environ_list_to_c), print.c (scm_iprlist), throw.c + (scm_exit_status), vectors.c (scm_vector), weaks.c + (scm_weak_vector): Use SCM_NULL_OR_NIL_P instead of SCM_NULLP. * boolean.c (scm_not): Use `SCM_FALSEP || SCM_NILP' instead of just SCM_FALSEP. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index b407c1a81..c18b87194 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,11 @@ +2002-01-25 Neil Jerram + + * tests/load.test: New test; for search-path with Elisp + nil-terminated lists for PATH and EXTENSIONS. + + * tests/elisp.test: More tests for Scheme primitives that should + accept Elisp nil-terminated lists. + 2002-01-24 Neil Jerram * tests/elisp.test: More new tests for the Elisp nil value. diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test index 3d7f3a303..a7a4c4a51 100644 --- a/test-suite/tests/elisp.test +++ b/test-suite/tests/elisp.test @@ -109,12 +109,22 @@ (pass-if "length (with backquoted list)" (= (length `(a b c . ,%nil)) 3)) - (pass-if "write" + (pass-if "write (%nil)" + (string=? (with-output-to-string + (lambda () (write %nil))) + "#nil")) ; Hmmm... should be "()" ? + + (pass-if "display (%nil)" + (string=? (with-output-to-string + (lambda () (display %nil))) + "#nil")) ; Ditto. + + (pass-if "write (list)" (string=? (with-output-to-string (lambda () (write (cons 'a %nil)))) "(a)")) - (pass-if "display" + (pass-if "display (list)" (string=? (with-output-to-string (lambda () (display (cons 'a %nil)))) "(a)")) @@ -186,6 +196,72 @@ (list-set! l 6 44) (= (list-ref l 6) 44))) + (pass-if "list-cdr-set!" + (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) + (and (begin + (list-cdr-set! l 4 44) + (equal? l '(0 1 2 3 4 . 44))) + (begin + (list-cdr-set! l 3 `(new . ,%nil)) + (equal? l `(0 1 2 3 new . ,%nil)))))) + + (pass-if-exception "list-cdr-set!" + exception:out-of-range + (let ((l (copy-tree `(0 1 2 3 4 . ,%nil)))) + (list-cdr-set! l 6 44))) + + (pass-if "memq" + (equal? (memq 'c `(a b c d . ,%nil)) `(c d . ,%nil))) + + (pass-if "memv" + (equal? (memv 'c `(a b c d . ,%nil)) `(c d . ,%nil))) + + (pass-if "member" + (equal? (member "c" `("a" "b" "c" "d" . ,%nil)) `("c" "d" . ,%nil))) + + (pass-if "list->vector" + (equal? #(1 2 3) (list->vector `(1 2 3 . ,%nil)))) + + (pass-if "list->vector" + (equal? #(1 2 3) (list->vector `(1 2 3 . ,%nil)))) + + (pass-if "list->weak-vector" + (equal? (weak-vector 1 2 3) (list->weak-vector `(1 2 3 . ,%nil)))) + + (pass-if "sorted?" + (and (sorted? `(1 2 3 . ,%nil) <) + (not (sorted? `(1 6 3 . ,%nil) <)))) + + (pass-if "merge" + (equal? (merge '(1 4 7 10) + (merge `(2 5 8 11 . ,%nil) + `(3 6 9 12 . ,%nil) + <) + <) + `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil))) + + (pass-if "merge!" + (equal? (merge! (copy-tree '(1 4 7 10)) + (merge! (copy-tree `(2 5 8 11 . ,%nil)) + (copy-tree `(3 6 9 12 . ,%nil)) + <) + <) + `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil))) + + (pass-if "sort" + (equal? (sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8))) + + (pass-if "stable-sort" + (equal? (stable-sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8))) + + (pass-if "sort!" + (equal? (sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <) + '(1 3 4 5 8))) + + (pass-if "stable-sort!" + (equal? (stable-sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <) + '(1 3 4 5 8))) + ) (with-test-prefix "value preservation" diff --git a/test-suite/tests/load.test b/test-suite/tests/load.test index 294bd252a..6b0de7612 100644 --- a/test-suite/tests/load.test +++ b/test-suite/tests/load.test @@ -114,4 +114,13 @@ (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm") (try-search-with-extensions path "ugly.ss" extensions #f) +(if (defined? '%nil) + ;; Check that search-path accepts Elisp nil-terminated lists for + ;; PATH and EXTENSIONS. + (with-test-prefix "elisp-nil" + (set-cdr! (last-pair path) %nil) + (set-cdr! (last-pair extensions) %nil) + (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm") + (try-search-with-extensions path "ugly.ss" extensions #f))) + (delete-tree temp-dir) From 1fa86ca526d94b9149bdd805989f694be8c120d5 Mon Sep 17 00:00:00 2001 From: Stefan Jahn Date: Thu, 31 Jan 2002 10:38:50 +0000 Subject: [PATCH 22/54] 2002-01-31 Stefan Jahn * convert.c, convert.h, convert.i.c: New files containing C array to Scheme conversion helpers meant to be replacement functions for the deprecated gh interface. * Makefile.am: Setup rules for new `convert.*' files. 2002-01-31 Stefan Jahn * configure.in: Add -DLIBLTDL_DLL_IMPORT to INCLTDL when using `libltdl.dll'. --- ChangeLog | 5 + configure.in | 4 + libguile/ChangeLog | 8 ++ libguile/Makefile.am | 12 +-- libguile/convert.c | 146 +++++++++++++++++++++++++ libguile/convert.h | 76 +++++++++++++ libguile/convert.i.c | 247 +++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 492 insertions(+), 6 deletions(-) create mode 100644 libguile/convert.c create mode 100644 libguile/convert.h create mode 100644 libguile/convert.i.c diff --git a/ChangeLog b/ChangeLog index 88b3a520e..dfac20bd8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2002-01-31 Stefan Jahn + + * configure.in: Add -DLIBLTDL_DLL_IMPORT to INCLTDL when using + `libltdl.dll'. + 2002-01-28 Stefan Jahn * configure.in (guile_cv_have_uint32_t): Look also in diff --git a/configure.in b/configure.in index 4607b4d76..2e0e2c0e5 100644 --- a/configure.in +++ b/configure.in @@ -251,6 +251,9 @@ if test "$MINGW32" = "yes" ; then AC_DEFINE(USE_DLL_IMPORT, 1, [Define if you need additional CPP macros on Win32 platforms.]) fi + if test x"$enable_ltdl_install" = x"yes" ; then + INCLTDL="-DLIBLTDL_DLL_IMPORT $INCLTDL" + fi fi AC_SUBST(EXTRA_DEFS) @@ -273,6 +276,7 @@ if test "$use_modules" != no; then done fi fi + AC_SUBST(INCLTDL) AC_SUBST(LIBLTDL) AC_SUBST(DLPREOPEN) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index bd6395e74..e4bab308a 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,11 @@ +2002-01-31 Stefan Jahn + + * convert.c, convert.h, convert.i.c: New files containing C + array to Scheme conversion helpers meant to be replacement + functions for the deprecated gh interface. + + * Makefile.am: Setup rules for new `convert.*' files. + 2002-01-28 Stefan Jahn * symbols.c (scm_c_symbol2str): New function, replacement for diff --git a/libguile/Makefile.am b/libguile/Makefile.am index e3bb3b3ea..c11ef267e 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -41,8 +41,8 @@ guile_LDFLAGS = @DLPREOPEN@ guile_filter_doc_snarfage_SOURCES = c-tokenize.c libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ - chars.c continuations.c debug.c deprecation.c dynl.c dynwind.c \ - environments.c eq.c error.c eval.c evalext.c extensions.c \ + chars.c continuations.c convert.c debug.c deprecation.c dynl.c \ + dynwind.c environments.c eq.c error.c eval.c evalext.c extensions.c \ feature.c fluids.c fports.c \ gc.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c \ gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c guardians.c hash.c \ @@ -117,7 +117,7 @@ install-exec-hook: ## Perhaps we can deal with them normally once the merge seems to be ## working. noinst_HEADERS = coop-threads.c coop-threads.h coop.c \ - num2integral.i.c num2float.i.c \ + num2integral.i.c num2float.i.c convert.i.c \ win32-uname.h win32-dirent.h win32-socket.h libguile_la_DEPENDENCIES = @LIBLOBJS@ @@ -130,9 +130,9 @@ pkginclude_HEADERS = gh.h # These are headers visible as . modincludedir = $(includedir)/libguile modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ - chars.h continuations.h coop-defs.h debug.h debug-malloc.h deprecation.h \ - dynl.h dynwind.h environments.h eq.h error.h eval.h evalext.h \ - extensions.h feature.h filesys.h fluids.h fports.h gc.h \ + chars.h continuations.h convert.h coop-defs.h debug.h debug-malloc.h \ + deprecation.h dynl.h dynwind.h environments.h eq.h error.h eval.h \ + evalext.h extensions.h feature.h filesys.h fluids.h fports.h gc.h \ gdb_interface.h gdbint.h \ goops.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h \ inline.h ioext.h \ diff --git a/libguile/convert.c b/libguile/convert.c new file mode 100644 index 000000000..43d5d7107 --- /dev/null +++ b/libguile/convert.c @@ -0,0 +1,146 @@ +/* Copyright (C) 2002 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + + +#include "libguile/_scm.h" +#include "libguile/validate.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/pairs.h" +#if HAVE_ARRAYS +# include "libguile/unif.h" +#endif + +#include "libguile/convert.h" + +#define CTYPE char +#define SCM2CTYPES_FN "scm_c_scm2chars" +#define SCM2CTYPES scm_c_scm2chars +#define CTYPES2SCM_FN "scm_c_chars2scm" +#define CTYPES2SCM scm_c_chars2scm +#define CTYPEFIXABLE +#define CTYPES2UVECT_FN "scm_c_chars2byvect" +#define CTYPES2UVECT scm_c_chars2byvect +#define UVECTTYPE scm_tc7_byvect +#define CTYPEMIN -128 +#define CTYPEMAX +255 +#define ARRAYTYPE1 scm_tc7_byvect +#define STRINGTYPE +#include "convert.i.c" + +#define CTYPE short +#define SCM2CTYPES_FN "scm_c_scm2shorts" +#define SCM2CTYPES scm_c_scm2shorts +#define CTYPES2SCM_FN "scm_c_shorts2scm" +#define CTYPES2SCM scm_c_shorts2scm +#define CTYPEFIXABLE +#define CTYPES2UVECT_FN "scm_c_shorts2svect" +#define CTYPES2UVECT scm_c_shorts2svect +#define UVECTTYPE scm_tc7_svect +#define CTYPEMIN -32768 +#define CTYPEMAX +65535 +#define ARRAYTYPE1 scm_tc7_svect +#include "convert.i.c" + +#define CTYPE int +#define SCM2CTYPES_FN "scm_c_scm2ints" +#define SCM2CTYPES scm_c_scm2ints +#define CTYPES2SCM_FN "scm_c_ints2scm" +#define CTYPES2SCM scm_c_ints2scm +#define CTYPES2UVECT_FN "scm_c_ints2ivect" +#define CTYPES2UVECT scm_c_ints2ivect +#define UVECTTYPE scm_tc7_ivect +#define CTYPES2UVECT_FN2 "scm_c_uints2uvect" +#define CTYPES2UVECT2 scm_c_uints2uvect +#define UVECTTYPE2 scm_tc7_uvect +#define ARRAYTYPE1 scm_tc7_ivect +#define ARRAYTYPE2 scm_tc7_uvect +#include "convert.i.c" + +#define CTYPE long +#define SCM2CTYPES_FN "scm_c_scm2longs" +#define SCM2CTYPES scm_c_scm2longs +#define CTYPES2SCM_FN "scm_c_longs2scm" +#define CTYPES2SCM scm_c_longs2scm +#define CTYPES2UVECT_FN "scm_c_longs2ivect" +#define CTYPES2UVECT scm_c_longs2ivect +#define UVECTTYPE scm_tc7_ivect +#define CTYPES2UVECT_FN2 "scm_c_ulongs2uvect" +#define CTYPES2UVECT2 scm_c_ulongs2uvect +#define UVECTTYPE2 scm_tc7_uvect +#define ARRAYTYPE1 scm_tc7_ivect +#define ARRAYTYPE2 scm_tc7_uvect +#include "convert.i.c" + +#define CTYPE float +#define SCM2CTYPES_FN "scm_c_scm2floats" +#define SCM2CTYPES scm_c_scm2floats +#define CTYPES2SCM_FN "scm_c_floats2scm" +#define CTYPES2SCM scm_c_floats2scm +#define CTYPES2UVECT_FN "scm_c_floats2fvect" +#define CTYPES2UVECT scm_c_floats2fvect +#define UVECTTYPE scm_tc7_fvect +#define ARRAYTYPE1 scm_tc7_fvect +#define ARRAYTYPE2 scm_tc7_dvect +#define FLOATTYPE1 float +#define FLOATTYPE2 double +#include "convert.i.c" + +#define CTYPE double +#define SCM2CTYPES_FN "scm_c_scm2doubles" +#define SCM2CTYPES scm_c_scm2doubles +#define CTYPES2SCM_FN "scm_c_doubles2scm" +#define CTYPES2SCM scm_c_doubles2scm +#define CTYPES2UVECT_FN "scm_c_doubles2dvect" +#define CTYPES2UVECT scm_c_doubles2dvect +#define UVECTTYPE scm_tc7_dvect +#define ARRAYTYPE1 scm_tc7_dvect +#define ARRAYTYPE2 scm_tc7_fvect +#define FLOATTYPE1 double +#define FLOATTYPE2 float +#include "convert.i.c" + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/convert.h b/libguile/convert.h new file mode 100644 index 000000000..ec350fef4 --- /dev/null +++ b/libguile/convert.h @@ -0,0 +1,76 @@ +/* classes: h_files */ + +#ifndef SCM_CONVERT_H +#define SCM_CONVERT_H + +/* Copyright (C) 2002 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + + + +#include "libguile/__scm.h" + +SCM_API char *scm_c_scm2chars (SCM obj, char *dst); +SCM_API short *scm_c_scm2shorts (SCM obj, short *dst); +SCM_API int *scm_c_scm2ints (SCM obj, int *dst); +SCM_API long *scm_c_scm2longs (SCM obj, long *dst); +SCM_API float *scm_c_scm2floats (SCM obj, float *dst); +SCM_API double *scm_c_scm2doubles (SCM obj, double *dst); + +SCM_API SCM scm_c_chars2scm (const char *src, long n); +SCM_API SCM scm_c_shorts2scm (const short *src, long n); +SCM_API SCM scm_c_ints2scm (const int *src, long n); +SCM_API SCM scm_c_longs2scm (const long *src, long n); +SCM_API SCM scm_c_floats2scm (const float *src, long n); +SCM_API SCM scm_c_doubles2scm (const double *src, long n); + +#if HAVE_ARRAYS +SCM_API SCM scm_c_chars2byvect (const char *src, long n); +SCM_API SCM scm_c_shorts2svect (const short *src, long n); +SCM_API SCM scm_c_ints2ivect (const int *src, long n); +SCM_API SCM scm_c_uints2uvect (const unsigned int *src, long n); +SCM_API SCM scm_c_longs2ivect (const long *src, long n); +SCM_API SCM scm_c_ulongs2uvect (const unsigned long *src, long n); +SCM_API SCM scm_c_floats2fvect (const float *src, long n); +SCM_API SCM scm_c_doubles2dvect (const double *src, long n); +#endif + +#endif /* SCM_CONVERT_H */ diff --git a/libguile/convert.i.c b/libguile/convert.i.c new file mode 100644 index 000000000..118182943 --- /dev/null +++ b/libguile/convert.i.c @@ -0,0 +1,247 @@ +/* this file is #include'd (x times) by convert.c */ + +/* FIXME: Should we use exported wrappers for malloc (and free), which + * allow windows DLLs to call the correct freeing function? */ + + +/* Convert a vector, weak vector, (if possible string, substring), list + or uniform vector into an C array. If result array in argument 2 is + NULL, malloc() a new one. If out of memory, return NULL. */ +#define FUNC_NAME SCM2CTYPES_FN +CTYPE * +SCM2CTYPES (SCM obj, CTYPE *data) +{ + long i, n; + SCM val; + + SCM_ASSERT (SCM_NIMP (obj) || SCM_NFALSEP (scm_list_p (obj)), + obj, SCM_ARG1, FUNC_NAME); + + if (SCM_NFALSEP (scm_list_p (obj))) + { + SCM list = obj; + for (n = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), n++) + { + val = SCM_CAR (list); +#if defined (CTYPEMIN) && defined (CTYPEMAX) + if (SCM_INUMP (val)) + { + long v = SCM_INUM (val); + SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX); + } + else +#elif defined (FLOATTYPE1) + if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val))) +#else + if (!SCM_INUMP (val) && !SCM_BIGP (val)) +#endif + SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); + } + if (data == NULL) + data = (CTYPE *) malloc (n * sizeof (CTYPE)); + if (data == NULL) + return NULL; + + list = obj; + for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++) + { + val = SCM_CAR (list); + if (SCM_INUMP (val)) + data[i] = SCM_INUM (val); + else if (SCM_BIGP (val)) + data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME); +#ifdef FLOATTYPE1 + else + data[i] = (CTYPE) SCM_REAL_VALUE (val); +#endif + } + return data; + } + + switch (SCM_TYP7 (obj)) + { + case scm_tc7_vector: + case scm_tc7_wvect: + n = SCM_VECTOR_LENGTH (obj); + for (i = 0; i < n; i++) + { + val = SCM_VELTS (obj)[i]; + +#if defined (CTYPEMIN) && defined (CTYPEMAX) + if (SCM_INUMP (val)) + { + long v = SCM_INUM (val); + SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX); + } + else +#elif defined (FLOATTYPE1) + if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val))) +#else + if (!SCM_INUMP (val) && !SCM_BIGP (val)) +#endif + SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); + } + if (data == NULL) + data = (CTYPE *) malloc (n * sizeof (CTYPE)); + if (data == NULL) + return NULL; + for (i = 0; i < n; i++) + { + val = SCM_VELTS (obj)[i]; + if (SCM_INUMP (val)) + data[i] = (CTYPE) SCM_INUM (val); + else if (SCM_BIGP (val)) + data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME); +#ifdef FLOATTYPE1 + else + data[i] = (CTYPE) SCM_REAL_VALUE (val); +#endif + } + break; + +#ifdef HAVE_ARRAYS + case ARRAYTYPE1: +#ifdef ARRAYTYPE2 + case ARRAYTYPE2: +#endif + n = SCM_UVECTOR_LENGTH (obj); + if (data == NULL) + data = (CTYPE *) malloc (n * sizeof (CTYPE)); + if (data == NULL) + return NULL; +#ifdef FLOATTYPE2 + if (SCM_TYP7 (obj) == ARRAYTYPE2) + { + for (i = 0; i < n; i++) + data[i] = ((FLOATTYPE2 *) SCM_UVECTOR_BASE (obj))[i]; + } + else +#endif + memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE)); + break; +#endif /* HAVE_ARRAYS */ + +#ifdef STRINGTYPE + case scm_tc7_string: + n = SCM_STRING_LENGTH (obj); + if (data == NULL) + data = (CTYPE *) malloc (n * sizeof (CTYPE)); + if (data == NULL) + return NULL; + memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE)); + break; +#endif /* STRINGTYPE */ + + default: + SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); + } + return data; +} +#undef FUNC_NAME + + +#if HAVE_ARRAYS + +/* Converts a C array into a uniform vector, returns SCM_UNDEFINED if out + of memory. */ +#define FUNC_NAME CTYPES2UVECT_FN +SCM +CTYPES2UVECT (const CTYPE *data, long n) +{ + char *v; + + SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), + n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); + if ((v = (char *) SCM_MUST_MALLOC_TYPE_NUM (CTYPE, n)) == NULL) + return SCM_UNDEFINED; + memcpy (v, data, n * sizeof (CTYPE)); + return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v); +} +#undef FUNC_NAME + +#ifdef UVECTTYPE2 +#define FUNC_NAME CTYPES2UVECT_FN2 +SCM +CTYPES2UVECT2 (const unsigned CTYPE *data, long n) +{ + char *v; + + SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), + n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); + if ((v = (char *) SCM_MUST_MALLOC_TYPE_NUM (unsigned CTYPE, n)) == NULL) + return SCM_UNDEFINED; + memcpy (v, data, n * sizeof (unsigned CTYPE)); + return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE2), (scm_t_bits) v); +} +#undef FUNC_NAME +#endif /* UVECTTYPE2 */ + +#endif /* HAVE_ARRAYS */ + +/* Converts a C array into a vector. */ +#define FUNC_NAME CTYPES2SCM_FN +SCM +CTYPES2SCM (const CTYPE *data, long n) +{ + long i; + SCM v, *velts; + + SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), + n > 0 && n <= SCM_VECTOR_MAX_LENGTH); + v = scm_c_make_vector (n, SCM_UNSPECIFIED); + velts = SCM_VELTS (v); + for (i = 0; i < n; i++) +#ifdef FLOATTYPE1 + velts[i] = scm_make_real ((double) data[i]); +#elif defined (CTYPEFIXABLE) + velts[i] = SCM_MAKINUM (data[i]); +#else + velts[i] = (SCM_FIXABLE (data[i]) ? SCM_MAKINUM (data[i]) : + scm_i_long2big (data[i])); +#endif + return v; +} +#undef FUNC_NAME + +/* cleanup of conditionals */ +#undef SCM2CTYPES +#undef SCM2CTYPES_FN +#undef CTYPES2SCM +#undef CTYPES2SCM_FN +#undef CTYPE +#undef CTYPES2UVECT +#undef CTYPES2UVECT_FN +#ifdef CTYPEFIXABLE +#undef CTYPEFIXABLE +#endif +#undef UVECTTYPE +#ifdef UVECTTYPE2 +#undef CTYPES2UVECT2 +#undef CTYPES2UVECT_FN2 +#undef UVECTTYPE2 +#endif +#ifdef CTYPEMIN +#undef CTYPEMIN +#endif +#ifdef CTYPEMAX +#undef CTYPEMAX +#endif +#undef ARRAYTYPE1 +#ifdef ARRAYTYPE2 +#undef ARRAYTYPE2 +#endif +#ifdef FLOATTYPE1 +#undef FLOATTYPE1 +#endif +#ifdef FLOATTYPE2 +#undef FLOATTYPE2 +#endif +#ifdef STRINGTYPE +#undef STRINGTYPE +#endif + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ From 68dc153d7f7a86c6e7843dc1a776d73014c89ed2 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 31 Jan 2002 19:59:26 +0000 Subject: [PATCH 23/54] (scm_gensym): Use " g" as default prefix, not "g". This might help to make unintented clashes less likely. (scm_string_to_symbol): Protect the string until the symbols is created. --- libguile/symbols.c | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index c3e22c865..3661106ea 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -139,7 +139,6 @@ scm_mem2symbol (const char *name, size_t len) } } - SCM scm_str2symbol (const char *str) { @@ -216,9 +215,12 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_string_to_symbol { + SCM sym; SCM_VALIDATE_STRING (1, string); - return scm_mem2symbol (SCM_STRING_CHARS (string), - SCM_STRING_LENGTH (string)); + sym = scm_mem2symbol (SCM_STRING_CHARS (string), + SCM_STRING_LENGTH (string)); + scm_remember_upto_here_1 (string); + return sym; } #undef FUNC_NAME @@ -230,7 +232,7 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, (SCM prefix), "Create a new symbol with a name constructed from a prefix and\n" "a counter value. The string @var{prefix} can be specified as\n" - "an optional argument. Default prefix is @code{g}. The counter\n" + "an optional argument. Default prefix is @code{ g}. The counter\n" "is increased by 1 at each call. There is no provision for\n" "resetting the counter.") #define FUNC_NAME s_scm_gensym @@ -240,8 +242,9 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, size_t len; if (SCM_UNBNDP (prefix)) { - name[0] = 'g'; - len = 1; + name[0] = ' '; + name[1] = 'g'; + len = 2; } else { From 1b39c2e37f9a4def1f834ecb86d705d7e4bf2682 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Thu, 31 Jan 2002 19:59:39 +0000 Subject: [PATCH 24/54] *** empty log message *** --- libguile/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index e4bab308a..d07a00f85 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2002-01-31 Marius Vollmer + + * symbols.c (scm_gensym): Use " g" as default prefix, not "g". + This might help to make unintented clashes less likely. + (scm_string_to_symbol): Protect the string until the symbols is + created. + 2002-01-31 Stefan Jahn * convert.c, convert.h, convert.i.c: New files containing C From 329e4968208252819b2c854367ca0dbcd6bc7600 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Fri, 1 Feb 2002 16:47:00 +0000 Subject: [PATCH 25/54] * Unquote uses of `begin' in transformed Elisp code. --- lang/elisp/ChangeLog | 5 +++++ lang/elisp/primitives/syntax.scm | 2 +- lang/elisp/transform.scm | 2 +- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/lang/elisp/ChangeLog b/lang/elisp/ChangeLog index f1ed71dbb..461436daf 100644 --- a/lang/elisp/ChangeLog +++ b/lang/elisp/ChangeLog @@ -1,3 +1,8 @@ +2002-02-01 Neil Jerram + + * transform.scm (transformer), primitives/syntax.scm (let*): + Unquote uses of `begin' in transformed code. + 2002-01-29 Neil Jerram * transform.scm (transform-1, transform-2, transform-3, diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm index ac0951439..3bf5a903a 100644 --- a/lang/elisp/primitives/syntax.scm +++ b/lang/elisp/primitives/syntax.scm @@ -332,7 +332,7 @@ (procedure->memoizing-macro (lambda (exp env) (if (null? (cadr exp)) - `(begin ,@(map transformer (cddr exp))) + `(,begin ,@(map transformer (cddr exp))) (car (let loop ((bindings (cadr exp))) (if (null? bindings) (map transformer (cddr exp)) diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm index ec1639d6e..0bb28ea37 100644 --- a/lang/elisp/transform.scm +++ b/lang/elisp/transform.scm @@ -25,7 +25,7 @@ (case (car x) ((@fop @bind define-module use-modules use-syntax) x) ; Escape to Scheme syntax - ((scheme) (cons 'begin (cdr x))) + ((scheme) (cons begin (cdr x))) ; Should be handled in reader ((quote function) `(,quote ,@(cars->nil (cdr x)))) ((quasiquote) (m-quasiquote x '())) From 3dd84ef10c2161b8ad320726940d3ee428301ffb Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 3 Feb 2002 05:19:05 +0000 Subject: [PATCH 26/54] (HAVE_UINTPTR_T): Only define if UINTPTR_T attributes are defined: UINTPTR_MAX, INTPTR_MAX, INTPTR_MIN. --- libguile/__scm.h | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/libguile/__scm.h b/libguile/__scm.h index d9e26cada..986797c57 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -293,7 +293,11 @@ * - ... add more */ -#if SIZEOF_UINTPTR_T != 0 +#if SIZEOF_UINTPTR_T != 0 && defined(UINTPTR_MAX) \ + && defined(INTPTR_MAX) \ + && defined(INTPTR_MIN) +/* Used as SCM if available, so we bundle related attributes to avoid possible + type incon[st][oi]n[ae]nce later. Word in tags.h. */ #define HAVE_UINTPTR_T 1 #endif @@ -384,7 +388,7 @@ typedef long ptrdiff_t; /* James Clark came up with this neat one instruction fix for * continuations on the SPARC. It flushes the register windows so - * that all the state of the process is contained in the stack. + * that all the state of the process is contained in the stack. */ #ifdef sparc @@ -393,7 +397,7 @@ typedef long ptrdiff_t; # define SCM_FLUSH_REGISTER_WINDOWS /* empty */ #endif -/* If stack is not longword aligned then +/* If stack is not longword aligned then */ /* #define SHORT_ALIGN */ @@ -415,8 +419,8 @@ typedef long SCM_STACKITEM; #ifndef USE_THREADS -#define SCM_CRITICAL_SECTION_START -#define SCM_CRITICAL_SECTION_END +#define SCM_CRITICAL_SECTION_START +#define SCM_CRITICAL_SECTION_END #define SCM_THREAD_SWITCHING_CODE #endif @@ -573,7 +577,7 @@ do { \ /** SCM_ASSERT - ** + ** **/ @@ -659,7 +663,7 @@ SCM_API SCM scm_apply_generic (SCM gf, SCM args); #define SCM_ARG4 4 #define SCM_ARG5 5 #define SCM_ARG6 6 -#define SCM_ARG7 7 +#define SCM_ARG7 7 #endif /* SCM_MAGIC_SNARFER */ From 34472dfe987302b9835d7e2f28d7bb2a6a9e421b Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 3 Feb 2002 05:20:21 +0000 Subject: [PATCH 27/54] *** empty log message *** --- libguile/ChangeLog | 45 +++++++++++++++++++++++++-------------------- 1 file changed, 25 insertions(+), 20 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d07a00f85..20c4e48da 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2002-02-02 Thien-Thi Nguyen + + * __scm.h (HAVE_UINTPTR_T): Only define if UINTPTR_T attributes + are defined: UINTPTR_MAX, INTPTR_MAX, INTPTR_MIN. + 2002-01-31 Marius Vollmer * symbols.c (scm_gensym): Use " g" as default prefix, not "g". @@ -8,7 +13,7 @@ 2002-01-31 Stefan Jahn * convert.c, convert.h, convert.i.c: New files containing C - array to Scheme conversion helpers meant to be replacement + array to Scheme conversion helpers meant to be replacement functions for the deprecated gh interface. * Makefile.am: Setup rules for new `convert.*' files. @@ -18,21 +23,21 @@ * symbols.c (scm_c_symbol2str): New function, replacement for `gh_scm2newsymbol()'. - * strings.c (scm_c_substring2str): New function. Proper + * strings.c (scm_c_substring2str): New function. Proper replacement for `gh_get_substr()'. * socket.c: Include `stdint.h' if available for the `uint32_t' declaration. - * scmsigs.c (s_scm_sigaction): Initialize `chandler' (inhibits + * scmsigs.c (s_scm_sigaction): Initialize `chandler' (inhibits compiler warning). * backtrace.c: Include `lang.h' for GUILE_DEBUG conditional. 2002-01-22 Neil Jerram - + Other changes unrelated to Elisp... - + * eval.c (scm_m_if): Use s_if rather than repeating string literal "if". (comments): Fix a few typos. @@ -60,7 +65,7 @@ * eval.c, eval.h, init.c, lang.c, lang.h: Use SCM_ENABLE_ELISP to conditionalize compilation and initialization of Elisp support function. - + * alist.c (scm_assq, scm_assv, scm_assoc), async.c (scm_asyncs_pending, scm_run_asyncs, noop), backtrace.c (scm_set_print_params_x), dynl.c (scm_make_argv_from_stringlist), @@ -76,7 +81,7 @@ * boolean.c (scm_not): Use `SCM_FALSEP || SCM_NILP' instead of just SCM_FALSEP. - + * boolean.c (scm_boolean_p): Use `SCM_BOOLP || SCM_NILP' instead of just SCM_BOOLP. @@ -123,7 +128,7 @@ (SCM_ELISP_NIL): New IFLAG. * validate.h (SCM_VALIDATE_NULL_OR_NIL): New. - + 2002-01-10 Dirk Herrmann * eval.c: Removed outdated references to "everr". Improved some @@ -179,7 +184,7 @@ 2001-12-08 Stefan Jahn * strings.c (scm_c_string2str): New function. Converts a - given Scheme string into a C string. Also put in two + given Scheme string into a C string. Also put in two THINKME's regarding the malloc policy for the missing converter routines. @@ -206,7 +211,7 @@ 2001-11-25 Marius Vollmer * vectors.h (SCM_MAKE_VECTOR_TAG): New. - * unif.h (SCM_MAKE_BITVECTOR_TAG, SCM_MAKE_UVECTOR_TAG): New. + * unif.h (SCM_MAKE_BITVECTOR_TAG, SCM_MAKE_UVECTOR_TAG): New. * symbols.h (SCM_MAKE_SYMBOL_TAG): New. * strings.h (SCM_MAKE_STRING_TAG): New. * procs.h (SCM_MAKE_CCLO_TAG): New. @@ -226,7 +231,7 @@ Deprecated SCM_NEWCELL and SCM_NEWCELL2. Added scm_alloc_cell and scm_alloc_double_cell in their place. - + * gc.h (SCM_GC_SET_ALLOCATED, scm_debug_newcell, scm_debug_newcell2, scm_tc16_allocated): Removed from header. (scm_deprecated_newcell, scm_deprecated_newcell2): New. @@ -240,11 +245,11 @@ (scm_init_gc): Do it here. (allocated_mark): New, from old code. (scm_deprecated_newcell, scm_deprecated_newcell2): New. - - * inline.c, inline.h: New files. - * Makefile.am: Added them in all the right places. - * _scm.h: Include "libguile/inline.h". + * inline.c, inline.h: New files. + * Makefile.am: Added them in all the right places. + + * _scm.h: Include "libguile/inline.h". * alist.c, coop-threads.c, debug.c, environments.c, eval.c, fports.c, gh_data.c, goops.c, guardians.c, lang.c, list.c, @@ -278,19 +283,19 @@ * Makefile.am (install-exec-hook): Prepend $(DESTDIR) to filename. Thanks to Eric Gillespie, Jr! - + 2001-11-21 Stefan Jahn - * win32-socket.c (getservent, setservent, endservent, - getprotoent, setprotoent, endprotoent): New functions. + * win32-socket.c (getservent, setservent, endservent, + getprotoent, setprotoent, endprotoent): New functions. Appropriate replacements for M$-Windows. * numbers.c (SIZE_MAX, PTRDIFF_MAX, PTRDIFF_MIN): Reintroduced these definitions for GUILE_DEBUG. * net_db.c: Include "win32-socket.h" if compiling with a native - M$-Windows compiler. Include some pieces of code (protoent and - servent interface) protected by HAVE_* macros when using a + M$-Windows compiler. Include some pieces of code (protoent and + servent interface) protected by HAVE_* macros when using a native M$-Windows compiler. 2001-11-20 Marius Vollmer From b0c6d4040eaf900b3037ed9cb13b0aae51f6879a Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 3 Feb 2002 07:08:50 +0000 Subject: [PATCH 28/54] Initial revision --- devel/build/README | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 devel/build/README diff --git a/devel/build/README b/devel/build/README new file mode 100644 index 000000000..e69de29bb From e3f394f39164d1b8f84b4b3187cde04e968aea13 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sun, 3 Feb 2002 07:12:58 +0000 Subject: [PATCH 29/54] Add instructions. Remove version control tag. --- devel/build/guile-projects-entry | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/devel/build/guile-projects-entry b/devel/build/guile-projects-entry index 7559b24d3..e69de29bb 100644 --- a/devel/build/guile-projects-entry +++ b/devel/build/guile-projects-entry @@ -1,15 +0,0 @@ -;;; $Date: 2001-11-15 21:11:25 $ -((name "guile") - (category "Core") - (keywords "Extension Language " "Scheme " "Interpreter") - (description "GNU Ubiquitous Intelligent Language for Extension") - (location (url "http://www.gnu.org/software/guile/guile.html" - "Guile Homepage")) - (mailing-list (url "http://www.gnu.org/software/guile/mail/mail.html" - "guile-user, guile-devel, etc.")) - (status "version 1.5.4 " - (url "ftp://alpha.gnu.org/gnu/guile/" - "(beta)") - " released 2001-09-28") - (license "GPL, with an exception to allow non-GPL'd programs to " - "link to the library without becoming derivitive works.")) From ac48757b5ed4efeb2b7018c8e08ea26cab8a5418 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Feb 2002 22:49:06 +0000 Subject: [PATCH 30/54] * symbols.h (SCM_SET_SYMBOL_HASH): Removed. (SCM_SYMBOL_INTERNED_P): New. * symbols.c (scm_symbol_hash): Use scm_ulong2num instead of SCM_MAKINUM since hash values can well be bignums. (scm_mem2symbol): Only use hash values below SCM_T_BITS_MAX/2. This signals a interned symbol. (scm_mem2uninterned_symbol, scm_symbol_interned_p, scm_make_symbol): New. --- libguile/symbols.c | 44 ++++++++++++++++++++++++++++++++++++++++++-- libguile/symbols.h | 6 +++++- 2 files changed, 47 insertions(+), 3 deletions(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index 3661106ea..b2f89b9e1 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -87,7 +87,7 @@ SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0, SCM scm_mem2symbol (const char *name, size_t len) { - size_t raw_hash = scm_string_hash ((const unsigned char *) name, len); + size_t raw_hash = scm_string_hash ((const unsigned char *) name, len)/2; size_t hash = raw_hash % SCM_VECTOR_LENGTH (symbols); { @@ -139,6 +139,19 @@ scm_mem2symbol (const char *name, size_t len) } } +SCM +scm_mem2uninterned_symbol (const char *name, size_t len) +{ + size_t raw_hash = (scm_string_hash ((const unsigned char *) name, len)/2 + + SCM_T_BITS_MAX/2 + 1); + + return scm_alloc_double_cell (SCM_MAKE_SYMBOL_TAG (len), + (scm_t_bits) scm_must_strndup (name, len), + raw_hash, + SCM_UNPACK (scm_cons (SCM_BOOL_F, + SCM_EOL))); +} + SCM scm_str2symbol (const char *str) { @@ -155,6 +168,33 @@ SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 1, 0, 0, + (SCM symbol), + "Return @code{#t} if @var{symbol} is interned, otherwise return\n" + "@code{#f}.") +#define FUNC_NAME s_scm_symbol_interned_p +{ + SCM_VALIDATE_SYMBOL (1, symbol); + return SCM_BOOL (SCM_SYMBOL_INTERNED_P (symbol)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0, + (SCM name), + "Return a new uninterned symbol with the name @var{name}. " + "The returned symbol is guaranteed to be unique and future " + "calls to @code{string->symnbol} will not return it.") +#define FUNC_NAME s_scm_make_symbol +{ + SCM sym; + SCM_VALIDATE_STRING (1, name); + sym = scm_mem2uninterned_symbol (SCM_STRING_CHARS (name), + SCM_STRING_LENGTH (name)); + scm_remember_upto_here_1 (name); + return sym; +} +#undef FUNC_NAME + SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0, (SCM s), "Return the name of @var{symbol} as a string. If the symbol was\n" @@ -270,7 +310,7 @@ SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0, #define FUNC_NAME s_scm_symbol_hash { SCM_VALIDATE_SYMBOL (1, symbol); - return SCM_MAKINUM (SCM_SYMBOL_HASH (symbol)); + return scm_ulong2num (SCM_SYMBOL_HASH (symbol)); } #undef FUNC_NAME diff --git a/libguile/symbols.h b/libguile/symbols.h index e4c624801..771d9ecab 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -51,6 +51,10 @@ /* SCM_SYMBOL_LENGTH(SYM) is the length of SYM's name in characters, and * SCM_SYMBOL_CHARS(SYM) is the address of the first character of SYM's name. + * + * SCM_SYMBOL_HASH is a hash value for the symbol. It is also used to + * encode whether the symbol is interned or not. See + * SCM_SYMBOL_INTERNED_P. */ #define SCM_SYMBOLP(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_symbol)) @@ -60,7 +64,7 @@ #define SCM_SYMBOL_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) #define SCM_SET_SYMBOL_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) #define SCM_SYMBOL_HASH(X) ((unsigned long) SCM_CELL_WORD_2 (X)) -#define SCM_SET_SYMBOL_HASH(X, v) (SCM_SET_CELL_WORD_2 ((X), (v))) +#define SCM_SYMBOL_INTERNED_P(X) (SCM_SYMBOL_HASH(X) <= (SCM_T_BITS_MAX/2)) #define SCM_PROP_SLOTS(X) (SCM_CELL_OBJECT_3 (X)) #define SCM_SET_PROP_SLOTS(X, v) (SCM_SET_CELL_OBJECT_3 ((X), (v))) From 9ff28a13e089fcd3706be7ba2edde98051e2df07 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Feb 2002 22:50:07 +0000 Subject: [PATCH 31/54] (scm_iprin1): Print uninterned symbols unreadably. --- libguile/print.c | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index e28284637..d972c3d4e 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -527,10 +527,23 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_lfwrite (SCM_STRING_CHARS (exp), SCM_STRING_LENGTH (exp), port); break; case scm_tc7_symbol: - scm_print_symbol_name (SCM_SYMBOL_CHARS (exp), - SCM_SYMBOL_LENGTH (exp), - port); - scm_remember_upto_here_1 (exp); + if (SCM_SYMBOL_INTERNED_P (exp)) + { + scm_print_symbol_name (SCM_SYMBOL_CHARS (exp), + SCM_SYMBOL_LENGTH (exp), + port); + scm_remember_upto_here_1 (exp); + } + else + { + scm_puts ("#', port); + } break; case scm_tc7_variable: scm_i_variable_print (exp, port, pstate); From 319b98ed9cd0b75d94775b9f0c0948a4fe6305c8 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Sun, 3 Feb 2002 22:50:18 +0000 Subject: [PATCH 32/54] *** empty log message *** --- libguile/ChangeLog | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 20c4e48da..74754eab9 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +2002-02-03 Marius Vollmer + + * symbols.h (SCM_SET_SYMBOL_HASH): Removed. + (SCM_SYMBOL_INTERNED_P): New. + * symbols.c (scm_symbol_hash): Use scm_ulong2num instead of + SCM_MAKINUM since hash values can well be bignums. + (scm_mem2symbol): Only use hash values below SCM_T_BITS_MAX/2. + This signals a interned symbol. + (scm_mem2uninterned_symbol, scm_symbol_interned_p, + scm_make_symbol): New. + + * print.c (scm_iprin1): Print uninterned symbols unreadably. + 2002-02-02 Thien-Thi Nguyen * __scm.h (HAVE_UINTPTR_T): Only define if UINTPTR_T attributes @@ -6,7 +19,7 @@ 2002-01-31 Marius Vollmer * symbols.c (scm_gensym): Use " g" as default prefix, not "g". - This might help to make unintented clashes less likely. + This might help to make unintended clashes less likely. (scm_string_to_symbol): Protect the string until the symbols is created. From a63cdd615010461c4d180149d5f9160a38c59c25 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Feb 2002 16:47:23 +0000 Subject: [PATCH 33/54] (scm_mem2uninterned_symbol, scm_symbol_interned_p, scm_make_symbol): New prototypes. --- libguile/symbols.h | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/symbols.h b/libguile/symbols.h index 771d9ecab..22dc5cc25 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -79,9 +79,12 @@ SCM_API SCM scm_sys_symbols (void); #endif SCM_API SCM scm_mem2symbol (const char*, size_t); +SCM_API SCM scm_mem2uninterned_symbol (const char *name, size_t len); SCM_API SCM scm_str2symbol (const char*); SCM_API SCM scm_symbol_p (SCM x); +SCM_API SCM scm_symbol_interned_p (SCM sym); +SCM_API SCM scm_make_symbol (SCM name); SCM_API SCM scm_symbol_to_string (SCM s); SCM_API SCM scm_string_to_symbol (SCM s); From d58d5bfc1cb55d2c21954369eb67e7c965ce49cd Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Feb 2002 16:47:35 +0000 Subject: [PATCH 34/54] (scm_make_symbol): Fix typo in docstring. --- libguile/symbols.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/symbols.c b/libguile/symbols.c index b2f89b9e1..106b18fce 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -183,7 +183,7 @@ SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0, (SCM name), "Return a new uninterned symbol with the name @var{name}. " "The returned symbol is guaranteed to be unique and future " - "calls to @code{string->symnbol} will not return it.") + "calls to @code{string->symbol} will not return it.") #define FUNC_NAME s_scm_make_symbol { SCM sym; From 3933a7860db8e375d35d769559e919e1e2b00a4d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Feb 2002 16:48:28 +0000 Subject: [PATCH 35/54] (Symbol Uninterned): Added node. --- doc/ref/scheme-data.texi | 87 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 87 insertions(+) diff --git a/doc/ref/scheme-data.texi b/doc/ref/scheme-data.texi index 9dbced157..0aeb7de6c 100755 --- a/doc/ref/scheme-data.texi +++ b/doc/ref/scheme-data.texi @@ -2211,6 +2211,7 @@ objects @i{per se}. * Symbol Primitives:: Operations related to symbols. * Symbol Discrete:: Using symbols as discrete values. * Symbol Props:: Function slots and property lists. +* Symbol Uninterned:: Uninterned symbols. @end menu @@ -2390,6 +2391,92 @@ Return the @dfn{property list} currently associated with @var{symbol}. Change the binding of @var{symbol}'s property slot. @end deffn +@node Symbol Uninterned +@subsection Uninterned Symbols + +What makes symbols useful is that they are automatically kept unique. +There are no two symbols that are distinct objects but have the same +name. But of course, there is no rule without exception. In addition +to the normal symbols that have been discussed upto now, you can also +create special @dfn{uninterned} symbols that behave slightly +differently. + +To understand what is different about them and why they might be useful, +we look at how normal symbols are actually kept unique. + +Whenever Guile wants to find the symbol with a specific name, for +example during @code{read} or when executing @code{string->symbol}, it +first looks into a table of all existing symbols to find out whether a +symbol with the given name already exists. When this is the case, Guile +just returns that symbol. When not, a new symbol with the name is +created and entered into the table so that it can be found later. + +Sometimes you might want to create a symbol that is guaranteed `fresh', +i.e., a symbol that did not exist previously. You might also want to +somehow guarantee that no one else will ever unintentionally stumble +across your symbol in the future. These properties of a symbol are +often needed when generating code during macro expansion. When +introducing new temporary variables, you want to guarantee that they +don't conflict with variables in other peoples code. + +The simplest way to arrange for this is to create a new symbol and to +not enter it into the global table of all symbols. That way, no one +will ever get access to your symbol by chance. Symbols that are not in +the table are called @dfn{uninterned}. Of course, symbols that +@emph{are} in the table are called @dfn{interned}. + +You create new uninterned symbols with the function @code{make-symbol}. +You can test whether a symbol is interned or not with +@code{symbol-interned?}. + +Uninterned symbols break the rule that the name of a symbol uniquely +identifies the symbol object. Because of this, they can not be written +out and read back in like interned symbols. Currently, Guile has no +support for reading uninterned symbols. Note that the function +@code{gensym} does not return uninterned symbols for this reason. + +@deffn {Scheme Procedure} make-symbol name +@deffnx {C Function} scm_make_symbol (name) +Return a new uninterned symbol with the name @var{name}. The returned +symbol is guaranteed to be unique and future calls to +@code{string->symbol} will not return it. +@end deffn + +@deffn {Scheme Procedure} symbol-interned? symbol +@deffnx {C Function} scm_symbol_interned_p (symbol) +Return @code{#t} if @var{symbol} is interned, otherwise return +@code{#f}. +@end deffn + +For example: + +@lisp +(define foo-1 (string->symbol "foo")) +(define foo-2 (string->symbol "foo")) +(define foo-3 (make-symbol "foo")) +(define foo-4 (make-symbol "foo")) + +(eq? foo-1 foo-2) +@result{#t} ; Two interned symbols with the same name are the same object, + +(eq? foo-1 foo-3) +@result{#f} ; but a call to make-symbol with the same name returns a + ; distinct object. + +(eq? foo-3 foo-4) +@result{#f} ; A call to make-symbol always returns a new object, even for + ; the same name. + +foo-3 +@result{#} + ; Uninterned symbols print different from interned symbols, +(symbol? foo-3) +@result{#t} ; but they are still symbols. + +(symbol-interned? foo-3) +@result{#f} ; Just not interned. + +@end lisp @node Keywords @section Keywords From 402e687cc9d1db7c2b9c277e9b3103258f06171c Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Feb 2002 16:48:36 +0000 Subject: [PATCH 36/54] *** empty log message *** --- doc/ref/ChangeLog | 4 ++++ libguile/ChangeLog | 7 +++++++ 2 files changed, 11 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index b0f5e2c67..58737d89e 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,7 @@ +2002-02-04 Marius Vollmer + + * scheme-data.texi (Symbol Uninterned): Added node. + 2002-01-29 Stefan Jahn * gh.texi (scm transition summary): Documented gh equivalents diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 74754eab9..1fc2f2169 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2002-02-04 Marius Vollmer + + * symbols.c (scm_make_symbol): Fix typo in docstring. + + * symbols.h (scm_mem2uninterned_symbol, scm_symbol_interned_p, + scm_make_symbol): New prototypes. + 2002-02-03 Marius Vollmer * symbols.h (SCM_SET_SYMBOL_HASH): Removed. From a284e7081e9219f0a316e9bf9ec379a56401dbbb Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 4 Feb 2002 19:20:00 +0000 Subject: [PATCH 37/54] (Autofrisk, Using Autofrisk): New sections. (Autoconf Support): Add new sections to menu. --- doc/ref/autoconf.texi | 112 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 111 insertions(+), 1 deletion(-) diff --git a/doc/ref/autoconf.texi b/doc/ref/autoconf.texi index 37f1a24ab..301dc440f 100644 --- a/doc/ref/autoconf.texi +++ b/doc/ref/autoconf.texi @@ -4,12 +4,15 @@ When Guile is installed, a set of autoconf macros is also installed as PREFIX/share/aclocal/guile.m4. This chapter documents the macros provided in -that file. @xref{Top,The GNU Autoconf Manual,,autoconf}, for more info. +that file, as well as the high-level guile-tool Autofrisk. @xref{Top,The GNU +Autoconf Manual,,autoconf}, for more info. @menu * Autoconf Background:: Why use autoconf? * Autoconf Macros:: The GUILE_* macros. * Using Autoconf Macros:: How to use them, plus examples. +* Autofrisk:: AUTOFRISK_CHECKS and AUTOFRISK_SUMMARY. +* Using Autofrisk:: Example modules.af files. @end menu @@ -120,4 +123,111 @@ In Makefile.in: $(INSTALL) my/*.scm $(instdir) @end example + +@node Autofrisk +@section Autofrisk + +The @dfn{guile-tools autofrisk} command looks for the file @file{modules.af} +in the current directory and writes out @file{modules.af.m4} containing +autoconf definitions for @code{AUTOFRISK_CHECKS} and @code{AUTOFRISK_SUMMARY}. +@xref{Autoconf Background}, and @xref{Using Autoconf Macros}, for more info. + +The modules.af file consists of a series of configuration forms (Scheme +lists), which have one of the following formats: + +@example + (files-glob PATTERN ...) ;; required + (non-critical-external MODULE ...) ;; optional + (non-critical-internal MODULE ...) ;; optional + (programs (MODULE PROG ...) ...) ;; optional + (pww-varname VARNAME) ;; optional +@end example + +@var{pattern} is a string that may contain "*" and "?" characters to be +expanded into filenames. @var{module} is a list of symbols naming a module, +such as `(srfi srfi-1)'. @var{varname} is a shell-safe name to use instead of +@code{probably_wont_work}, the default. This var is passed to `AC_SUBST'. +@var{prog} is a string that names a program, such as "gpg". + +Autofrisk expands the @code{files-glob} pattern(s) into a list of files, scans +each file's module definition form(s), and constructs a module dependency +graph wherein modules defined by @code{define-module} are considered +@dfn{internal} and the remaining, @dfn{external}. For each external module +that has an internal dependency, Autofrisk emits a +@code{GUILE_MODULE_REQUIRED} check (@pxref{Autoconf Macros}), which altogether +form the body of @code{AUTOFRISK_CHECKS}. + +@code{GUILE_MODULE_REQUIRED} causes the @file{configure} script to exit with +an error message if the specified module is not available; it enforces a +strong dependency. You can temper dependency strength by using the +@code{non-critical-external} and @code{non-critical-internal} configuration +forms in modules.af. For graph edges that touch such non-critical modules, +Autofrisk uses @code{GUILE_MODULE_AVAILABLE}, and arranges for +@code{AUTOFRISK_SUMMARY} to display a warning if they are not found. + +The shell code resulting from the expansion of @code{AUTOFRISK_CHECKS} and +@code{AUTOFRISK_SUMMARY} uses the shell variable @code{probably_wont_work} to +collect the names of unfound non-critical modules. If this bothers you, use +configuration form @code{(pww-name foo)} in modules.af. + +Although Autofrisk does not detect when a module uses a program (for example, +in a @code{system} call), it can generate @code{AC_PATH_PROG} forms anyway if +you use the @code{programs} configuration form in modules.af. These are +collected into @code{AUTOCONF_CHECKS}. + +@xref{Using Autofrisk}, for some modules.af examples. + + +@node Using Autofrisk +@section Using Autofrisk + +Using Autofrisk (@pxref{Autofrisk}) involves writing @file{modules.af} and +adding two macro calls to @file{configure.in}. Here is an example of the +latter: + +@example +AUTOFRISK_CHECKS +AUTOFRISK_SUMMARY +@end example + +Here is an adaptation of the second "GUILE_*" example (@pxref{Using Autoconf +Macros}) that does basically the same thing. + +@example +(files-glob "my/*.scm") +(non-critical-external (database postgres)) +(programs ((my gpgutils) "gpg")) ;; (my gpgutils) uses "gpg" +@end example + +If the SRFI modules (@pxref{SRFI Support}) were a separate package, we could +use @code{guile-tools frisk} to find out its dependencies: + +@example +$ guile-tools frisk srfi/*.scm +13 files, 18 modules (13 internal, 5 external), 9 edges + +x (ice-9 and-let-star) + regular (srfi srfi-2) +x (ice-9 syncase) + regular (srfi srfi-11) +x (ice-9 rdelim) + regular (srfi srfi-10) +x (ice-9 receive) + regular (srfi srfi-8) + regular (srfi srfi-1) +x (ice-9 session) + regular (srfi srfi-1) +@end example + +Then, we could use the following modules.af to help configure it: + +@example +(files-glob "srfi/*.scm") +(non-critical-external ;; relatively recent + (ice-9 rdelim) + (ice-9 receive) + (ice-9 and-let-star)) +(pww-varname not_fully_supported) +@end example + @c autoconf.texi ends here From 7c5c279671e81bb99d3f8ac195a2426254853541 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Mon, 4 Feb 2002 19:21:37 +0000 Subject: [PATCH 38/54] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 58737d89e..0d50fade9 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2002-02-04 Thien-Thi Nguyen + + * autoconf.texi (Autofrisk, Using Autofrisk): New sections. + (Autoconf Support): Add new sections to menu. + 2002-02-04 Marius Vollmer * scheme-data.texi (Symbol Uninterned): Added node. From 877accb11a14f88d5bda60629aa40ae4283ce01a Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Mon, 4 Feb 2002 21:13:46 +0000 Subject: [PATCH 39/54] * Further Elisp translator work. --- lang/elisp/ChangeLog | 21 ++++++ lang/elisp/internals/Makefile.am | 1 + lang/elisp/internals/fset.scm | 6 +- lang/elisp/internals/lambda.scm | 108 ++++++++++++++++++++++++++++++ lang/elisp/primitives/syntax.scm | 110 ++----------------------------- lang/elisp/transform.scm | 4 +- 6 files changed, 140 insertions(+), 110 deletions(-) create mode 100644 lang/elisp/internals/lambda.scm diff --git a/lang/elisp/ChangeLog b/lang/elisp/ChangeLog index 461436daf..d20d6e355 100644 --- a/lang/elisp/ChangeLog +++ b/lang/elisp/ChangeLog @@ -1,3 +1,24 @@ +2002-02-04 Neil Jerram + + * primitives/syntax.scm (parse-formals, transform-lambda, + interactive-spec, set-not-subr!, transform-lambda/interactive): + Move into internals/lambda.scm so that these can also be used + by... + + * internals/fset.scm (elisp-apply): Use `eval' and + `transform-lambda/interactive' to turn a quoted lambda expression + into a Scheme procedure. + + * transform.scm (m-quasiquote): Don't quote `quasiquote' in + transformed code. + (transformer): Transform '() to #nil. + +2002-02-03 Neil Jerram + + * internals/Makefile.am (elisp_sources): Add lambda.scm. + + * internals/lambda.scm (lang): New file. + 2002-02-01 Neil Jerram * transform.scm (transformer), primitives/syntax.scm (let*): diff --git a/lang/elisp/internals/Makefile.am b/lang/elisp/internals/Makefile.am index 49226038b..c66edb491 100644 --- a/lang/elisp/internals/Makefile.am +++ b/lang/elisp/internals/Makefile.am @@ -27,6 +27,7 @@ elisp_sources = \ evaluation.scm \ format.scm \ fset.scm \ + lambda.scm \ load.scm \ null.scm \ set.scm \ diff --git a/lang/elisp/internals/fset.scm b/lang/elisp/internals/fset.scm index 885c9e897..249db7c91 100644 --- a/lang/elisp/internals/fset.scm +++ b/lang/elisp/internals/fset.scm @@ -1,6 +1,7 @@ (define-module (lang elisp internals fset) - #:use-module (lang elisp internals signal) #:use-module (lang elisp internals evaluation) + #:use-module (lang elisp internals lambda) + #:use-module (lang elisp internals signal) #:export (fset fref fref/error-if-void @@ -105,7 +106,8 @@ function) ((and (pair? function) (eq? (car function) 'lambda)) - (eval function the-elisp-module)) + (eval (transform-lambda/interactive function ') + the-root-module)) (else (signal 'invalid-function (list function)))) args)) diff --git a/lang/elisp/internals/lambda.scm b/lang/elisp/internals/lambda.scm new file mode 100644 index 000000000..96b21f650 --- /dev/null +++ b/lang/elisp/internals/lambda.scm @@ -0,0 +1,108 @@ +(define-module (lang elisp internals lambda) + #:use-module (lang elisp internals fset) + #:use-module (lang elisp transform) + #:export (parse-formals + transform-lambda/interactive + interactive-spec)) + +;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and +;;; returns three values: (i) list of symbols for required arguments, +;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or +;;; #f if there is no rest argument. +(define (parse-formals formals) + (letrec ((do-required + (lambda (required formals) + (if (null? formals) + (values (reverse required) '() #f) + (let ((next-sym (car formals))) + (cond ((not (symbol? next-sym)) + (error "Bad formals (non-symbol in required list)")) + ((eq? next-sym '&optional) + (do-optional required '() (cdr formals))) + ((eq? next-sym '&rest) + (do-rest required '() (cdr formals))) + (else + (do-required (cons next-sym required) + (cdr formals)))))))) + (do-optional + (lambda (required optional formals) + (if (null? formals) + (values (reverse required) (reverse optional) #f) + (let ((next-sym (car formals))) + (cond ((not (symbol? next-sym)) + (error "Bad formals (non-symbol in optional list)")) + ((eq? next-sym '&rest) + (do-rest required optional (cdr formals))) + (else + (do-optional required + (cons next-sym optional) + (cdr formals)))))))) + (do-rest + (lambda (required optional formals) + (if (= (length formals) 1) + (let ((next-sym (car formals))) + (if (symbol? next-sym) + (values (reverse required) (reverse optional) next-sym) + (error "Bad formals (non-symbol rest formal)"))) + (error "Bad formals (more than one rest formal)"))))) + + (do-required '() (cond ((list? formals) + formals) + ((symbol? formals) + (list '&rest formals)) + (else + (error "Bad formals (not a list or a single symbol)")))))) + +(define (transform-lambda exp) + (call-with-values (lambda () (parse-formals (cadr exp))) + (lambda (required optional rest) + (let ((num-required (length required)) + (num-optional (length optional))) + `(,lambda %--args + (,let ((%--num-args (,length %--args))) + (,cond ((,< %--num-args ,num-required) + (,error "Wrong number of args (not enough required args)")) + ,@(if rest + '() + `(((,> %--num-args ,(+ num-required num-optional)) + (,error "Wrong number of args (too many args)")))) + (else + (@bind ,(append (map (lambda (i) + (list (list-ref required i) + `(,list-ref %--args ,i))) + (iota num-required)) + (map (lambda (i) + (let ((i+nr (+ i num-required))) + (list (list-ref optional i) + `(,if (,> %--num-args ,i+nr) + (,list-ref %--args ,i+nr) + #f)))) + (iota num-optional)) + (if rest + (list (list rest + `(,if (,> %--num-args + ,(+ num-required + num-optional)) + (,list-tail %--args + ,(+ num-required + num-optional)) + '()))) + '())) + ,@(map transformer (cddr exp))))))))))) + +(define (set-not-subr! proc boolean) + (set! (not-subr? proc) boolean)) + +(define (transform-lambda/interactive exp name) + (fluid-set! interactive-spec #f) + (let* ((x (transform-lambda exp)) + (is (fluid-ref interactive-spec))) + `(,let ((%--lambda ,x)) + (,set-procedure-property! %--lambda (,quote name) (,quote ,name)) + (,set-not-subr! %--lambda #t) + ,@(if is + `((,set! (,interactive-spec %--lambda) (,quote ,is))) + '()) + %--lambda))) + +(define interactive-spec (make-fluid)) diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm index 3bf5a903a..7f7e4af21 100644 --- a/lang/elisp/primitives/syntax.scm +++ b/lang/elisp/primitives/syntax.scm @@ -1,13 +1,13 @@ (define-module (lang elisp primitives syntax) #:use-module (lang elisp internals evaluation) #:use-module (lang elisp internals fset) + #:use-module (lang elisp internals lambda) #:use-module (lang elisp internals trace) #:use-module (lang elisp transform)) -;;; Define Emacs Lisp special forms as macros. This is much more -;;; flexible than handling them specially in the translator: allows -;;; them to be redefined, and hopefully allows better source location -;;; tracking. +;;; Define Emacs Lisp special forms as macros. This is more flexible +;;; than handling them specially in the translator: allows them to be +;;; redefined, and hopefully allows better source location tracking. ;;; {Variables} @@ -44,108 +44,6 @@ ;;; {lambda, function and macro definitions} -;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and -;;; returns three values: (i) list of symbols for required arguments, -;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or -;;; #f if there is no rest argument. -(define (parse-formals formals) - (letrec ((do-required - (lambda (required formals) - (if (null? formals) - (values (reverse required) '() #f) - (let ((next-sym (car formals))) - (cond ((not (symbol? next-sym)) - (error "Bad formals (non-symbol in required list)")) - ((eq? next-sym '&optional) - (do-optional required '() (cdr formals))) - ((eq? next-sym '&rest) - (do-rest required '() (cdr formals))) - (else - (do-required (cons next-sym required) - (cdr formals)))))))) - (do-optional - (lambda (required optional formals) - (if (null? formals) - (values (reverse required) (reverse optional) #f) - (let ((next-sym (car formals))) - (cond ((not (symbol? next-sym)) - (error "Bad formals (non-symbol in optional list)")) - ((eq? next-sym '&rest) - (do-rest required optional (cdr formals))) - (else - (do-optional required - (cons next-sym optional) - (cdr formals)))))))) - (do-rest - (lambda (required optional formals) - (if (= (length formals) 1) - (let ((next-sym (car formals))) - (if (symbol? next-sym) - (values (reverse required) (reverse optional) next-sym) - (error "Bad formals (non-symbol rest formal)"))) - (error "Bad formals (more than one rest formal)"))))) - - (do-required '() (cond ((list? formals) - formals) - ((symbol? formals) - (list '&rest formals)) - (else - (error "Bad formals (not a list or a single symbol)")))))) - -(define (transform-lambda exp) - (call-with-values (lambda () (parse-formals (cadr exp))) - (lambda (required optional rest) - (let ((num-required (length required)) - (num-optional (length optional))) - `(,lambda %--args - (,let ((%--num-args (,length %--args))) - (,cond ((,< %--num-args ,num-required) - (,error "Wrong number of args (not enough required args)")) - ,@(if rest - '() - `(((,> %--num-args ,(+ num-required num-optional)) - (,error "Wrong number of args (too many args)")))) - (else - (@bind ,(append (map (lambda (i) - (list (list-ref required i) - `(,list-ref %--args ,i))) - (iota num-required)) - (map (lambda (i) - (let ((i+nr (+ i num-required))) - (list (list-ref optional i) - `(,if (,> %--num-args ,i+nr) - (,list-ref %--args ,i+nr) - #f)))) - (iota num-optional)) - (if rest - (list (list rest - `(,if (,> %--num-args - ,(+ num-required - num-optional)) - (,list-tail %--args - ,(+ num-required - num-optional)) - '()))) - '())) - ,@(map transformer (cddr exp))))))))))) - -(define interactive-spec (make-fluid)) - -(define (set-not-subr! proc boolean) - (set! (not-subr? proc) boolean)) - -(define (transform-lambda/interactive exp name) - (fluid-set! interactive-spec #f) - (let* ((x (transform-lambda exp)) - (is (fluid-ref interactive-spec))) - `(,let ((%--lambda ,x)) - (,set-procedure-property! %--lambda (,quote name) (,quote ,name)) - (,set-not-subr! %--lambda #t) - ,@(if is - `((,set! (,interactive-spec %--lambda) (,quote ,is))) - '()) - %--lambda))) - (fset 'lambda (procedure->memoizing-macro (lambda (exp env) diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm index 0bb28ea37..0221dcc8a 100644 --- a/lang/elisp/transform.scm +++ b/lang/elisp/transform.scm @@ -16,7 +16,7 @@ (define (transformer x) (cond ((eq? x 'nil) %nil) ((eq? x 't) #t) - ((null? x) '()) + ((null? x) %nil) ((not (pair? x)) x) ((and (pair? (car x)) (eq? (caar x) 'quasiquote)) @@ -51,7 +51,7 @@ (else (syntax-error x)))) (define (m-quasiquote exp env) - (cons 'quasiquote + (cons quasiquote (map transform-inside-qq (cdr exp)))) (define (transform-inside-qq x) From 610922b2e20b49ae282c7099d5e14557dc64c8fa Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 4 Feb 2002 22:00:42 +0000 Subject: [PATCH 40/54] Added blurb about uninterned symbols. --- NEWS | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/NEWS b/NEWS index 69e639cb3..05904d621 100644 --- a/NEWS +++ b/NEWS @@ -20,6 +20,15 @@ debugging evaluator gives better error messages. * Changes to Scheme functions and syntax +** We now have uninterned symbols. + +The new function 'make-symbol' will return a uninterned symbol. This +is a symbol that is unique and is guaranteed to remain unique. +However, uninterned symbols can not yet be read back in. + +Use the new function 'symbol-interned?' to check whether a symbol is +interned or not. + ** pretty-print has more options. The function pretty-print from the (ice-9 pretty-print) module can now From 9c8d9ff91951626dd38c2e3c356610fafd172242 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:13:00 +0000 Subject: [PATCH 41/54] *** empty log message *** --- devel/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/devel/ChangeLog b/devel/ChangeLog index b60980387..70ffefe55 100644 --- a/devel/ChangeLog +++ b/devel/ChangeLog @@ -1,3 +1,7 @@ +2002-02-05 Thien-Thi Nguyen + + * build/pre-inst-guile.text: Initial revision. + 2001-12-04 Gary Houston * some discussion in extension/dynamic-root.text. From 3ac1e90a7c392d6c7c29b33d5fd45a635a969e90 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:14:26 +0000 Subject: [PATCH 42/54] Initial revision --- devel/build/pre-inst-guile.text | 47 ++++++++++++++++++ pre-inst-guile | 84 +++++++++++++++++++++++++++++++++ pre-inst-guile.am | 0 3 files changed, 131 insertions(+) create mode 100644 devel/build/pre-inst-guile.text create mode 100755 pre-inst-guile create mode 100644 pre-inst-guile.am diff --git a/devel/build/pre-inst-guile.text b/devel/build/pre-inst-guile.text new file mode 100644 index 000000000..5e9a24b37 --- /dev/null +++ b/devel/build/pre-inst-guile.text @@ -0,0 +1,47 @@ +THEORY + + The pre-installed guile interpreter can be used if has access to + the proper shared libraries and scheme modules, which can be + arranged by tweaking GUILE_LOAD_PATH and LTDL_LIBRARY_PATH env + vars, respectively. + + +GENERAL PRACTICE + + To invoke the guile interpreter before installing it (and its + support files), call ${top_srcdir}/pre-inst-guile w/ first arg + ${top_builddir}, where you would normally call guile. + + Similarly, for scripts/* (normally found by guile-tools), set + env var GUILE to the above combination. + + See commentary in ${top_srcdir}/pre-inst-guile for more info. + + +SPECIFIC PRACTICE + + Include the following line in any Makefile.am with rules that + need to call the pre-installed guile interpreter: + + include $(top_srcdir)/pre-inst-guile.am + + This causes Automake to include a makefile fragment that defines + two vars: `preinstguile' and `preinstguiletool'. The following + examples show how these vars are used: + + display-sum5: + $(preinstguile) -c '(display (+ 1 2 3 4 5))' + + display-deps-dotty: + $(preinstguiletool)/use2dot *.scm + + Note the particular syntax of `preinstguiletool' usage. + + +KNOWN USAGE + + check-guile.in + doc/ref/Makefile.am + libguile/Makefile.am + ice-9/Makefile.am + scripts/Makefile.am diff --git a/pre-inst-guile b/pre-inst-guile new file mode 100755 index 000000000..6f684e5bb --- /dev/null +++ b/pre-inst-guile @@ -0,0 +1,84 @@ +#!/bin/sh + +# Copyright (C) 2002 Free Software Foundation +# +# This file is part of GUILE. +# +# GUILE is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as +# published by the Free Software Foundation; either version 2, or +# (at your option) any later version. +# +# GUILE is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public +# License along with GUILE; see the file COPYING. If not, write +# to the Free Software Foundation, Inc., 59 Temple Place, Suite +# 330, Boston, MA 02111-1307 USA + +# Commentary: + +# Usage: pre-inst-guile TOP-BUILDDIR [ARGS] +# +# This script arranges for the environment to support, and eventaully execs, +# the uninstalled binary guile executable located somewhere under libguile/, +# passing ARGS to it. In the process, env var GUILE is clobbered, and the +# following env vars are modified (but not clobbered): +# GUILE_LOAD_PATH +# LTDL_LOAD_PATH +# +# WARNING: This script is *NOT* a "drop in" replacement for $bindir/guile; +# it is intended only for use in building/testing. + +# Code: + +subdirs_with_ltlibs="srfi guile-readline" # maintain me + +# determine absolute top_srcdir +[ x"$top_srcdir" = x ] && case $0 in */*) top_srcdir=`dirname $0` ;; esac +if [ x"$top_srcdir" = x ] ; then + echo $0: could not determine top_srcdir + exit 1 +fi +top_srcdir=`(cd $top_srcdir ; pwd)` + +# determine absolute top_builddir +if [ x"$1" = x ] ; then + echo $0: could not determine top_builddir + exit 1 +fi +top_builddir=`(cd $1 ; pwd)` +shift + +# handle GUILE_LOAD_PATH (no clobber) +if [ x"$GUILE_LOAD_PATH" = x ] ; then + GUILE_LOAD_PATH="${top_srcdir}" +else + case "$GUILE_LOAD_PATH" in *${top_srcdir}*) ;; + *) GUILE_LOAD_PATH="${top_srcdir}:$GUILE_LOAD_PATH" ;; + esac +fi +export GUILE_LOAD_PATH + +# handle LTDL_LIBRARY_PATH (no clobber) +ltdl_prefix="" +for dir in $subdirs_with_ltlibs ; do + ltdl_prefix="${top_builddir}/${dir}:${ltdl_prefix}" +done +LTDL_LIBRARY_PATH="${ltdl_prefix}$LTDL_LIBRARY_PATH" +export LTDL_LIBRARY_PATH + +# set GUILE (clobber) +GUILE=${top_builddir}/libguile/guile +export GUILE + +# do it +exec $GUILE "$@" + +# never reached +exit 1 + +# pre-inst-guile ends here diff --git a/pre-inst-guile.am b/pre-inst-guile.am new file mode 100644 index 000000000..e69de29bb From ba833f4a2fdd81311b6a31398c59cf23b5f22e4d Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:21:54 +0000 Subject: [PATCH 43/54] (srcdir): Delete var. (top_builddir, top_srcdir, guile_opts): New vars. Use "set -e". No longer set LTDL_LIBRARY_PATH. Use ${top_srcdir}/pre-inst-guile instead of libguile/guile. --- check-guile.in | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/check-guile.in b/check-guile.in index ebfe89cb2..ed571becb 100644 --- a/check-guile.in +++ b/check-guile.in @@ -1,6 +1,6 @@ #! /bin/sh # Usage: check-guile [-i GUILE-INTERPRETER] [GUILE-TEST-ARGS] -# If `-i GUILE-INTERPRETER' is omitted, use libguile/guile. +# If `-i GUILE-INTERPRETER' is omitted, use ${top_srcdir}/pre-inst-guile. # See test-suite/guile-test for documentation on GUILE-TEST-ARGS. # # Example invocations: @@ -9,27 +9,31 @@ # ./check-guile -i /usr/local/bin/guile # ./check-guile -i /usr/local/bin/guile numbers.test +set -e + # this script runs in the top-level build-dir. -srcdir=@srcdir@ -TEST_SUITE_DIR=$srcdir/test-suite +top_builddir=@srcdir@ + +top_srcdir=@top_srcdir@ + +TEST_SUITE_DIR=$top_builddir/test-suite if [ x"$1" = x-i ] ; then guile=$2 + guile_opts= shift shift GUILE_LOAD_PATH=$TEST_SUITE_DIR else - guile=libguile/guile - GUILE_LOAD_PATH=$srcdir:$TEST_SUITE_DIR - LTDL_LIBRARY_PATH=`pwd`/srfi:${LTDL_LIBRARY_PATH} + guile=${top_srcdir}/pre-inst-guile + guile_opts="${top_builddir}" + GUILE_LOAD_PATH=${top_builddir}:$TEST_SUITE_DIR fi export GUILE_LOAD_PATH -export LTDL_LIBRARY_PATH if [ -f "$guile" -a -x "$guile" ] ; then echo Testing $guile ... "$@" echo with GUILE_LOAD_PATH=$GUILE_LOAD_PATH - echo with LTDL_LIBRARY_PATH=$LTDL_LIBRARY_PATH else echo ERROR: Cannot execute $guile exit 1 @@ -40,6 +44,9 @@ if [ ! -f guile-procedures.txt ] ; then @LN_S@ libguile/guile-procedures.txt . fi -exec "$guile" -e main -s "$TEST_SUITE_DIR/guile-test" --test-suite "$TEST_SUITE_DIR/tests" --log-file check-guile.log "$@" +exec $guile $guile_opts \ + -e main -s "$TEST_SUITE_DIR/guile-test" \ + --test-suite "$TEST_SUITE_DIR/tests" \ + --log-file check-guile.log "$@" # check-guile ends here From 9d32aac72a07754c296c0662033629b7fdffdfe0 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:25:56 +0000 Subject: [PATCH 44/54] Include $(top_srcdir)/pre-inst-guile.am. (GUILE): Delete var. (autoconf-macros.texi): Use $(preinstguiletool). --- doc/ref/Makefile.am | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 1f42fcc80..d9da61d85 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -37,14 +37,13 @@ guile_TEXINFOS = preface.texi intro.texi program.texi scheme-intro.texi \ ETAGS_ARGS = $(info_TEXINFOS) $(guile_TEXINFOS) -GUILE = $(top_builddir)/libguile/guile +include $(top_srcdir)/pre-inst-guile.am # Automated snarfing autoconf.texi: autoconf-macros.texi autoconf-macros.texi: $(top_srcdir)/guile-config/guile.m4 - GUILE=$(GUILE) GUILE_LOAD_PATH=$(top_srcdir) \ - $(top_srcdir)/scripts/snarf-guile-m4-docs $< > $(srcdir)/$@ + $(preinstguiletool)/snarf-guile-m4-docs $< > $(srcdir)/$@ # Optionally support building an HTML version of the reference manual. From 5e9d88a400263af2e6622957e58c8dad587aaece Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:27:12 +0000 Subject: [PATCH 45/54] *** empty log message *** --- doc/ref/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 0d50fade9..4c9a21bd9 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,10 @@ +2002-02-05 Thien-Thi Nguyen + + * Makefile.am: Include $(top_srcdir)/pre-inst-guile.am. + + (GUILE): Delete var. + (autoconf-macros.texi): Use $(preinstguiletool). + 2002-02-04 Thien-Thi Nguyen * autoconf.texi (Autofrisk, Using Autofrisk): New sections. From f8241358de5cac4ae582878ace0a2cc85299f88d Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:29:53 +0000 Subject: [PATCH 46/54] Include $(top_srcdir)/pre-inst-guile.am. (bin_SCRIPTS): Remove guile-snarf-docs-texi. (alldotdocfiles, snarf2checkedtexi, dotdoc2texi): New vars. (guile.texi, guile-procedures.texi): Use $(dotdoc2texi). --- libguile/Makefile.am | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index c11ef267e..e0d1dfbd4 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -149,7 +149,7 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \ modinclude_DATA = scmconfig.h bin_SCRIPTS = guile-snarf guile-doc-snarf guile-snarf-docs \ - guile-snarf-docs-texi guile-func-name-check + guile-func-name-check EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \ ChangeLog-1996-1999 ChangeLog-2000 cpp_signal.c \ @@ -213,13 +213,17 @@ error.x: cpp_err_symbols.c posix.x: cpp_sig_symbols.c load.x: libpath.h -guile.texi: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) guile-snarf-docs-texi.in guile - cat $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) | ./guile-snarf-docs-texi --manual > $@ \ - || { rm $@; false; } +include $(top_srcdir)/pre-inst-guile.am -guile-procedures.texi: $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) guile-snarf-docs-texi.in guile - cat $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) | ./guile-snarf-docs-texi > $@ \ - || { rm $@; false; } +alldotdocfiles = $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) +snarf2checkedtexi = $(preinstguiletool)/snarf-check-and-output-texi +dotdoc2texi = cat $(alldotdocfiles) | $(snarf2checkedtexi) + +guile.texi: $(alldotdocfiles) guile + $(dotdoc2texi) --manual > $@ || { rm $@; false; } + +guile-procedures.texi: $(alldotdocfiles) guile + $(dotdoc2texi) > $@ || { rm $@; false; } if HAVE_MAKEINFO From d6c33794d55de6c79df09c34e812eeabde7d7159 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:32:26 +0000 Subject: [PATCH 47/54] bye bye --- libguile/guile-snarf-docs-texi.in | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100755 libguile/guile-snarf-docs-texi.in diff --git a/libguile/guile-snarf-docs-texi.in b/libguile/guile-snarf-docs-texi.in deleted file mode 100755 index e69de29bb..000000000 From dce05f4a4b2e4394cdd2671ee4e9461901b2b244 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:35:42 +0000 Subject: [PATCH 48/54] (libguile/guile-snarf-docs-texi): Remove from `AC_CONFIG_FILES' and `AC_CONFIG_COMMANDS'. --- configure.in | 2 -- 1 file changed, 2 deletions(-) diff --git a/configure.in b/configure.in index 2e0e2c0e5..ca9971ffb 100644 --- a/configure.in +++ b/configure.in @@ -674,7 +674,6 @@ AC_CONFIG_FILES([ libguile/guile-doc-snarf libguile/guile-func-name-check libguile/guile-snarf-docs - libguile/guile-snarf-docs-texi libguile/version.h ice-9/Makefile lang/Makefile @@ -712,7 +711,6 @@ AC_CONFIG_COMMANDS(default, libguile/guile-doc-snarf \ libguile/guile-func-name-check \ libguile/guile-snarf-docs \ - libguile/guile-snarf-docs-texi \ check-guile \ guile-tools]) From 9f03ac3db23914c5e93c3b3f00bf765770823258 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:38:23 +0000 Subject: [PATCH 49/54] Include $(top_srcdir)/pre-inst-guile.am. (psyntax.pp): Use $(preinstguile). --- ice-9/Makefile.am | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 4034be602..2c36a76ac 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -3,17 +3,17 @@ ## Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. ## ## This file is part of GUILE. -## +## ## GUILE is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as ## published by the Free Software Foundation; either version 2, or ## (at your option) any later version. -## +## ## GUILE is distributed in the hope that it will be useful, but ## WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. -## +## ## You should have received a copy of the GNU General Public ## License along with GUILE; see the file COPYING. If not, write ## to the Free Software Foundation, Inc., 59 Temple Place, Suite @@ -42,6 +42,13 @@ ETAGS_ARGS = $(subpkgdata_DATA) EXTRA_DIST = $(ice9_sources) test.scm compile-psyntax.scm if MAINTAINER_MODE +# We expect this to never be invoked when there is not already +# ice-9/psyntax.pp in %load-path, since compile-psyntax.scm depends +# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax.pp")'. +# In other words, to bootstrap this file, you need to do something like: +# GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax.pp +include $(top_srcdir)/pre-inst-guile.am psyntax.pp: psyntax.ss - GUILE_LOAD_PATH=$(srcdir)/..:.. ../libguile/guile -s $(srcdir)/compile-psyntax.scm $(srcdir)/psyntax.ss $(srcdir)/psyntax.pp + $(preinstguile) -s $(srcdir)/compile-psyntax.scm \ + $(srcdir)/psyntax.ss $(srcdir)/psyntax.pp endif From 0f73b20f51ab4e9e8e0b088ba29c68b1fce27ddf Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:40:56 +0000 Subject: [PATCH 50/54] Include $(top_srcdir)/pre-inst-guile.am. (overview): Use $(preinstguiletool). --- scripts/Makefile.am | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/scripts/Makefile.am b/scripts/Makefile.am index 3e21a0a7a..270120800 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -42,7 +42,9 @@ EXTRA_DIST = $(scripts_sources) list: @echo $(scripts_sources) -overview: +include $(top_srcdir)/pre-inst-guile.am + +overview: $(scripts_sources) @echo '----------------------------' @echo Overview @echo I. Commentaries @@ -50,10 +52,10 @@ overview: @echo '----------------------------' @echo I. Commentaries @echo '----------------------------' - @GUILE_LOAD_PATH=`(cd $(srcdir)/.. ; pwd)` \ - $(srcdir)/display-commentary $(scripts_sources) + $(preinstguiletool)/display-commentary $^ @echo '----------------------------' @echo II. Module Interfaces @echo '----------------------------' - @GUILE_LOAD_PATH=`(cd $(srcdir)/.. ; pwd)` \ - $(srcdir)/frisk $(scripts_sources) + $(preinstguiletool)/frisk $^ + +# Makefile.am ends here From 0187b4f4171ee98042278fc5734bedb20ed2d13e Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 09:42:16 +0000 Subject: [PATCH 51/54] *** empty log message *** --- ChangeLog | 18 ++++++++++++++++-- ice-9/ChangeLog | 8 +++++++- libguile/ChangeLog | 13 ++++++++++++- scripts/ChangeLog | 6 ++++++ 4 files changed, 41 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index dfac20bd8..0b1c124f8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,17 @@ +2002-02-05 Thien-Thi Nguyen + + * pre-inst-guile.am, pre-inst-guile: New files. + + * check-guile.in (srcdir): Delete var. + (top_builddir, top_srcdir, guile_opts): New vars. + + Use "set -e". + No longer set LTDL_LIBRARY_PATH. + Use ${top_srcdir}/pre-inst-guile instead of libguile/guile. + + * configure.in (libguile/guile-snarf-docs-texi): Remove + from `AC_CONFIG_FILES' and `AC_CONFIG_COMMANDS'. + 2002-01-31 Stefan Jahn * configure.in: Add -DLIBLTDL_DLL_IMPORT to INCLTDL when using @@ -5,7 +19,7 @@ 2002-01-28 Stefan Jahn - * configure.in (guile_cv_have_uint32_t): Look also in + * configure.in (guile_cv_have_uint32_t): Look also in `stdint.h' for uint32_t. 2002-01-13 Neil Jerram @@ -31,7 +45,7 @@ * configure.in (HAVE_MAKEINFO): Check for the makeinfo program and set this conditional accordingly. - + 2001-12-01 Thien-Thi Nguyen * README: Fix virulent typo. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 016ee6e56..542d0aa67 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2002-02-05 Thien-Thi Nguyen + + * Makefile.am: Include $(top_srcdir)/pre-inst-guile.am. + + (psyntax.pp): Use $(preinstguile). + 2002-01-14 Marius Vollmer * psyntax.ss (datum->syntax-object): Removed assertion in @@ -8,7 +14,7 @@ 2002-01-12 Marius Vollmer More options for pretty-print. Thanks to Matthias Köppe! - + * pretty-print.scm (generic-write): New per-line-prefix argument. (pretty-print): Check whether the new keyword argument style is used and dispatch to pretty-print-with-keys accordingly. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1fc2f2169..a0680ab60 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,13 @@ +2002-02-05 Thien-Thi Nguyen + + * Makefile.am: Include $(top_srcdir)/pre-inst-guile.am. + + (bin_SCRIPTS): Remove guile-snarf-docs-texi. + (alldotdocfiles, snarf2checkedtexi, dotdoc2texi): New vars. + (guile.texi, guile-procedures.texi): Use $(dotdoc2texi). + + * guile-snarf-docs-texi.in: Bye bye. + 2002-02-04 Marius Vollmer * symbols.c (scm_make_symbol): Fix typo in docstring. @@ -15,13 +25,14 @@ This signals a interned symbol. (scm_mem2uninterned_symbol, scm_symbol_interned_p, scm_make_symbol): New. - + * print.c (scm_iprin1): Print uninterned symbols unreadably. 2002-02-02 Thien-Thi Nguyen * __scm.h (HAVE_UINTPTR_T): Only define if UINTPTR_T attributes are defined: UINTPTR_MAX, INTPTR_MAX, INTPTR_MIN. + Thanks to Dave Love. 2002-01-31 Marius Vollmer diff --git a/scripts/ChangeLog b/scripts/ChangeLog index c936eaefd..f11df41c2 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,3 +1,9 @@ +2002-02-05 Thien-Thi Nguyen + + * Include $(top_srcdir)/pre-inst-guile.am. + + (overview): Use $(preinstguiletool). + 2002-01-11 Thien-Thi Nguyen * Makefile.am (scripts_sources): Add autofrisk. From e15fa93d74c659e8b0aacfe4151f51a2863dbfd7 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 10:09:39 +0000 Subject: [PATCH 52/54] (top_builddir): Fix bug: Use cwd. --- check-guile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/check-guile.in b/check-guile.in index ed571becb..8c350f258 100644 --- a/check-guile.in +++ b/check-guile.in @@ -12,7 +12,7 @@ set -e # this script runs in the top-level build-dir. -top_builddir=@srcdir@ +top_builddir=`pwd` top_srcdir=@top_srcdir@ From 77bf05e08bd9a3614277d109874c5567bbd3a162 Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 10:10:49 +0000 Subject: [PATCH 53/54] *** empty log message *** --- ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog b/ChangeLog index 0b1c124f8..a3e00ee53 100644 --- a/ChangeLog +++ b/ChangeLog @@ -12,6 +12,8 @@ * configure.in (libguile/guile-snarf-docs-texi): Remove from `AC_CONFIG_FILES' and `AC_CONFIG_COMMANDS'. + * check-guile.in (top_builddir): Fix bug: Use cwd. + 2002-01-31 Stefan Jahn * configure.in: Add -DLIBLTDL_DLL_IMPORT to INCLTDL when using From ec5e172228605bdcc96b1edc48859be6135ea0ef Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Tue, 5 Feb 2002 10:30:04 +0000 Subject: [PATCH 54/54] Fix bug: Use ":" in `case' pattern to prevent prefix aliasing. --- pre-inst-guile | 84 -------------------------------------------------- 1 file changed, 84 deletions(-) diff --git a/pre-inst-guile b/pre-inst-guile index 6f684e5bb..e69de29bb 100755 --- a/pre-inst-guile +++ b/pre-inst-guile @@ -1,84 +0,0 @@ -#!/bin/sh - -# Copyright (C) 2002 Free Software Foundation -# -# This file is part of GUILE. -# -# GUILE is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as -# published by the Free Software Foundation; either version 2, or -# (at your option) any later version. -# -# GUILE is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public -# License along with GUILE; see the file COPYING. If not, write -# to the Free Software Foundation, Inc., 59 Temple Place, Suite -# 330, Boston, MA 02111-1307 USA - -# Commentary: - -# Usage: pre-inst-guile TOP-BUILDDIR [ARGS] -# -# This script arranges for the environment to support, and eventaully execs, -# the uninstalled binary guile executable located somewhere under libguile/, -# passing ARGS to it. In the process, env var GUILE is clobbered, and the -# following env vars are modified (but not clobbered): -# GUILE_LOAD_PATH -# LTDL_LOAD_PATH -# -# WARNING: This script is *NOT* a "drop in" replacement for $bindir/guile; -# it is intended only for use in building/testing. - -# Code: - -subdirs_with_ltlibs="srfi guile-readline" # maintain me - -# determine absolute top_srcdir -[ x"$top_srcdir" = x ] && case $0 in */*) top_srcdir=`dirname $0` ;; esac -if [ x"$top_srcdir" = x ] ; then - echo $0: could not determine top_srcdir - exit 1 -fi -top_srcdir=`(cd $top_srcdir ; pwd)` - -# determine absolute top_builddir -if [ x"$1" = x ] ; then - echo $0: could not determine top_builddir - exit 1 -fi -top_builddir=`(cd $1 ; pwd)` -shift - -# handle GUILE_LOAD_PATH (no clobber) -if [ x"$GUILE_LOAD_PATH" = x ] ; then - GUILE_LOAD_PATH="${top_srcdir}" -else - case "$GUILE_LOAD_PATH" in *${top_srcdir}*) ;; - *) GUILE_LOAD_PATH="${top_srcdir}:$GUILE_LOAD_PATH" ;; - esac -fi -export GUILE_LOAD_PATH - -# handle LTDL_LIBRARY_PATH (no clobber) -ltdl_prefix="" -for dir in $subdirs_with_ltlibs ; do - ltdl_prefix="${top_builddir}/${dir}:${ltdl_prefix}" -done -LTDL_LIBRARY_PATH="${ltdl_prefix}$LTDL_LIBRARY_PATH" -export LTDL_LIBRARY_PATH - -# set GUILE (clobber) -GUILE=${top_builddir}/libguile/guile -export GUILE - -# do it -exec $GUILE "$@" - -# never reached -exit 1 - -# pre-inst-guile ends here