ref: 2b34bcfbd3881d039ec43becdaf61fc3171ada29
parent: 6afa9c998f5a8d1f9fc8b1647e4fef0c67695f74
author: Jeff Bezanson <bezanson@post.harvard.edu>
date: Fri Feb 17 12:53:34 EST 2012
moving stuff around some more
--- /dev/null
+++ b/.gitignore
@@ -1,0 +1,5 @@
+/*.o
+/*.do
+/*.a
+/*.da
+/flisp
--- /dev/null
+++ b/FLOSSING
@@ -1,0 +1,13 @@
+Flossing is important to overall oral health.
+
+Even by itself, flossing does a good job of cleaning teeth and gums,
+and is the only way to clean below the gumline.
+
+However it has an important secondary purpose as well. Most people assume
+the point of brushing teeth is to scrub the teeth with bristles. This
+is not fully true; the more significant purpose of brushing is to apply
+fluoride to teeth. If you don't floss, food particles are left between
+the teeth and gums, blocking fluoride from reaching tooth surfaces. It
+is then as if you were not brushing at all. Even if no material is
+visible between teeth, there is probably some there. Flossing can pull
+a surprising amount of gunk from a mouth that appears totally clean.
--- /dev/null
+++ b/LICENSE
@@ -1,0 +1,26 @@
+Copyright (c) 2008 Jeff Bezanson
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+ * Neither the author nor the names of any contributors may be used to
+ endorse or promote products derived from this software without specific
+ prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- /dev/null
+++ b/Makefile
@@ -1,0 +1,60 @@
+CC = gcc
+
+NAME = flisp
+SRCS = $(NAME).c builtins.c string.c equalhash.c table.c iostream.c
+OBJS = $(SRCS:%.c=%.o)
+DOBJS = $(SRCS:%.c=%.do)
+EXENAME = $(NAME)
+LIBTARGET = lib$(NAME)
+LLTDIR = ../llt
+LLT = $(LLTDIR)/libllt.a
+
+# OS flags: LINUX, WIN32, MACOSX
+# architecture flags: __CPU__=xxx, BITS64, ARCH_X86, ARCH_X86_64
+CONFIG = -DLINUX -DARCH_X86_64 -DBITS64 -D__CPU__=686
+FLAGS = -falign-functions -Wall -Wno-strict-aliasing -I$(LLTDIR) $(CFLAGS) -DUSE_COMPUTED_GOTO $(CONFIG)
+LIBFILES = $(LLT)
+LIBS = $(LIBFILES) -lm
+
+DEBUGFLAGS = -g -DDEBUG $(FLAGS)
+SHIPFLAGS = -O2 -DNDEBUG $(FLAGS)
+
+default: release test
+
+test:
+ cd tests && ../flisp unittest.lsp
+
+%.o: %.c
+ $(CC) $(SHIPFLAGS) -c $< -o $@
+%.do: %.c
+ $(CC) $(DEBUGFLAGS) -c $< -o $@
+
+flisp.o: flisp.c cvalues.c types.c flisp.h print.c read.c equal.c
+flisp.do: flisp.c cvalues.c types.c flisp.h print.c read.c equal.c
+flmain.o: flmain.c flisp.h
+flmain.do: flmain.c flisp.h
+
+$(LLT):
+ cd $(LLTDIR) && make
+
+$(LIBTARGET).da: $(DOBJS)
+ rm -rf $@
+ ar rs $@ $(DOBJS)
+
+$(LIBTARGET).a: $(OBJS)
+ rm -rf $@
+ ar rs $@ $(OBJS)
+
+debug: $(DOBJS) $(LIBFILES) $(LIBTARGET).da flmain.do
+ $(CC) $(DEBUGFLAGS) $(DOBJS) flmain.do -o $(EXENAME) $(LIBS) $(LIBTARGET).da
+ make test
+
+release: $(OBJS) $(LIBFILES) $(LIBTARGET).a flmain.o
+ $(CC) $(SHIPFLAGS) $(OBJS) flmain.o -o $(EXENAME) $(LIBS) $(LIBTARGET).a
+
+clean:
+ rm -f *.o
+ rm -f *.do
+ rm -f $(EXENAME)
+ rm -f $(LIBTARGET).a
+ rm -f $(LIBTARGET).da
--- /dev/null
+++ b/Makefile.macosx
@@ -1,0 +1,44 @@
+CC = gcc
+
+NAME = flisp
+SRCS = $(NAME).c builtins.c string.c equalhash.c table.c iostream.c
+OBJS = $(SRCS:%.c=%.o)
+DOBJS = $(SRCS:%.c=%.do)
+EXENAME = $(NAME)
+LLTDIR = ../llt
+LLT = $(LLTDIR)/libllt.a
+
+FLAGS = -falign-functions -Wall -Wno-strict-aliasing -I$(LLTDIR) $(CFLAGS) -DUSE_COMPUTED_GOTO
+LIBFILES = $(LLT)
+LIBS = $(LIBFILES) -lm -framework ApplicationServices
+
+DEBUGFLAGS = -g -DDEBUG $(FLAGS)
+SHIPFLAGS = -O2 -DNDEBUG $(FLAGS)
+
+default: release test
+
+test:
+ ./flisp unittest.lsp
+
+%.o: %.c
+ $(CC) $(SHIPFLAGS) -c $< -o $@
+%.do: %.c
+ $(CC) $(DEBUGFLAGS) -c $< -o $@
+
+flisp.o: flisp.c cvalues.c types.c flisp.h print.c read.c equal.c
+flisp.do: flisp.c cvalues.c types.c flisp.h print.c read.c equal.c
+
+$(LLT):
+ cd $(LLTDIR) && make
+
+debug: $(DOBJS) $(LIBFILES)
+ $(CC) $(DEBUGFLAGS) $(DOBJS) -o $(EXENAME) $(LIBS)
+ make test
+
+release: $(OBJS) $(LIBFILES)
+ $(CC) $(SHIPFLAGS) $(OBJS) -o $(EXENAME) $(LIBS)
+
+clean:
+ rm -f *.o
+ rm -f *.do
+ rm -f $(EXENAME)
--- /dev/null
+++ b/README.md
@@ -1,0 +1,37 @@
+## ...a purely symbolic gesture...
+
+This project began with an attempt to write the fastest lisp interpreter I could in under 1000 lines of C. It snowballed from there as I kept trying to see if I could add powerful features with minimal code. At the same time I assembled a library of some of my favorite C code (by myself and others) to use as a base for a standard library. This includes `ios`, a replacement for parts of C's stdio that adds more flexible features.
+
+Before you say "oh no, another lisp", consider the following: femtolisp is about 150kb, is very self-contained, and has the following features:
+
+ * vectors, strings, gensyms
+ * backquote
+ * exceptions
+ * printing and reading circular/shared structure
+ * all values can be printed readably
+ * prettyprinting
+ * hash tables
+ * support for directly using C data types ala Python's ctypes
+ * `equal` and ordered comparison predicates that work on circular structure
+ * proper tail recursion
+ * io and memory streams with utf8 support
+ * highly compatible with Scheme, including some `R6RS` features
+ * simple, well-organized, powerful API with as few functions as possible
+ * compacting GC
+ * and...
+
+...it is fast, ranking among the fastest non-native-compiled Scheme implementations. It achieves this level of speed even though many primitives (like `map`) are written in the language instead of C. femtolisp uses a bytecode compiler and VM, with the compiler written in femtolisp. Bytecode is first-class, can be printed and read, and is "human readable" (the representation is a string of normal low-ASCII characters).
+
+femtolisp is a simple, elegant Scheme dialect. It is a lisp-1 with lexical scope. The core is 12 builtin special forms and 33 builtin functions.
+
+A primary design goal is to keep the code concise and interesting. I strive to have each concept implemented in just one place, so the system is easy to understand and modify. The result is high reliability, because there are fewer places for bugs to hide. You want a small core of generically useful features that work _really well_ (for example, see `torture.scm`).
+
+Almost everybody has their own lisp implementation. Some programmers' dogs and cats probably have _their_ own lisp implementations as well. This is great, but too often I see people omit some of the obscure but critical features that make lisp uniquely wonderful. These include read macros like `#.` and backreferences, gensyms, and properly escaped symbol names. If you're going to waste everybody's time with yet another lisp, at least do it right damnit.
+
+Another design goal is to avoid spurious novelties. Many others offering their own "shiny new" lisp dialects get carried away and change anything that strikes their fancy. These changes have no effect except incompatibility, and often make the language worse because the new design was not as carefully thought out and has not stood the test of time. For example, how does it help to remove backquote? One design changes the syntax of `quote`. Some systems disallow dotted lists. (I've seen all three of these.) What's the point? Implementers wave the banner of "simplicity", yet wedge in all kinds of weird implicit behaviors and extra evaluation rules.
+
+Lately a surprising amount of FUD has been spread about tail call optimization. I agree that not every language needs it, but I would like to refute the idea that it makes interpreters slow. Look at the "tiny" subdirectory or the "interpreter" branch to see a pure s-expr interpreter with efficient TCO. All you have to do is keep track of whether you're in tail position, which can be done very cheaply. These interpreters are difficult to beat for speed, yet they have lexical scope and TCO.
+
+This project is mostly a matter of style. Look at the code and you'll understand.
+
+This is what I do for fun, because it is the _exact opposite_ of the kind of thing people will pay for: an obscure implementation of a programming language everybody hates.
--- /dev/null
+++ b/aliases.scm
@@ -1,0 +1,300 @@
+; definitions of standard scheme procedures in terms of
+; femtolisp procedures
+; sufficient to run the R5RS version of psyntax
+
+(define top-level-bound? bound?)
+(define (eval-core x) (eval x))
+(define (symbol-value s) (top-level-value s))
+(define (set-symbol-value! s v) (set-top-level-value! s v))
+(define (eval x)
+ ((compile-thunk (expand
+ (if (and (pair? x)
+ (equal? (car x) "noexpand"))
+ (cadr x)
+ x)))))
+(define (command-line) *argv*)
+
+(define gensym
+ (let (($gensym gensym))
+ (lambda ((x #f)) ($gensym))))
+
+(define-macro (begin0 first . rest)
+ (let ((g (gensym)))
+ `(let ((,g ,first))
+ ,@rest
+ ,g)))
+
+(define vector-ref aref)
+(define vector-set! aset!)
+(define vector-length length)
+(define make-vector vector.alloc)
+(define (vector-fill! v f)
+ (for 0 (- (length v) 1)
+ (lambda (i) (aset! v i f)))
+ #t)
+(define (vector-map f v) (vector.map f v))
+
+(define array-ref! aref)
+(define (array-set! a obj i0 . idxs)
+ (if (null? idxs)
+ (aset! a i0 obj)
+ (error "array-set!: multiple dimensions not yet implemented")))
+
+(define (array-dimensions a)
+ (list (length a)))
+
+(define (complex? x) #f)
+(define (real? x) (number? x))
+(define (rational? x) (integer? x))
+(define (exact? x) (integer? x))
+(define (inexact? x) (not (exact? x)))
+(define (flonum? x) (not (exact? x)))
+(define quotient div0)
+(define remainder mod0)
+(define (inexact x) x)
+(define (exact x)
+ (if (exact? x) x
+ (error "exact real numbers not supported")))
+(define (exact->inexact x) (double x))
+(define (inexact->exact x)
+ (if (integer-valued? x)
+ (truncate x)
+ (error "exact real numbers not supported")))
+(define (floor x) (if (< x 0) (truncate (- x 0.5)) (truncate x)))
+(define (ceiling x) (if (< x 0) (truncate x) (truncate (+ x 0.5))))
+(define (finite? x) (and (< x +inf.0) (> x -inf.0)))
+(define (infinite? x) (or (equal? x +inf.0) (equal? x -inf.0)))
+(define (nan? x) (or (equal? x +nan.0) (equal? x -nan.0)))
+
+(define (char->integer c) (fixnum c))
+(define (integer->char i) (wchar i))
+(define char-upcase char.upcase)
+(define char-downcase char.downcase)
+(define char=? eqv?)
+(define char<? <)
+(define char>? >)
+(define char<=? <=)
+(define char>=? >=)
+(define (char-whitespace? c) (not (not (string.find *whitespace* c))))
+(define (char-numeric? c) (not (not (string.find "0123456789" c))))
+
+(define string=? eqv?)
+(define string<? <)
+(define string>? >)
+(define string<=? <=)
+(define string>=? >=)
+(define string-copy copy)
+(define string-append string)
+(define string-length string.count)
+(define string->symbol symbol)
+(define (symbol->string s) (string s))
+(define symbol=? eq?)
+(define (make-string k (fill #\space))
+ (string.rep fill k))
+
+(define (string-ref s i)
+ (string.char s (string.inc s 0 i)))
+
+(define (list->string l) (apply string l))
+(define (string->list s)
+ (do ((i (sizeof s) i)
+ (l '() (cons (string.char s i) l)))
+ ((= i 0) l)
+ (set! i (string.dec s i))))
+
+(define (substring s start end)
+ (string.sub s (string.inc s 0 start) (string.inc s 0 end)))
+
+(define (input-port? x) (iostream? x))
+(define (output-port? x) (iostream? x))
+(define (port? x) (iostream? x))
+(define close-input-port io.close)
+(define close-output-port io.close)
+(define (read-char (s *input-stream*)) (io.getc s))
+(define (peek-char (s *input-stream*)) (io.peekc s))
+(define (write-char c (s *output-stream*)) (io.putc s c))
+; TODO: unread-char
+(define (port-eof? p) (io.eof? p))
+(define (open-input-string str)
+ (let ((b (buffer)))
+ (io.write b str)
+ (io.seek b 0)
+ b))
+(define (open-output-string) (buffer))
+(define (open-string-output-port)
+ (let ((b (buffer)))
+ (values b (lambda () (io.tostring! b)))))
+
+(define (get-output-string b)
+ (let ((p (io.pos b)))
+ (io.seek b 0)
+ (let ((s (io.readall b)))
+ (io.seek b p)
+ (if (eof-object? s) "" s))))
+
+(define (open-input-file name) (file name :read))
+(define (open-output-file name) (file name :write :create))
+
+(define (current-input-port (p *input-stream*))
+ (set! *input-stream* p))
+(define (current-output-port (p *output-stream*))
+ (set! *output-stream* p))
+
+(define (input-port-line p)
+ ; TODO
+ 1)
+
+(define get-datum read)
+(define (put-datum port x)
+ (with-bindings ((*print-readably* #t))
+ (write x port)))
+
+(define (put-u8 port o) (io.write port (uint8 o)))
+(define (put-string port s (start 0) (count #f))
+ (let* ((start (string.inc s 0 start))
+ (end (if count
+ (string.inc s start count)
+ (sizeof s))))
+ (io.write port s start (- end start))))
+
+(define (io.skipws s)
+ (let ((c (io.peekc s)))
+ (if (and (not (eof-object? c)) (char-whitespace? c))
+ (begin (io.getc s)
+ (io.skipws s)))))
+
+(define (with-output-to-file name thunk)
+ (let ((f (file name :write :create :truncate)))
+ (unwind-protect
+ (with-output-to f (thunk))
+ (io.close f))))
+
+(define (with-input-from-file name thunk)
+ (let ((f (file name :read)))
+ (unwind-protect
+ (with-input-from f (thunk))
+ (io.close f))))
+
+(define (call-with-input-file name proc)
+ (let ((f (open-input-file name)))
+ (prog1 (proc f)
+ (io.close f))))
+
+(define (call-with-output-file name proc)
+ (let ((f (open-output-file name)))
+ (prog1 (proc f)
+ (io.close f))))
+
+(define (file-exists? f) (path.exists? f))
+(define (delete-file name) (void)) ; TODO
+
+(define (display x (port *output-stream*))
+ (with-output-to port (princ x))
+ #t)
+
+(define assertion-violation
+ (lambda args
+ (display 'assertion-violation)
+ (newline)
+ (display args)
+ (newline)
+ (car #f)))
+
+(define pretty-print write)
+
+(define (memp proc ls)
+ (cond ((null? ls) #f)
+ ((pair? ls) (if (proc (car ls))
+ ls
+ (memp proc (cdr ls))))
+ (else (assertion-violation 'memp "Invalid argument" ls))))
+
+(define (assp pred lst)
+ (cond ((atom? lst) #f)
+ ((pred (caar lst)) (car lst))
+ (else (assp pred (cdr lst)))))
+
+(define (for-all proc l . ls)
+ (or (null? l)
+ (and (apply proc (car l) (map car ls))
+ (apply for-all proc (cdr l) (map cdr ls)))))
+(define andmap for-all)
+
+(define (exists proc l . ls)
+ (and (not (null? l))
+ (or (apply proc (car l) (map car ls))
+ (apply exists proc (cdr l) (map cdr ls)))))
+(define ormap exists)
+
+(define cons* list*)
+
+(define (fold-left f zero lst)
+ (if (null? lst) zero
+ (fold-left f (f zero (car lst)) (cdr lst))))
+
+(define fold-right foldr)
+
+(define (partition pred lst)
+ (let ((s (separate pred lst)))
+ (values (car s) (cdr s))))
+
+(define (dynamic-wind before thunk after)
+ (before)
+ (unwind-protect (thunk)
+ (after)))
+
+(let ((*properties* (table)))
+ (set! putprop
+ (lambda (sym key val)
+ (let ((sp (get *properties* sym #f)))
+ (if (not sp)
+ (let ((t (table)))
+ (put! *properties* sym t)
+ (set! sp t)))
+ (put! sp key val))))
+
+ (set! getprop
+ (lambda (sym key)
+ (let ((sp (get *properties* sym #f)))
+ (and sp (get sp key #f)))))
+
+ (set! remprop
+ (lambda (sym key)
+ (let ((sp (get *properties* sym #f)))
+ (and sp (has? sp key) (del! sp key))))))
+
+; --- gambit
+
+(define arithmetic-shift ash)
+(define bitwise-and logand)
+(define bitwise-or logior)
+(define bitwise-not lognot)
+(define bitwise-xor logxor)
+
+(define (include f) (load f))
+(define (with-exception-catcher hand thk)
+ (trycatch (thk)
+ (lambda (e) (hand e))))
+
+(define (current-exception-handler)
+ ; close enough
+ (lambda (e) (raise e)))
+
+(define make-table table)
+(define table-ref get)
+(define table-set! put!)
+(define (read-line (s *input-stream*))
+ (io.flush *output-stream*)
+ (io.discardbuffer s)
+ (io.readline s))
+(define (shell-command s) 1)
+(define (error-exception-message e) (cadr e))
+(define (error-exception-parameters e) (cddr e))
+
+(define (with-output-to-string nada thunk)
+ (let ((b (buffer)))
+ (with-output-to b (thunk))
+ (io.tostring! b)))
+
+(define (read-u8) (io.read *input-stream* 'uint8))
+(define modulo mod)
--- /dev/null
+++ b/ascii-mona-lisa
@@ -1,0 +1,47 @@
+iIYVVVVXVVVVVVVVVYVYVYYVYYYYIIIIYYYIYVVVYYYYYYYYYVVYVVVVXVVVVVYI+.
+tYVXXXXXXVXXXXVVVYVVVVVVVVVVVVYVVVVVVVVVVVVVVVVVXXXXXVXXXXXXXVVYi.
+iYXRXRRRXXXXXXXXXXXVVXVXVVVVVVVVXXXVXVVXXXXXXXXXXXXXXRRRRRRRRRXVi.
+tVRRRRRRRRRRRRRRRXRXXXXXXXXXXXXXXRRXXXXRRRRXXXXXXXRRRRRRRRRRRRXV+.
+tVRRBBBRMBRRRRRRRRRXXRRRRRXt=+;;;;;==iVXRRRRXXXXRRRRRRRRMMBRRRRXi,
+tVRRBMBBMMBBBBBMBBRBBBRBX++=++;;;;;;:;;;IRRRRXXRRRBBBBBBMMBBBRRXi,
+iVRMMMMMMMMMMMMMMBRBBMMV==iIVYIi=;;;;:::;;XRRRRRRBBMMMMMMMMBBRRXi.
+iVRMMMMMMMMMMMMMMMMMMMY;IBWWWWMMXYi=;:::::;RBBBMMMMMMMMMMMMMMBBXi,
++VRMMRBMMMMMMMMMMMMMMY+;VMMMMMMMRXIi=;:::::=VVXXXRRRMMMMMMMMBBMXi;
+=tYYVVVXRRRXXRBMMMMMV+;=RBBMMMXVXXVYt;::::::ttYYVYVVRMMMMMMBXXVI+=
+;=tIYYVYYYYYYVVVMMMBt=;;+i=IBi+t==;;i;::::::+iitIIttYRMMMMMRXVVI=;
+;=IIIIYYYIIIIttIYItIt;;=VVYXBIVRXVVXI;::::::;+iitttttVMMBRRRVVVI+,
+;+++tttIttttiiii+i++==;;RMMMBXXMMMXI+;::::::;+ittttitYVXVYYIYVIi;;
+;===iiittiiIitiii++;;;;:IVRVi=iBXVIi;::::::::;==+++++iiittii+++=;;
+;;==+iiiiiiiiii+++=;;;;;;VYVIiiiVVt+;::::::::;++++++++++iti++++=;;
+;;=++iiii+i+++++iii==;;;::tXYIIYIi+=;:::::,::;+++++++++++++++++=;;
+;;;+==+ii+++++iiiiit=;;:::::=====;;;::::::::::+++i+++++++++i+++;;;
+;;;==+=+iiiiitttIIII+;;;:,::,;;;;:;=;;;::,::::=++++++++==++++++;;;
+:;====+tittiiittttti+;;::::,:=Ytiiiiti=;:::::,:;;==ii+ittItii+==;;
+;;+iiittIti+ii;;===;;:;::::;+IVXVVVVVVt;;;;;::::;;===;+IIiiti=;;;;
+;=++++iIti+ii+=;;;=;:::;;+VXBMMBBBBBBXY=;=;;:::::;=iYVIIttii++;;;;
+;;++iiiItttIi+++=;;:::;=iBMMMMMMMMMMMXI==;;,::;;:;;=+itIttIIti+;;;
+;=+++++i+tYIIiii;:,::;itXMMMMMMMMMMMBXti==;:;++=;:::::;=+iittti+;;
+;;+ii+ii+iitiIi;::::;iXBMMMMMWWWWWMMBXti+ii=;::::,,,,:::=;==+tI+;;
+;;iiiitItttti;:::;::=+itYXXMWWWWWWMBYt+;;::,,,,,,,,,,,,,:==;==;;;;
+:;=iIIIttIt+:;:::;;;==;+=+iiittttti+;;:,:,,,,::,,,,,,,,:::;=;==::;
+;::=+ittiii=;:::::;;;:;:;=++==;;==;:,,,,,,:;::::,,,,,,,,::;==;;::;
+:::;+iiiii=;::::,:;:::::;;:;;::;:::,,,,,,,:::;=;;;:,,,,,:::;;::::;
+:;;iIIIIII=;:::,:::::::,::::,:::,,,,,,,,,,,:;;=;:,,,,,,::::;=;:::;
+:;==++ii+;;;:::::::::::,,,,,,::,,,,,,,,,,,::::,,,,,,,,,,:,:::::::;
+::;;=+=;;;:::;;::,,,,,,,,,,,,,,,,,,,,,,,,,:,,,,,,,,,,,,,,,,,:::::;
+::;=;;;:;:::;;;;::,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,::,,::::;
+:;;:;::::::,::,,:,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,:::;
+:::::::::::;;;:,,,,,,,,,,,,,...,...,,,.,,,,,,,,,,,,.,,,,,,,,,,,,:;
+::::::::;=;;;;;::,,,,,,,,,,,.......,...,,,,,,,,,,,,.,,,,,,,,,,,,,;
+:::::,,:;=;;;;;;;iVXXXVt+:,,....,,,,....,.,,,,,,,.,.....,,,,,,,,:;
+:,,::,,:::;;;;;;=IVVVXXXXVXVt:,,,,,..,..,,,,.,,,,,..,.,,,,,,,,,,,;
+::,::,,,:,:::::,::;=iIYVXVVVVIYIi;,,.,.,,,::,,,,,,,,,,,,,,,,,,,,,.
+:,,,,,,,,,,,,,,,,::;+itIIIIIIi:;;i++=;;;;;;;;;::,,,...,,..,,,,,,,.
+:,,,,,,,,,,,,,,=iitVYi++iitt==it;;:;;;;::;;::::,,,......,,,,,,,::.
+::,,,,,,,,,,,,,++iiIVIi=;;=;+i;:;+:::,,,,,,,,,,,,,.....,,,,,,,,::,
+,,,,,,,,,,,,,,,;=+it=:::,,,,,,,,,,.,......,,.,..........,,,,,,,,::
+:,,,,,,,,,,,,,,,,:=:,,,,,,,,,,,,,,......................,.,,.,.,,:
+:,,,,,,,,,,,,,,,,,:,,,,,,,,,,..,........................,..,...,,:
+,,,,,,,,,,,,,,,,,,,.....................................,.......,,
+,,,,,,,,,.,,,,,,,...............................................,,
+itittiiiii+=++=;;=iiiiiiittiiiiii+iii===;++iiitiiiiiii+=====+ii=+i
--- /dev/null
+++ b/ascii-mona-lisa-2
@@ -1,0 +1,71 @@
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!>''''''<!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!'''''` ``'!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!''` ..... `'!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!'` . :::::' `'!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!' . ' .::::' `!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!' : ````` `!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!! .,cchcccccc,,. `!!!!!!!!!!!!
+!!!!!!!!!!!!!!! .-"?$$$$$$$$$$$$$$c, `!!!!!!!!!!!
+!!!!!!!!!!!!!! ,ccc$$$$$$$$$$$$$$$$$$$, `!!!!!!!!!!
+!!!!!!!!!!!!! z$$$$$$$$$$$$$$$$$$$$$$$$;. `!!!!!!!!!
+!!!!!!!!!!!! <$$$$$$$$$$$$$$$$$$$$$$$$$$:. `!!!!!!!!
+!!!!!!!!!!! $$$$$$$$$$$$$$$$$$$$$$$$$$$h;:. !!!!!!!!
+!!!!!!!!!!' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$h;. !!!!!!!
+!!!!!!!!!' <$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !!!!!!!
+!!!!!!!!' `$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$F `!!!!!!
+!!!!!!!! c$$$$???$$$$$$$P"" """??????" !!!!!!
+!!!!!!! `"" .,.. "$$$$F .,zcr !!!!!!
+!!!!!!! . dL .?$$$ .,cc, .,z$h. !!!!!!
+!!!!!!!! <. $$c= <$d$$$ <$$$$=-=+"$$$$$$$ !!!!!!
+!!!!!!! d$$$hcccd$$$$$ d$$$hcccd$$$$$$$F `!!!!!
+!!!!!! ,$$$$$$$$$$$$$$h d$$$$$$$$$$$$$$$$ `!!!!!
+!!!!! `$$$$$$$$$$$$$$$<$$$$$$$$$$$$$$$$' !!!!!
+!!!!! `$$$$$$$$$$$$$$$$"$$$$$$$$$$$$$P> !!!!!
+!!!!! ?$$$$$$$$$$$$??$c`$$$$$$$$$$$?>' `!!!!
+!!!!! `?$$$$$$I7?"" ,$$$$$$$$$?>>' !!!!
+!!!!!. <<?$$$$$$c. ,d$$?$$$$$F>>'' `!!!
+!!!!!! <i?$P"??$$r--"?"" ,$$$$h;>'' `!!!
+!!!!!! $$$hccccccccc= cc$$$$$$$>>' !!!
+!!!!! `?$$$$$$F"""" `"$$$$$>>>'' `!!
+!!!!! "?$$$$$cccccc$$$$??>>>>' !!
+!!!!> "$$$$$$$$$$$$$F>>>>'' `!
+!!!!! "$$$$$$$$???>''' !
+!!!!!> `""""" `
+!!!!!!; . `
+!!!!!!! ?h.
+!!!!!!!! $$c,
+!!!!!!!!> ?$$$h. .,c
+!!!!!!!!! $$$$$$$$$hc,.,,cc$$$$$
+!!!!!!!!! .,zcc$$$$$$$$$$$$$$$$$$$$$$
+!!!!!!!!! .z$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+!!!!!!!!! ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ .
+!!!!!!!!! ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !!
+!!!!!!!!! ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ,!'
+!!!!!!!!> c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$. !'
+!!!!!!'' ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> '
+!!!'' z$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$>
+!' ,$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> ..
+ z$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$' ;!!!!''`
+ $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$F ,;;!'`' .''
+ <$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> ,;'`' ,;
+ `$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$F -' ,;!!'
+ "?$$$$$$$$$$?$$$$$$$$$$$$$$$$$$$$$$$$$$F .<!!!''' <!
+ !> ""??$$$?C3$$$$$$$$$$$$$$$$$$$$$$$$"" ;!''' !!!
+ ;!!!!;, `"''""????$$$$$$$$$$$$$$$$"" ,;-'' ',!
+ ;!!!!<!!!; . `""""""""""" `' ' '
+ !!!! ;!!! ;!!!!>;,;, .. ' . ' '
+ !!' ,;!!! ;'`!!!!!!!!;!!!!!; . >' .'' ;
+ !!' ;!!'!';! !! !!!!!!!!!!!!! ' -'
+ <!! !! `!;! `!' !!!!!!!!!!<! .
+ `! ;! ;!!! <' <!!!! `!!! < /
+ `; !> <!! ;' !!!!' !!';! ;'
+ ! ! !!! ! `!!! ;!! ! ' '
+ ; `! `!! ,' !' ;!'
+ ' /`! ! < !! < '
+ / ;! >;! ;>
+ !' ; !! '
+ ' ;! > ! '
+ '
+by Allen Mullen
--- /dev/null
+++ b/attic/dict.lsp
@@ -1,0 +1,51 @@
+; dictionary as binary tree
+
+(defun dict () ())
+
+; node representation ((k . v) L R)
+(defun dict-peek (d key nf)
+ (if (null d) nf
+ (let ((c (compare key (caar d))))
+ (cond ((= c 0) (cdar d))
+ ((< c 0) (dict-peek (cadr d) key nf))
+ (T (dict-peek (caddr d) key nf))))))
+
+(defun dict-get (d key) (dict-peek d key nil))
+
+(defun dict-put (d key v)
+ (if (null d) (list (cons key v) (dict) (dict))
+ (let ((c (compare key (caar d))))
+ (cond ((= c 0) (list (cons key v) (cadr d) (caddr d)))
+ ((< c 0) (list (car d)
+ (dict-put (cadr d) key v)
+ (caddr d)))
+ (T (list (car d)
+ (cadr d)
+ (dict-put (caddr d) key v)))))))
+
+; mutable dictionary
+(defun dict-nput (d key v)
+ (if (null d) (list (cons key v) (dict) (dict))
+ (let ((c (compare key (caar d))))
+ (cond ((= c 0) (rplacd (car d) v))
+ ((< c 0) (setf (cadr d) (dict-nput (cadr d) key v)))
+ (T (setf (caddr d) (dict-nput (caddr d) key v))))
+ d)))
+
+(defun dict-collect (f d)
+ (if (null d) ()
+ (cons (f (caar d) (cdar d)) (nconc (dict-collect f (cadr d))
+ (dict-collect f (caddr d))))))
+
+(defun dict-keys (d) (dict-collect K d))
+(defun dict-pairs (d) (dict-collect cons d))
+
+(defun dict-each (f d)
+ (if (null d) ()
+ (progn (f (caar d) (cdar d))
+ (dict-each f (cadr d))
+ (dict-each f (caddr d)))))
+
+(defun alist-to-dict (a)
+ (foldl (lambda (p d) (dict-put d (car p) (cdr p)))
+ (dict) a))
--- /dev/null
+++ b/attic/flutils.c
@@ -1,0 +1,59 @@
+typedef struct {+ size_t n, maxsize;
+ unsigned long *items;
+} ltable_t;
+
+void ltable_init(ltable_t *t, size_t n)
+{+ t->n = 0;
+ t->maxsize = n;
+ t->items = (unsigned long*)malloc(n * sizeof(unsigned long));
+}
+
+void ltable_clear(ltable_t *t)
+{+ t->n = 0;
+}
+
+void ltable_insert(ltable_t *t, unsigned long item)
+{+ unsigned long *p;
+
+ if (t->n == t->maxsize) {+ p = realloc(t->items, (t->maxsize*2)*sizeof(unsigned long));
+ if (p == NULL) return;
+ t->items = p;
+ t->maxsize *= 2;
+ }
+ t->items[t->n++] = item;
+}
+
+#define LT_NOTFOUND ((int)-1)
+
+int ltable_lookup(ltable_t *t, unsigned long item)
+{+ int i;
+ for(i=0; i < (int)t->n; i++)
+ if (t->items[i] == item)
+ return i;
+ return LT_NOTFOUND;
+}
+
+void ltable_adjoin(ltable_t *t, unsigned long item)
+{+ if (ltable_lookup(t, item) == LT_NOTFOUND)
+ ltable_insert(t, item);
+}
+
+char *snprintf_gensym_id(char *nbuf, size_t n, u_int32_t g)
+{+ size_t i=n-1;
+
+ nbuf[i--] = '\0';
+ do {+ nbuf[i--] = '0' + g%10;
+ g/=10;
+ } while (g && i);
+ nbuf[i] = 'g';
+ return &nbuf[i];
+}
--- /dev/null
+++ b/attic/plists.lsp
@@ -1,0 +1,28 @@
+; property lists. they really suck.
+(setq *plists* nil)
+
+(defun symbol-plist (sym)
+ (cdr (or (assoc sym *plists*) '(()))))
+
+(defun set-symbol-plist (sym lst)
+ (let ((p (assoc sym *plists*)))
+ (if (null p) ; sym has no plist yet
+ (setq *plists* (cons (cons sym lst) *plists*))
+ (rplacd p lst))))
+
+(defun get (sym prop)
+ (let ((pl (symbol-plist sym)))
+ (if pl
+ (let ((pr (member prop pl)))
+ (if pr (cadr pr) nil))
+ nil)))
+
+(defun put (sym prop val)
+ (let ((p (assoc sym *plists*)))
+ (if (null p) ; sym has no plist yet
+ (setq *plists* (cons (list sym prop val) *plists*))
+ (let ((pr (member prop p)))
+ (if (null pr) ; sym doesn't have this property yet
+ (rplacd p (cons prop (cons val (cdr p))))
+ (rplaca (cdr pr) val)))))
+ val)
--- /dev/null
+++ b/attic/s.c
@@ -1,0 +1,212 @@
+#include <stdio.h>
+
+struct _b {+ char a;
+ short b:9;
+};
+
+struct _bb {+ char a;
+ int :0;
+ int b:10;
+ int :0;
+ int b0:10;
+ int :0;
+ int b1:10;
+ int :0;
+ int b2:10;
+ int :0;
+ int b4:30;
+ char c;
+};
+
+union _cc {+ struct {+ char a;
+ int b:1; // bit 8
+ int b1:1; // bit 9
+ int b2:24; // bits 32..55
+ char c;
+ };
+ unsigned long long ull;
+};
+
+union _cc2 {+ struct {+ char a;
+ int b:24; // bit 8
+ int b1:1;
+ int b2:1;
+ char c;
+ };
+ unsigned long long ull;
+};
+
+union _dd {+ struct {+ int a0:10;
+ int a1:10;
+ int a2:10;
+ int a3:10;
+ int a4:10;
+ };
+ struct {+ unsigned long long ull;
+ };
+};
+
+struct _ee {+ short s:9;
+ short j:9;
+ char c;
+};
+
+typedef long long int int64_t;
+typedef unsigned long long int uint64_t;
+typedef int int32_t;
+typedef unsigned int uint32_t;
+typedef short int16_t;
+typedef unsigned short uint16_t;
+typedef char int8_t;
+typedef unsigned char uint8_t;
+
+#define lomask(type,n) (type)((((type)1)<<(n))-1)
+
+uint64_t get_u_bitfield(char *ptr, int typesz, int boffs, int blen)
+{+ uint64_t i8;
+ uint32_t i4;
+ uint16_t i2;
+ uint8_t i1;
+
+ switch (typesz) {+ case 8:
+ i8 = *(uint64_t*)ptr;
+ return (i8>>boffs) & lomask(uint64_t,blen);
+ case 4:
+ i4 = *(uint32_t*)ptr;
+ return (i4>>boffs) & lomask(uint32_t,blen);
+ case 2:
+ i2 = *(uint16_t*)ptr;
+ return (i2>>boffs) & lomask(uint16_t,blen);
+ case 1:
+ i1 = *(uint8_t*)ptr;
+ return (i1>>boffs) & lomask(uint8_t,blen);
+ }
+ //error
+ return 0;
+}
+
+int64_t get_s_bitfield(char *ptr, int typesz, int boffs, int blen)
+{+ int64_t i8;
+ int32_t i4;
+ int16_t i2;
+ int8_t i1;
+
+ switch (typesz) {+ case 8:
+ i8 = *(int64_t*)ptr;
+ return (i8<<(64-boffs-blen))>>(64-blen);
+ case 4:
+ i4 = *(int32_t*)ptr;
+ return (i4<<(32-boffs-blen))>>(32-blen);
+ case 2:
+ i2 = *(int16_t*)ptr;
+ return (i2<<(16-boffs-blen))>>(16-blen);
+ case 1:
+ i1 = *(int8_t*)ptr;
+ return (i1<<(8-boffs-blen))>>(8-blen);
+ }
+ //error
+ return 0;
+}
+
+void set_bitfield(char *ptr, int typesz, int boffs, int blen, uint64_t v)
+{+ uint64_t i8, m8;
+ uint32_t i4, m4;
+ uint16_t i2, m2;
+ uint8_t i1, m1;
+
+ switch (typesz) {+ case 8:
+ m8 = lomask(uint64_t,blen)<<boffs;
+ i8 = *(uint64_t*)ptr;
+ *(uint64_t*)ptr = (i8&~m8) | ((v<<boffs)&m8);
+ break;
+ case 4:
+ m4 = lomask(uint32_t,blen)<<boffs;
+ i4 = *(uint32_t*)ptr;
+ *(uint32_t*)ptr = (i4&~m4) | ((v<<boffs)&m4);
+ break;
+ case 2:
+ m2 = lomask(uint16_t,blen)<<boffs;
+ i2 = *(uint16_t*)ptr;
+ *(uint16_t*)ptr = (i2&~m2) | ((v<<boffs)&m2);
+ break;
+ case 1:
+ m1 = lomask(uint8_t,blen)<<boffs;
+ i1 = *(uint8_t*)ptr;
+ *(uint8_t*)ptr = (i1&~m1) | ((v<<boffs)&m1);
+ break;
+ }
+}
+
+int main()
+{+ union _cc2 c;
+ union _dd d;
+ printf("%d\n", sizeof(struct _b));+
+ printf("%d\n", sizeof(d));+ //printf("%d\n\n", sizeof(struct _bb));+
+ //printf("%d\n", (char*)&b.b - (char*)&b);+ //printf("%d\n", (char*)&b.c - (char*)&b);+ //printf("%d\n", (char*)&b.e - (char*)&b);+
+ c.ull = 0;
+ d.ull = 0;
+ //d.ull2 = 0;
+
+ d.a0 = d.a1 = d.a2 = d.a3 = d.a4 = 1;
+ printf("0x%016llx\n", d.ull);+ unsigned long long m = 1;
+ int bn = 0;
+ while (m) {+ if (d.ull & m)
+ printf("bit %d set\n", bn);+ bn++;
+ m<<=1;
+ }
+ //printf("%016x\n", d.ull2);+
+
+ c.a = 1;
+ c.b = 1;
+ c.c = 1;
+ printf("0x%016llx\n", c.ull);+ bn=0;m=1;
+ while (m) {+ if (c.ull & m)
+ printf("bit %d set\n", bn);+ bn++;
+ m<<=1;
+ }
+
+ return 0;
+}
+
+/*
+ offset/alignment rules for bit fields:
+
+ - alignment for whole struct is still the most strict of any of the
+ named types, regardless of bit fields. (i.e. just take the bit field
+ widths away and compute struct alignment normally)
+
+ - a bit field cannot cross a word boundary of its declared type
+
+ - otherwise pack bit fields as tightly as possible
+
+ */
--- /dev/null
+++ b/attic/scrap.lsp
@@ -1,0 +1,108 @@
+; -*- scheme -*-
+; (try expr
+; (catch (type-error e) . exprs)
+; (catch (io-error e) . exprs)
+; (catch (e) . exprs)
+; (finally . exprs))
+(define-macro (try expr . forms)
+ (let* ((e (gensym))
+ (reraised (gensym))
+ (final (f-body (cdr (or (assq 'finally forms) '(())))))
+ (catches (filter (lambda (f) (eq (car f) 'catch)) forms))
+ (catchblock `(cond
+ ,.(map (lambda (catc)
+ (let* ((specific (cdr (cadr catc)))
+ (extype (caadr catc))
+ (var (if specific (car specific)
+ extype))
+ (todo (cddr catc)))
+ `(,(if specific
+ ; exception matching logic
+ `(or (eq ,e ',extype)
+ (and (pair? ,e)
+ (eq (car ,e)
+ ',extype)))
+ #t); (catch (e) ...), match anything
+ (let ((,var ,e)) (begin ,@todo)))))
+ catches)
+ (#t (raise ,e))))) ; no matches, reraise
+ (if final
+ (if catches
+ ; form with both catch and finally
+ `(prog1 (trycatch ,expr
+ (lambda (,e)
+ (trycatch ,catchblock
+ (lambda (,reraised)
+ (begin ,final
+ (raise ,reraised))))))
+ ,final)
+ ; finally only; same as unwind-protect
+ `(prog1 (trycatch ,expr (lambda (,e)
+ (begin ,final (raise ,e))))
+ ,final))
+ ; catch, no finally
+ `(trycatch ,expr (lambda (,e) ,catchblock)))))
+
+; setf
+; expands (setf (place x ...) v) to (mutator (f x ...) v)
+; (mutator (identity x ...) v) is interpreted as (mutator x ... v)
+(set! *setf-place-list*
+ ; place mutator f
+ '((car rplaca identity)
+ (cdr rplacd identity)
+ (caar rplaca car)
+ (cadr rplaca cdr)
+ (cdar rplacd car)
+ (cddr rplacd cdr)
+ (caaar rplaca caar)
+ (caadr rplaca cadr)
+ (cadar rplaca cdar)
+ (caddr rplaca cddr)
+ (cdaar rplacd caar)
+ (cdadr rplacd cadr)
+ (cddar rplacd cdar)
+ (cdddr rplacd cddr)
+ (list-ref rplaca nthcdr)
+ (get put! identity)
+ (aref aset! identity)
+ (symbol-syntax set-syntax! identity)))
+
+(define (setf-place-mutator place val)
+ (if (symbol? place)
+ (list 'set! place val)
+ (let ((mutator (assq (car place) *setf-place-list*)))
+ (if (null? mutator)
+ (error "setf: unknown place " (car place))
+ (if (eq (caddr mutator) 'identity)
+ (cons (cadr mutator) (append (cdr place) (list val)))
+ (list (cadr mutator)
+ (cons (caddr mutator) (cdr place))
+ val))))))
+
+(define-macro (setf . args)
+ (f-body
+ ((label setf-
+ (lambda (args)
+ (if (null? args)
+ ()
+ (cons (setf-place-mutator (car args) (cadr args))
+ (setf- (cddr args))))))
+ args)))
+
+(define-macro (labels binds . body)
+ (cons (list 'lambda (map car binds)
+ (f-body
+ (nconc (map (lambda (b)
+ (list 'set! (car b) (cons 'lambda (cdr b))))
+ binds)
+ body)))
+ (map (lambda (x) #f) binds)))
+
+ (define (evalhead e env)
+ (if (and (symbol? e)
+ (or (constant? e)
+ (and (not (memq e env))
+ (bound? e)
+ (builtin? (eval e)))))
+ (eval e)
+ e))
--- /dev/null
+++ b/attic/system-old.lsp
@@ -1,0 +1,25 @@
+(define (equal a b)
+ (if (and (consp a) (consp b))
+ (and (equal (car a) (car b))
+ (equal (cdr a) (cdr b)))
+ (eq a b)))
+
+; compare imposes an ordering on all values. yields -1 for a<b,
+; 0 for a==b, and 1 for a>b. lists are compared up to the first
+; point of difference.
+(defun compare (a b)
+ (cond ((eq a b) 0)
+ ((or (atom a) (atom b)) (if (< a b) -1 1))
+ (T (let ((c (compare (car a) (car b))))
+ (if (not (eq c 0))
+ c
+ (compare (cdr a) (cdr b)))))))
+
+(defun length (l)
+ (if (null l) 0
+ (+ 1 (length (cdr l)))))
+
+(define (assoc item lst)
+ (cond ((atom lst) ())
+ ((eq (caar lst) item) (car lst))
+ (T (assoc item (cdr lst)))))
--- /dev/null
+++ b/attic/trash.c
@@ -1,0 +1,303 @@
+value_t prim_types[32];
+value_t *prim_sym_addrs[] = {+ &int8sym, &uint8sym, &int16sym, &uint16sym, &int32sym, &uint32sym,
+ &int64sym, &uint64sym, &charsym, &ucharsym, &shortsym, &ushortsym,
+ &intsym, &uintsym, &longsym, &ulongsym,
+ &lispvaluesym };
+#define N_PRIMSYMS (sizeof(prim_sym_addrs) / sizeof(value_t*))
+
+static value_t cv_type(cvalue_t *cv)
+{+ if (cv->flags.prim) {+ return prim_types[cv->flags.primtype];
+ }
+ return cv->type;
+}
+
+
+ double t0,t1;
+ int i;
+ int32_t i32;
+ char s8;
+ ulong_t c8=3;
+ t0 = clock(); //0.058125017
+ set_secret_symtag(ulongsym,TAG_UINT32);
+ set_secret_symtag(int8sym,TAG_INT8);
+ for(i=0; i < 8000000; i++) {+ cnvt_to_int32(&i32, &s8, int8sym);
+ c8+=c8;
+ s8+=s8;
+ }
+ t1 = clock();
+ printf("%d. that took %.16f\n", i32, t1-t0);+
+
+#define int_converter(type) \
+static int cnvt_to_##type(type##_t *i, void *data, value_t type) \
+{ \+ if (type==int32sym) *i = *(int32_t*)data; \
+ else if (type==charsym) *i = *(char*)data; \
+ else if (type==ulongsym) *i = *(ulong*)data; \
+ else if (type==uint32sym) *i = *(uint32_t*)data; \
+ else if (type==int8sym) *i = *(int8_t*)data; \
+ else if (type==uint8sym) *i = *(uint8_t*)data; \
+ else if (type==int64sym) *i = *(int64_t*)data; \
+ else if (type==uint64sym) *i = *(uint64_t*)data; \
+ else if (type==wcharsym) *i = *(wchar_t*)data; \
+ else if (type==longsym) *i = *(long*)data; \
+ else if (type==int16sym) *i = *(int16_t*)data; \
+ else if (type==uint16sym) *i = *(uint16_t*)data; \
+ else \
+ return 1; \
+ return 0; \
+}
+int_converter(int32)
+int_converter(uint32)
+int_converter(int64)
+int_converter(uint64)
+
+#ifdef BITS64
+#define cnvt_to_ulong(i,d,t) cnvt_to_uint64(i,d,t)
+#else
+#define cnvt_to_ulong(i,d,t) cnvt_to_uint32(i,d,t)
+#endif
+
+long intabs(long n)
+{+ long s = n>>(NBITS-1); // either -1 or 0
+ return (n^s) - s;
+}
+
+value_t fl_inv(value_t b)
+{+ int_t bi;
+ int tb;
+ void *bptr=NULL;
+ cvalue_t *cv;
+
+ if (isfixnum(b)) {+ bi = numval(b);
+ if (bi == 0)
+ goto inv_error;
+ else if (bi == 1)
+ return fixnum(1);
+ else if (bi == -1)
+ return fixnum(-1);
+ return fixnum(0);
+ }
+ else if (iscvalue(b)) {+ cv = (cvalue_t*)ptr(b);
+ tb = cv_numtype(cv);
+ if (tb <= T_DOUBLE)
+ bptr = cv_data(cv);
+ }
+ if (bptr == NULL)
+ type_error("/", "number", b);+
+ if (tb == T_FLOAT)
+ return mk_double(1.0/(double)*(float*)bptr);
+ if (tb == T_DOUBLE)
+ return mk_double(1.0 / *(double*)bptr);
+
+ if (tb == T_UINT64) {+ if (*(uint64_t*)bptr > 1)
+ return fixnum(0);
+ else if (*(uint64_t*)bptr == 1)
+ return fixnum(1);
+ goto inv_error;
+ }
+ int64_t b64 = conv_to_int64(bptr, tb);
+ if (b64 == 0) goto inv_error;
+ else if (b64 == 1) return fixnum(1);
+ else if (b64 == -1) return fixnum(-1);
+
+ return fixnum(0);
+ inv_error:
+ lerror(DivideError, "/: division by zero");
+}
+
+static void printstack(value_t *penv, uint32_t envsz)
+{+ int i;
+ printf("env=%d, size=%d\n", penv - &Stack[0], envsz);+ for(i=0; i < SP; i++) {+ printf("%d: ", i);+ print(stdout, Stack[i], 0);
+ printf("\n");+ }
+ printf("\n");+}
+
+// unordered comparison
+// not any faster than ordered comparison
+
+// a is a fixnum, b is a cvalue
+static value_t equal_num_cvalue(value_t a, value_t b)
+{+ cvalue_t *bcv = (cvalue_t*)ptr(b);
+ numerictype_t bt;
+ if (valid_numtype(bt=cv_numtype(bcv))) {+ fixnum_t ia = numval(a);
+ void *bptr = cv_data(bcv);
+ if (cmp_eq(&ia, T_FIXNUM, bptr, bt))
+ return fixnum(0);
+ }
+ return fixnum(1);
+}
+
+static value_t bounded_equal(value_t a, value_t b, int bound);
+static value_t cyc_equal(value_t a, value_t b, ptrhash_t *table);
+
+static value_t bounded_vector_equal(value_t a, value_t b, int bound)
+{+ size_t la = vector_size(a);
+ size_t lb = vector_size(b);
+ if (la != lb) return fixnum(1);
+ size_t i;
+ for (i = 0; i < la; i++) {+ value_t d = bounded_equal(vector_elt(a,i), vector_elt(b,i), bound-1);
+ if (d==NIL || numval(d)!=0) return d;
+ }
+ return fixnum(0);
+}
+
+static value_t bounded_equal(value_t a, value_t b, int bound)
+{+ value_t d;
+
+ compare_top:
+ if (a == b) return fixnum(0);
+ if (bound <= 0)
+ return NIL;
+ int taga = tag(a);
+ int tagb = cmptag(b);
+ switch (taga) {+ case TAG_NUM :
+ case TAG_NUM1:
+ if (isfixnum(b)) {+ return fixnum(1);
+ }
+ if (iscvalue(b)) {+ return equal_num_cvalue(a, b);
+ }
+ return fixnum(1);
+ case TAG_SYM:
+ return fixnum(1);
+ case TAG_VECTOR:
+ if (isvector(b))
+ return bounded_vector_equal(a, b, bound);
+ break;
+ case TAG_CVALUE:
+ if (iscvalue(b)) {+ cvalue_t *acv=(cvalue_t*)ptr(a), *bcv=(cvalue_t*)ptr(b);
+ numerictype_t at, bt;
+ if (valid_numtype(at=cv_numtype(acv)) &&
+ valid_numtype(bt=cv_numtype(bcv))) {+ void *aptr = cv_data(acv);
+ void *bptr = cv_data(bcv);
+ if (cmp_eq(aptr, at, bptr, bt))
+ return fixnum(0);
+ return fixnum(1);
+ }
+ return cvalue_compare(a, b);
+ }
+ else if (isfixnum(b)) {+ return equal_num_cvalue(b, a);
+ }
+ break;
+ case TAG_BUILTIN:
+ return fixnum(1);
+ case TAG_CONS:
+ if (tagb != TAG_CONS) return fixnum(1);
+ d = bounded_equal(car_(a), car_(b), bound-1);
+ if (d==NIL || numval(d) != 0) return d;
+ a = cdr_(a); b = cdr_(b);
+ bound--;
+ goto compare_top;
+ }
+ return fixnum(1);
+}
+
+static value_t cyc_vector_equal(value_t a, value_t b, ptrhash_t *table)
+{+ size_t la = vector_size(a);
+ size_t lb = vector_size(b);
+ size_t i;
+ value_t d, xa, xb, ca, cb;
+ if (la != lb) return fixnum(1);
+
+ // first try to prove them different with no recursion
+ for (i = 0; i < la; i++) {+ xa = vector_elt(a,i);
+ xb = vector_elt(b,i);
+ if (leafp(xa) || leafp(xb)) {+ d = bounded_equal(xa, xb, 1);
+ if (numval(d)!=0) return d;
+ }
+ else if (cmptag(xa) != cmptag(xb)) {+ return fixnum(1);
+ }
+ }
+
+ ca = eq_class(table, a);
+ cb = eq_class(table, b);
+ if (ca!=NIL && ca==cb)
+ return fixnum(0);
+
+ eq_union(table, a, b, ca, cb);
+
+ for (i = 0; i < la; i++) {+ xa = vector_elt(a,i);
+ xb = vector_elt(b,i);
+ if (!leafp(xa) && !leafp(xb)) {+ d = cyc_equal(xa, xb, table);
+ if (numval(d)!=0) return d;
+ }
+ }
+
+ return fixnum(0);
+}
+
+static value_t cyc_equal(value_t a, value_t b, ptrhash_t *table)
+{+ if (a==b)
+ return fixnum(0);
+ if (iscons(a)) {+ if (iscons(b)) {+ value_t aa = car_(a); value_t da = cdr_(a);
+ value_t ab = car_(b); value_t db = cdr_(b);
+ int tagaa = cmptag(aa); int tagda = cmptag(da);
+ int tagab = cmptag(ab); int tagdb = cmptag(db);
+ value_t d, ca, cb;
+ if (leafp(aa) || leafp(ab)) {+ d = bounded_equal(aa, ab, 1);
+ if (numval(d)!=0) return d;
+ }
+ else if (tagaa != tagab)
+ return fixnum(1);
+ if (leafp(da) || leafp(db)) {+ d = bounded_equal(da, db, 1);
+ if (numval(d)!=0) return d;
+ }
+ else if (tagda != tagdb)
+ return fixnum(1);
+
+ ca = eq_class(table, a);
+ cb = eq_class(table, b);
+ if (ca!=NIL && ca==cb)
+ return fixnum(0);
+
+ eq_union(table, a, b, ca, cb);
+ d = cyc_equal(aa, ab, table);
+ if (numval(d)!=0) return d;
+ return cyc_equal(da, db, table);
+ }
+ else {+ return fixnum(1);
+ }
+ }
+ else if (isvector(a) && isvector(b)) {+ return cyc_vector_equal(a, b, table);
+ }
+ return bounded_equal(a, b, 1);
+}
--- /dev/null
+++ b/bootstrap.sh
@@ -1,0 +1,14 @@
+#!/bin/sh
+
+cp flisp.boot flisp.boot.bak
+
+echo "Creating stage 0 boot file..."
+#../../branches/interpreter/femtolisp/flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot.new
+./flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot.new
+mv flisp.boot.new flisp.boot
+
+echo "Creating stage 1 boot file..."
+./flisp mkboot1.lsp
+
+echo "Testing..."
+make test
--- /dev/null
+++ b/builtins.c
@@ -1,0 +1,488 @@
+/*
+ Extra femtoLisp builtin functions
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <ctype.h>
+#include <sys/types.h>
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <errno.h>
+#include "llt.h"
+#include "flisp.h"
+#include "random.h"
+
+size_t llength(value_t v)
+{+ size_t n = 0;
+ while (iscons(v)) {+ n++;
+ v = cdr_(v);
+ }
+ return n;
+}
+
+static value_t fl_nconc(value_t *args, u_int32_t nargs)
+{+ if (nargs == 0)
+ return FL_NIL;
+ value_t lst, first=FL_NIL;
+ value_t *pcdr = &first;
+ cons_t *c;
+ uint32_t i=0;
+ while (1) {+ lst = args[i++];
+ if (i >= nargs) break;
+ if (iscons(lst)) {+ *pcdr = lst;
+ c = (cons_t*)ptr(lst);
+ while (iscons(c->cdr))
+ c = (cons_t*)ptr(c->cdr);
+ pcdr = &c->cdr;
+ }
+ else if (lst != FL_NIL) {+ type_error("nconc", "cons", lst);+ }
+ }
+ *pcdr = lst;
+ return first;
+}
+
+static value_t fl_assq(value_t *args, u_int32_t nargs)
+{+ argcount("assq", nargs, 2);+ value_t item = args[0];
+ value_t v = args[1];
+ value_t bind;
+
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == item)
+ return bind;
+ v = cdr_(v);
+ }
+ return FL_F;
+}
+
+static value_t fl_memq(value_t *args, u_int32_t nargs)
+{+ argcount("memq", nargs, 2);+ while (iscons(args[1])) {+ cons_t *c = (cons_t*)ptr(args[1]);
+ if (c->car == args[0])
+ return args[1];
+ args[1] = c->cdr;
+ }
+ return FL_F;
+}
+
+static value_t fl_length(value_t *args, u_int32_t nargs)
+{+ argcount("length", nargs, 1);+ value_t a = args[0];
+ cvalue_t *cv;
+ if (isvector(a)) {+ return fixnum(vector_size(a));
+ }
+ else if (iscprim(a)) {+ cv = (cvalue_t*)ptr(a);
+ if (cp_class(cv) == bytetype)
+ return fixnum(1);
+ else if (cp_class(cv) == wchartype)
+ return fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv)));
+ }
+ else if (iscvalue(a)) {+ cv = (cvalue_t*)ptr(a);
+ if (cv_class(cv)->eltype != NULL)
+ return size_wrap(cvalue_arraylen(a));
+ }
+ else if (a == FL_NIL) {+ return fixnum(0);
+ }
+ else if (iscons(a)) {+ return fixnum(llength(a));
+ }
+ type_error("length", "sequence", a);+}
+
+static value_t fl_f_raise(value_t *args, u_int32_t nargs)
+{+ argcount("raise", nargs, 1);+ fl_raise(args[0]);
+}
+
+static value_t fl_exit(value_t *args, u_int32_t nargs)
+{+ if (nargs > 0)
+ exit(tofixnum(args[0], "exit"));
+ exit(0);
+ return FL_NIL;
+}
+
+static value_t fl_symbol(value_t *args, u_int32_t nargs)
+{+ argcount("symbol", nargs, 1);+ if (!fl_isstring(args[0]))
+ type_error("symbol", "string", args[0]);+ return symbol(cvalue_data(args[0]));
+}
+
+static value_t fl_keywordp(value_t *args, u_int32_t nargs)
+{+ argcount("keyword?", nargs, 1);+ return (issymbol(args[0]) &&
+ iskeyword((symbol_t*)ptr(args[0]))) ? FL_T : FL_F;
+}
+
+static value_t fl_top_level_value(value_t *args, u_int32_t nargs)
+{+ argcount("top-level-value", nargs, 1);+ symbol_t *sym = tosymbol(args[0], "top-level-value");
+ if (sym->binding == UNBOUND)
+ fl_raise(fl_list2(UnboundError, args[0]));
+ return sym->binding;
+}
+
+static value_t fl_set_top_level_value(value_t *args, u_int32_t nargs)
+{+ argcount("set-top-level-value!", nargs, 2);+ symbol_t *sym = tosymbol(args[0], "set-top-level-value!");
+ if (!isconstant(sym))
+ sym->binding = args[1];
+ return args[1];
+}
+
+static void global_env_list(symbol_t *root, value_t *pv)
+{+ while (root != NULL) {+ if (root->name[0] != ':' && (root->binding != UNBOUND)) {+ *pv = fl_cons(tagptr(root,TAG_SYM), *pv);
+ }
+ global_env_list(root->left, pv);
+ root = root->right;
+ }
+}
+
+extern symbol_t *symtab;
+
+value_t fl_global_env(value_t *args, u_int32_t nargs)
+{+ (void)args;
+ argcount("environment", nargs, 0);+ value_t lst = FL_NIL;
+ fl_gc_handle(&lst);
+ global_env_list(symtab, &lst);
+ fl_free_gc_handles(1);
+ return lst;
+}
+
+extern value_t QUOTE;
+
+static value_t fl_constantp(value_t *args, u_int32_t nargs)
+{+ argcount("constant?", nargs, 1);+ if (issymbol(args[0]))
+ return (isconstant((symbol_t*)ptr(args[0])) ? FL_T : FL_F);
+ if (iscons(args[0])) {+ if (car_(args[0]) == QUOTE)
+ return FL_T;
+ return FL_F;
+ }
+ return FL_T;
+}
+
+static value_t fl_integer_valuedp(value_t *args, u_int32_t nargs)
+{+ argcount("integer-valued?", nargs, 1);+ value_t v = args[0];
+ if (isfixnum(v)) {+ return FL_T;
+ }
+ else if (iscprim(v)) {+ numerictype_t nt = cp_numtype((cprim_t*)ptr(v));
+ if (nt < T_FLOAT)
+ return FL_T;
+ void *data = cp_data((cprim_t*)ptr(v));
+ if (nt == T_FLOAT) {+ float f = *(float*)data;
+ if (f < 0) f = -f;
+ if (f <= FLT_MAXINT && (float)(int32_t)f == f)
+ return FL_T;
+ }
+ else {+ assert(nt == T_DOUBLE);
+ double d = *(double*)data;
+ if (d < 0) d = -d;
+ if (d <= DBL_MAXINT && (double)(int64_t)d == d)
+ return FL_T;
+ }
+ }
+ return FL_F;
+}
+
+static value_t fl_integerp(value_t *args, u_int32_t nargs)
+{+ argcount("integer?", nargs, 1);+ value_t v = args[0];
+ return (isfixnum(v) ||
+ (iscprim(v) && cp_numtype((cprim_t*)ptr(v)) < T_FLOAT)) ?
+ FL_T : FL_F;
+}
+
+static value_t fl_fixnum(value_t *args, u_int32_t nargs)
+{+ argcount("fixnum", nargs, 1);+ if (isfixnum(args[0])) {+ return args[0];
+ }
+ else if (iscprim(args[0])) {+ cprim_t *cp = (cprim_t*)ptr(args[0]);
+ return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp)));
+ }
+ type_error("fixnum", "number", args[0]);+}
+
+static value_t fl_truncate(value_t *args, u_int32_t nargs)
+{+ argcount("truncate", nargs, 1);+ if (isfixnum(args[0]))
+ return args[0];
+ if (iscprim(args[0])) {+ cprim_t *cp = (cprim_t*)ptr(args[0]);
+ void *data = cp_data(cp);
+ numerictype_t nt = cp_numtype(cp);
+ double d;
+ if (nt == T_FLOAT)
+ d = (double)*(float*)data;
+ else if (nt == T_DOUBLE)
+ d = *(double*)data;
+ else
+ return args[0];
+ if (d > 0) {+ if (d > (double)U64_MAX)
+ return args[0];
+ return return_from_uint64((uint64_t)d);
+ }
+ if (d > (double)S64_MAX || d < (double)S64_MIN)
+ return args[0];
+ return return_from_int64((int64_t)d);
+ }
+ type_error("truncate", "number", args[0]);+}
+
+static value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
+{+ fixnum_t i;
+ value_t f, v;
+ if (nargs == 0)
+ lerror(ArgError, "vector.alloc: too few arguments");
+ i = (fixnum_t)toulong(args[0], "vector.alloc");
+ if (i < 0)
+ lerror(ArgError, "vector.alloc: invalid size");
+ if (nargs == 2)
+ f = args[1];
+ else
+ f = FL_UNSPECIFIED;
+ v = alloc_vector((unsigned)i, f==FL_UNSPECIFIED);
+ if (f != FL_UNSPECIFIED) {+ int k;
+ for(k=0; k < i; k++)
+ vector_elt(v,k) = f;
+ }
+ return v;
+}
+
+static value_t fl_time_now(value_t *args, u_int32_t nargs)
+{+ argcount("time.now", nargs, 0);+ (void)args;
+ return mk_double(clock_now());
+}
+
+static double todouble(value_t a, char *fname)
+{+ if (isfixnum(a))
+ return (double)numval(a);
+ if (iscprim(a)) {+ cprim_t *cp = (cprim_t*)ptr(a);
+ numerictype_t nt = cp_numtype(cp);
+ return conv_to_double(cp_data(cp), nt);
+ }
+ type_error(fname, "number", a);
+}
+
+static value_t fl_time_string(value_t *args, uint32_t nargs)
+{+ argcount("time.string", nargs, 1);+ double t = todouble(args[0], "time.string");
+ char buf[64];
+ timestring(t, buf, sizeof(buf));
+ return string_from_cstr(buf);
+}
+
+static value_t fl_time_fromstring(value_t *args, uint32_t nargs)
+{+ argcount("time.fromstring", nargs, 1);+ char *ptr = tostring(args[0], "time.fromstring");
+ double t = parsetime(ptr);
+ int64_t it = (int64_t)t;
+ if ((double)it == t && fits_fixnum(it))
+ return fixnum(it);
+ return mk_double(t);
+}
+
+static value_t fl_path_cwd(value_t *args, uint32_t nargs)
+{+ if (nargs > 1)
+ argcount("path.cwd", nargs, 1);+ if (nargs == 0) {+ char buf[1024];
+ get_cwd(buf, sizeof(buf));
+ return string_from_cstr(buf);
+ }
+ char *ptr = tostring(args[0], "path.cwd");
+ if (set_cwd(ptr))
+ lerrorf(IOError, "path.cwd: could not cd to %s", ptr);
+ return FL_T;
+}
+
+#ifdef WIN32
+#define stat _stat
+#endif
+static value_t fl_path_exists(value_t *args, uint32_t nargs)
+{+ argcount("path.exists?", nargs, 1);+ char *str = tostring(args[0], "path.exists?");
+ struct stat sbuf;
+ if (stat(str, &sbuf) == -1)
+ return FL_F;
+ return FL_T;
+}
+
+static value_t fl_os_getenv(value_t *args, uint32_t nargs)
+{+ argcount("os.getenv", nargs, 1);+ char *name = tostring(args[0], "os.getenv");
+ char *val = getenv(name);
+ if (val == NULL) return FL_F;
+ if (*val == 0)
+ return symbol_value(emptystringsym);
+ return cvalue_static_cstring(val);
+}
+
+static value_t fl_os_setenv(value_t *args, uint32_t nargs)
+{+ argcount("os.setenv", nargs, 2);+ char *name = tostring(args[0], "os.setenv");
+ int result;
+ if (args[1] == FL_F) {+#ifdef LINUX
+ result = unsetenv(name);
+#else
+ (void)unsetenv(name);
+ result = 0;
+#endif
+ }
+ else {+ char *val = tostring(args[1], "os.setenv");
+ result = setenv(name, val, 1);
+ }
+ if (result != 0)
+ lerror(ArgError, "os.setenv: invalid environment variable");
+ return FL_T;
+}
+
+static value_t fl_rand(value_t *args, u_int32_t nargs)
+{+ (void)args; (void)nargs;
+ fixnum_t r;
+#ifdef BITS64
+ r = ((((uint64_t)random())<<32) | random()) & 0x1fffffffffffffffLL;
+#else
+ r = random() & 0x1fffffff;
+#endif
+ return fixnum(r);
+}
+static value_t fl_rand32(value_t *args, u_int32_t nargs)
+{+ (void)args; (void)nargs;
+ uint32_t r = random();
+#ifdef BITS64
+ return fixnum(r);
+#else
+ return mk_uint32(r);
+#endif
+}
+static value_t fl_rand64(value_t *args, u_int32_t nargs)
+{+ (void)args; (void)nargs;
+ uint64_t r = (((uint64_t)random())<<32) | random();
+ return mk_uint64(r);
+}
+static value_t fl_randd(value_t *args, u_int32_t nargs)
+{+ (void)args; (void)nargs;
+ return mk_double(rand_double());
+}
+static value_t fl_randf(value_t *args, u_int32_t nargs)
+{+ (void)args; (void)nargs;
+ return mk_float(rand_float());
+}
+
+extern void stringfuncs_init();
+extern void table_init();
+extern void iostream_init();
+
+static builtinspec_t builtin_info[] = {+ { "environment", fl_global_env },+ { "constant?", fl_constantp },+ { "top-level-value", fl_top_level_value },+ { "set-top-level-value!", fl_set_top_level_value },+ { "raise", fl_f_raise },+ { "exit", fl_exit },+ { "symbol", fl_symbol },+ { "keyword?", fl_keywordp },+
+ { "fixnum", fl_fixnum },+ { "truncate", fl_truncate },+ { "integer?", fl_integerp },+ { "integer-valued?", fl_integer_valuedp },+ { "nconc", fl_nconc },+ { "append!", fl_nconc },+ { "assq", fl_assq },+ { "memq", fl_memq },+ { "length", fl_length },+
+ { "vector.alloc", fl_vector_alloc },+
+ { "time.now", fl_time_now },+ { "time.string", fl_time_string },+ { "time.fromstring", fl_time_fromstring },+
+ { "rand", fl_rand },+ { "rand.uint32", fl_rand32 },+ { "rand.uint64", fl_rand64 },+ { "rand.double", fl_randd },+ { "rand.float", fl_randf },+
+ { "path.cwd", fl_path_cwd },+ { "path.exists?", fl_path_exists },+
+ { "os.getenv", fl_os_getenv },+ { "os.setenv", fl_os_setenv },+ { NULL, NULL }+};
+
+void builtins_init()
+{+ assign_global_builtins(builtin_info);
+ stringfuncs_init();
+ table_init();
+ iostream_init();
+}
--- /dev/null
+++ b/compiler.lsp
@@ -1,0 +1,754 @@
+; -*- scheme -*-
+
+(define Instructions
+ (let ((e (table))
+ (keys
+ [nop dup pop call tcall jmp brf brt jmp.l brf.l brt.l ret
+
+ eq? eqv? equal? atom? not null? boolean? symbol?
+ number? bound? pair? builtin? vector? fixnum? function?
+
+ cons list car cdr set-car! set-cdr!
+ apply
+
+ + - * / div0 = < compare
+
+ vector aref aset!
+
+ loadt loadf loadnil load0 load1 loadi8
+ loadv loadv.l
+ loadg loadg.l
+ loada loada.l loadc loadc.l
+ setg setg.l
+ seta seta.l setc setc.l
+
+ closure argc vargc trycatch for tapply
+ add2 sub2 neg largc lvargc
+ loada0 loada1 loadc00 loadc01 call.l tcall.l
+ brne brne.l cadr brnn brnn.l brn brn.l
+ optargs brbound keyargs
+
+ dummy_t dummy_f dummy_nil]))
+ (for 0 (1- (length keys))
+ (lambda (i)
+ (put! e (aref keys i) i)))))
+
+(define arg-counts
+ (table eq? 2 eqv? 2
+ equal? 2 atom? 1
+ not 1 null? 1
+ boolean? 1 symbol? 1
+ number? 1 bound? 1
+ pair? 1 builtin? 1
+ vector? 1 fixnum? 1
+ cons 2 car 1
+ cdr 1 set-car! 2
+ set-cdr! 2 = 2
+ < 2 compare 2
+ aref 2 aset! 3
+ div0 2))
+
+(define (make-code-emitter) (vector () (table) 0 +inf.0))
+(define (bcode:code b) (aref b 0))
+(define (bcode:ctable b) (aref b 1))
+(define (bcode:nconst b) (aref b 2))
+(define (bcode:cdepth b d) (aset! b 3 (min (aref b 3) d)))
+; get an index for a referenced value in a bytecode object
+(define (bcode:indexfor b v)
+ (let ((const-to-idx (bcode:ctable b))
+ (nconst (bcode:nconst b)))
+ (if (has? const-to-idx v)
+ (get const-to-idx v)
+ (begin (put! const-to-idx v nconst)
+ (prog1 nconst
+ (aset! b 2 (+ nconst 1)))))))
+(define (emit e inst . args)
+ (if (null? args)
+ (if (and (eq? inst 'car) (pair? (aref e 0))
+ (eq? (car (aref e 0)) 'cdr))
+ (set-car! (aref e 0) 'cadr)
+ (aset! e 0 (cons inst (aref e 0))))
+ (begin
+ (if (memq inst '(loadv loadg setg))
+ (set! args (list (bcode:indexfor e (car args)))))
+ (let ((longform
+ (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)
+ (loada loada.l) (seta seta.l)))))
+ (if (and longform
+ (> (car args) 255))
+ (set! inst (cadr longform))))
+ (let ((longform
+ (assq inst '((loadc loadc.l) (setc setc.l)))))
+ (if (and longform
+ (or (> (car args) 255)
+ (> (cadr args) 255)))
+ (set! inst (cadr longform))))
+ (if (eq? inst 'loada)
+ (cond ((equal? args '(0))
+ (set! inst 'loada0)
+ (set! args ()))
+ ((equal? args '(1))
+ (set! inst 'loada1)
+ (set! args ()))))
+ (if (eq? inst 'loadc)
+ (cond ((equal? args '(0 0))
+ (set! inst 'loadc00)
+ (set! args ()))
+ ((equal? args '(0 1))
+ (set! inst 'loadc01)
+ (set! args ()))))
+
+ (let ((lasti (if (pair? (aref e 0))
+ (car (aref e 0)) ()))
+ (bc (aref e 0)))
+ (cond ((and
+ (eq? inst 'brf)
+ (cond ((and (eq? lasti 'not)
+ (eq? (cadr bc) 'null?))
+ (aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
+ ((eq? lasti 'not)
+ (aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
+ ((eq? lasti 'eq?)
+ (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
+ ((eq? lasti 'null?)
+ (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
+ (else #f))))
+ ((and (eq? inst 'brt) (eq? lasti 'null?))
+ (aset! e 0 (cons (car args) (cons 'brn (cdr bc)))))
+ (else
+ (aset! e 0 (nreconc (cons inst args) bc)))))))
+ e)
+
+(define (make-label e) (gensym))
+(define (mark-label e l) (emit e 'label l))
+
+; convert symbolic bytecode representation to a byte array.
+; labels are fixed-up.
+(define (encode-byte-code e)
+ (let* ((cl (reverse! e))
+ (v (list->vector cl))
+ (long? (>= (+ (length v) ; 1 byte for each entry, plus...
+ ; at most half the entries in this vector can be
+ ; instructions accepting 32-bit arguments
+ (* 3 (div0 (length v) 2)))
+ 65536)))
+ (let ((n (length v))
+ (i 0)
+ (label-to-loc (table))
+ (fixup-to-label (table))
+ (bcode (buffer))
+ (vi #f)
+ (nxt #f))
+ (io.write bcode #int32(0))
+ (while (< i n)
+ (begin
+ (set! vi (aref v i))
+ (if (eq? vi 'label)
+ (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
+ (set! i (+ i 2)))
+ (begin
+ (io.write bcode
+ (byte
+ (get Instructions
+ (if long?
+ (case vi
+ (jmp 'jmp.l)
+ (brt 'brt.l)
+ (brf 'brf.l)
+ (brne 'brne.l)
+ (brnn 'brnn.l)
+ (brn 'brn.l)
+ (else vi))
+ vi))))
+ (set! i (+ i 1))
+ (set! nxt (if (< i n) (aref v i) #f))
+ (cond ((memq vi '(jmp brf brt brne brnn brn))
+ (put! fixup-to-label (sizeof bcode) nxt)
+ (io.write bcode ((if long? int32 int16) 0))
+ (set! i (+ i 1)))
+ ((eq? vi 'brbound)
+ (io.write bcode (int32 nxt))
+ (set! i (+ i 1)))
+ ((number? nxt)
+ (case vi
+ ((loadv.l loadg.l setg.l loada.l seta.l
+ largc lvargc call.l tcall.l)
+ (io.write bcode (int32 nxt))
+ (set! i (+ i 1)))
+
+ ((loadc setc) ; 2 uint8 args
+ (io.write bcode (uint8 nxt))
+ (set! i (+ i 1))
+ (io.write bcode (uint8 (aref v i)))
+ (set! i (+ i 1)))
+
+ ((loadc.l setc.l optargs keyargs) ; 2 int32 args
+ (io.write bcode (int32 nxt))
+ (set! i (+ i 1))
+ (io.write bcode (int32 (aref v i)))
+ (set! i (+ i 1))
+ (if (eq? vi 'keyargs)
+ (begin (io.write bcode (int32 (aref v i)))
+ (set! i (+ i 1)))))
+
+ (else
+ ; other number arguments are always uint8
+ (io.write bcode (uint8 nxt))
+ (set! i (+ i 1)))))
+ (else #f))))))
+
+ (table.foreach
+ (lambda (addr labl)
+ (begin (io.seek bcode addr)
+ (io.write bcode ((if long? int32 int16)
+ (- (get label-to-loc labl)
+ addr)))))
+ fixup-to-label)
+ (io.tostring! bcode))))
+
+(define (const-to-idx-vec e)
+ (let ((cvec (vector.alloc (bcode:nconst e))))
+ (table.foreach (lambda (val idx) (aset! cvec idx val))
+ (bcode:ctable e))
+ cvec))
+
+(define (index-of item lst start)
+ (cond ((null? lst) #f)
+ ((eq? item (car lst)) start)
+ (else (index-of item (cdr lst) (+ start 1)))))
+
+(define (in-env? s env)
+ (and (pair? env)
+ (or (memq s (car env))
+ (in-env? s (cdr env)))))
+
+(define (lookup-sym s env lev arg?)
+ (if (null? env)
+ '(global)
+ (let* ((curr (car env))
+ (i (index-of s curr 0)))
+ (if i
+ (if arg?
+ i
+ (cons lev i))
+ (lookup-sym s
+ (cdr env)
+ (if (or arg? (null? curr)) lev (+ lev 1))
+ #f)))))
+
+; number of non-nulls
+(define (nnn e) (count (lambda (x) (not (null? x))) e))
+
+(define (printable? x) (not (or (iostream? x)
+ (eof-object? x))))
+
+(define (compile-sym g env s Is)
+ (let ((loc (lookup-sym s env 0 #t)))
+ (cond ((number? loc) (emit g (aref Is 0) loc))
+ ((number? (car loc)) (emit g (aref Is 1) (car loc) (cdr loc))
+ ; update index of most distant captured frame
+ (bcode:cdepth g (- (nnn (cdr env)) 1 (car loc))))
+ (else
+ (if (and (constant? s)
+ (printable? (top-level-value s)))
+ (emit g 'loadv (top-level-value s))
+ (emit g (aref Is 2) s))))))
+
+(define (compile-if g env tail? x)
+ (let ((elsel (make-label g))
+ (endl (make-label g))
+ (test (cadr x))
+ (then (caddr x))
+ (else (if (pair? (cdddr x))
+ (cadddr x)
+ (void))))
+ (cond ((eq? test #t)
+ (compile-in g env tail? then))
+ ((eq? test #f)
+ (compile-in g env tail? else))
+ (else
+ (compile-in g env #f test)
+ (emit g 'brf elsel)
+ (compile-in g env tail? then)
+ (if tail?
+ (emit g 'ret)
+ (emit g 'jmp endl))
+ (mark-label g elsel)
+ (compile-in g env tail? else)
+ (mark-label g endl)))))
+
+(define (compile-begin g env tail? forms)
+ (cond ((atom? forms) (compile-in g env tail? (void)))
+ ((atom? (cdr forms))
+ (compile-in g env tail? (car forms)))
+ (else
+ (compile-in g env #f (car forms))
+ (emit g 'pop)
+ (compile-begin g env tail? (cdr forms)))))
+
+(define (compile-prog1 g env x)
+ (compile-in g env #f (cadr x))
+ (if (pair? (cddr x))
+ (begin (compile-begin g env #f (cddr x))
+ (emit g 'pop))))
+
+(define (compile-while g env cond body)
+ (let ((top (make-label g))
+ (end (make-label g)))
+ (compile-in g env #f (void))
+ (mark-label g top)
+ (compile-in g env #f cond)
+ (emit g 'brf end)
+ (emit g 'pop)
+ (compile-in g env #f body)
+ (emit g 'jmp top)
+ (mark-label g end)))
+
+(define (1arg-lambda? func)
+ (and (pair? func)
+ (eq? (car func) 'lambda)
+ (pair? (cdr func))
+ (pair? (cadr func))
+ (length= (cadr func) 1)))
+
+(define (compile-for g env lo hi func)
+ (if (1arg-lambda? func)
+ (begin (compile-in g env #f lo)
+ (compile-in g env #f hi)
+ (compile-in g env #f func)
+ (emit g 'for))
+ (error "for: third form must be a 1-argument lambda")))
+
+(define (compile-short-circuit g env tail? forms default branch)
+ (cond ((atom? forms) (compile-in g env tail? default))
+ ((atom? (cdr forms)) (compile-in g env tail? (car forms)))
+ (else
+ (let ((end (make-label g)))
+ (compile-in g env #f (car forms))
+ (emit g 'dup)
+ (emit g branch end)
+ (emit g 'pop)
+ (compile-short-circuit g env tail? (cdr forms) default branch)
+ (mark-label g end)))))
+
+(define (compile-and g env tail? forms)
+ (compile-short-circuit g env tail? forms #t 'brf))
+(define (compile-or g env tail? forms)
+ (compile-short-circuit g env tail? forms #f 'brt))
+
+(define (compile-arglist g env lst)
+ (for-each (lambda (a)
+ (compile-in g env #f a))
+ lst)
+ (length lst))
+
+(define (argc-error head count)
+ (error "compile error: " head " expects " count
+ (if (= count 1)
+ " argument."
+ " arguments.")))
+
+(define builtin->instruction
+ (let ((b2i (table number? 'number? cons 'cons
+ fixnum? 'fixnum? equal? 'equal?
+ eq? 'eq? symbol? 'symbol?
+ div0 'div0 builtin? 'builtin?
+ aset! 'aset! - '- boolean? 'boolean? not 'not
+ apply 'apply atom? 'atom?
+ set-cdr! 'set-cdr! / '/
+ function? 'function? vector 'vector
+ list 'list bound? 'bound?
+ < '< * '* cdr 'cdr null? 'null?
+ + '+ eqv? 'eqv? compare 'compare aref 'aref
+ set-car! 'set-car! car 'car
+ pair? 'pair? = '= vector? 'vector?)))
+ (lambda (b)
+ (get b2i b #f))))
+
+(define (compile-builtin-call g env tail? x head b nargs)
+ (let ((count (get arg-counts b #f)))
+ (if (and count
+ (not (length= (cdr x) count)))
+ (argc-error head count))
+ (case b ; handle special cases of vararg builtins
+ (list (if (= nargs 0) (emit g 'loadnil) (emit g b nargs)))
+ (+ (cond ((= nargs 0) (emit g 'load0))
+ ((= nargs 2) (emit g 'add2))
+ (else (emit g b nargs))))
+ (- (cond ((= nargs 0) (argc-error head 1))
+ ((= nargs 1) (emit g 'neg))
+ ((= nargs 2) (emit g 'sub2))
+ (else (emit g b nargs))))
+ (* (if (= nargs 0) (emit g 'load1)
+ (emit g b nargs)))
+ (/ (if (= nargs 0)
+ (argc-error head 1)
+ (emit g b nargs)))
+ (vector (if (= nargs 0)
+ (emit g 'loadv [])
+ (emit g b nargs)))
+ (apply (if (< nargs 2)
+ (argc-error head 2)
+ (emit g (if tail? 'tapply 'apply) nargs)))
+ (else (emit g b)))))
+
+(define (compile-app g env tail? x)
+ (let ((head (car x)))
+ (let ((head
+ (if (and (symbol? head)
+ (not (in-env? head env))
+ (bound? head)
+ (constant? head)
+ (builtin? (top-level-value head)))
+ (top-level-value head)
+ head)))
+ (if (length> (cdr x) 255)
+ ; more than 255 arguments, need long versions of instructions
+ (begin (compile-in g env #f head)
+ (let ((nargs (compile-arglist g env (cdr x))))
+ (emit g (if tail? 'tcall.l 'call.l) nargs)))
+ (let ((b (and (builtin? head)
+ (builtin->instruction head))))
+ (if (and (eq? head 'cadr)
+ (not (in-env? head env))
+ (equal? (top-level-value 'cadr) cadr)
+ (length= x 2))
+ (begin (compile-in g env #f (cadr x))
+ (emit g 'cadr))
+ (begin
+ (if (not b)
+ (compile-in g env #f head))
+ (let ((nargs (compile-arglist g env (cdr x))))
+ (if b
+ (compile-builtin-call g env tail? x head b nargs)
+ (emit g (if tail? 'tcall 'call) nargs))))))))))
+
+(define (expand-define x)
+ (let ((form (cadr x))
+ (body (if (pair? (cddr x))
+ (cddr x)
+ (if (symbol? (cadr x))
+ `(,(void))
+ (error "compile error: invalid syntax "
+ (print-to-string x))))))
+ (if (symbol? form)
+ `(set! ,form ,(car body))
+ `(set! ,(car form)
+ (lambda ,(cdr form) ,@body . ,(car form))))))
+
+(define (fits-i8 x) (and (fixnum? x) (>= x -128) (<= x 127)))
+
+(define (compile-in g env tail? x)
+ (cond ((symbol? x) (compile-sym g env x [loada loadc loadg]))
+ ((atom? x)
+ (cond ((eq? x 0) (emit g 'load0))
+ ((eq? x 1) (emit g 'load1))
+ ((eq? x #t) (emit g 'loadt))
+ ((eq? x #f) (emit g 'loadf))
+ ((eq? x ()) (emit g 'loadnil))
+ ((fits-i8 x) (emit g 'loadi8 x))
+ ((eof-object? x)
+ (compile-in g env tail? (list (top-level-value 'eof-object))))
+ (else (emit g 'loadv x))))
+ ((or (not (symbol? (car x))) (bound? (car x)) (in-env? (car x) env))
+ (compile-app g env tail? x))
+ (else
+ (case (car x)
+ (quote (if (self-evaluating? (cadr x))
+ (compile-in g env tail? (cadr x))
+ (emit g 'loadv (cadr x))))
+ (if (compile-if g env tail? x))
+ (begin (compile-begin g env tail? (cdr x)))
+ (prog1 (compile-prog1 g env x))
+ (lambda (receive (the-f dept) (compile-f- env x)
+ (begin (emit g 'loadv the-f)
+ (bcode:cdepth g dept)
+ (if (< dept (nnn env))
+ (emit g 'closure)))))
+ (and (compile-and g env tail? (cdr x)))
+ (or (compile-or g env tail? (cdr x)))
+ (while (compile-while g env (cadr x) (cons 'begin (cddr x))))
+ (for (compile-for g env (cadr x) (caddr x) (cadddr x)))
+ (return (compile-in g env #t (cadr x))
+ (emit g 'ret))
+ (set! (compile-in g env #f (caddr x))
+ (compile-sym g env (cadr x) [seta setc setg]))
+ (define (compile-in g env tail?
+ (expand-define x)))
+ (trycatch (compile-in g env #f `(lambda () ,(cadr x)))
+ (unless (1arg-lambda? (caddr x))
+ (error "trycatch: second form must be a 1-argument lambda"))
+ (compile-in g env #f (caddr x))
+ (emit g 'trycatch))
+ (else (compile-app g env tail? x))))))
+
+(define (compile-f env f)
+ (receive (ff ignore)
+ (compile-f- env f)
+ ff))
+
+(define get-defined-vars
+ (letrec ((get-defined-vars-
+ (lambda (expr)
+ (cond ((atom? expr) ())
+ ((and (eq? (car expr) 'define)
+ (pair? (cdr expr)))
+ (or (and (symbol? (cadr expr))
+ (list (cadr expr)))
+ (and (pair? (cadr expr))
+ (symbol? (caadr expr))
+ (list (caadr expr)))
+ ()))
+ ((eq? (car expr) 'begin)
+ (apply nconc (map get-defined-vars- (cdr expr))))
+ (else ())))))
+ (lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
+
+(define (keyword-arg? x) (and (pair? x) (keyword? (car x))))
+(define (keyword->symbol k)
+ (if (keyword? k)
+ (symbol (let ((s (string k)))
+ (string.sub s 0 (string.dec s (length s)))))
+ k))
+
+(define (lambda-arg-names argl)
+ (map! (lambda (s) (if (pair? s) (keyword->symbol (car s)) s))
+ (to-proper argl)))
+
+(define (lambda-vars l)
+ (define (check-formals l o opt kw)
+ (cond ((or (null? l) (symbol? l)) #t)
+ ((and (pair? l) (symbol? (car l)))
+ (if (or opt kw)
+ (error "compile error: invalid argument list "
+ o ". optional arguments must come after required.")
+ (check-formals (cdr l) o opt kw)))
+ ((and (pair? l) (pair? (car l)))
+ (unless (and (length= (car l) 2)
+ (symbol? (caar l)))
+ (error "compile error: invalid optional argument " (car l)
+ " in list " o))
+ (if (keyword? (caar l))
+ (check-formals (cdr l) o opt #t)
+ (if kw
+ (error "compile error: invalid argument list "
+ o ". keyword arguments must come last.")
+ (check-formals (cdr l) o #t kw))))
+ ((pair? l)
+ (error "compile error: invalid formal argument " (car l)
+ " in list " o))
+ (else
+ (if (eq? l o)
+ (error "compile error: invalid argument list " o)
+ (error "compile error: invalid formal argument " l
+ " in list " o)))))
+ (check-formals l l #f #f)
+ (lambda-arg-names l))
+
+(define (emit-optional-arg-inits g env opta vars i)
+ ; i is the lexical var index of the opt arg to process next
+ (if (pair? opta)
+ (let ((nxt (make-label g)))
+ (emit g 'brbound i)
+ (emit g 'brt nxt)
+ (compile-in g (cons (list-head vars i) env) #f (cadar opta))
+ (emit g 'seta i)
+ (emit g 'pop)
+ (mark-label g nxt)
+ (emit-optional-arg-inits g env (cdr opta) vars (+ i 1)))))
+
+#;(define (free-vars e)
+ (cond ((symbol? e) (list e))
+ ((or (atom? e) (eq? (car e) 'quote)) ())
+ ((eq? (car e) 'lambda)
+ (diff (free-vars (cddr e))
+ (nconc (get-defined-vars (cons 'begin (cddr e)))
+ (lambda-arg-names (cadr e)))))
+ (else (delete-duplicates (apply nconc (map free-vars (cdr e)))))))
+
+(define compile-f-
+ (let ((*defines-processed-token* (gensym)))
+ ; to eval a top-level expression we need to avoid internal define
+ (set-top-level-value!
+ 'compile-thunk
+ (lambda (expr)
+ (compile `(lambda () ,expr . ,*defines-processed-token*))))
+
+ (lambda (env f)
+ ; convert lambda to one body expression and process internal defines
+ (define (lambda-body e)
+ (let ((B (if (pair? (cddr e))
+ (if (pair? (cdddr e))
+ (cons 'begin (cddr e))
+ (caddr e))
+ (void))))
+ (let ((V (get-defined-vars B)))
+ (if (null? V)
+ B
+ (cons (list* 'lambda V B *defines-processed-token*)
+ (map (lambda (x) (void)) V))))))
+ (define (lam:body f)
+ (if (eq? (lastcdr f) *defines-processed-token*)
+ (caddr f)
+ (lambda-body f)))
+
+ (let ((g (make-code-emitter))
+ (args (cadr f))
+ (atail (lastcdr (cadr f)))
+ (vars (lambda-vars (cadr f)))
+ (opta (filter pair? (cadr f)))
+ (name (if (eq? (lastcdr f) *defines-processed-token*)
+ 'lambda
+ (lastcdr f))))
+ (let* ((nargs (if (atom? args) 0 (length args)))
+ (nreq (- nargs (length opta)))
+ (kwa (filter keyword-arg? opta)))
+
+ ; emit argument checking prologue
+ (if (not (null? opta))
+ (begin
+ (if (null? kwa)
+ (emit g 'optargs nreq
+ (if (null? atail) nargs (- nargs)))
+ (begin
+ (bcode:indexfor g (make-perfect-hash-table
+ (map cons
+ (map car kwa)
+ (iota (length kwa)))))
+ (emit g 'keyargs nreq (length kwa)
+ (if (null? atail) nargs (- nargs)))))
+ (emit-optional-arg-inits g env opta vars nreq)))
+
+ (cond ((> nargs 255) (emit g (if (null? atail)
+ 'largc 'lvargc)
+ nargs))
+ ((not (null? atail)) (emit g 'vargc nargs))
+ ((null? opta) (emit g 'argc nargs)))
+
+ ; compile body and return
+ (compile-in g (cons vars env) #t (lam:body f))
+ (emit g 'ret)
+ (values (function (encode-byte-code (bcode:code g))
+ (const-to-idx-vec g) name)
+ (aref g 3)))))))
+
+(define (compile f) (compile-f () f))
+
+(define (ref-int32-LE a i)
+ (int32 (+ (ash (aref a (+ i 0)) 0)
+ (ash (aref a (+ i 1)) 8)
+ (ash (aref a (+ i 2)) 16)
+ (ash (aref a (+ i 3)) 24))))
+
+(define (ref-int16-LE a i)
+ (int16 (+ (ash (aref a (+ i 0)) 0)
+ (ash (aref a (+ i 1)) 8))))
+
+(define (hex5 n)
+ (string.lpad (number->string n 16) 5 #\0))
+
+(define (disassemble f . lev?)
+ (if (null? lev?)
+ (begin (disassemble f 0)
+ (newline)
+ (return #t)))
+ (let ((lev (car lev?))
+ (code (function:code f))
+ (vals (function:vals f)))
+ (define (print-val v)
+ (if (and (function? v) (not (builtin? v)))
+ (begin (princ "\n")
+ (disassemble v (+ lev 1)))
+ (print v)))
+ (dotimes (xx lev) (princ "\t"))
+ (princ "maxstack " (ref-int32-LE code 0) "\n")
+ (let ((i 4)
+ (N (length code)))
+ (while (< i N)
+ ; find key whose value matches the current byte
+ (let ((inst (table.foldl (lambda (k v z)
+ (or z (and (eq? v (aref code i))
+ k)))
+ #f Instructions)))
+ (if (> i 4) (newline))
+ (dotimes (xx lev) (princ "\t"))
+ (princ (hex5 (- i 4)) ": "
+ (string inst) "\t")
+ (set! i (+ i 1))
+ (case inst
+ ((loadv.l loadg.l setg.l)
+ (print-val (aref vals (ref-int32-LE code i)))
+ (set! i (+ i 4)))
+
+ ((loadv loadg setg)
+ (print-val (aref vals (aref code i)))
+ (set! i (+ i 1)))
+
+ ((loada seta call tcall list + - * / vector
+ argc vargc loadi8 apply tapply)
+ (princ (number->string (aref code i)))
+ (set! i (+ i 1)))
+
+ ((loada.l seta.l largc lvargc call.l tcall.l)
+ (princ (number->string (ref-int32-LE code i)))
+ (set! i (+ i 4)))
+
+ ((loadc setc)
+ (princ (number->string (aref code i)) " ")
+ (set! i (+ i 1))
+ (princ (number->string (aref code i)))
+ (set! i (+ i 1)))
+
+ ((loadc.l setc.l optargs keyargs)
+ (princ (number->string (ref-int32-LE code i)) " ")
+ (set! i (+ i 4))
+ (princ (number->string (ref-int32-LE code i)))
+ (set! i (+ i 4))
+ (if (eq? inst 'keyargs)
+ (begin
+ (princ " ")
+ (princ (number->string (ref-int32-LE code i)) " ")
+ (set! i (+ i 4)))))
+
+ ((brbound)
+ (princ (number->string (ref-int32-LE code i)) " ")
+ (set! i (+ i 4)))
+
+ ((jmp brf brt brne brnn brn)
+ (princ "@" (hex5 (+ i -4 (ref-int16-LE code i))))
+ (set! i (+ i 2)))
+
+ ((jmp.l brf.l brt.l brne.l brnn.l brn.l)
+ (princ "@" (hex5 (+ i -4 (ref-int32-LE code i))))
+ (set! i (+ i 4)))
+
+ (else #f)))))))
+
+; From SRFI 89 by Marc Feeley (http://srfi.schemers.org/srfi-89/srfi-89.html)
+; Copyright (C) Marc Feeley 2006. All Rights Reserved.
+;
+; "alist" is a list of pairs of the form "(keyword . value)"
+; The result is a perfect hash-table represented as a vector of
+; length 2*N, where N is the hash modulus. If the keyword K is in
+; the hash-table it is at index
+;
+; X = (* 2 ($hash-keyword K N))
+;
+; and the associated value is at index X+1.
+(define (make-perfect-hash-table alist)
+ (define ($hash-keyword key n) (mod0 (abs (hash key)) n))
+ (let loop1 ((n (length alist)))
+ (let ((v (vector.alloc (* 2 n) #f)))
+ (let loop2 ((lst alist))
+ (if (pair? lst)
+ (let ((key (caar lst)))
+ (let ((x (* 2 ($hash-keyword key n))))
+ (if (aref v x)
+ (loop1 (+ n 1))
+ (begin
+ (aset! v x key)
+ (aset! v (+ x 1) (cdar lst))
+ (loop2 (cdr lst))))))
+ v)))))
+
+#t
--- /dev/null
+++ b/cvalues.c
@@ -1,0 +1,1533 @@
+#ifdef BITS64
+#define NWORDS(sz) (((sz)+7)>>3)
+#else
+#define NWORDS(sz) (((sz)+3)>>2)
+#endif
+
+static int ALIGN2, ALIGN4, ALIGN8, ALIGNPTR;
+
+value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
+value_t int64sym, uint64sym;
+value_t longsym, ulongsym, bytesym, wcharsym;
+value_t floatsym, doublesym;
+value_t gftypesym, stringtypesym, wcstringtypesym;
+value_t emptystringsym;
+
+value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
+value_t unionsym;
+
+static htable_t TypeTable;
+static htable_t reverse_dlsym_lookup_table;
+static fltype_t *int8type, *uint8type;
+static fltype_t *int16type, *uint16type;
+static fltype_t *int32type, *uint32type;
+static fltype_t *int64type, *uint64type;
+static fltype_t *longtype, *ulongtype;
+static fltype_t *floattype, *doubletype;
+ fltype_t *bytetype, *wchartype;
+ fltype_t *stringtype, *wcstringtype;
+ fltype_t *builtintype;
+
+static void cvalue_init(fltype_t *type, value_t v, void *dest);
+
+// cvalues-specific builtins
+value_t cvalue_new(value_t *args, u_int32_t nargs);
+value_t cvalue_sizeof(value_t *args, u_int32_t nargs);
+value_t cvalue_typeof(value_t *args, u_int32_t nargs);
+
+// trigger unconditional GC after this many bytes are allocated
+#define ALLOC_LIMIT_TRIGGER 67108864
+
+static size_t malloc_pressure = 0;
+
+static cvalue_t **Finalizers = NULL;
+static size_t nfinalizers=0;
+static size_t maxfinalizers=0;
+
+void add_finalizer(cvalue_t *cv)
+{+ if (nfinalizers == maxfinalizers) {+ size_t nn = (maxfinalizers==0 ? 256 : maxfinalizers*2);
+ cvalue_t **temp = (cvalue_t**)realloc(Finalizers, nn*sizeof(value_t));
+ if (temp == NULL)
+ lerror(MemoryError, "out of memory");
+ Finalizers = temp;
+ maxfinalizers = nn;
+ }
+ Finalizers[nfinalizers++] = cv;
+}
+
+// remove dead objects from finalization list in-place
+static void sweep_finalizers()
+{+ cvalue_t **lst = Finalizers;
+ size_t n=0, ndel=0, l=nfinalizers;
+ cvalue_t *tmp;
+#define SWAP_sf(a,b) (tmp=a,a=b,b=tmp,1)
+ if (l == 0)
+ return;
+ do {+ tmp = lst[n];
+ if (isforwarded((value_t)tmp)) {+ // object is alive
+ lst[n] = (cvalue_t*)ptr(forwardloc((value_t)tmp));
+ n++;
+ }
+ else {+ fltype_t *t = cv_class(tmp);
+ if (t->vtable != NULL && t->vtable->finalize != NULL) {+ t->vtable->finalize(tagptr(tmp, TAG_CVALUE));
+ }
+ if (!isinlined(tmp) && owned(tmp)) {+#ifndef NDEBUG
+ memset(cv_data(tmp), 0xbb, cv_len(tmp));
+#endif
+ free(cv_data(tmp));
+ }
+ ndel++;
+ }
+ } while ((n < l-ndel) && SWAP_sf(lst[n],lst[n+ndel]));
+
+ nfinalizers -= ndel;
+#ifdef VERBOSEGC
+ if (ndel > 0)
+ printf("GC: finalized %d objects\n", ndel);+#endif
+
+ malloc_pressure = 0;
+}
+
+// compute the size of the metadata object for a cvalue
+static size_t cv_nwords(cvalue_t *cv)
+{+ if (isinlined(cv)) {+ size_t n = cv_len(cv);
+ if (n==0 || cv_isstr(cv))
+ n++;
+ return CVALUE_NWORDS - 1 + NWORDS(n);
+ }
+ return CVALUE_NWORDS;
+}
+
+static void autorelease(cvalue_t *cv)
+{+ cv->type = (fltype_t*)(((uptrint_t)cv->type) | CV_OWNED_BIT);
+ add_finalizer(cv);
+}
+
+void cv_autorelease(cvalue_t *cv)
+{+ autorelease(cv);
+}
+
+static value_t cprim(fltype_t *type, size_t sz)
+{+ assert(!ismanaged((uptrint_t)type));
+ assert(sz == type->size);
+ cprim_t *pcp = (cprim_t*)alloc_words(CPRIM_NWORDS-1+NWORDS(sz));
+ pcp->type = type;
+ return tagptr(pcp, TAG_CPRIM);
+}
+
+value_t cvalue(fltype_t *type, size_t sz)
+{+ cvalue_t *pcv;
+ int str=0;
+
+ if (valid_numtype(type->numtype)) {+ return cprim(type, sz);
+ }
+ if (type->eltype == bytetype) {+ if (sz == 0)
+ return symbol_value(emptystringsym);
+ sz++;
+ str=1;
+ }
+ if (sz <= MAX_INL_SIZE) {+ size_t nw = CVALUE_NWORDS - 1 + NWORDS(sz) + (sz==0 ? 1 : 0);
+ pcv = (cvalue_t*)alloc_words(nw);
+ pcv->type = type;
+ pcv->data = &pcv->_space[0];
+ if (type->vtable != NULL && type->vtable->finalize != NULL)
+ add_finalizer(pcv);
+ }
+ else {+ if (malloc_pressure > ALLOC_LIMIT_TRIGGER)
+ gc(0);
+ pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS);
+ pcv->type = type;
+ pcv->data = malloc(sz);
+ autorelease(pcv);
+ malloc_pressure += sz;
+ }
+ if (str) {+ sz--;
+ ((char*)pcv->data)[sz] = '\0';
+ }
+ pcv->len = sz;
+ return tagptr(pcv, TAG_CVALUE);
+}
+
+value_t cvalue_from_data(fltype_t *type, void *data, size_t sz)
+{+ value_t cv;
+ cv = cvalue(type, sz);
+ memcpy(cptr(cv), data, sz);
+ return cv;
+}
+
+// this effectively dereferences a pointer
+// just like *p in C, it only removes a level of indirection from the type,
+// it doesn't copy any data.
+// this method of creating a cvalue only allocates metadata.
+// ptr is user-managed; we don't autorelease it unless the
+// user explicitly calls (autorelease ) on the result of this function.
+// 'parent' is an optional cvalue that this pointer is known to point
+// into; NIL if none.
+value_t cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent)
+{+ cvalue_t *pcv;
+ value_t cv;
+
+ pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS);
+ pcv->data = ptr;
+ pcv->len = sz;
+ pcv->type = type;
+ if (parent != NIL) {+ pcv->type = (fltype_t*)(((uptrint_t)pcv->type) | CV_PARENT_BIT);
+ pcv->parent = parent;
+ }
+ cv = tagptr(pcv, TAG_CVALUE);
+ return cv;
+}
+
+value_t cvalue_string(size_t sz)
+{+ return cvalue(stringtype, sz);
+}
+
+value_t cvalue_static_cstring(const char *str)
+{+ return cvalue_from_ref(stringtype, (char*)str, strlen(str), NIL);
+}
+
+value_t string_from_cstrn(char *str, size_t n)
+{+ value_t v = cvalue_string(n);
+ memcpy(cvalue_data(v), str, n);
+ return v;
+}
+
+value_t string_from_cstr(char *str)
+{+ return string_from_cstrn(str, strlen(str));
+}
+
+int fl_isstring(value_t v)
+{+ return (iscvalue(v) && cv_isstr((cvalue_t*)ptr(v)));
+}
+
+// convert to malloc representation (fixed address)
+void cv_pin(cvalue_t *cv)
+{+ if (!isinlined(cv))
+ return;
+ size_t sz = cv_len(cv);
+ if (cv_isstr(cv)) sz++;
+ void *data = malloc(sz);
+ memcpy(data, cv_data(cv), sz);
+ cv->data = data;
+ autorelease(cv);
+}
+
+#define num_init(ctype, cnvt, tag) \
+static int cvalue_##ctype##_init(fltype_t *type, value_t arg, \
+ void *dest) \
+{ \+ fl_##ctype##_t n=0; \
+ (void)type; \
+ if (isfixnum(arg)) { \+ n = numval(arg); \
+ } \
+ else if (iscprim(arg)) { \+ cprim_t *cp = (cprim_t*)ptr(arg); \
+ void *p = cp_data(cp); \
+ n = (fl_##ctype##_t)conv_to_##cnvt(p, cp_numtype(cp)); \
+ } \
+ else { \+ return 1; \
+ } \
+ *((fl_##ctype##_t*)dest) = n; \
+ return 0; \
+}
+num_init(int8, int32, T_INT8)
+num_init(uint8, uint32, T_UINT8)
+num_init(int16, int32, T_INT16)
+num_init(uint16, uint32, T_UINT16)
+num_init(int32, int32, T_INT32)
+num_init(uint32, uint32, T_UINT32)
+num_init(int64, int64, T_INT64)
+num_init(uint64, uint64, T_UINT64)
+num_init(float, double, T_FLOAT)
+num_init(double, double, T_DOUBLE)
+
+#define num_ctor_init(typenam, ctype, tag) \
+value_t cvalue_##typenam(value_t *args, u_int32_t nargs) \
+{ \+ if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; } \+ value_t cp = cprim(typenam##type, sizeof(fl_##ctype##_t)); \
+ if (cvalue_##ctype##_init(typenam##type, \
+ args[0], cp_data((cprim_t*)ptr(cp)))) \
+ type_error(#typenam, "number", args[0]); \
+ return cp; \
+}
+
+#define num_ctor_ctor(typenam, ctype, tag) \
+value_t mk_##typenam(fl_##ctype##_t n) \
+{ \+ value_t cp = cprim(typenam##type, sizeof(fl_##ctype##_t)); \
+ *(fl_##ctype##_t*)cp_data((cprim_t*)ptr(cp)) = n; \
+ return cp; \
+}
+
+#define num_ctor(typenam, ctype, tag) \
+ num_ctor_init(typenam, ctype, tag) \
+ num_ctor_ctor(typenam, ctype, tag)
+
+num_ctor(int8, int8, T_INT8)
+num_ctor(uint8, uint8, T_UINT8)
+num_ctor(int16, int16, T_INT16)
+num_ctor(uint16, uint16, T_UINT16)
+num_ctor(int32, int32, T_INT32)
+num_ctor(uint32, uint32, T_UINT32)
+num_ctor(int64, int64, T_INT64)
+num_ctor(uint64, uint64, T_UINT64)
+num_ctor(byte, uint8, T_UINT8)
+num_ctor(wchar, int32, T_INT32)
+#ifdef BITS64
+num_ctor(long, int64, T_INT64)
+num_ctor(ulong, uint64, T_UINT64)
+#else
+num_ctor(long, int32, T_INT32)
+num_ctor(ulong, uint32, T_UINT32)
+#endif
+num_ctor(float, float, T_FLOAT)
+num_ctor(double, double, T_DOUBLE)
+
+value_t size_wrap(size_t sz)
+{+ if (fits_fixnum(sz))
+ return fixnum(sz);
+ assert(sizeof(void*) == sizeof(size_t));
+ return mk_ulong(sz);
+}
+
+size_t toulong(value_t n, char *fname)
+{+ if (isfixnum(n))
+ return numval(n);
+ if (iscprim(n)) {+ cprim_t *cp = (cprim_t*)ptr(n);
+ return conv_to_ulong(cp_data(cp), cp_numtype(cp));
+ }
+ type_error(fname, "number", n);
+ return 0;
+}
+
+static int cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
+{+ int n=0;
+ value_t syms;
+ value_t type = ft->type;
+
+ syms = car(cdr(type));
+ if (!isvector(syms))
+ type_error("enum", "vector", syms);+ if (issymbol(arg)) {+ for(n=0; n < (int)vector_size(syms); n++) {+ if (vector_elt(syms, n) == arg) {+ *(int*)dest = n;
+ return 0;
+ }
+ }
+ lerror(ArgError, "enum: invalid enum value");
+ }
+ if (isfixnum(arg)) {+ n = (int)numval(arg);
+ }
+ else if (iscprim(arg)) {+ cprim_t *cp = (cprim_t*)ptr(arg);
+ n = conv_to_int32(cp_data(cp), cp_numtype(cp));
+ }
+ else {+ type_error("enum", "number", arg);+ }
+ if ((unsigned)n >= vector_size(syms))
+ lerror(ArgError, "enum: value out of range");
+ *(int*)dest = n;
+ return 0;
+}
+
+value_t cvalue_enum(value_t *args, u_int32_t nargs)
+{+ argcount("enum", nargs, 2);+ value_t type = fl_list2(enumsym, args[0]);
+ fltype_t *ft = get_type(type);
+ value_t cv = cvalue(ft, sizeof(int32_t));
+ cvalue_enum_init(ft, args[1], cp_data((cprim_t*)ptr(cv)));
+ return cv;
+}
+
+static int isarray(value_t v)
+{+ return iscvalue(v) && cv_class((cvalue_t*)ptr(v))->eltype != NULL;
+}
+
+static size_t predict_arraylen(value_t arg)
+{+ if (isvector(arg))
+ return vector_size(arg);
+ else if (iscons(arg))
+ return llength(arg);
+ else if (arg == NIL)
+ return 0;
+ if (isarray(arg))
+ return cvalue_arraylen(arg);
+ return 1;
+}
+
+static int cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
+{+ value_t type = ft->type;
+ size_t elsize, i, cnt, sz;
+ fltype_t *eltype = ft->eltype;
+
+ elsize = ft->elsz;
+ cnt = predict_arraylen(arg);
+
+ if (iscons(cdr_(cdr_(type)))) {+ size_t tc = toulong(car_(cdr_(cdr_(type))), "array");
+ if (tc != cnt)
+ lerror(ArgError, "array: size mismatch");
+ }
+
+ sz = elsize * cnt;
+
+ if (isvector(arg)) {+ assert(cnt <= vector_size(arg));
+ for(i=0; i < cnt; i++) {+ cvalue_init(eltype, vector_elt(arg,i), dest);
+ dest += elsize;
+ }
+ return 0;
+ }
+ else if (iscons(arg) || arg==NIL) {+ i = 0;
+ while (iscons(arg)) {+ if (i == cnt) { i++; break; } // trigger error+ cvalue_init(eltype, car_(arg), dest);
+ i++;
+ dest += elsize;
+ arg = cdr_(arg);
+ }
+ if (i != cnt)
+ lerror(ArgError, "array: size mismatch");
+ return 0;
+ }
+ else if (iscvalue(arg)) {+ cvalue_t *cv = (cvalue_t*)ptr(arg);
+ if (isarray(arg)) {+ fltype_t *aet = cv_class(cv)->eltype;
+ if (aet == eltype) {+ if (cv_len(cv) == sz)
+ memcpy(dest, cv_data(cv), sz);
+ else
+ lerror(ArgError, "array: size mismatch");
+ return 0;
+ }
+ else {+ // TODO: initialize array from different type elements
+ lerror(ArgError, "array: element type mismatch");
+ }
+ }
+ }
+ if (cnt == 1)
+ cvalue_init(eltype, arg, dest);
+ else
+ type_error("array", "sequence", arg);+ return 0;
+}
+
+value_t cvalue_array(value_t *args, u_int32_t nargs)
+{+ size_t elsize, cnt, sz, i;
+ value_t arg;
+
+ if (nargs < 1)
+ argcount("array", nargs, 1);+
+ cnt = nargs - 1;
+ fltype_t *type = get_array_type(args[0]);
+ elsize = type->elsz;
+ sz = elsize * cnt;
+
+ value_t cv = cvalue(type, sz);
+ char *dest = cv_data((cvalue_t*)ptr(cv));
+ FOR_ARGS(i,1,arg,args) {+ cvalue_init(type->eltype, arg, dest);
+ dest += elsize;
+ }
+ return cv;
+}
+
+// NOTE: v must be an array
+size_t cvalue_arraylen(value_t v)
+{+ cvalue_t *cv = (cvalue_t*)ptr(v);
+ return cv_len(cv)/(cv_class(cv)->elsz);
+}
+
+static size_t cvalue_struct_offs(value_t type, value_t field, int computeTotal,
+ int *palign)
+{+ value_t fld = car(cdr_(type));
+ size_t fsz, ssz = 0;
+ int al;
+ *palign = 0;
+
+ while (iscons(fld)) {+ fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
+
+ ssz = LLT_ALIGN(ssz, al);
+ if (al > *palign)
+ *palign = al;
+
+ if (!computeTotal && field==car_(car_(fld))) {+ // found target field
+ return ssz;
+ }
+
+ ssz += fsz;
+ fld = cdr_(fld);
+ }
+ return LLT_ALIGN(ssz, *palign);
+}
+
+static size_t cvalue_union_size(value_t type, int *palign)
+{+ value_t fld = car(cdr_(type));
+ size_t fsz, usz = 0;
+ int al;
+ *palign = 0;
+
+ while (iscons(fld)) {+ fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
+ if (al > *palign) *palign = al;
+ if (fsz > usz) usz = fsz;
+ fld = cdr_(fld);
+ }
+ return LLT_ALIGN(usz, *palign);
+}
+
+// *palign is an output argument giving the alignment required by type
+size_t ctype_sizeof(value_t type, int *palign)
+{+ if (type == int8sym || type == uint8sym || type == bytesym) {+ *palign = 1;
+ return 1;
+ }
+ if (type == int16sym || type == uint16sym) {+ *palign = ALIGN2;
+ return 2;
+ }
+ if (type == int32sym || type == uint32sym || type == wcharsym ||
+ type == floatsym) {+ *palign = ALIGN4;
+ return 4;
+ }
+ if (type == int64sym || type == uint64sym || type == doublesym) {+ *palign = ALIGN8;
+ return 8;
+ }
+ if (type == longsym || type == ulongsym) {+#ifdef BITS64
+ *palign = ALIGN8;
+ return 8;
+#else
+ *palign = ALIGN4;
+ return 4;
+#endif
+ }
+ if (iscons(type)) {+ value_t hed = car_(type);
+ if (hed == pointersym || hed == cfunctionsym) {+ *palign = ALIGNPTR;
+ return sizeof(void*);
+ }
+ if (hed == arraysym) {+ value_t t = car(cdr_(type));
+ if (!iscons(cdr_(cdr_(type))))
+ lerror(ArgError, "sizeof: incomplete type");
+ value_t n = car_(cdr_(cdr_(type)));
+ size_t sz = toulong(n, "sizeof");
+ return sz * ctype_sizeof(t, palign);
+ }
+ else if (hed == structsym) {+ return cvalue_struct_offs(type, NIL, 1, palign);
+ }
+ else if (hed == unionsym) {+ return cvalue_union_size(type, palign);
+ }
+ else if (hed == enumsym) {+ *palign = ALIGN4;
+ return 4;
+ }
+ }
+ lerror(ArgError, "sizeof: invalid c type");
+ return 0;
+}
+
+extern fltype_t *iostreamtype;
+
+// get pointer and size for any plain-old-data value
+void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz)
+{+ if (iscvalue(v)) {+ cvalue_t *pcv = (cvalue_t*)ptr(v);
+ ios_t *x = value2c(ios_t*,v);
+ if (cv_class(pcv) == iostreamtype && (x->bm == bm_mem)) {+ *pdata = x->buf;
+ *psz = x->size;
+ return;
+ }
+ else if (cv_isPOD(pcv)) {+ *pdata = cv_data(pcv);
+ *psz = cv_len(pcv);
+ return;
+ }
+ }
+ else if (iscprim(v)) {+ cprim_t *pcp = (cprim_t*)ptr(v);
+ *pdata = cp_data(pcp);
+ *psz = cp_class(pcp)->size;
+ return;
+ }
+ type_error(fname, "plain-old-data", v);
+}
+
+value_t cvalue_sizeof(value_t *args, u_int32_t nargs)
+{+ argcount("sizeof", nargs, 1);+ if (issymbol(args[0]) || iscons(args[0])) {+ int a;
+ return size_wrap(ctype_sizeof(args[0], &a));
+ }
+ size_t n; char *data;
+ to_sized_ptr(args[0], "sizeof", &data, &n);
+ return size_wrap(n);
+}
+
+value_t cvalue_typeof(value_t *args, u_int32_t nargs)
+{+ argcount("typeof", nargs, 1);+ switch(tag(args[0])) {+ case TAG_CONS: return pairsym;
+ case TAG_NUM1:
+ case TAG_NUM: return fixnumsym;
+ case TAG_SYM: return symbolsym;
+ case TAG_VECTOR: return vectorsym;
+ case TAG_FUNCTION:
+ if (args[0] == FL_T || args[0] == FL_F)
+ return booleansym;
+ if (args[0] == NIL)
+ return nullsym;
+ if (args[0] == FL_EOF)
+ return symbol("eof-object");+ if (isbuiltin(args[0]))
+ return builtinsym;
+ return FUNCTION;
+ }
+ return cv_type((cvalue_t*)ptr(args[0]));
+}
+
+static value_t cvalue_relocate(value_t v)
+{+ size_t nw;
+ cvalue_t *cv = (cvalue_t*)ptr(v);
+ cvalue_t *nv;
+ value_t ncv;
+
+ nw = cv_nwords(cv);
+ nv = (cvalue_t*)alloc_words(nw);
+ memcpy(nv, cv, nw*sizeof(value_t));
+ if (isinlined(cv))
+ nv->data = &nv->_space[0];
+ ncv = tagptr(nv, TAG_CVALUE);
+ fltype_t *t = cv_class(cv);
+ if (t->vtable != NULL && t->vtable->relocate != NULL)
+ t->vtable->relocate(v, ncv);
+ forward(v, ncv);
+ return ncv;
+}
+
+value_t cvalue_copy(value_t v)
+{+ assert(iscvalue(v));
+ PUSH(v);
+ cvalue_t *cv = (cvalue_t*)ptr(v);
+ size_t nw = cv_nwords(cv);
+ cvalue_t *ncv = (cvalue_t*)alloc_words(nw);
+ v = POP(); cv = (cvalue_t*)ptr(v);
+ memcpy(ncv, cv, nw * sizeof(value_t));
+ if (!isinlined(cv)) {+ size_t len = cv_len(cv);
+ if (cv_isstr(cv)) len++;
+ ncv->data = malloc(len);
+ memcpy(ncv->data, cv_data(cv), len);
+ autorelease(ncv);
+ if (hasparent(cv)) {+ ncv->type = (fltype_t*)(((uptrint_t)ncv->type) & ~CV_PARENT_BIT);
+ ncv->parent = NIL;
+ }
+ }
+ else {+ ncv->data = &ncv->_space[0];
+ }
+
+ return tagptr(ncv, TAG_CVALUE);
+}
+
+value_t fl_copy(value_t *args, u_int32_t nargs)
+{+ argcount("copy", nargs, 1);+ if (iscons(args[0]) || isvector(args[0]))
+ lerror(ArgError, "copy: argument must be a leaf atom");
+ if (!iscvalue(args[0]))
+ return args[0];
+ if (!cv_isPOD((cvalue_t*)ptr(args[0])))
+ lerror(ArgError, "copy: argument must be a plain-old-data type");
+ return cvalue_copy(args[0]);
+}
+
+value_t fl_podp(value_t *args, u_int32_t nargs)
+{+ argcount("plain-old-data?", nargs, 1);+ return (iscprim(args[0]) ||
+ (iscvalue(args[0]) && cv_isPOD((cvalue_t*)ptr(args[0])))) ?
+ FL_T : FL_F;
+}
+
+static void cvalue_init(fltype_t *type, value_t v, void *dest)
+{+ cvinitfunc_t f=type->init;
+
+ if (f == NULL)
+ lerror(ArgError, "c-value: invalid c type");
+
+ f(type, v, dest);
+}
+
+static numerictype_t sym_to_numtype(value_t type)
+{+ if (type == int8sym)
+ return T_INT8;
+ else if (type == uint8sym || type == bytesym)
+ return T_UINT8;
+ else if (type == int16sym)
+ return T_INT16;
+ else if (type == uint16sym)
+ return T_UINT16;
+#ifdef BITS64
+ else if (type == int32sym || type == wcharsym)
+#else
+ else if (type == int32sym || type == wcharsym || type == longsym)
+#endif
+ return T_INT32;
+#ifdef BITS64
+ else if (type == uint32sym)
+#else
+ else if (type == uint32sym || type == ulongsym)
+#endif
+ return T_UINT32;
+#ifdef BITS64
+ else if (type == int64sym || type == longsym)
+#else
+ else if (type == int64sym)
+#endif
+ return T_INT64;
+#ifdef BITS64
+ else if (type == uint64sym || type == ulongsym)
+#else
+ else if (type == uint64sym)
+#endif
+ return T_UINT64;
+ else if (type == floatsym)
+ return T_FLOAT;
+ else if (type == doublesym)
+ return T_DOUBLE;
+ assert(0);
+ return N_NUMTYPES;
+}
+
+// (new type . args)
+// this provides (1) a way to allocate values with a shared type for
+// efficiency, (2) a uniform interface for allocating cvalues of any
+// type, including user-defined.
+value_t cvalue_new(value_t *args, u_int32_t nargs)
+{+ if (nargs < 1 || nargs > 2)
+ argcount("c-value", nargs, 2);+ value_t type = args[0];
+ fltype_t *ft = get_type(type);
+ value_t cv;
+ if (ft->eltype != NULL) {+ // special case to handle incomplete array types bla[]
+ size_t elsz = ft->elsz;
+ size_t cnt;
+
+ if (iscons(cdr_(cdr_(type))))
+ cnt = toulong(car_(cdr_(cdr_(type))), "array");
+ else if (nargs == 2)
+ cnt = predict_arraylen(args[1]);
+ else
+ cnt = 0;
+ cv = cvalue(ft, elsz * cnt);
+ if (nargs == 2)
+ cvalue_array_init(ft, args[1], cv_data((cvalue_t*)ptr(cv)));
+ }
+ else {+ cv = cvalue(ft, ft->size);
+ if (nargs == 2)
+ cvalue_init(ft, args[1], cptr(cv));
+ }
+ return cv;
+}
+
+// NOTE: this only compares lexicographically; it ignores numeric formats
+value_t cvalue_compare(value_t a, value_t b)
+{+ cvalue_t *ca = (cvalue_t*)ptr(a);
+ cvalue_t *cb = (cvalue_t*)ptr(b);
+ char *adata = cv_data(ca);
+ char *bdata = cv_data(cb);
+ size_t asz = cv_len(ca);
+ size_t bsz = cv_len(cb);
+ size_t minsz = asz < bsz ? asz : bsz;
+ int diff = memcmp(adata, bdata, minsz);
+ if (diff == 0) {+ if (asz > bsz)
+ return fixnum(1);
+ else if (asz < bsz)
+ return fixnum(-1);
+ }
+ return fixnum(diff);
+}
+
+static void check_addr_args(char *fname, value_t arr, value_t ind,
+ char **data, ulong_t *index)
+{+ size_t numel;
+ cvalue_t *cv = (cvalue_t*)ptr(arr);
+ *data = cv_data(cv);
+ numel = cv_len(cv)/(cv_class(cv)->elsz);
+ *index = toulong(ind, fname);
+ if (*index >= numel)
+ bounds_error(fname, arr, ind);
+}
+
+static value_t cvalue_array_aref(value_t *args)
+{+ char *data; ulong_t index;
+ fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
+ value_t el = 0;
+ numerictype_t nt = eltype->numtype;
+ if (nt >= T_INT32)
+ el = cvalue(eltype, eltype->size);
+ check_addr_args("aref", args[0], args[1], &data, &index);+ if (nt < T_INT32) {+ if (nt == T_INT8)
+ return fixnum((int8_t)data[index]);
+ else if (nt == T_UINT8)
+ return fixnum((uint8_t)data[index]);
+ else if (nt == T_INT16)
+ return fixnum(((int16_t*)data)[index]);
+ return fixnum(((uint16_t*)data)[index]);
+ }
+ char *dest = cptr(el);
+ size_t sz = eltype->size;
+ if (sz == 1)
+ *dest = data[index];
+ else if (sz == 2)
+ *(int16_t*)dest = ((int16_t*)data)[index];
+ else if (sz == 4)
+ *(int32_t*)dest = ((int32_t*)data)[index];
+ else if (sz == 8)
+ *(int64_t*)dest = ((int64_t*)data)[index];
+ else
+ memcpy(dest, data + index*sz, sz);
+ return el;
+}
+
+static value_t cvalue_array_aset(value_t *args)
+{+ char *data; ulong_t index;
+ fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
+ check_addr_args("aset!", args[0], args[1], &data, &index);+ char *dest = data + index*eltype->size;
+ cvalue_init(eltype, args[2], dest);
+ return args[2];
+}
+
+value_t fl_builtin(value_t *args, u_int32_t nargs)
+{+ argcount("builtin", nargs, 1);+ symbol_t *name = tosymbol(args[0], "builtin");
+ cvalue_t *cv;
+ if (ismanaged(args[0]) || (cv=name->dlcache) == NULL) {+ lerrorf(ArgError, "builtin: function %s not found", name->name);
+ }
+ return tagptr(cv, TAG_CVALUE);
+}
+
+value_t cbuiltin(char *name, builtin_t f)
+{+ cvalue_t *cv = (cvalue_t*)malloc(CVALUE_NWORDS * sizeof(value_t));
+ cv->type = builtintype;
+ cv->data = &cv->_space[0];
+ cv->len = sizeof(value_t);
+ *(void**)cv->data = f;
+
+ value_t sym = symbol(name);
+ ((symbol_t*)ptr(sym))->dlcache = cv;
+ ptrhash_put(&reverse_dlsym_lookup_table, cv, (void*)sym);
+
+ return tagptr(cv, TAG_CVALUE);
+}
+
+static value_t fl_logand(value_t *args, u_int32_t nargs);
+static value_t fl_logior(value_t *args, u_int32_t nargs);
+static value_t fl_logxor(value_t *args, u_int32_t nargs);
+static value_t fl_lognot(value_t *args, u_int32_t nargs);
+static value_t fl_ash(value_t *args, u_int32_t nargs);
+
+static builtinspec_t cvalues_builtin_info[] = {+ { "c-value", cvalue_new },+ { "typeof", cvalue_typeof },+ { "sizeof", cvalue_sizeof },+ { "builtin", fl_builtin },+ { "copy", fl_copy },+ { "plain-old-data?", fl_podp },+
+ { "logand", fl_logand },+ { "logior", fl_logior },+ { "logxor", fl_logxor },+ { "lognot", fl_lognot },+ { "ash", fl_ash },+ // todo: autorelease
+ { NULL, NULL }+};
+
+#define cv_intern(tok) tok##sym = symbol(#tok)
+#define ctor_cv_intern(tok) \
+ cv_intern(tok);set(tok##sym, cbuiltin(#tok, cvalue_##tok))
+
+#define mk_primtype(name) \
+ name##type=get_type(name##sym);name##type->init = &cvalue_##name##_init
+
+#define mk_primtype_(name,ctype) \
+ name##type=get_type(name##sym);name##type->init = &cvalue_##ctype##_init
+
+static void cvalues_init()
+{+ htable_new(&TypeTable, 256);
+ htable_new(&reverse_dlsym_lookup_table, 256);
+
+ // compute struct field alignment required for primitives
+ ALIGN2 = sizeof(struct { char a; int16_t i; }) - 2;+ ALIGN4 = sizeof(struct { char a; int32_t i; }) - 4;+ ALIGN8 = sizeof(struct { char a; int64_t i; }) - 8;+ ALIGNPTR = sizeof(struct { char a; void *i; }) - sizeof(void*);+
+ builtintype = define_opaque_type(builtinsym, sizeof(builtin_t), NULL, NULL);
+
+ ctor_cv_intern(int8);
+ ctor_cv_intern(uint8);
+ ctor_cv_intern(int16);
+ ctor_cv_intern(uint16);
+ ctor_cv_intern(int32);
+ ctor_cv_intern(uint32);
+ ctor_cv_intern(int64);
+ ctor_cv_intern(uint64);
+ ctor_cv_intern(byte);
+ ctor_cv_intern(wchar);
+ ctor_cv_intern(long);
+ ctor_cv_intern(ulong);
+ ctor_cv_intern(float);
+ ctor_cv_intern(double);
+
+ ctor_cv_intern(array);
+ ctor_cv_intern(enum);
+ cv_intern(pointer);
+ cv_intern(struct);
+ cv_intern(union);
+ cv_intern(void);
+ cfunctionsym = symbol("c-function");+
+ assign_global_builtins(cvalues_builtin_info);
+
+ stringtypesym = symbol("*string-type*");+ setc(stringtypesym, fl_list2(arraysym, bytesym));
+
+ wcstringtypesym = symbol("*wcstring-type*");+ setc(wcstringtypesym, fl_list2(arraysym, wcharsym));
+
+ mk_primtype(int8);
+ mk_primtype(uint8);
+ mk_primtype(int16);
+ mk_primtype(uint16);
+ mk_primtype(int32);
+ mk_primtype(uint32);
+ mk_primtype(int64);
+ mk_primtype(uint64);
+#ifdef BITS64
+ mk_primtype_(long,int64);
+ mk_primtype_(ulong,uint64);
+#else
+ mk_primtype_(long,int32);
+ mk_primtype_(ulong,uint32);
+#endif
+ mk_primtype_(byte,uint8);
+ mk_primtype_(wchar,int32);
+ mk_primtype(float);
+ mk_primtype(double);
+
+ stringtype = get_type(symbol_value(stringtypesym));
+ wcstringtype = get_type(symbol_value(wcstringtypesym));
+
+ emptystringsym = symbol("*empty-string*");+ setc(emptystringsym, cvalue_static_cstring(""));+}
+
+#define RETURN_NUM_AS(var, type) return(mk_##type((fl_##type##_t)var))
+
+value_t return_from_uint64(uint64_t Uaccum)
+{+ if (fits_fixnum(Uaccum)) {+ return fixnum((fixnum_t)Uaccum);
+ }
+ if (Uaccum > (uint64_t)S64_MAX) {+ RETURN_NUM_AS(Uaccum, uint64);
+ }
+ else if (Uaccum > (uint64_t)UINT_MAX) {+ RETURN_NUM_AS(Uaccum, int64);
+ }
+ else if (Uaccum > (uint64_t)INT_MAX) {+ RETURN_NUM_AS(Uaccum, uint32);
+ }
+ RETURN_NUM_AS(Uaccum, int32);
+}
+
+value_t return_from_int64(int64_t Saccum)
+{+ if (fits_fixnum(Saccum)) {+ return fixnum((fixnum_t)Saccum);
+ }
+ if (Saccum > (int64_t)UINT_MAX || Saccum < (int64_t)INT_MIN) {+ RETURN_NUM_AS(Saccum, int64);
+ }
+ else if (Saccum > (int64_t)INT_MAX) {+ RETURN_NUM_AS(Saccum, uint32);
+ }
+ RETURN_NUM_AS(Saccum, int32);
+}
+
+static value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn)
+{+ uint64_t Uaccum=0;
+ int64_t Saccum = carryIn;
+ double Faccum=0;
+ uint32_t i;
+ value_t arg=NIL;
+
+ FOR_ARGS(i,0,arg,args) {+ if (isfixnum(arg)) {+ Saccum += numval(arg);
+ continue;
+ }
+ else if (iscprim(arg)) {+ cprim_t *cp = (cprim_t*)ptr(arg);
+ void *a = cp_data(cp);
+ int64_t i64;
+ switch(cp_numtype(cp)) {+ case T_INT8: Saccum += *(int8_t*)a; break;
+ case T_UINT8: Saccum += *(uint8_t*)a; break;
+ case T_INT16: Saccum += *(int16_t*)a; break;
+ case T_UINT16: Saccum += *(uint16_t*)a; break;
+ case T_INT32: Saccum += *(int32_t*)a; break;
+ case T_UINT32: Saccum += *(uint32_t*)a; break;
+ case T_INT64:
+ i64 = *(int64_t*)a;
+ if (i64 > 0)
+ Uaccum += (uint64_t)i64;
+ else
+ Saccum += i64;
+ break;
+ case T_UINT64: Uaccum += *(uint64_t*)a; break;
+ case T_FLOAT: Faccum += *(float*)a; break;
+ case T_DOUBLE: Faccum += *(double*)a; break;
+ default:
+ goto add_type_error;
+ }
+ continue;
+ }
+ add_type_error:
+ type_error("+", "number", arg);+ }
+ if (Faccum != 0) {+ Faccum += Uaccum;
+ Faccum += Saccum;
+ return mk_double(Faccum);
+ }
+ else if (Saccum < 0) {+ uint64_t negpart = (uint64_t)(-Saccum);
+ if (negpart > Uaccum) {+ Saccum += (int64_t)Uaccum;
+ // return value in Saccum
+ if (Saccum >= INT_MIN) {+ if (fits_fixnum(Saccum)) {+ return fixnum((fixnum_t)Saccum);
+ }
+ RETURN_NUM_AS(Saccum, int32);
+ }
+ RETURN_NUM_AS(Saccum, int64);
+ }
+ Uaccum -= negpart;
+ }
+ else {+ Uaccum += (uint64_t)Saccum;
+ }
+ // return value in Uaccum
+ return return_from_uint64(Uaccum);
+}
+
+static value_t fl_neg(value_t n)
+{+ if (isfixnum(n)) {+ return fixnum(-numval(n));
+ }
+ else if (iscprim(n)) {+ cprim_t *cp = (cprim_t*)ptr(n);
+ void *a = cp_data(cp);
+ uint32_t ui32;
+ int32_t i32;
+ int64_t i64;
+ switch(cp_numtype(cp)) {+ case T_INT8: return fixnum(-(int32_t)*(int8_t*)a);
+ case T_UINT8: return fixnum(-(int32_t)*(uint8_t*)a);
+ case T_INT16: return fixnum(-(int32_t)*(int16_t*)a);
+ case T_UINT16: return fixnum(-(int32_t)*(uint16_t*)a);
+ case T_INT32:
+ i32 = *(int32_t*)a;
+ if (i32 == (int32_t)BIT31)
+ return mk_uint32((uint32_t)BIT31);
+ return mk_int32(-i32);
+ case T_UINT32:
+ ui32 = *(uint32_t*)a;
+ if (ui32 <= ((uint32_t)INT_MAX)+1) return mk_int32(-(int32_t)ui32);
+ return mk_int64(-(int64_t)ui32);
+ case T_INT64:
+ i64 = *(int64_t*)a;
+ if (i64 == (int64_t)BIT63)
+ return mk_uint64((uint64_t)BIT63);
+ return mk_int64(-i64);
+ case T_UINT64: return mk_int64(-(int64_t)*(uint64_t*)a);
+ case T_FLOAT: return mk_float(-*(float*)a);
+ case T_DOUBLE: return mk_double(-*(double*)a);
+ break;
+ }
+ }
+ type_error("-", "number", n);+}
+
+static value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum)
+{+ uint64_t Uaccum=1;
+ double Faccum=1;
+ uint32_t i;
+ value_t arg=NIL;
+
+ FOR_ARGS(i,0,arg,args) {+ if (isfixnum(arg)) {+ Saccum *= numval(arg);
+ continue;
+ }
+ else if (iscprim(arg)) {+ cprim_t *cp = (cprim_t*)ptr(arg);
+ void *a = cp_data(cp);
+ int64_t i64;
+ switch(cp_numtype(cp)) {+ case T_INT8: Saccum *= *(int8_t*)a; break;
+ case T_UINT8: Saccum *= *(uint8_t*)a; break;
+ case T_INT16: Saccum *= *(int16_t*)a; break;
+ case T_UINT16: Saccum *= *(uint16_t*)a; break;
+ case T_INT32: Saccum *= *(int32_t*)a; break;
+ case T_UINT32: Saccum *= *(uint32_t*)a; break;
+ case T_INT64:
+ i64 = *(int64_t*)a;
+ if (i64 > 0)
+ Uaccum *= (uint64_t)i64;
+ else
+ Saccum *= i64;
+ break;
+ case T_UINT64: Uaccum *= *(uint64_t*)a; break;
+ case T_FLOAT: Faccum *= *(float*)a; break;
+ case T_DOUBLE: Faccum *= *(double*)a; break;
+ default:
+ goto mul_type_error;
+ }
+ continue;
+ }
+ mul_type_error:
+ type_error("*", "number", arg);+ }
+ if (Faccum != 1) {+ Faccum *= Uaccum;
+ Faccum *= Saccum;
+ return mk_double(Faccum);
+ }
+ else if (Saccum < 0) {+ Saccum *= (int64_t)Uaccum;
+ if (Saccum >= INT_MIN) {+ if (fits_fixnum(Saccum)) {+ return fixnum((fixnum_t)Saccum);
+ }
+ RETURN_NUM_AS(Saccum, int32);
+ }
+ RETURN_NUM_AS(Saccum, int64);
+ }
+ else {+ Uaccum *= (uint64_t)Saccum;
+ }
+ return return_from_uint64(Uaccum);
+}
+
+static int num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp)
+{+ cprim_t *cp;
+ if (isfixnum(a)) {+ *pi = numval(a);
+ *pp = pi;
+ *pt = T_FIXNUM;
+ }
+ else if (iscprim(a)) {+ cp = (cprim_t*)ptr(a);
+ *pp = cp_data(cp);
+ *pt = cp_numtype(cp);
+ }
+ else {+ return 0;
+ }
+ return 1;
+}
+
+/*
+ returns -1, 0, or 1 based on ordering of a and b
+ eq: consider equality only, returning 0 or nonzero
+ eqnans: NaNs considered equal to each other
+ -0.0 not considered equal to 0.0
+ inexact not considered equal to exact
+ fname: if not NULL, throws type errors, else returns 2 for type errors
+*/
+int numeric_compare(value_t a, value_t b, int eq, int eqnans, char *fname)
+{+ int_t ai, bi;
+ numerictype_t ta, tb;
+ void *aptr, *bptr;
+
+ if (bothfixnums(a,b)) {+ if (a==b) return 0;
+ if (numval(a) < numval(b)) return -1;
+ return 1;
+ }
+ if (!num_to_ptr(a, &ai, &ta, &aptr)) {+ if (fname) type_error(fname, "number", a); else return 2;
+ }
+ if (!num_to_ptr(b, &bi, &tb, &bptr)) {+ if (fname) type_error(fname, "number", b); else return 2;
+ }
+ if (eq && eqnans && ((ta >= T_FLOAT) != (tb >= T_FLOAT)))
+ return 1;
+ if (cmp_eq(aptr, ta, bptr, tb, eqnans))
+ return 0;
+ if (eq) return 1;
+ if (cmp_lt(aptr, ta, bptr, tb))
+ return -1;
+ return 1;
+}
+
+static void DivideByZeroError() __attribute__ ((__noreturn__));
+static void DivideByZeroError()
+{+ lerror(DivideError, "/: division by zero");
+}
+
+static value_t fl_div2(value_t a, value_t b)
+{+ double da, db;
+ int_t ai, bi;
+ numerictype_t ta, tb;
+ void *aptr, *bptr;
+
+ if (!num_to_ptr(a, &ai, &ta, &aptr))
+ type_error("/", "number", a);+ if (!num_to_ptr(b, &bi, &tb, &bptr))
+ type_error("/", "number", b);+
+ da = conv_to_double(aptr, ta);
+ db = conv_to_double(bptr, tb);
+
+ if (db == 0 && tb < T_FLOAT) // exact 0
+ DivideByZeroError();
+
+ da = da/db;
+
+ if (ta < T_FLOAT && tb < T_FLOAT && (double)(int64_t)da == da)
+ return return_from_int64((int64_t)da);
+ return mk_double(da);
+}
+
+static value_t fl_idiv2(value_t a, value_t b)
+{+ int_t ai, bi;
+ numerictype_t ta, tb;
+ void *aptr, *bptr;
+ int64_t a64, b64;
+
+ if (!num_to_ptr(a, &ai, &ta, &aptr))
+ type_error("div0", "number", a);+ if (!num_to_ptr(b, &bi, &tb, &bptr))
+ type_error("div0", "number", b);+
+ if (ta == T_UINT64) {+ if (tb == T_UINT64) {+ if (*(uint64_t*)bptr == 0) goto div_error;
+ return return_from_uint64(*(uint64_t*)aptr / *(uint64_t*)bptr);
+ }
+ b64 = conv_to_int64(bptr, tb);
+ if (b64 < 0) {+ return return_from_int64(-(int64_t)(*(uint64_t*)aptr /
+ (uint64_t)(-b64)));
+ }
+ if (b64 == 0)
+ goto div_error;
+ return return_from_uint64(*(uint64_t*)aptr / (uint64_t)b64);
+ }
+ if (tb == T_UINT64) {+ if (*(uint64_t*)bptr == 0) goto div_error;
+ a64 = conv_to_int64(aptr, ta);
+ if (a64 < 0) {+ return return_from_int64(-((int64_t)((uint64_t)(-a64) /
+ *(uint64_t*)bptr)));
+ }
+ return return_from_uint64((uint64_t)a64 / *(uint64_t*)bptr);
+ }
+
+ b64 = conv_to_int64(bptr, tb);
+ if (b64 == 0) goto div_error;
+
+ return return_from_int64(conv_to_int64(aptr, ta) / b64);
+ div_error:
+ DivideByZeroError();
+}
+
+static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
+{+ int_t ai, bi;
+ numerictype_t ta, tb, itmp;
+ void *aptr=NULL, *bptr=NULL, *ptmp;
+ int64_t b64;
+
+ if (!num_to_ptr(a, &ai, &ta, &aptr) || ta >= T_FLOAT)
+ type_error(fname, "integer", a);
+ if (!num_to_ptr(b, &bi, &tb, &bptr) || tb >= T_FLOAT)
+ type_error(fname, "integer", b);
+
+ if (ta < tb) {+ itmp = ta; ta = tb; tb = itmp;
+ ptmp = aptr; aptr = bptr; bptr = ptmp;
+ }
+ // now a's type is larger than or same as b's
+ b64 = conv_to_int64(bptr, tb);
+ switch (opcode) {+ case 0:
+ switch (ta) {+ case T_INT8: return fixnum( *(int8_t *)aptr & (int8_t )b64);
+ case T_UINT8: return fixnum( *(uint8_t *)aptr & (uint8_t )b64);
+ case T_INT16: return fixnum( *(int16_t*)aptr & (int16_t )b64);
+ case T_UINT16: return fixnum( *(uint16_t*)aptr & (uint16_t)b64);
+ case T_INT32: return mk_int32( *(int32_t*)aptr & (int32_t )b64);
+ case T_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64);
+ case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64);
+ case T_UINT64: return mk_uint64(*(uint64_t*)aptr & (uint64_t)b64);
+ case T_FLOAT:
+ case T_DOUBLE: assert(0);
+ }
+ break;
+ case 1:
+ switch (ta) {+ case T_INT8: return fixnum( *(int8_t *)aptr | (int8_t )b64);
+ case T_UINT8: return fixnum( *(uint8_t *)aptr | (uint8_t )b64);
+ case T_INT16: return fixnum( *(int16_t*)aptr | (int16_t )b64);
+ case T_UINT16: return fixnum( *(uint16_t*)aptr | (uint16_t)b64);
+ case T_INT32: return mk_int32( *(int32_t*)aptr | (int32_t )b64);
+ case T_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64);
+ case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64);
+ case T_UINT64: return mk_uint64(*(uint64_t*)aptr | (uint64_t)b64);
+ case T_FLOAT:
+ case T_DOUBLE: assert(0);
+ }
+ break;
+ case 2:
+ switch (ta) {+ case T_INT8: return fixnum( *(int8_t *)aptr ^ (int8_t )b64);
+ case T_UINT8: return fixnum( *(uint8_t *)aptr ^ (uint8_t )b64);
+ case T_INT16: return fixnum( *(int16_t*)aptr ^ (int16_t )b64);
+ case T_UINT16: return fixnum( *(uint16_t*)aptr ^ (uint16_t)b64);
+ case T_INT32: return mk_int32( *(int32_t*)aptr ^ (int32_t )b64);
+ case T_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64);
+ case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64);
+ case T_UINT64: return mk_uint64(*(uint64_t*)aptr ^ (uint64_t)b64);
+ case T_FLOAT:
+ case T_DOUBLE: assert(0);
+ }
+ }
+ assert(0);
+ return NIL;
+}
+
+static value_t fl_logand(value_t *args, u_int32_t nargs)
+{+ value_t v, e;
+ int i;
+ if (nargs == 0)
+ return fixnum(-1);
+ v = args[0];
+ FOR_ARGS(i,1,e,args) {+ if (bothfixnums(v, e))
+ v = v & e;
+ else
+ v = fl_bitwise_op(v, e, 0, "logand");
+ }
+ return v;
+}
+
+static value_t fl_logior(value_t *args, u_int32_t nargs)
+{+ value_t v, e;
+ int i;
+ if (nargs == 0)
+ return fixnum(0);
+ v = args[0];
+ FOR_ARGS(i,1,e,args) {+ if (bothfixnums(v, e))
+ v = v | e;
+ else
+ v = fl_bitwise_op(v, e, 1, "logior");
+ }
+ return v;
+}
+
+static value_t fl_logxor(value_t *args, u_int32_t nargs)
+{+ value_t v, e;
+ int i;
+ if (nargs == 0)
+ return fixnum(0);
+ v = args[0];
+ FOR_ARGS(i,1,e,args) {+ if (bothfixnums(v, e))
+ v = fixnum(numval(v) ^ numval(e));
+ else
+ v = fl_bitwise_op(v, e, 2, "logxor");
+ }
+ return v;
+}
+
+static value_t fl_lognot(value_t *args, u_int32_t nargs)
+{+ argcount("lognot", nargs, 1);+ value_t a = args[0];
+ if (isfixnum(a))
+ return fixnum(~numval(a));
+ cprim_t *cp;
+ int ta;
+ void *aptr;
+
+ if (iscprim(a)) {+ cp = (cprim_t*)ptr(a);
+ ta = cp_numtype(cp);
+ aptr = cp_data(cp);
+ switch (ta) {+ case T_INT8: return fixnum(~*(int8_t *)aptr);
+ case T_UINT8: return fixnum(~*(uint8_t *)aptr);
+ case T_INT16: return fixnum(~*(int16_t *)aptr);
+ case T_UINT16: return fixnum(~*(uint16_t*)aptr);
+ case T_INT32: return mk_int32(~*(int32_t *)aptr);
+ case T_UINT32: return mk_uint32(~*(uint32_t*)aptr);
+ case T_INT64: return mk_int64(~*(int64_t *)aptr);
+ case T_UINT64: return mk_uint64(~*(uint64_t*)aptr);
+ }
+ }
+ type_error("lognot", "integer", a);+}
+
+static value_t fl_ash(value_t *args, u_int32_t nargs)
+{+ fixnum_t n;
+ int64_t accum;
+ argcount("ash", nargs, 2);+ value_t a = args[0];
+ n = tofixnum(args[1], "ash");
+ if (isfixnum(a)) {+ if (n <= 0)
+ return fixnum(numval(a)>>(-n));
+ accum = ((int64_t)numval(a))<<n;
+ if (fits_fixnum(accum))
+ return fixnum(accum);
+ else
+ return return_from_int64(accum);
+ }
+ cprim_t *cp;
+ int ta;
+ void *aptr;
+ if (iscprim(a)) {+ if (n == 0) return a;
+ cp = (cprim_t*)ptr(a);
+ ta = cp_numtype(cp);
+ aptr = cp_data(cp);
+ if (n < 0) {+ n = -n;
+ switch (ta) {+ case T_INT8: return fixnum((*(int8_t *)aptr) >> n);
+ case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n);
+ case T_INT16: return fixnum((*(int16_t *)aptr) >> n);
+ case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n);
+ case T_INT32: return mk_int32((*(int32_t *)aptr) >> n);
+ case T_UINT32: return mk_uint32((*(uint32_t*)aptr) >> n);
+ case T_INT64: return mk_int64((*(int64_t *)aptr) >> n);
+ case T_UINT64: return mk_uint64((*(uint64_t*)aptr) >> n);
+ }
+ }
+ else {+ if (ta == T_UINT64)
+ return return_from_uint64((*(uint64_t*)aptr)<<n);
+ else if (ta < T_FLOAT) {+ int64_t i64 = conv_to_int64(aptr, ta);
+ return return_from_int64(i64<<n);
+ }
+ }
+ }
+ type_error("ash", "integer", a);+ return NIL;
+}
--- /dev/null
+++ b/equal.c
@@ -1,0 +1,385 @@
+#define BOUNDED_COMPARE_BOUND 4096
+#define BOUNDED_HASH_BOUND 16384
+
+// comparable tag
+#define cmptag(v) (isfixnum(v) ? TAG_NUM : tag(v))
+
+static value_t eq_class(htable_t *table, value_t key)
+{+ value_t c = (value_t)ptrhash_get(table, (void*)key);
+ if (c == (value_t)HT_NOTFOUND)
+ return NIL;
+ if (c == key)
+ return c;
+ return eq_class(table, c);
+}
+
+static void eq_union(htable_t *table, value_t a, value_t b,
+ value_t c, value_t cb)
+{+ value_t ca = (c==NIL ? a : c);
+ if (cb != NIL)
+ ptrhash_put(table, (void*)cb, (void*)ca);
+ ptrhash_put(table, (void*)a, (void*)ca);
+ ptrhash_put(table, (void*)b, (void*)ca);
+}
+
+static value_t bounded_compare(value_t a, value_t b, int bound, int eq);
+static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq);
+
+static value_t bounded_vector_compare(value_t a, value_t b, int bound, int eq)
+{+ size_t la = vector_size(a);
+ size_t lb = vector_size(b);
+ size_t m, i;
+ if (eq && (la!=lb)) return fixnum(1);
+ m = la < lb ? la : lb;
+ for (i = 0; i < m; i++) {+ value_t d = bounded_compare(vector_elt(a,i), vector_elt(b,i),
+ bound-1, eq);
+ if (d==NIL || numval(d)!=0) return d;
+ }
+ if (la < lb) return fixnum(-1);
+ if (la > lb) return fixnum(1);
+ return fixnum(0);
+}
+
+// strange comparisons are resolved arbitrarily but consistently.
+// ordering: number < cprim < function < vector < cvalue < symbol < cons
+static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
+{+ value_t d;
+
+ compare_top:
+ if (a == b) return fixnum(0);
+ if (bound <= 0)
+ return NIL;
+ int taga = tag(a);
+ int tagb = cmptag(b);
+ int c;
+ switch (taga) {+ case TAG_NUM :
+ case TAG_NUM1:
+ if (isfixnum(b)) {+ return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1);
+ }
+ if (iscprim(b)) {+ if (cp_class((cprim_t*)ptr(b)) == wchartype)
+ return fixnum(1);
+ return fixnum(numeric_compare(a, b, eq, 1, NULL));
+ }
+ return fixnum(-1);
+ case TAG_SYM:
+ if (eq) return fixnum(1);
+ if (tagb < TAG_SYM) return fixnum(1);
+ if (tagb > TAG_SYM) return fixnum(-1);
+ return fixnum(strcmp(symbol_name(a), symbol_name(b)));
+ case TAG_VECTOR:
+ if (isvector(b))
+ return bounded_vector_compare(a, b, bound, eq);
+ break;
+ case TAG_CPRIM:
+ if (cp_class((cprim_t*)ptr(a)) == wchartype) {+ if (!iscprim(b) || cp_class((cprim_t*)ptr(b)) != wchartype)
+ return fixnum(-1);
+ }
+ else if (iscprim(b) && cp_class((cprim_t*)ptr(b)) == wchartype) {+ return fixnum(1);
+ }
+ c = numeric_compare(a, b, eq, 1, NULL);
+ if (c != 2)
+ return fixnum(c);
+ break;
+ case TAG_CVALUE:
+ if (iscvalue(b)) {+ if (cv_isPOD((cvalue_t*)ptr(a)) && cv_isPOD((cvalue_t*)ptr(b)))
+ return cvalue_compare(a, b);
+ return fixnum(1);
+ }
+ break;
+ case TAG_FUNCTION:
+ if (tagb == TAG_FUNCTION) {+ if (uintval(a) > N_BUILTINS && uintval(b) > N_BUILTINS) {+ function_t *fa = (function_t*)ptr(a);
+ function_t *fb = (function_t*)ptr(b);
+ d = bounded_compare(fa->bcode, fb->bcode, bound-1, eq);
+ if (d==NIL || numval(d) != 0) return d;
+ d = bounded_compare(fa->vals, fb->vals, bound-1, eq);
+ if (d==NIL || numval(d) != 0) return d;
+ d = bounded_compare(fa->env, fb->env, bound-1, eq);
+ if (d==NIL || numval(d) != 0) return d;
+ return fixnum(0);
+ }
+ return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
+ }
+ break;
+ case TAG_CONS:
+ if (tagb < TAG_CONS) return fixnum(1);
+ d = bounded_compare(car_(a), car_(b), bound-1, eq);
+ if (d==NIL || numval(d) != 0) return d;
+ a = cdr_(a); b = cdr_(b);
+ bound--;
+ goto compare_top;
+ }
+ return (taga < tagb) ? fixnum(-1) : fixnum(1);
+}
+
+static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
+ int eq)
+{+ size_t la = vector_size(a);
+ size_t lb = vector_size(b);
+ size_t m, i;
+ value_t d, xa, xb, ca, cb;
+
+ // first try to prove them different with no recursion
+ if (eq && (la!=lb)) return fixnum(1);
+ m = la < lb ? la : lb;
+ for (i = 0; i < m; i++) {+ xa = vector_elt(a,i);
+ xb = vector_elt(b,i);
+ if (leafp(xa) || leafp(xb)) {+ d = bounded_compare(xa, xb, 1, eq);
+ if (d!=NIL && numval(d)!=0) return d;
+ }
+ else if (tag(xa) < tag(xb)) {+ return fixnum(-1);
+ }
+ else if (tag(xa) > tag(xb)) {+ return fixnum(1);
+ }
+ }
+
+ ca = eq_class(table, a);
+ cb = eq_class(table, b);
+ if (ca!=NIL && ca==cb)
+ return fixnum(0);
+
+ eq_union(table, a, b, ca, cb);
+
+ for (i = 0; i < m; i++) {+ xa = vector_elt(a,i);
+ xb = vector_elt(b,i);
+ if (!leafp(xa) || tag(xa)==TAG_FUNCTION) {+ d = cyc_compare(xa, xb, table, eq);
+ if (numval(d)!=0)
+ return d;
+ }
+ }
+
+ if (la < lb) return fixnum(-1);
+ if (la > lb) return fixnum(1);
+ return fixnum(0);
+}
+
+static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
+{+ value_t d, ca, cb;
+ cyc_compare_top:
+ if (a==b)
+ return fixnum(0);
+ if (iscons(a)) {+ if (iscons(b)) {+ value_t aa = car_(a); value_t da = cdr_(a);
+ value_t ab = car_(b); value_t db = cdr_(b);
+ int tagaa = tag(aa); int tagda = tag(da);
+ int tagab = tag(ab); int tagdb = tag(db);
+ if (leafp(aa) || leafp(ab)) {+ d = bounded_compare(aa, ab, 1, eq);
+ if (d!=NIL && numval(d)!=0) return d;
+ }
+ else if (tagaa < tagab)
+ return fixnum(-1);
+ else if (tagaa > tagab)
+ return fixnum(1);
+ if (leafp(da) || leafp(db)) {+ d = bounded_compare(da, db, 1, eq);
+ if (d!=NIL && numval(d)!=0) return d;
+ }
+ else if (tagda < tagdb)
+ return fixnum(-1);
+ else if (tagda > tagdb)
+ return fixnum(1);
+
+ ca = eq_class(table, a);
+ cb = eq_class(table, b);
+ if (ca!=NIL && ca==cb)
+ return fixnum(0);
+
+ eq_union(table, a, b, ca, cb);
+ d = cyc_compare(aa, ab, table, eq);
+ if (numval(d)!=0) return d;
+ a = da;
+ b = db;
+ goto cyc_compare_top;
+ }
+ else {+ return fixnum(1);
+ }
+ }
+ else if (isvector(a) && isvector(b)) {+ return cyc_vector_compare(a, b, table, eq);
+ }
+ else if (isclosure(a) && isclosure(b)) {+ function_t *fa = (function_t*)ptr(a);
+ function_t *fb = (function_t*)ptr(b);
+ d = bounded_compare(fa->bcode, fb->bcode, 1, eq);
+ if (numval(d) != 0) return d;
+
+ ca = eq_class(table, a);
+ cb = eq_class(table, b);
+ if (ca!=NIL && ca==cb)
+ return fixnum(0);
+
+ eq_union(table, a, b, ca, cb);
+ d = cyc_compare(fa->vals, fb->vals, table, eq);
+ if (numval(d) != 0) return d;
+ a = fa->env;
+ b = fb->env;
+ goto cyc_compare_top;
+ }
+ return bounded_compare(a, b, 1, eq);
+}
+
+static htable_t equal_eq_hashtable;
+void comparehash_init()
+{+ htable_new(&equal_eq_hashtable, 512);
+}
+
+// 'eq' means unordered comparison is sufficient
+static value_t compare_(value_t a, value_t b, int eq)
+{+ value_t guess = bounded_compare(a, b, BOUNDED_COMPARE_BOUND, eq);
+ if (guess == NIL) {+ guess = cyc_compare(a, b, &equal_eq_hashtable, eq);
+ htable_reset(&equal_eq_hashtable, 512);
+ }
+ return guess;
+}
+
+value_t fl_compare(value_t a, value_t b)
+{+ return compare_(a, b, 0);
+}
+
+value_t fl_equal(value_t a, value_t b)
+{+ if (eq_comparable(a, b))
+ return (a == b) ? FL_T : FL_F;
+ return (numval(compare_(a,b,1))==0 ? FL_T : FL_F);
+}
+
+/*
+ optimizations:
+ - use hash updates instead of calling lookup then insert. i.e. get the
+ bp once and use it twice.
+ * preallocate hash table and call reset() instead of new/free
+ * less redundant tag checking, 3-bit tags
+*/
+
+#ifdef BITS64
+#define MIX(a, b) int64hash((int64_t)(a) ^ (int64_t)(b));
+#define doublehash(a) int64hash(a)
+#else
+#define MIX(a, b) int64to32hash(((int64_t)(a))<<32 | ((int64_t)(b)))
+#define doublehash(a) int64to32hash(a)
+#endif
+
+// *oob: output argument, means we hit the limit specified by 'bound'
+static uptrint_t bounded_hash(value_t a, int bound, int *oob)
+{+ *oob = 0;
+ union {+ double d;
+ int64_t i64;
+ } u;
+ numerictype_t nt;
+ size_t i, len;
+ cvalue_t *cv;
+ cprim_t *cp;
+ void *data;
+ uptrint_t h = 0;
+ int oob2, tg = tag(a);
+ switch(tg) {+ case TAG_NUM :
+ case TAG_NUM1:
+ u.d = (double)numval(a);
+ return doublehash(u.i64);
+ case TAG_FUNCTION:
+ if (uintval(a) > N_BUILTINS)
+ return bounded_hash(((function_t*)ptr(a))->bcode, bound, oob);
+ return inthash(a);
+ case TAG_SYM:
+ return ((symbol_t*)ptr(a))->hash;
+ case TAG_CPRIM:
+ cp = (cprim_t*)ptr(a);
+ data = cp_data(cp);
+ if (cp_class(cp) == wchartype)
+ return inthash(*(int32_t*)data);
+ nt = cp_numtype(cp);
+ u.d = conv_to_double(data, nt);
+ return doublehash(u.i64);
+ case TAG_CVALUE:
+ cv = (cvalue_t*)ptr(a);
+ data = cv_data(cv);
+ return memhash(data, cv_len(cv));
+
+ case TAG_VECTOR:
+ if (bound <= 0) {+ *oob = 1;
+ return 1;
+ }
+ len = vector_size(a);
+ for(i=0; i < len; i++) {+ h = MIX(h, bounded_hash(vector_elt(a,i), bound/2, &oob2)^1);
+ if (oob2)
+ bound/=2;
+ *oob = *oob || oob2;
+ }
+ return h;
+
+ case TAG_CONS:
+ do {+ if (bound <= 0) {+ *oob = 1;
+ return h;
+ }
+ h = MIX(h, bounded_hash(car_(a), bound/2, &oob2));
+ // bounds balancing: try to share the bounds efficiently
+ // so we can hash better when a list is cdr-deep (a common case)
+ if (oob2)
+ bound/=2;
+ else
+ bound--;
+ // recursive OOB propagation. otherwise this case is slow:
+ // (hash '#2=((#0=(#1=(#1#) . #0#)) . #2#))
+ *oob = *oob || oob2;
+ a = cdr_(a);
+ } while (iscons(a));
+ h = MIX(h, bounded_hash(a, bound-1, &oob2)^2);
+ *oob = *oob || oob2;
+ return h;
+ }
+ return 0;
+}
+
+int equal_lispvalue(value_t a, value_t b)
+{+ if (eq_comparable(a, b))
+ return (a==b);
+ return (numval(compare_(a,b,1))==0);
+}
+
+uptrint_t hash_lispvalue(value_t a)
+{+ int oob=0;
+ uptrint_t n = bounded_hash(a, BOUNDED_HASH_BOUND, &oob);
+ return n;
+}
+
+value_t fl_hash(value_t *args, u_int32_t nargs)
+{+ argcount("hash", nargs, 1);+ return fixnum(hash_lispvalue(args[0]));
+}
--- /dev/null
+++ b/equalhash.c
@@ -1,0 +1,16 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+#include <setjmp.h>
+
+#include "llt.h"
+#include "flisp.h"
+#include "equalhash.h"
+
+#include "htable.inc"
+
+#define _equal_lispvalue_(x,y) equal_lispvalue((value_t)(x),(value_t)(y))
+
+HTIMPL(equalhash, hash_lispvalue, _equal_lispvalue_)
--- /dev/null
+++ b/equalhash.h
@@ -1,0 +1,8 @@
+#ifndef __EQUALHASH_H_
+#define __EQUALHASH_H_
+
+#include "htableh.inc"
+
+HTPROT(equalhash)
+
+#endif
--- /dev/null
+++ b/examples/bq.scm
@@ -1,0 +1,122 @@
+(define (bq-process2 x d)
+ (define (splice-form? x)
+ (or (and (pair? x) (or (eq? (car x) 'unquote-splicing)
+ (eq? (car x) 'unquote-nsplicing)
+ (and (eq? (car x) 'unquote)
+ (length> x 2))))
+ (eq? x 'unquote)))
+ ;; bracket without splicing
+ (define (bq-bracket1 x)
+ (if (and (pair? x) (eq? (car x) 'unquote))
+ (if (= d 0)
+ (cadr x)
+ (list cons ''unquote
+ (bq-process2 (cdr x) (- d 1))))
+ (bq-process2 x d)))
+ (define (bq-bracket x)
+ (cond ((atom? x) (list list (bq-process2 x d)))
+ ((eq? (car x) 'unquote)
+ (if (= d 0)
+ (cons list (cdr x))
+ (list list (list cons ''unquote
+ (bq-process2 (cdr x) (- d 1))))))
+ ((eq? (car x) 'unquote-splicing)
+ (if (= d 0)
+ (list 'copy-list (cadr x))
+ (list list (list list ''unquote-splicing
+ (bq-process2 (cadr x) (- d 1))))))
+ ((eq? (car x) 'unquote-nsplicing)
+ (if (= d 0)
+ (cadr x)
+ (list list (list list ''unquote-nsplicing
+ (bq-process2 (cadr x) (- d 1))))))
+ (else (list list (bq-process2 x d)))))
+ (cond ((symbol? x) (list 'quote x))
+ ((vector? x)
+ (let ((body (bq-process2 (vector->list x) d)))
+ (if (eq? (car body) list)
+ (cons vector (cdr body))
+ (list apply vector body))))
+ ((atom? x) x)
+ ((eq? (car x) 'quasiquote)
+ (list list ''quasiquote (bq-process2 (cadr x) (+ d 1))))
+ ((eq? (car x) 'unquote)
+ (if (and (= d 0) (length= x 2))
+ (cadr x)
+ (list cons ''unquote (bq-process2 (cdr x) (- d 1)))))
+ ((or (> d 0) (not (any splice-form? x)))
+ (let ((lc (lastcdr x))
+ (forms (map bq-bracket1 x)))
+ (if (null? lc)
+ (cons list forms)
+ (if (null? (cdr forms))
+ (list cons (car forms) (bq-process2 lc d))
+ (nconc (cons list* forms) (list (bq-process2 lc d)))))))
+ (else
+ (let loop ((p x) (q ()))
+ (cond ((null? p) ;; proper list
+ (cons 'nconc (reverse! q)))
+ ((pair? p)
+ (cond ((eq? (car p) 'unquote)
+ ;; (... . ,x)
+ (cons 'nconc
+ (nreconc q
+ (if (= d 0)
+ (cdr p)
+ (list (list list ''unquote)
+ (bq-process2 (cdr p)
+ (- d 1)))))))
+ (else
+ (loop (cdr p) (cons (bq-bracket (car p)) q)))))
+ (else
+ ;; (... . x)
+ (cons 'nconc (reverse! (cons (bq-process2 p d) q)))))))))
+
+#|
+tests
+
+> ``(,a ,,a ,b ,@b ,,@b)
+`(,a ,1 ,b ,@b (unquote 2 3))
+> `(,a ,1 ,b ,@b (unquote 2 3))
+(1 1 (2 3) 2 3 2 3)
+
+(define a 1)
+
+(bq-process2 '`(,a (unquote unquote a)) 0)
+
+(define b '(unquote a))
+(define unquote 88)
+(bq-process2 '``(,a ,,,@b) 0)
+; etc. => (1 88 1)
+
+(define b '(a a))
+(bq-process2 '``(,a ,,,@b) 0)
+; etc. => (1 1 1)
+|#
+
+;; minimal version with no optimizations, vectors, or dotted lists
+(define (bq-process0 x d)
+ (define (bq-bracket x)
+ (cond ((and (pair? x) (eq? (car x) 'unquote))
+ (if (= d 0)
+ (cons list (cdr x))
+ (list list (list cons ''unquote
+ (bq-process0 (cdr x) (- d 1))))))
+ ((and (pair? x) (eq? (car x) 'unquote-splicing))
+ (if (= d 0)
+ (list 'copy-list (cadr x))
+ (list list (list list ''unquote-splicing
+ (bq-process0 (cadr x) (- d 1))))))
+ (else (list list (bq-process0 x d)))))
+ (cond ((symbol? x) (list 'quote x))
+ ((atom? x) x)
+ ((eq? (car x) 'quasiquote)
+ (list list ''quasiquote (bq-process0 (cadr x) (+ d 1))))
+ ((eq? (car x) 'unquote)
+ (if (and (= d 0) (length= x 2))
+ (cadr x)
+ (list cons ''unquote (bq-process0 (cdr x) (- d 1)))))
+ (else
+ (cons 'nconc (map bq-bracket x)))))
+
+#t
--- /dev/null
+++ b/examples/cps.lsp
@@ -1,0 +1,308 @@
+; -*- scheme -*-
+(define (begin->cps forms k)
+ (cond ((atom? forms) `(,k ,forms))
+ ((null? (cdr forms)) (cps- (car forms) k))
+ (#t (let ((_ (gensym))) ; var to bind ignored value
+ (cps- (car forms) `(lambda (,_)
+ ,(begin->cps (cdr forms) k)))))))
+
+(define-macro (lambda/cc args body)
+ `(cons 'lambda/cc (lambda ,args ,body)))
+
+; a utility used at run time to dispatch a call with or without
+; the continuation argument, depending on the function
+(define (funcall/cc f k . args)
+ (if (and (pair? f) (eq (car f) 'lambda/cc))
+ (apply (cdr f) (cons k args))
+ (k (apply f args))))
+(define *funcall/cc-names*
+ (list->vector
+ (map (lambda (i) (symbol (string 'funcall/cc- i)))
+ (iota 6))))
+(define-macro (def-funcall/cc-n args)
+ (let ((name (aref *funcall/cc-names* (length args))))
+ `(define (,name f k ,@args)
+ (if (and (pair? f) (eq (car f) 'lambda/cc))
+ ((cdr f) k ,@args)
+ (k (f ,@args))))))
+(def-funcall/cc-n ())
+(def-funcall/cc-n (a0))
+(def-funcall/cc-n (a0 a1))
+(def-funcall/cc-n (a0 a1 a2))
+(def-funcall/cc-n (a0 a1 a2 a3))
+(def-funcall/cc-n (a0 a1 a2 a3 a4))
+
+(define (rest->cps xformer form k argsyms)
+ (let ((el (car form)))
+ (if (or (atom? el) (constant? el))
+ (xformer (cdr form) k (cons el argsyms))
+ (let ((g (gensym)))
+ (cps- el `(lambda (,g)
+ ,(xformer (cdr form) k (cons g argsyms))))))))
+
+(define (make-funcall/cc head ke args)
+ (let ((n (length args)))
+ (if (< n 6)
+ `(,(aref *funcall/cc-names* n) ,head ,ke ,@args)
+ `(funcall/cc ,head ,ke ,@args))))
+
+; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X)))))
+(define (app->cps form k argsyms)
+ (cond ((atom? form)
+ (let ((r (reverse argsyms)))
+ (make-funcall/cc (car r) k (cdr r))))
+ (#t (rest->cps app->cps form k argsyms))))
+
+; (+ x) => (cps- x `(lambda (X) (,k (+ X))))
+(define (builtincall->cps form k)
+ (prim->cps (cdr form) k (list (car form))))
+(define (prim->cps form k argsyms)
+ (cond ((atom? form) `(,k ,(reverse argsyms)))
+ (#t (rest->cps prim->cps form k argsyms))))
+
+(define *top-k* (gensym))
+(set-top-level-value! *top-k* identity)
+
+(define (cps form)
+ (η-reduce
+ (β-reduce
+ (expand
+ (cps- (expand form) *top-k*)))))
+(define (cps- form k)
+ (let ((g (gensym)))
+ (cond ((or (atom? form) (constant? form))
+ `(,k ,form))
+
+ ((eq (car form) 'lambda)
+ `(,k (lambda/cc ,(cons g (cadr form)) ,(cps- (caddr form) g))))
+
+ ((eq (car form) 'begin)
+ (begin->cps (cdr form) k))
+
+ ((eq (car form) 'if)
+ (let ((test (cadr form))
+ (then (caddr form))
+ (else (cadddr form)))
+ (if (atom? k)
+ (cps- test `(lambda (,g)
+ (if ,g
+ ,(cps- then k)
+ ,(cps- else k))))
+ `(let ((,g ,k))
+ ,(cps- form g)))))
+
+ ((eq (car form) 'and)
+ (cond ((atom? (cdr form)) `(,k #t))
+ ((atom? (cddr form)) (cps- (cadr form) k))
+ (#t
+ (if (atom? k)
+ (cps- (cadr form)
+ `(lambda (,g)
+ (if ,g ,(cps- `(and ,@(cddr form)) k)
+ (,k ,g))))
+ `(let ((,g ,k))
+ ,(cps- form g))))))
+
+ ((eq (car form) 'or)
+ (cond ((atom? (cdr form)) `(,k #f))
+ ((atom? (cddr form)) (cps- (cadr form) k))
+ (#t
+ (if (atom? k)
+ (cps- (cadr form)
+ `(lambda (,g)
+ (if ,g (,k ,g)
+ ,(cps- `(or ,@(cddr form)) k))))
+ `(let ((,g ,k))
+ ,(cps- form g))))))
+
+ ((eq (car form) 'while)
+ (let ((test (cadr form))
+ (body (caddr form))
+ (lastval (gensym)))
+ (cps- (expand
+ `(let ((,lastval #f))
+ ((label ,g (lambda ()
+ (if ,test
+ (begin (set! ,lastval ,body)
+ (,g))
+ ,lastval))))))
+ k)))
+
+ ((eq (car form) 'set!)
+ (let ((var (cadr form))
+ (E (caddr form)))
+ (cps- E `(lambda (,g) (,k (set! ,var ,g))))))
+
+ ((eq (car form) 'reset)
+ `(,k ,(cps- (cadr form) *top-k*)))
+
+ ((eq (car form) 'shift)
+ (let ((v (cadr form))
+ (E (caddr form))
+ (val (gensym)))
+ `(let ((,v (lambda/cc (,g ,val) (,g (,k ,val)))))
+ ,(cps- E *top-k*))))
+
+ ((eq (car form) 'without-delimited-continuations)
+ `(,k ,(cadr form)))
+
+ ((and (constant? (car form))
+ (builtin? (eval (car form))))
+ (builtincall->cps form k))
+
+ ; ((lambda (...) body) ...)
+ ((and (pair? (car form))
+ (eq (caar form) 'lambda))
+ (let ((largs (cadr (car form)))
+ (lbody (caddr (car form))))
+ (cond ((null? largs) ; ((lambda () body))
+ (cps- lbody k))
+ ((symbol? largs) ; ((lambda x body) args...)
+ (cps- `((lambda (,largs) ,lbody) (list ,@(cdr form))) k))
+ (#t
+ (cps- (cadr form) `(lambda (,(car largs))
+ ,(cps- `((lambda ,(cdr largs) ,lbody)
+ ,@(cddr form))
+ k)))))))
+
+ (#t
+ (app->cps form k ())))))
+
+; (lambda (args...) (f args...)) => f
+; but only for constant, builtin f
+(define (η-reduce form)
+ (cond ((or (atom? form) (constant? form)) form)
+ ((and (eq (car form) 'lambda)
+ (let ((body (caddr form))
+ (args (cadr form)))
+ (and (pair? body)
+ (equal? (cdr body) args)
+ (constant? (car (caddr form))))))
+ (car (caddr form)))
+ (#t (map η-reduce form))))
+
+(define (contains x form)
+ (or (eq form x)
+ (any (lambda (p) (contains x p)) form)))
+
+(define (β-reduce form)
+ (if (or (atom? form) (constant? form))
+ form
+ (β-reduce- (map β-reduce form))))
+
+(define (β-reduce- form)
+ ; ((lambda (f) (f arg)) X) => (X arg)
+ (cond ((and (length= form 2)
+ (pair? (car form))
+ (eq (caar form) 'lambda)
+ (let ((args (cadr (car form)))
+ (body (caddr (car form))))
+ (and (pair? body) (pair? args)
+ (length= body 2)
+ (length= args 1)
+ (eq (car body) (car args))
+ (not (eq (cadr body) (car args)))
+ (symbol? (cadr body)))))
+ `(,(cadr form)
+ ,(cadr (caddr (car form)))))
+
+ ; (identity x) => x
+ ((eq (car form) *top-k*)
+ (cadr form))
+
+ ; uncurry:
+ ; ((lambda (p1) ((lambda (args...) body) exprs...)) s) =>
+ ; ((lambda (p1 args...) body) s exprs...)
+ ; where exprs... doesn't contain p1
+ ((and (length= form 2)
+ (pair? (car form))
+ (eq (caar form) 'lambda)
+ (or (atom? (cadr form)) (constant? (cadr form)))
+ (let ((args (cadr (car form)))
+ (s (cadr form))
+ (body (caddr (car form))))
+ (and (pair? args) (length= args 1)
+ (pair? body)
+ (pair? (car body))
+ (eq (caar body) 'lambda)
+ (let ((innerargs (cadr (car body)))
+ (innerbody (caddr (car body)))
+ (params (cdr body)))
+ (and (not (contains (car args) params))
+ `((lambda ,(cons (car args) innerargs)
+ ,innerbody)
+ ,s
+ ,@params)))))))
+
+ (#t form)))
+
+(define-macro (with-delimited-continuations . code)
+ (cps `((lambda () ,@code))))
+
+(define-macro (define-generator form . body)
+ (let ((ko (gensym))
+ (cur (gensym))
+ (name (car form))
+ (args (cdr form)))
+ `(define (,name ,@args)
+ (let ((,ko #f)
+ (,cur #f))
+ (lambda ()
+ (with-delimited-continuations
+ (if ,ko (,ko ,cur)
+ (reset
+ (let ((yield
+ (lambda (v)
+ (shift yk
+ (begin (set! ,ko yk)
+ (set! ,cur v))))))
+ ,@body)))))))))
+
+; a test case
+(define-generator (range-iterator lo hi)
+ ((label loop
+ (lambda (i)
+ (if (< hi i)
+ 'done
+ (begin (yield i)
+ (loop (+ 1 i))))))
+ lo))
+
+; example from Chung-chieh Shan's paper
+(assert (equal?
+ (with-delimited-continuations
+ (cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c ())))))))))
+ '(a 1 b b c)))
+
+#t
+
+#|
+todo:
+* tag lambdas that accept continuation arguments, compile computed
+ calls to calls to funcall/cc that does the right thing for both
+ cc-lambdas and normal lambdas
+
+* handle dotted arglists in lambda
+
+- optimize constant functions, e.g. (funcall/cc-0 #:g65 (lambda (#:g58) 'done))
+
+- implement CPS version of apply
+
+- use fewer gensyms
+
+ here's an alternate way to transform a while loop:
+
+ (let ((x 0))
+ (while (< x 10)
+ (begin (print x) (set! x (+ 1 x)))))
+ =>
+ (let ((x 0))
+ (reset
+ (let ((l #f))
+ (let ((k (shift k (k k))))
+ (if (< x 10)
+ (begin (set! l (begin (print x)
+ (set! x (+ 1 x))))
+ (k k))
+ l)))))
+|#
--- /dev/null
+++ b/examples/rule30.lsp
@@ -1,0 +1,25 @@
+; -*- scheme -*-
+
+(define (rule30-step b)
+ (let ((L (ash b -1))
+ (R (ash b 1)))
+ (let ((~b (lognot b))
+ (~L (lognot L))
+ (~R (lognot R)))
+ (logior (logand L ~b ~R)
+ (logand ~L b R)
+ (logand ~L b ~R)
+ (logand ~L ~b R)))))
+
+(define (bin-draw s)
+ (string.map (lambda (c) (case c
+ (#\1 #\#)
+ (#\0 #\ )
+ (else c)))
+ s))
+
+(for-each (lambda (n)
+ (begin
+ (princ (bin-draw (string.lpad (number->string n 2) 63 #\0)))
+ (newline)))
+ (nestlist rule30-step (uint64 0x0000000080000000) 32))
--- a/femtolisp/.gitignore
+++ /dev/null
@@ -1,4 +1,0 @@
-/*.o
-/*.do
-/*.a
-/flisp
--- a/femtolisp/FLOSSING
+++ /dev/null
@@ -1,13 +1,0 @@
-Flossing is important to overall oral health.
-
-Even by itself, flossing does a good job of cleaning teeth and gums,
-and is the only way to clean below the gumline.
-
-However it has an important secondary purpose as well. Most people assume
-the point of brushing teeth is to scrub the teeth with bristles. This
-is not fully true; the more significant purpose of brushing is to apply
-fluoride to teeth. If you don't floss, food particles are left between
-the teeth and gums, blocking fluoride from reaching tooth surfaces. It
-is then as if you were not brushing at all. Even if no material is
-visible between teeth, there is probably some there. Flossing can pull
-a surprising amount of gunk from a mouth that appears totally clean.
--- a/femtolisp/LICENSE
+++ /dev/null
@@ -1,26 +1,0 @@
-Copyright (c) 2008 Jeff Bezanson
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
- * Redistributions of source code must retain the above copyright notice,
- this list of conditions and the following disclaimer.
- * Redistributions in binary form must reproduce the above copyright notice,
- this list of conditions and the following disclaimer in the documentation
- and/or other materials provided with the distribution.
- * Neither the author nor the names of any contributors may be used to
- endorse or promote products derived from this software without specific
- prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
-ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
-ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- a/femtolisp/Makefile
+++ /dev/null
@@ -1,58 +1,0 @@
-CC = gcc
-
-NAME = flisp
-SRCS = $(NAME).c builtins.c string.c equalhash.c table.c iostream.c
-OBJS = $(SRCS:%.c=%.o)
-DOBJS = $(SRCS:%.c=%.do)
-EXENAME = $(NAME)
-LIBTARGET = lib$(NAME)
-LLTDIR = ../llt
-LLT = $(LLTDIR)/libllt.a
-
-# OS flags: LINUX, WIN32, MACOSX
-# architecture flags: __CPU__=xxx, BITS64, ARCH_X86, ARCH_X86_64
-CONFIG = -DLINUX -DARCH_X86_64 -DBITS64 -D__CPU__=686
-FLAGS = -falign-functions -Wall -Wno-strict-aliasing -I$(LLTDIR) $(CFLAGS) -DUSE_COMPUTED_GOTO $(CONFIG)
-LIBFILES = $(LLT)
-LIBS = $(LIBFILES) -lm
-
-DEBUGFLAGS = -g -DDEBUG $(FLAGS)
-SHIPFLAGS = -O2 -DNDEBUG $(FLAGS)
-
-default: release test
-
-test:
- cd tests && ../flisp unittest.lsp
-
-%.o: %.c
- $(CC) $(SHIPFLAGS) -c $< -o $@
-%.do: %.c
- $(CC) $(DEBUGFLAGS) -c $< -o $@
-
-flisp.o: flisp.c cvalues.c types.c flisp.h print.c read.c equal.c
-flisp.do: flisp.c cvalues.c types.c flisp.h print.c read.c equal.c
-flmain.o: flmain.c flisp.h
-flmain.do: flmain.c flisp.h
-
-$(LLT):
- cd $(LLTDIR) && make
-
-$(LIBTARGET).da: $(DOBJS)
- rm -rf $@
- ar rs $@ $(DOBJS)
-
-$(LIBTARGET).a: $(OBJS)
- rm -rf $@
- ar rs $@ $(OBJS)
-
-debug: $(DOBJS) $(LIBFILES) $(LIBTARGET).da flmain.do
- $(CC) $(DEBUGFLAGS) $(DOBJS) flmain.do -o $(EXENAME) $(LIBS) $(LIBTARGET).da
- make test
-
-release: $(OBJS) $(LIBFILES) $(LIBTARGET).a flmain.o
- $(CC) $(SHIPFLAGS) $(OBJS) flmain.o -o $(EXENAME) $(LIBS) $(LIBTARGET).a
-
-clean:
- rm -f *.o
- rm -f *.do
- rm -f $(EXENAME)
--- a/femtolisp/Makefile.macosx
+++ /dev/null
@@ -1,44 +1,0 @@
-CC = gcc
-
-NAME = flisp
-SRCS = $(NAME).c builtins.c string.c equalhash.c table.c iostream.c
-OBJS = $(SRCS:%.c=%.o)
-DOBJS = $(SRCS:%.c=%.do)
-EXENAME = $(NAME)
-LLTDIR = ../llt
-LLT = $(LLTDIR)/libllt.a
-
-FLAGS = -falign-functions -Wall -Wno-strict-aliasing -I$(LLTDIR) $(CFLAGS) -DUSE_COMPUTED_GOTO
-LIBFILES = $(LLT)
-LIBS = $(LIBFILES) -lm -framework ApplicationServices
-
-DEBUGFLAGS = -g -DDEBUG $(FLAGS)
-SHIPFLAGS = -O2 -DNDEBUG $(FLAGS)
-
-default: release test
-
-test:
- ./flisp unittest.lsp
-
-%.o: %.c
- $(CC) $(SHIPFLAGS) -c $< -o $@
-%.do: %.c
- $(CC) $(DEBUGFLAGS) -c $< -o $@
-
-flisp.o: flisp.c cvalues.c types.c flisp.h print.c read.c equal.c
-flisp.do: flisp.c cvalues.c types.c flisp.h print.c read.c equal.c
-
-$(LLT):
- cd $(LLTDIR) && make
-
-debug: $(DOBJS) $(LIBFILES)
- $(CC) $(DEBUGFLAGS) $(DOBJS) -o $(EXENAME) $(LIBS)
- make test
-
-release: $(OBJS) $(LIBFILES)
- $(CC) $(SHIPFLAGS) $(OBJS) -o $(EXENAME) $(LIBS)
-
-clean:
- rm -f *.o
- rm -f *.do
- rm -f $(EXENAME)
--- a/femtolisp/README.md
+++ /dev/null
@@ -1,37 +1,0 @@
-## ...a purely symbolic gesture...
-
-This project began with an attempt to write the fastest lisp interpreter I could in under 1000 lines of C. It snowballed from there as I kept trying to see if I could add powerful features with minimal code. At the same time I assembled a library of some of my favorite C code (by myself and others) to use as a base for a standard library. This includes `ios`, a replacement for parts of C's stdio that adds more flexible features.
-
-Before you say "oh no, another lisp", consider the following: femtolisp is about 150kb, is very self-contained, and has the following features:
-
- * vectors, strings, gensyms
- * backquote
- * exceptions
- * printing and reading circular/shared structure
- * all values can be printed readably
- * prettyprinting
- * hash tables
- * support for directly using C data types ala Python's ctypes
- * `equal` and ordered comparison predicates that work on circular structure
- * proper tail recursion
- * io and memory streams with utf8 support
- * highly compatible with Scheme, including some `R6RS` features
- * simple, well-organized, powerful API with as few functions as possible
- * compacting GC
- * and...
-
-...it is fast, ranking among the fastest non-native-compiled Scheme implementations. It achieves this level of speed even though many primitives (like `map`) are written in the language instead of C. femtolisp uses a bytecode compiler and VM, with the compiler written in femtolisp. Bytecode is first-class, can be printed and read, and is "human readable" (the representation is a string of normal low-ASCII characters).
-
-femtolisp is a simple, elegant Scheme dialect. It is a lisp-1 with lexical scope. The core is 12 builtin special forms and 33 builtin functions.
-
-A primary design goal is to keep the code concise and interesting. I strive to have each concept implemented in just one place, so the system is easy to understand and modify. The result is high reliability, because there are fewer places for bugs to hide. You want a small core of generically useful features that work _really well_ (for example, see `torture.scm`).
-
-Almost everybody has their own lisp implementation. Some programmers' dogs and cats probably have _their_ own lisp implementations as well. This is great, but too often I see people omit some of the obscure but critical features that make lisp uniquely wonderful. These include read macros like `#.` and backreferences, gensyms, and properly escaped symbol names. If you're going to waste everybody's time with yet another lisp, at least do it right damnit.
-
-Another design goal is to avoid spurious novelties. Many others offering their own "shiny new" lisp dialects get carried away and change anything that strikes their fancy. These changes have no effect except incompatibility, and often make the language worse because the new design was not as carefully thought out and has not stood the test of time. For example, how does it help to remove backquote? One design changes the syntax of `quote`. Some systems disallow dotted lists. (I've seen all three of these.) What's the point? Implementers wave the banner of "simplicity", yet wedge in all kinds of weird implicit behaviors and extra evaluation rules.
-
-Lately a surprising amount of FUD has been spread about tail call optimization. I agree that not every language needs it, but I would like to refute the idea that it makes interpreters slow. Look at the "tiny" subdirectory or the "interpreter" branch to see a pure s-expr interpreter with efficient TCO. All you have to do is keep track of whether you're in tail position, which can be done very cheaply. These interpreters are difficult to beat for speed, yet they have lexical scope and TCO.
-
-This project is mostly a matter of style. Look at the code and you'll understand.
-
-This is what I do for fun, because it is the _exact opposite_ of the kind of thing people will pay for: an obscure implementation of a programming language everybody hates.
--- a/femtolisp/aliases.scm
+++ /dev/null
@@ -1,300 +1,0 @@
-; definitions of standard scheme procedures in terms of
-; femtolisp procedures
-; sufficient to run the R5RS version of psyntax
-
-(define top-level-bound? bound?)
-(define (eval-core x) (eval x))
-(define (symbol-value s) (top-level-value s))
-(define (set-symbol-value! s v) (set-top-level-value! s v))
-(define (eval x)
- ((compile-thunk (expand
- (if (and (pair? x)
- (equal? (car x) "noexpand"))
- (cadr x)
- x)))))
-(define (command-line) *argv*)
-
-(define gensym
- (let (($gensym gensym))
- (lambda ((x #f)) ($gensym))))
-
-(define-macro (begin0 first . rest)
- (let ((g (gensym)))
- `(let ((,g ,first))
- ,@rest
- ,g)))
-
-(define vector-ref aref)
-(define vector-set! aset!)
-(define vector-length length)
-(define make-vector vector.alloc)
-(define (vector-fill! v f)
- (for 0 (- (length v) 1)
- (lambda (i) (aset! v i f)))
- #t)
-(define (vector-map f v) (vector.map f v))
-
-(define array-ref! aref)
-(define (array-set! a obj i0 . idxs)
- (if (null? idxs)
- (aset! a i0 obj)
- (error "array-set!: multiple dimensions not yet implemented")))
-
-(define (array-dimensions a)
- (list (length a)))
-
-(define (complex? x) #f)
-(define (real? x) (number? x))
-(define (rational? x) (integer? x))
-(define (exact? x) (integer? x))
-(define (inexact? x) (not (exact? x)))
-(define (flonum? x) (not (exact? x)))
-(define quotient div0)
-(define remainder mod0)
-(define (inexact x) x)
-(define (exact x)
- (if (exact? x) x
- (error "exact real numbers not supported")))
-(define (exact->inexact x) (double x))
-(define (inexact->exact x)
- (if (integer-valued? x)
- (truncate x)
- (error "exact real numbers not supported")))
-(define (floor x) (if (< x 0) (truncate (- x 0.5)) (truncate x)))
-(define (ceiling x) (if (< x 0) (truncate x) (truncate (+ x 0.5))))
-(define (finite? x) (and (< x +inf.0) (> x -inf.0)))
-(define (infinite? x) (or (equal? x +inf.0) (equal? x -inf.0)))
-(define (nan? x) (or (equal? x +nan.0) (equal? x -nan.0)))
-
-(define (char->integer c) (fixnum c))
-(define (integer->char i) (wchar i))
-(define char-upcase char.upcase)
-(define char-downcase char.downcase)
-(define char=? eqv?)
-(define char<? <)
-(define char>? >)
-(define char<=? <=)
-(define char>=? >=)
-(define (char-whitespace? c) (not (not (string.find *whitespace* c))))
-(define (char-numeric? c) (not (not (string.find "0123456789" c))))
-
-(define string=? eqv?)
-(define string<? <)
-(define string>? >)
-(define string<=? <=)
-(define string>=? >=)
-(define string-copy copy)
-(define string-append string)
-(define string-length string.count)
-(define string->symbol symbol)
-(define (symbol->string s) (string s))
-(define symbol=? eq?)
-(define (make-string k (fill #\space))
- (string.rep fill k))
-
-(define (string-ref s i)
- (string.char s (string.inc s 0 i)))
-
-(define (list->string l) (apply string l))
-(define (string->list s)
- (do ((i (sizeof s) i)
- (l '() (cons (string.char s i) l)))
- ((= i 0) l)
- (set! i (string.dec s i))))
-
-(define (substring s start end)
- (string.sub s (string.inc s 0 start) (string.inc s 0 end)))
-
-(define (input-port? x) (iostream? x))
-(define (output-port? x) (iostream? x))
-(define (port? x) (iostream? x))
-(define close-input-port io.close)
-(define close-output-port io.close)
-(define (read-char (s *input-stream*)) (io.getc s))
-(define (peek-char (s *input-stream*)) (io.peekc s))
-(define (write-char c (s *output-stream*)) (io.putc s c))
-; TODO: unread-char
-(define (port-eof? p) (io.eof? p))
-(define (open-input-string str)
- (let ((b (buffer)))
- (io.write b str)
- (io.seek b 0)
- b))
-(define (open-output-string) (buffer))
-(define (open-string-output-port)
- (let ((b (buffer)))
- (values b (lambda () (io.tostring! b)))))
-
-(define (get-output-string b)
- (let ((p (io.pos b)))
- (io.seek b 0)
- (let ((s (io.readall b)))
- (io.seek b p)
- (if (eof-object? s) "" s))))
-
-(define (open-input-file name) (file name :read))
-(define (open-output-file name) (file name :write :create))
-
-(define (current-input-port (p *input-stream*))
- (set! *input-stream* p))
-(define (current-output-port (p *output-stream*))
- (set! *output-stream* p))
-
-(define (input-port-line p)
- ; TODO
- 1)
-
-(define get-datum read)
-(define (put-datum port x)
- (with-bindings ((*print-readably* #t))
- (write x port)))
-
-(define (put-u8 port o) (io.write port (uint8 o)))
-(define (put-string port s (start 0) (count #f))
- (let* ((start (string.inc s 0 start))
- (end (if count
- (string.inc s start count)
- (sizeof s))))
- (io.write port s start (- end start))))
-
-(define (io.skipws s)
- (let ((c (io.peekc s)))
- (if (and (not (eof-object? c)) (char-whitespace? c))
- (begin (io.getc s)
- (io.skipws s)))))
-
-(define (with-output-to-file name thunk)
- (let ((f (file name :write :create :truncate)))
- (unwind-protect
- (with-output-to f (thunk))
- (io.close f))))
-
-(define (with-input-from-file name thunk)
- (let ((f (file name :read)))
- (unwind-protect
- (with-input-from f (thunk))
- (io.close f))))
-
-(define (call-with-input-file name proc)
- (let ((f (open-input-file name)))
- (prog1 (proc f)
- (io.close f))))
-
-(define (call-with-output-file name proc)
- (let ((f (open-output-file name)))
- (prog1 (proc f)
- (io.close f))))
-
-(define (file-exists? f) (path.exists? f))
-(define (delete-file name) (void)) ; TODO
-
-(define (display x (port *output-stream*))
- (with-output-to port (princ x))
- #t)
-
-(define assertion-violation
- (lambda args
- (display 'assertion-violation)
- (newline)
- (display args)
- (newline)
- (car #f)))
-
-(define pretty-print write)
-
-(define (memp proc ls)
- (cond ((null? ls) #f)
- ((pair? ls) (if (proc (car ls))
- ls
- (memp proc (cdr ls))))
- (else (assertion-violation 'memp "Invalid argument" ls))))
-
-(define (assp pred lst)
- (cond ((atom? lst) #f)
- ((pred (caar lst)) (car lst))
- (else (assp pred (cdr lst)))))
-
-(define (for-all proc l . ls)
- (or (null? l)
- (and (apply proc (car l) (map car ls))
- (apply for-all proc (cdr l) (map cdr ls)))))
-(define andmap for-all)
-
-(define (exists proc l . ls)
- (and (not (null? l))
- (or (apply proc (car l) (map car ls))
- (apply exists proc (cdr l) (map cdr ls)))))
-(define ormap exists)
-
-(define cons* list*)
-
-(define (fold-left f zero lst)
- (if (null? lst) zero
- (fold-left f (f zero (car lst)) (cdr lst))))
-
-(define fold-right foldr)
-
-(define (partition pred lst)
- (let ((s (separate pred lst)))
- (values (car s) (cdr s))))
-
-(define (dynamic-wind before thunk after)
- (before)
- (unwind-protect (thunk)
- (after)))
-
-(let ((*properties* (table)))
- (set! putprop
- (lambda (sym key val)
- (let ((sp (get *properties* sym #f)))
- (if (not sp)
- (let ((t (table)))
- (put! *properties* sym t)
- (set! sp t)))
- (put! sp key val))))
-
- (set! getprop
- (lambda (sym key)
- (let ((sp (get *properties* sym #f)))
- (and sp (get sp key #f)))))
-
- (set! remprop
- (lambda (sym key)
- (let ((sp (get *properties* sym #f)))
- (and sp (has? sp key) (del! sp key))))))
-
-; --- gambit
-
-(define arithmetic-shift ash)
-(define bitwise-and logand)
-(define bitwise-or logior)
-(define bitwise-not lognot)
-(define bitwise-xor logxor)
-
-(define (include f) (load f))
-(define (with-exception-catcher hand thk)
- (trycatch (thk)
- (lambda (e) (hand e))))
-
-(define (current-exception-handler)
- ; close enough
- (lambda (e) (raise e)))
-
-(define make-table table)
-(define table-ref get)
-(define table-set! put!)
-(define (read-line (s *input-stream*))
- (io.flush *output-stream*)
- (io.discardbuffer s)
- (io.readline s))
-(define (shell-command s) 1)
-(define (error-exception-message e) (cadr e))
-(define (error-exception-parameters e) (cddr e))
-
-(define (with-output-to-string nada thunk)
- (let ((b (buffer)))
- (with-output-to b (thunk))
- (io.tostring! b)))
-
-(define (read-u8) (io.read *input-stream* 'uint8))
-(define modulo mod)
--- a/femtolisp/ascii-mona-lisa
+++ /dev/null
@@ -1,47 +1,0 @@
-iIYVVVVXVVVVVVVVVYVYVYYVYYYYIIIIYYYIYVVVYYYYYYYYYVVYVVVVXVVVVVYI+.
-tYVXXXXXXVXXXXVVVYVVVVVVVVVVVVYVVVVVVVVVVVVVVVVVXXXXXVXXXXXXXVVYi.
-iYXRXRRRXXXXXXXXXXXVVXVXVVVVVVVVXXXVXVVXXXXXXXXXXXXXXRRRRRRRRRXVi.
-tVRRRRRRRRRRRRRRRXRXXXXXXXXXXXXXXRRXXXXRRRRXXXXXXXRRRRRRRRRRRRXV+.
-tVRRBBBRMBRRRRRRRRRXXRRRRRXt=+;;;;;==iVXRRRRXXXXRRRRRRRRMMBRRRRXi,
-tVRRBMBBMMBBBBBMBBRBBBRBX++=++;;;;;;:;;;IRRRRXXRRRBBBBBBMMBBBRRXi,
-iVRMMMMMMMMMMMMMMBRBBMMV==iIVYIi=;;;;:::;;XRRRRRRBBMMMMMMMMBBRRXi.
-iVRMMMMMMMMMMMMMMMMMMMY;IBWWWWMMXYi=;:::::;RBBBMMMMMMMMMMMMMMBBXi,
-+VRMMRBMMMMMMMMMMMMMMY+;VMMMMMMMRXIi=;:::::=VVXXXRRRMMMMMMMMBBMXi;
-=tYYVVVXRRRXXRBMMMMMV+;=RBBMMMXVXXVYt;::::::ttYYVYVVRMMMMMMBXXVI+=
-;=tIYYVYYYYYYVVVMMMBt=;;+i=IBi+t==;;i;::::::+iitIIttYRMMMMMRXVVI=;
-;=IIIIYYYIIIIttIYItIt;;=VVYXBIVRXVVXI;::::::;+iitttttVMMBRRRVVVI+,
-;+++tttIttttiiii+i++==;;RMMMBXXMMMXI+;::::::;+ittttitYVXVYYIYVIi;;
-;===iiittiiIitiii++;;;;:IVRVi=iBXVIi;::::::::;==+++++iiittii+++=;;
-;;==+iiiiiiiiii+++=;;;;;;VYVIiiiVVt+;::::::::;++++++++++iti++++=;;
-;;=++iiii+i+++++iii==;;;::tXYIIYIi+=;:::::,::;+++++++++++++++++=;;
-;;;+==+ii+++++iiiiit=;;:::::=====;;;::::::::::+++i+++++++++i+++;;;
-;;;==+=+iiiiitttIIII+;;;:,::,;;;;:;=;;;::,::::=++++++++==++++++;;;
-:;====+tittiiittttti+;;::::,:=Ytiiiiti=;:::::,:;;==ii+ittItii+==;;
-;;+iiittIti+ii;;===;;:;::::;+IVXVVVVVVt;;;;;::::;;===;+IIiiti=;;;;
-;=++++iIti+ii+=;;;=;:::;;+VXBMMBBBBBBXY=;=;;:::::;=iYVIIttii++;;;;
-;;++iiiItttIi+++=;;:::;=iBMMMMMMMMMMMXI==;;,::;;:;;=+itIttIIti+;;;
-;=+++++i+tYIIiii;:,::;itXMMMMMMMMMMMBXti==;:;++=;:::::;=+iittti+;;
-;;+ii+ii+iitiIi;::::;iXBMMMMMWWWWWMMBXti+ii=;::::,,,,:::=;==+tI+;;
-;;iiiitItttti;:::;::=+itYXXMWWWWWWMBYt+;;::,,,,,,,,,,,,,:==;==;;;;
-:;=iIIIttIt+:;:::;;;==;+=+iiittttti+;;:,:,,,,::,,,,,,,,:::;=;==::;
-;::=+ittiii=;:::::;;;:;:;=++==;;==;:,,,,,,:;::::,,,,,,,,::;==;;::;
-:::;+iiiii=;::::,:;:::::;;:;;::;:::,,,,,,,:::;=;;;:,,,,,:::;;::::;
-:;;iIIIIII=;:::,:::::::,::::,:::,,,,,,,,,,,:;;=;:,,,,,,::::;=;:::;
-:;==++ii+;;;:::::::::::,,,,,,::,,,,,,,,,,,::::,,,,,,,,,,:,:::::::;
-::;;=+=;;;:::;;::,,,,,,,,,,,,,,,,,,,,,,,,,:,,,,,,,,,,,,,,,,,:::::;
-::;=;;;:;:::;;;;::,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,::,,::::;
-:;;:;::::::,::,,:,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,:::;
-:::::::::::;;;:,,,,,,,,,,,,,...,...,,,.,,,,,,,,,,,,.,,,,,,,,,,,,:;
-::::::::;=;;;;;::,,,,,,,,,,,.......,...,,,,,,,,,,,,.,,,,,,,,,,,,,;
-:::::,,:;=;;;;;;;iVXXXVt+:,,....,,,,....,.,,,,,,,.,.....,,,,,,,,:;
-:,,::,,:::;;;;;;=IVVVXXXXVXVt:,,,,,..,..,,,,.,,,,,..,.,,,,,,,,,,,;
-::,::,,,:,:::::,::;=iIYVXVVVVIYIi;,,.,.,,,::,,,,,,,,,,,,,,,,,,,,,.
-:,,,,,,,,,,,,,,,,::;+itIIIIIIi:;;i++=;;;;;;;;;::,,,...,,..,,,,,,,.
-:,,,,,,,,,,,,,,=iitVYi++iitt==it;;:;;;;::;;::::,,,......,,,,,,,::.
-::,,,,,,,,,,,,,++iiIVIi=;;=;+i;:;+:::,,,,,,,,,,,,,.....,,,,,,,,::,
-,,,,,,,,,,,,,,,;=+it=:::,,,,,,,,,,.,......,,.,..........,,,,,,,,::
-:,,,,,,,,,,,,,,,,:=:,,,,,,,,,,,,,,......................,.,,.,.,,:
-:,,,,,,,,,,,,,,,,,:,,,,,,,,,,..,........................,..,...,,:
-,,,,,,,,,,,,,,,,,,,.....................................,.......,,
-,,,,,,,,,.,,,,,,,...............................................,,
-itittiiiii+=++=;;=iiiiiiittiiiiii+iii===;++iiitiiiiiii+=====+ii=+i
--- a/femtolisp/ascii-mona-lisa-2
+++ /dev/null
@@ -1,71 +1,0 @@
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!>''''''<!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!'''''` ``'!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!''` ..... `'!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!'` . :::::' `'!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!' . ' .::::' `!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!' : ````` `!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!! .,cchcccccc,,. `!!!!!!!!!!!!
-!!!!!!!!!!!!!!! .-"?$$$$$$$$$$$$$$c, `!!!!!!!!!!!
-!!!!!!!!!!!!!! ,ccc$$$$$$$$$$$$$$$$$$$, `!!!!!!!!!!
-!!!!!!!!!!!!! z$$$$$$$$$$$$$$$$$$$$$$$$;. `!!!!!!!!!
-!!!!!!!!!!!! <$$$$$$$$$$$$$$$$$$$$$$$$$$:. `!!!!!!!!
-!!!!!!!!!!! $$$$$$$$$$$$$$$$$$$$$$$$$$$h;:. !!!!!!!!
-!!!!!!!!!!' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$h;. !!!!!!!
-!!!!!!!!!' <$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !!!!!!!
-!!!!!!!!' `$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$F `!!!!!!
-!!!!!!!! c$$$$???$$$$$$$P"" """??????" !!!!!!
-!!!!!!! `"" .,.. "$$$$F .,zcr !!!!!!
-!!!!!!! . dL .?$$$ .,cc, .,z$h. !!!!!!
-!!!!!!!! <. $$c= <$d$$$ <$$$$=-=+"$$$$$$$ !!!!!!
-!!!!!!! d$$$hcccd$$$$$ d$$$hcccd$$$$$$$F `!!!!!
-!!!!!! ,$$$$$$$$$$$$$$h d$$$$$$$$$$$$$$$$ `!!!!!
-!!!!! `$$$$$$$$$$$$$$$<$$$$$$$$$$$$$$$$' !!!!!
-!!!!! `$$$$$$$$$$$$$$$$"$$$$$$$$$$$$$P> !!!!!
-!!!!! ?$$$$$$$$$$$$??$c`$$$$$$$$$$$?>' `!!!!
-!!!!! `?$$$$$$I7?"" ,$$$$$$$$$?>>' !!!!
-!!!!!. <<?$$$$$$c. ,d$$?$$$$$F>>'' `!!!
-!!!!!! <i?$P"??$$r--"?"" ,$$$$h;>'' `!!!
-!!!!!! $$$hccccccccc= cc$$$$$$$>>' !!!
-!!!!! `?$$$$$$F"""" `"$$$$$>>>'' `!!
-!!!!! "?$$$$$cccccc$$$$??>>>>' !!
-!!!!> "$$$$$$$$$$$$$F>>>>'' `!
-!!!!! "$$$$$$$$???>''' !
-!!!!!> `""""" `
-!!!!!!; . `
-!!!!!!! ?h.
-!!!!!!!! $$c,
-!!!!!!!!> ?$$$h. .,c
-!!!!!!!!! $$$$$$$$$hc,.,,cc$$$$$
-!!!!!!!!! .,zcc$$$$$$$$$$$$$$$$$$$$$$
-!!!!!!!!! .z$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-!!!!!!!!! ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ .
-!!!!!!!!! ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !!
-!!!!!!!!! ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ,!'
-!!!!!!!!> c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$. !'
-!!!!!!'' ,d$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> '
-!!!'' z$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$>
-!' ,$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> ..
- z$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$' ;!!!!''`
- $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$F ,;;!'`' .''
- <$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$> ,;'`' ,;
- `$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$F -' ,;!!'
- "?$$$$$$$$$$?$$$$$$$$$$$$$$$$$$$$$$$$$$F .<!!!''' <!
- !> ""??$$$?C3$$$$$$$$$$$$$$$$$$$$$$$$"" ;!''' !!!
- ;!!!!;, `"''""????$$$$$$$$$$$$$$$$"" ,;-'' ',!
- ;!!!!<!!!; . `""""""""""" `' ' '
- !!!! ;!!! ;!!!!>;,;, .. ' . ' '
- !!' ,;!!! ;'`!!!!!!!!;!!!!!; . >' .'' ;
- !!' ;!!'!';! !! !!!!!!!!!!!!! ' -'
- <!! !! `!;! `!' !!!!!!!!!!<! .
- `! ;! ;!!! <' <!!!! `!!! < /
- `; !> <!! ;' !!!!' !!';! ;'
- ! ! !!! ! `!!! ;!! ! ' '
- ; `! `!! ,' !' ;!'
- ' /`! ! < !! < '
- / ;! >;! ;>
- !' ; !! '
- ' ;! > ! '
- '
-by Allen Mullen
--- a/femtolisp/attic/dict.lsp
+++ /dev/null
@@ -1,51 +1,0 @@
-; dictionary as binary tree
-
-(defun dict () ())
-
-; node representation ((k . v) L R)
-(defun dict-peek (d key nf)
- (if (null d) nf
- (let ((c (compare key (caar d))))
- (cond ((= c 0) (cdar d))
- ((< c 0) (dict-peek (cadr d) key nf))
- (T (dict-peek (caddr d) key nf))))))
-
-(defun dict-get (d key) (dict-peek d key nil))
-
-(defun dict-put (d key v)
- (if (null d) (list (cons key v) (dict) (dict))
- (let ((c (compare key (caar d))))
- (cond ((= c 0) (list (cons key v) (cadr d) (caddr d)))
- ((< c 0) (list (car d)
- (dict-put (cadr d) key v)
- (caddr d)))
- (T (list (car d)
- (cadr d)
- (dict-put (caddr d) key v)))))))
-
-; mutable dictionary
-(defun dict-nput (d key v)
- (if (null d) (list (cons key v) (dict) (dict))
- (let ((c (compare key (caar d))))
- (cond ((= c 0) (rplacd (car d) v))
- ((< c 0) (setf (cadr d) (dict-nput (cadr d) key v)))
- (T (setf (caddr d) (dict-nput (caddr d) key v))))
- d)))
-
-(defun dict-collect (f d)
- (if (null d) ()
- (cons (f (caar d) (cdar d)) (nconc (dict-collect f (cadr d))
- (dict-collect f (caddr d))))))
-
-(defun dict-keys (d) (dict-collect K d))
-(defun dict-pairs (d) (dict-collect cons d))
-
-(defun dict-each (f d)
- (if (null d) ()
- (progn (f (caar d) (cdar d))
- (dict-each f (cadr d))
- (dict-each f (caddr d)))))
-
-(defun alist-to-dict (a)
- (foldl (lambda (p d) (dict-put d (car p) (cdr p)))
- (dict) a))
--- a/femtolisp/attic/flutils.c
+++ /dev/null
@@ -1,59 +1,0 @@
-typedef struct {- size_t n, maxsize;
- unsigned long *items;
-} ltable_t;
-
-void ltable_init(ltable_t *t, size_t n)
-{- t->n = 0;
- t->maxsize = n;
- t->items = (unsigned long*)malloc(n * sizeof(unsigned long));
-}
-
-void ltable_clear(ltable_t *t)
-{- t->n = 0;
-}
-
-void ltable_insert(ltable_t *t, unsigned long item)
-{- unsigned long *p;
-
- if (t->n == t->maxsize) {- p = realloc(t->items, (t->maxsize*2)*sizeof(unsigned long));
- if (p == NULL) return;
- t->items = p;
- t->maxsize *= 2;
- }
- t->items[t->n++] = item;
-}
-
-#define LT_NOTFOUND ((int)-1)
-
-int ltable_lookup(ltable_t *t, unsigned long item)
-{- int i;
- for(i=0; i < (int)t->n; i++)
- if (t->items[i] == item)
- return i;
- return LT_NOTFOUND;
-}
-
-void ltable_adjoin(ltable_t *t, unsigned long item)
-{- if (ltable_lookup(t, item) == LT_NOTFOUND)
- ltable_insert(t, item);
-}
-
-char *snprintf_gensym_id(char *nbuf, size_t n, u_int32_t g)
-{- size_t i=n-1;
-
- nbuf[i--] = '\0';
- do {- nbuf[i--] = '0' + g%10;
- g/=10;
- } while (g && i);
- nbuf[i] = 'g';
- return &nbuf[i];
-}
--- a/femtolisp/attic/plists.lsp
+++ /dev/null
@@ -1,28 +1,0 @@
-; property lists. they really suck.
-(setq *plists* nil)
-
-(defun symbol-plist (sym)
- (cdr (or (assoc sym *plists*) '(()))))
-
-(defun set-symbol-plist (sym lst)
- (let ((p (assoc sym *plists*)))
- (if (null p) ; sym has no plist yet
- (setq *plists* (cons (cons sym lst) *plists*))
- (rplacd p lst))))
-
-(defun get (sym prop)
- (let ((pl (symbol-plist sym)))
- (if pl
- (let ((pr (member prop pl)))
- (if pr (cadr pr) nil))
- nil)))
-
-(defun put (sym prop val)
- (let ((p (assoc sym *plists*)))
- (if (null p) ; sym has no plist yet
- (setq *plists* (cons (list sym prop val) *plists*))
- (let ((pr (member prop p)))
- (if (null pr) ; sym doesn't have this property yet
- (rplacd p (cons prop (cons val (cdr p))))
- (rplaca (cdr pr) val)))))
- val)
--- a/femtolisp/attic/s.c
+++ /dev/null
@@ -1,212 +1,0 @@
-#include <stdio.h>
-
-struct _b {- char a;
- short b:9;
-};
-
-struct _bb {- char a;
- int :0;
- int b:10;
- int :0;
- int b0:10;
- int :0;
- int b1:10;
- int :0;
- int b2:10;
- int :0;
- int b4:30;
- char c;
-};
-
-union _cc {- struct {- char a;
- int b:1; // bit 8
- int b1:1; // bit 9
- int b2:24; // bits 32..55
- char c;
- };
- unsigned long long ull;
-};
-
-union _cc2 {- struct {- char a;
- int b:24; // bit 8
- int b1:1;
- int b2:1;
- char c;
- };
- unsigned long long ull;
-};
-
-union _dd {- struct {- int a0:10;
- int a1:10;
- int a2:10;
- int a3:10;
- int a4:10;
- };
- struct {- unsigned long long ull;
- };
-};
-
-struct _ee {- short s:9;
- short j:9;
- char c;
-};
-
-typedef long long int int64_t;
-typedef unsigned long long int uint64_t;
-typedef int int32_t;
-typedef unsigned int uint32_t;
-typedef short int16_t;
-typedef unsigned short uint16_t;
-typedef char int8_t;
-typedef unsigned char uint8_t;
-
-#define lomask(type,n) (type)((((type)1)<<(n))-1)
-
-uint64_t get_u_bitfield(char *ptr, int typesz, int boffs, int blen)
-{- uint64_t i8;
- uint32_t i4;
- uint16_t i2;
- uint8_t i1;
-
- switch (typesz) {- case 8:
- i8 = *(uint64_t*)ptr;
- return (i8>>boffs) & lomask(uint64_t,blen);
- case 4:
- i4 = *(uint32_t*)ptr;
- return (i4>>boffs) & lomask(uint32_t,blen);
- case 2:
- i2 = *(uint16_t*)ptr;
- return (i2>>boffs) & lomask(uint16_t,blen);
- case 1:
- i1 = *(uint8_t*)ptr;
- return (i1>>boffs) & lomask(uint8_t,blen);
- }
- //error
- return 0;
-}
-
-int64_t get_s_bitfield(char *ptr, int typesz, int boffs, int blen)
-{- int64_t i8;
- int32_t i4;
- int16_t i2;
- int8_t i1;
-
- switch (typesz) {- case 8:
- i8 = *(int64_t*)ptr;
- return (i8<<(64-boffs-blen))>>(64-blen);
- case 4:
- i4 = *(int32_t*)ptr;
- return (i4<<(32-boffs-blen))>>(32-blen);
- case 2:
- i2 = *(int16_t*)ptr;
- return (i2<<(16-boffs-blen))>>(16-blen);
- case 1:
- i1 = *(int8_t*)ptr;
- return (i1<<(8-boffs-blen))>>(8-blen);
- }
- //error
- return 0;
-}
-
-void set_bitfield(char *ptr, int typesz, int boffs, int blen, uint64_t v)
-{- uint64_t i8, m8;
- uint32_t i4, m4;
- uint16_t i2, m2;
- uint8_t i1, m1;
-
- switch (typesz) {- case 8:
- m8 = lomask(uint64_t,blen)<<boffs;
- i8 = *(uint64_t*)ptr;
- *(uint64_t*)ptr = (i8&~m8) | ((v<<boffs)&m8);
- break;
- case 4:
- m4 = lomask(uint32_t,blen)<<boffs;
- i4 = *(uint32_t*)ptr;
- *(uint32_t*)ptr = (i4&~m4) | ((v<<boffs)&m4);
- break;
- case 2:
- m2 = lomask(uint16_t,blen)<<boffs;
- i2 = *(uint16_t*)ptr;
- *(uint16_t*)ptr = (i2&~m2) | ((v<<boffs)&m2);
- break;
- case 1:
- m1 = lomask(uint8_t,blen)<<boffs;
- i1 = *(uint8_t*)ptr;
- *(uint8_t*)ptr = (i1&~m1) | ((v<<boffs)&m1);
- break;
- }
-}
-
-int main()
-{- union _cc2 c;
- union _dd d;
- printf("%d\n", sizeof(struct _b));-
- printf("%d\n", sizeof(d));- //printf("%d\n\n", sizeof(struct _bb));-
- //printf("%d\n", (char*)&b.b - (char*)&b);- //printf("%d\n", (char*)&b.c - (char*)&b);- //printf("%d\n", (char*)&b.e - (char*)&b);-
- c.ull = 0;
- d.ull = 0;
- //d.ull2 = 0;
-
- d.a0 = d.a1 = d.a2 = d.a3 = d.a4 = 1;
- printf("0x%016llx\n", d.ull);- unsigned long long m = 1;
- int bn = 0;
- while (m) {- if (d.ull & m)
- printf("bit %d set\n", bn);- bn++;
- m<<=1;
- }
- //printf("%016x\n", d.ull2);-
-
- c.a = 1;
- c.b = 1;
- c.c = 1;
- printf("0x%016llx\n", c.ull);- bn=0;m=1;
- while (m) {- if (c.ull & m)
- printf("bit %d set\n", bn);- bn++;
- m<<=1;
- }
-
- return 0;
-}
-
-/*
- offset/alignment rules for bit fields:
-
- - alignment for whole struct is still the most strict of any of the
- named types, regardless of bit fields. (i.e. just take the bit field
- widths away and compute struct alignment normally)
-
- - a bit field cannot cross a word boundary of its declared type
-
- - otherwise pack bit fields as tightly as possible
-
- */
--- a/femtolisp/attic/scrap.lsp
+++ /dev/null
@@ -1,108 +1,0 @@
-; -*- scheme -*-
-; (try expr
-; (catch (type-error e) . exprs)
-; (catch (io-error e) . exprs)
-; (catch (e) . exprs)
-; (finally . exprs))
-(define-macro (try expr . forms)
- (let* ((e (gensym))
- (reraised (gensym))
- (final (f-body (cdr (or (assq 'finally forms) '(())))))
- (catches (filter (lambda (f) (eq (car f) 'catch)) forms))
- (catchblock `(cond
- ,.(map (lambda (catc)
- (let* ((specific (cdr (cadr catc)))
- (extype (caadr catc))
- (var (if specific (car specific)
- extype))
- (todo (cddr catc)))
- `(,(if specific
- ; exception matching logic
- `(or (eq ,e ',extype)
- (and (pair? ,e)
- (eq (car ,e)
- ',extype)))
- #t); (catch (e) ...), match anything
- (let ((,var ,e)) (begin ,@todo)))))
- catches)
- (#t (raise ,e))))) ; no matches, reraise
- (if final
- (if catches
- ; form with both catch and finally
- `(prog1 (trycatch ,expr
- (lambda (,e)
- (trycatch ,catchblock
- (lambda (,reraised)
- (begin ,final
- (raise ,reraised))))))
- ,final)
- ; finally only; same as unwind-protect
- `(prog1 (trycatch ,expr (lambda (,e)
- (begin ,final (raise ,e))))
- ,final))
- ; catch, no finally
- `(trycatch ,expr (lambda (,e) ,catchblock)))))
-
-; setf
-; expands (setf (place x ...) v) to (mutator (f x ...) v)
-; (mutator (identity x ...) v) is interpreted as (mutator x ... v)
-(set! *setf-place-list*
- ; place mutator f
- '((car rplaca identity)
- (cdr rplacd identity)
- (caar rplaca car)
- (cadr rplaca cdr)
- (cdar rplacd car)
- (cddr rplacd cdr)
- (caaar rplaca caar)
- (caadr rplaca cadr)
- (cadar rplaca cdar)
- (caddr rplaca cddr)
- (cdaar rplacd caar)
- (cdadr rplacd cadr)
- (cddar rplacd cdar)
- (cdddr rplacd cddr)
- (list-ref rplaca nthcdr)
- (get put! identity)
- (aref aset! identity)
- (symbol-syntax set-syntax! identity)))
-
-(define (setf-place-mutator place val)
- (if (symbol? place)
- (list 'set! place val)
- (let ((mutator (assq (car place) *setf-place-list*)))
- (if (null? mutator)
- (error "setf: unknown place " (car place))
- (if (eq (caddr mutator) 'identity)
- (cons (cadr mutator) (append (cdr place) (list val)))
- (list (cadr mutator)
- (cons (caddr mutator) (cdr place))
- val))))))
-
-(define-macro (setf . args)
- (f-body
- ((label setf-
- (lambda (args)
- (if (null? args)
- ()
- (cons (setf-place-mutator (car args) (cadr args))
- (setf- (cddr args))))))
- args)))
-
-(define-macro (labels binds . body)
- (cons (list 'lambda (map car binds)
- (f-body
- (nconc (map (lambda (b)
- (list 'set! (car b) (cons 'lambda (cdr b))))
- binds)
- body)))
- (map (lambda (x) #f) binds)))
-
- (define (evalhead e env)
- (if (and (symbol? e)
- (or (constant? e)
- (and (not (memq e env))
- (bound? e)
- (builtin? (eval e)))))
- (eval e)
- e))
--- a/femtolisp/attic/system-old.lsp
+++ /dev/null
@@ -1,25 +1,0 @@
-(define (equal a b)
- (if (and (consp a) (consp b))
- (and (equal (car a) (car b))
- (equal (cdr a) (cdr b)))
- (eq a b)))
-
-; compare imposes an ordering on all values. yields -1 for a<b,
-; 0 for a==b, and 1 for a>b. lists are compared up to the first
-; point of difference.
-(defun compare (a b)
- (cond ((eq a b) 0)
- ((or (atom a) (atom b)) (if (< a b) -1 1))
- (T (let ((c (compare (car a) (car b))))
- (if (not (eq c 0))
- c
- (compare (cdr a) (cdr b)))))))
-
-(defun length (l)
- (if (null l) 0
- (+ 1 (length (cdr l)))))
-
-(define (assoc item lst)
- (cond ((atom lst) ())
- ((eq (caar lst) item) (car lst))
- (T (assoc item (cdr lst)))))
--- a/femtolisp/attic/trash.c
+++ /dev/null
@@ -1,303 +1,0 @@
-value_t prim_types[32];
-value_t *prim_sym_addrs[] = {- &int8sym, &uint8sym, &int16sym, &uint16sym, &int32sym, &uint32sym,
- &int64sym, &uint64sym, &charsym, &ucharsym, &shortsym, &ushortsym,
- &intsym, &uintsym, &longsym, &ulongsym,
- &lispvaluesym };
-#define N_PRIMSYMS (sizeof(prim_sym_addrs) / sizeof(value_t*))
-
-static value_t cv_type(cvalue_t *cv)
-{- if (cv->flags.prim) {- return prim_types[cv->flags.primtype];
- }
- return cv->type;
-}
-
-
- double t0,t1;
- int i;
- int32_t i32;
- char s8;
- ulong_t c8=3;
- t0 = clock(); //0.058125017
- set_secret_symtag(ulongsym,TAG_UINT32);
- set_secret_symtag(int8sym,TAG_INT8);
- for(i=0; i < 8000000; i++) {- cnvt_to_int32(&i32, &s8, int8sym);
- c8+=c8;
- s8+=s8;
- }
- t1 = clock();
- printf("%d. that took %.16f\n", i32, t1-t0);-
-
-#define int_converter(type) \
-static int cnvt_to_##type(type##_t *i, void *data, value_t type) \
-{ \- if (type==int32sym) *i = *(int32_t*)data; \
- else if (type==charsym) *i = *(char*)data; \
- else if (type==ulongsym) *i = *(ulong*)data; \
- else if (type==uint32sym) *i = *(uint32_t*)data; \
- else if (type==int8sym) *i = *(int8_t*)data; \
- else if (type==uint8sym) *i = *(uint8_t*)data; \
- else if (type==int64sym) *i = *(int64_t*)data; \
- else if (type==uint64sym) *i = *(uint64_t*)data; \
- else if (type==wcharsym) *i = *(wchar_t*)data; \
- else if (type==longsym) *i = *(long*)data; \
- else if (type==int16sym) *i = *(int16_t*)data; \
- else if (type==uint16sym) *i = *(uint16_t*)data; \
- else \
- return 1; \
- return 0; \
-}
-int_converter(int32)
-int_converter(uint32)
-int_converter(int64)
-int_converter(uint64)
-
-#ifdef BITS64
-#define cnvt_to_ulong(i,d,t) cnvt_to_uint64(i,d,t)
-#else
-#define cnvt_to_ulong(i,d,t) cnvt_to_uint32(i,d,t)
-#endif
-
-long intabs(long n)
-{- long s = n>>(NBITS-1); // either -1 or 0
- return (n^s) - s;
-}
-
-value_t fl_inv(value_t b)
-{- int_t bi;
- int tb;
- void *bptr=NULL;
- cvalue_t *cv;
-
- if (isfixnum(b)) {- bi = numval(b);
- if (bi == 0)
- goto inv_error;
- else if (bi == 1)
- return fixnum(1);
- else if (bi == -1)
- return fixnum(-1);
- return fixnum(0);
- }
- else if (iscvalue(b)) {- cv = (cvalue_t*)ptr(b);
- tb = cv_numtype(cv);
- if (tb <= T_DOUBLE)
- bptr = cv_data(cv);
- }
- if (bptr == NULL)
- type_error("/", "number", b);-
- if (tb == T_FLOAT)
- return mk_double(1.0/(double)*(float*)bptr);
- if (tb == T_DOUBLE)
- return mk_double(1.0 / *(double*)bptr);
-
- if (tb == T_UINT64) {- if (*(uint64_t*)bptr > 1)
- return fixnum(0);
- else if (*(uint64_t*)bptr == 1)
- return fixnum(1);
- goto inv_error;
- }
- int64_t b64 = conv_to_int64(bptr, tb);
- if (b64 == 0) goto inv_error;
- else if (b64 == 1) return fixnum(1);
- else if (b64 == -1) return fixnum(-1);
-
- return fixnum(0);
- inv_error:
- lerror(DivideError, "/: division by zero");
-}
-
-static void printstack(value_t *penv, uint32_t envsz)
-{- int i;
- printf("env=%d, size=%d\n", penv - &Stack[0], envsz);- for(i=0; i < SP; i++) {- printf("%d: ", i);- print(stdout, Stack[i], 0);
- printf("\n");- }
- printf("\n");-}
-
-// unordered comparison
-// not any faster than ordered comparison
-
-// a is a fixnum, b is a cvalue
-static value_t equal_num_cvalue(value_t a, value_t b)
-{- cvalue_t *bcv = (cvalue_t*)ptr(b);
- numerictype_t bt;
- if (valid_numtype(bt=cv_numtype(bcv))) {- fixnum_t ia = numval(a);
- void *bptr = cv_data(bcv);
- if (cmp_eq(&ia, T_FIXNUM, bptr, bt))
- return fixnum(0);
- }
- return fixnum(1);
-}
-
-static value_t bounded_equal(value_t a, value_t b, int bound);
-static value_t cyc_equal(value_t a, value_t b, ptrhash_t *table);
-
-static value_t bounded_vector_equal(value_t a, value_t b, int bound)
-{- size_t la = vector_size(a);
- size_t lb = vector_size(b);
- if (la != lb) return fixnum(1);
- size_t i;
- for (i = 0; i < la; i++) {- value_t d = bounded_equal(vector_elt(a,i), vector_elt(b,i), bound-1);
- if (d==NIL || numval(d)!=0) return d;
- }
- return fixnum(0);
-}
-
-static value_t bounded_equal(value_t a, value_t b, int bound)
-{- value_t d;
-
- compare_top:
- if (a == b) return fixnum(0);
- if (bound <= 0)
- return NIL;
- int taga = tag(a);
- int tagb = cmptag(b);
- switch (taga) {- case TAG_NUM :
- case TAG_NUM1:
- if (isfixnum(b)) {- return fixnum(1);
- }
- if (iscvalue(b)) {- return equal_num_cvalue(a, b);
- }
- return fixnum(1);
- case TAG_SYM:
- return fixnum(1);
- case TAG_VECTOR:
- if (isvector(b))
- return bounded_vector_equal(a, b, bound);
- break;
- case TAG_CVALUE:
- if (iscvalue(b)) {- cvalue_t *acv=(cvalue_t*)ptr(a), *bcv=(cvalue_t*)ptr(b);
- numerictype_t at, bt;
- if (valid_numtype(at=cv_numtype(acv)) &&
- valid_numtype(bt=cv_numtype(bcv))) {- void *aptr = cv_data(acv);
- void *bptr = cv_data(bcv);
- if (cmp_eq(aptr, at, bptr, bt))
- return fixnum(0);
- return fixnum(1);
- }
- return cvalue_compare(a, b);
- }
- else if (isfixnum(b)) {- return equal_num_cvalue(b, a);
- }
- break;
- case TAG_BUILTIN:
- return fixnum(1);
- case TAG_CONS:
- if (tagb != TAG_CONS) return fixnum(1);
- d = bounded_equal(car_(a), car_(b), bound-1);
- if (d==NIL || numval(d) != 0) return d;
- a = cdr_(a); b = cdr_(b);
- bound--;
- goto compare_top;
- }
- return fixnum(1);
-}
-
-static value_t cyc_vector_equal(value_t a, value_t b, ptrhash_t *table)
-{- size_t la = vector_size(a);
- size_t lb = vector_size(b);
- size_t i;
- value_t d, xa, xb, ca, cb;
- if (la != lb) return fixnum(1);
-
- // first try to prove them different with no recursion
- for (i = 0; i < la; i++) {- xa = vector_elt(a,i);
- xb = vector_elt(b,i);
- if (leafp(xa) || leafp(xb)) {- d = bounded_equal(xa, xb, 1);
- if (numval(d)!=0) return d;
- }
- else if (cmptag(xa) != cmptag(xb)) {- return fixnum(1);
- }
- }
-
- ca = eq_class(table, a);
- cb = eq_class(table, b);
- if (ca!=NIL && ca==cb)
- return fixnum(0);
-
- eq_union(table, a, b, ca, cb);
-
- for (i = 0; i < la; i++) {- xa = vector_elt(a,i);
- xb = vector_elt(b,i);
- if (!leafp(xa) && !leafp(xb)) {- d = cyc_equal(xa, xb, table);
- if (numval(d)!=0) return d;
- }
- }
-
- return fixnum(0);
-}
-
-static value_t cyc_equal(value_t a, value_t b, ptrhash_t *table)
-{- if (a==b)
- return fixnum(0);
- if (iscons(a)) {- if (iscons(b)) {- value_t aa = car_(a); value_t da = cdr_(a);
- value_t ab = car_(b); value_t db = cdr_(b);
- int tagaa = cmptag(aa); int tagda = cmptag(da);
- int tagab = cmptag(ab); int tagdb = cmptag(db);
- value_t d, ca, cb;
- if (leafp(aa) || leafp(ab)) {- d = bounded_equal(aa, ab, 1);
- if (numval(d)!=0) return d;
- }
- else if (tagaa != tagab)
- return fixnum(1);
- if (leafp(da) || leafp(db)) {- d = bounded_equal(da, db, 1);
- if (numval(d)!=0) return d;
- }
- else if (tagda != tagdb)
- return fixnum(1);
-
- ca = eq_class(table, a);
- cb = eq_class(table, b);
- if (ca!=NIL && ca==cb)
- return fixnum(0);
-
- eq_union(table, a, b, ca, cb);
- d = cyc_equal(aa, ab, table);
- if (numval(d)!=0) return d;
- return cyc_equal(da, db, table);
- }
- else {- return fixnum(1);
- }
- }
- else if (isvector(a) && isvector(b)) {- return cyc_vector_equal(a, b, table);
- }
- return bounded_equal(a, b, 1);
-}
--- a/femtolisp/bootstrap.sh
+++ /dev/null
@@ -1,14 +1,0 @@
-#!/bin/sh
-
-cp flisp.boot flisp.boot.bak
-
-echo "Creating stage 0 boot file..."
-#../../branches/interpreter/femtolisp/flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot.new
-./flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot.new
-mv flisp.boot.new flisp.boot
-
-echo "Creating stage 1 boot file..."
-./flisp mkboot1.lsp
-
-echo "Testing..."
-make test
--- a/femtolisp/builtins.c
+++ /dev/null
@@ -1,488 +1,0 @@
-/*
- Extra femtoLisp builtin functions
-*/
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <setjmp.h>
-#include <stdarg.h>
-#include <assert.h>
-#include <ctype.h>
-#include <sys/types.h>
-#include <sys/time.h>
-#include <sys/stat.h>
-#include <errno.h>
-#include "llt.h"
-#include "flisp.h"
-#include "random.h"
-
-size_t llength(value_t v)
-{- size_t n = 0;
- while (iscons(v)) {- n++;
- v = cdr_(v);
- }
- return n;
-}
-
-static value_t fl_nconc(value_t *args, u_int32_t nargs)
-{- if (nargs == 0)
- return FL_NIL;
- value_t lst, first=FL_NIL;
- value_t *pcdr = &first;
- cons_t *c;
- uint32_t i=0;
- while (1) {- lst = args[i++];
- if (i >= nargs) break;
- if (iscons(lst)) {- *pcdr = lst;
- c = (cons_t*)ptr(lst);
- while (iscons(c->cdr))
- c = (cons_t*)ptr(c->cdr);
- pcdr = &c->cdr;
- }
- else if (lst != FL_NIL) {- type_error("nconc", "cons", lst);- }
- }
- *pcdr = lst;
- return first;
-}
-
-static value_t fl_assq(value_t *args, u_int32_t nargs)
-{- argcount("assq", nargs, 2);- value_t item = args[0];
- value_t v = args[1];
- value_t bind;
-
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == item)
- return bind;
- v = cdr_(v);
- }
- return FL_F;
-}
-
-static value_t fl_memq(value_t *args, u_int32_t nargs)
-{- argcount("memq", nargs, 2);- while (iscons(args[1])) {- cons_t *c = (cons_t*)ptr(args[1]);
- if (c->car == args[0])
- return args[1];
- args[1] = c->cdr;
- }
- return FL_F;
-}
-
-static value_t fl_length(value_t *args, u_int32_t nargs)
-{- argcount("length", nargs, 1);- value_t a = args[0];
- cvalue_t *cv;
- if (isvector(a)) {- return fixnum(vector_size(a));
- }
- else if (iscprim(a)) {- cv = (cvalue_t*)ptr(a);
- if (cp_class(cv) == bytetype)
- return fixnum(1);
- else if (cp_class(cv) == wchartype)
- return fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv)));
- }
- else if (iscvalue(a)) {- cv = (cvalue_t*)ptr(a);
- if (cv_class(cv)->eltype != NULL)
- return size_wrap(cvalue_arraylen(a));
- }
- else if (a == FL_NIL) {- return fixnum(0);
- }
- else if (iscons(a)) {- return fixnum(llength(a));
- }
- type_error("length", "sequence", a);-}
-
-static value_t fl_f_raise(value_t *args, u_int32_t nargs)
-{- argcount("raise", nargs, 1);- fl_raise(args[0]);
-}
-
-static value_t fl_exit(value_t *args, u_int32_t nargs)
-{- if (nargs > 0)
- exit(tofixnum(args[0], "exit"));
- exit(0);
- return FL_NIL;
-}
-
-static value_t fl_symbol(value_t *args, u_int32_t nargs)
-{- argcount("symbol", nargs, 1);- if (!fl_isstring(args[0]))
- type_error("symbol", "string", args[0]);- return symbol(cvalue_data(args[0]));
-}
-
-static value_t fl_keywordp(value_t *args, u_int32_t nargs)
-{- argcount("keyword?", nargs, 1);- return (issymbol(args[0]) &&
- iskeyword((symbol_t*)ptr(args[0]))) ? FL_T : FL_F;
-}
-
-static value_t fl_top_level_value(value_t *args, u_int32_t nargs)
-{- argcount("top-level-value", nargs, 1);- symbol_t *sym = tosymbol(args[0], "top-level-value");
- if (sym->binding == UNBOUND)
- fl_raise(fl_list2(UnboundError, args[0]));
- return sym->binding;
-}
-
-static value_t fl_set_top_level_value(value_t *args, u_int32_t nargs)
-{- argcount("set-top-level-value!", nargs, 2);- symbol_t *sym = tosymbol(args[0], "set-top-level-value!");
- if (!isconstant(sym))
- sym->binding = args[1];
- return args[1];
-}
-
-static void global_env_list(symbol_t *root, value_t *pv)
-{- while (root != NULL) {- if (root->name[0] != ':' && (root->binding != UNBOUND)) {- *pv = fl_cons(tagptr(root,TAG_SYM), *pv);
- }
- global_env_list(root->left, pv);
- root = root->right;
- }
-}
-
-extern symbol_t *symtab;
-
-value_t fl_global_env(value_t *args, u_int32_t nargs)
-{- (void)args;
- argcount("environment", nargs, 0);- value_t lst = FL_NIL;
- fl_gc_handle(&lst);
- global_env_list(symtab, &lst);
- fl_free_gc_handles(1);
- return lst;
-}
-
-extern value_t QUOTE;
-
-static value_t fl_constantp(value_t *args, u_int32_t nargs)
-{- argcount("constant?", nargs, 1);- if (issymbol(args[0]))
- return (isconstant((symbol_t*)ptr(args[0])) ? FL_T : FL_F);
- if (iscons(args[0])) {- if (car_(args[0]) == QUOTE)
- return FL_T;
- return FL_F;
- }
- return FL_T;
-}
-
-static value_t fl_integer_valuedp(value_t *args, u_int32_t nargs)
-{- argcount("integer-valued?", nargs, 1);- value_t v = args[0];
- if (isfixnum(v)) {- return FL_T;
- }
- else if (iscprim(v)) {- numerictype_t nt = cp_numtype((cprim_t*)ptr(v));
- if (nt < T_FLOAT)
- return FL_T;
- void *data = cp_data((cprim_t*)ptr(v));
- if (nt == T_FLOAT) {- float f = *(float*)data;
- if (f < 0) f = -f;
- if (f <= FLT_MAXINT && (float)(int32_t)f == f)
- return FL_T;
- }
- else {- assert(nt == T_DOUBLE);
- double d = *(double*)data;
- if (d < 0) d = -d;
- if (d <= DBL_MAXINT && (double)(int64_t)d == d)
- return FL_T;
- }
- }
- return FL_F;
-}
-
-static value_t fl_integerp(value_t *args, u_int32_t nargs)
-{- argcount("integer?", nargs, 1);- value_t v = args[0];
- return (isfixnum(v) ||
- (iscprim(v) && cp_numtype((cprim_t*)ptr(v)) < T_FLOAT)) ?
- FL_T : FL_F;
-}
-
-static value_t fl_fixnum(value_t *args, u_int32_t nargs)
-{- argcount("fixnum", nargs, 1);- if (isfixnum(args[0])) {- return args[0];
- }
- else if (iscprim(args[0])) {- cprim_t *cp = (cprim_t*)ptr(args[0]);
- return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp)));
- }
- type_error("fixnum", "number", args[0]);-}
-
-static value_t fl_truncate(value_t *args, u_int32_t nargs)
-{- argcount("truncate", nargs, 1);- if (isfixnum(args[0]))
- return args[0];
- if (iscprim(args[0])) {- cprim_t *cp = (cprim_t*)ptr(args[0]);
- void *data = cp_data(cp);
- numerictype_t nt = cp_numtype(cp);
- double d;
- if (nt == T_FLOAT)
- d = (double)*(float*)data;
- else if (nt == T_DOUBLE)
- d = *(double*)data;
- else
- return args[0];
- if (d > 0) {- if (d > (double)U64_MAX)
- return args[0];
- return return_from_uint64((uint64_t)d);
- }
- if (d > (double)S64_MAX || d < (double)S64_MIN)
- return args[0];
- return return_from_int64((int64_t)d);
- }
- type_error("truncate", "number", args[0]);-}
-
-static value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
-{- fixnum_t i;
- value_t f, v;
- if (nargs == 0)
- lerror(ArgError, "vector.alloc: too few arguments");
- i = (fixnum_t)toulong(args[0], "vector.alloc");
- if (i < 0)
- lerror(ArgError, "vector.alloc: invalid size");
- if (nargs == 2)
- f = args[1];
- else
- f = FL_UNSPECIFIED;
- v = alloc_vector((unsigned)i, f==FL_UNSPECIFIED);
- if (f != FL_UNSPECIFIED) {- int k;
- for(k=0; k < i; k++)
- vector_elt(v,k) = f;
- }
- return v;
-}
-
-static value_t fl_time_now(value_t *args, u_int32_t nargs)
-{- argcount("time.now", nargs, 0);- (void)args;
- return mk_double(clock_now());
-}
-
-static double todouble(value_t a, char *fname)
-{- if (isfixnum(a))
- return (double)numval(a);
- if (iscprim(a)) {- cprim_t *cp = (cprim_t*)ptr(a);
- numerictype_t nt = cp_numtype(cp);
- return conv_to_double(cp_data(cp), nt);
- }
- type_error(fname, "number", a);
-}
-
-static value_t fl_time_string(value_t *args, uint32_t nargs)
-{- argcount("time.string", nargs, 1);- double t = todouble(args[0], "time.string");
- char buf[64];
- timestring(t, buf, sizeof(buf));
- return string_from_cstr(buf);
-}
-
-static value_t fl_time_fromstring(value_t *args, uint32_t nargs)
-{- argcount("time.fromstring", nargs, 1);- char *ptr = tostring(args[0], "time.fromstring");
- double t = parsetime(ptr);
- int64_t it = (int64_t)t;
- if ((double)it == t && fits_fixnum(it))
- return fixnum(it);
- return mk_double(t);
-}
-
-static value_t fl_path_cwd(value_t *args, uint32_t nargs)
-{- if (nargs > 1)
- argcount("path.cwd", nargs, 1);- if (nargs == 0) {- char buf[1024];
- get_cwd(buf, sizeof(buf));
- return string_from_cstr(buf);
- }
- char *ptr = tostring(args[0], "path.cwd");
- if (set_cwd(ptr))
- lerrorf(IOError, "path.cwd: could not cd to %s", ptr);
- return FL_T;
-}
-
-#ifdef WIN32
-#define stat _stat
-#endif
-static value_t fl_path_exists(value_t *args, uint32_t nargs)
-{- argcount("path.exists?", nargs, 1);- char *str = tostring(args[0], "path.exists?");
- struct stat sbuf;
- if (stat(str, &sbuf) == -1)
- return FL_F;
- return FL_T;
-}
-
-static value_t fl_os_getenv(value_t *args, uint32_t nargs)
-{- argcount("os.getenv", nargs, 1);- char *name = tostring(args[0], "os.getenv");
- char *val = getenv(name);
- if (val == NULL) return FL_F;
- if (*val == 0)
- return symbol_value(emptystringsym);
- return cvalue_static_cstring(val);
-}
-
-static value_t fl_os_setenv(value_t *args, uint32_t nargs)
-{- argcount("os.setenv", nargs, 2);- char *name = tostring(args[0], "os.setenv");
- int result;
- if (args[1] == FL_F) {-#ifdef LINUX
- result = unsetenv(name);
-#else
- (void)unsetenv(name);
- result = 0;
-#endif
- }
- else {- char *val = tostring(args[1], "os.setenv");
- result = setenv(name, val, 1);
- }
- if (result != 0)
- lerror(ArgError, "os.setenv: invalid environment variable");
- return FL_T;
-}
-
-static value_t fl_rand(value_t *args, u_int32_t nargs)
-{- (void)args; (void)nargs;
- fixnum_t r;
-#ifdef BITS64
- r = ((((uint64_t)random())<<32) | random()) & 0x1fffffffffffffffLL;
-#else
- r = random() & 0x1fffffff;
-#endif
- return fixnum(r);
-}
-static value_t fl_rand32(value_t *args, u_int32_t nargs)
-{- (void)args; (void)nargs;
- uint32_t r = random();
-#ifdef BITS64
- return fixnum(r);
-#else
- return mk_uint32(r);
-#endif
-}
-static value_t fl_rand64(value_t *args, u_int32_t nargs)
-{- (void)args; (void)nargs;
- uint64_t r = (((uint64_t)random())<<32) | random();
- return mk_uint64(r);
-}
-static value_t fl_randd(value_t *args, u_int32_t nargs)
-{- (void)args; (void)nargs;
- return mk_double(rand_double());
-}
-static value_t fl_randf(value_t *args, u_int32_t nargs)
-{- (void)args; (void)nargs;
- return mk_float(rand_float());
-}
-
-extern void stringfuncs_init();
-extern void table_init();
-extern void iostream_init();
-
-static builtinspec_t builtin_info[] = {- { "environment", fl_global_env },- { "constant?", fl_constantp },- { "top-level-value", fl_top_level_value },- { "set-top-level-value!", fl_set_top_level_value },- { "raise", fl_f_raise },- { "exit", fl_exit },- { "symbol", fl_symbol },- { "keyword?", fl_keywordp },-
- { "fixnum", fl_fixnum },- { "truncate", fl_truncate },- { "integer?", fl_integerp },- { "integer-valued?", fl_integer_valuedp },- { "nconc", fl_nconc },- { "append!", fl_nconc },- { "assq", fl_assq },- { "memq", fl_memq },- { "length", fl_length },-
- { "vector.alloc", fl_vector_alloc },-
- { "time.now", fl_time_now },- { "time.string", fl_time_string },- { "time.fromstring", fl_time_fromstring },-
- { "rand", fl_rand },- { "rand.uint32", fl_rand32 },- { "rand.uint64", fl_rand64 },- { "rand.double", fl_randd },- { "rand.float", fl_randf },-
- { "path.cwd", fl_path_cwd },- { "path.exists?", fl_path_exists },-
- { "os.getenv", fl_os_getenv },- { "os.setenv", fl_os_setenv },- { NULL, NULL }-};
-
-void builtins_init()
-{- assign_global_builtins(builtin_info);
- stringfuncs_init();
- table_init();
- iostream_init();
-}
--- a/femtolisp/compiler.lsp
+++ /dev/null
@@ -1,754 +1,0 @@
-; -*- scheme -*-
-
-(define Instructions
- (let ((e (table))
- (keys
- [nop dup pop call tcall jmp brf brt jmp.l brf.l brt.l ret
-
- eq? eqv? equal? atom? not null? boolean? symbol?
- number? bound? pair? builtin? vector? fixnum? function?
-
- cons list car cdr set-car! set-cdr!
- apply
-
- + - * / div0 = < compare
-
- vector aref aset!
-
- loadt loadf loadnil load0 load1 loadi8
- loadv loadv.l
- loadg loadg.l
- loada loada.l loadc loadc.l
- setg setg.l
- seta seta.l setc setc.l
-
- closure argc vargc trycatch for tapply
- add2 sub2 neg largc lvargc
- loada0 loada1 loadc00 loadc01 call.l tcall.l
- brne brne.l cadr brnn brnn.l brn brn.l
- optargs brbound keyargs
-
- dummy_t dummy_f dummy_nil]))
- (for 0 (1- (length keys))
- (lambda (i)
- (put! e (aref keys i) i)))))
-
-(define arg-counts
- (table eq? 2 eqv? 2
- equal? 2 atom? 1
- not 1 null? 1
- boolean? 1 symbol? 1
- number? 1 bound? 1
- pair? 1 builtin? 1
- vector? 1 fixnum? 1
- cons 2 car 1
- cdr 1 set-car! 2
- set-cdr! 2 = 2
- < 2 compare 2
- aref 2 aset! 3
- div0 2))
-
-(define (make-code-emitter) (vector () (table) 0 +inf.0))
-(define (bcode:code b) (aref b 0))
-(define (bcode:ctable b) (aref b 1))
-(define (bcode:nconst b) (aref b 2))
-(define (bcode:cdepth b d) (aset! b 3 (min (aref b 3) d)))
-; get an index for a referenced value in a bytecode object
-(define (bcode:indexfor b v)
- (let ((const-to-idx (bcode:ctable b))
- (nconst (bcode:nconst b)))
- (if (has? const-to-idx v)
- (get const-to-idx v)
- (begin (put! const-to-idx v nconst)
- (prog1 nconst
- (aset! b 2 (+ nconst 1)))))))
-(define (emit e inst . args)
- (if (null? args)
- (if (and (eq? inst 'car) (pair? (aref e 0))
- (eq? (car (aref e 0)) 'cdr))
- (set-car! (aref e 0) 'cadr)
- (aset! e 0 (cons inst (aref e 0))))
- (begin
- (if (memq inst '(loadv loadg setg))
- (set! args (list (bcode:indexfor e (car args)))))
- (let ((longform
- (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)
- (loada loada.l) (seta seta.l)))))
- (if (and longform
- (> (car args) 255))
- (set! inst (cadr longform))))
- (let ((longform
- (assq inst '((loadc loadc.l) (setc setc.l)))))
- (if (and longform
- (or (> (car args) 255)
- (> (cadr args) 255)))
- (set! inst (cadr longform))))
- (if (eq? inst 'loada)
- (cond ((equal? args '(0))
- (set! inst 'loada0)
- (set! args ()))
- ((equal? args '(1))
- (set! inst 'loada1)
- (set! args ()))))
- (if (eq? inst 'loadc)
- (cond ((equal? args '(0 0))
- (set! inst 'loadc00)
- (set! args ()))
- ((equal? args '(0 1))
- (set! inst 'loadc01)
- (set! args ()))))
-
- (let ((lasti (if (pair? (aref e 0))
- (car (aref e 0)) ()))
- (bc (aref e 0)))
- (cond ((and
- (eq? inst 'brf)
- (cond ((and (eq? lasti 'not)
- (eq? (cadr bc) 'null?))
- (aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
- ((eq? lasti 'not)
- (aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
- ((eq? lasti 'eq?)
- (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
- ((eq? lasti 'null?)
- (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
- (else #f))))
- ((and (eq? inst 'brt) (eq? lasti 'null?))
- (aset! e 0 (cons (car args) (cons 'brn (cdr bc)))))
- (else
- (aset! e 0 (nreconc (cons inst args) bc)))))))
- e)
-
-(define (make-label e) (gensym))
-(define (mark-label e l) (emit e 'label l))
-
-; convert symbolic bytecode representation to a byte array.
-; labels are fixed-up.
-(define (encode-byte-code e)
- (let* ((cl (reverse! e))
- (v (list->vector cl))
- (long? (>= (+ (length v) ; 1 byte for each entry, plus...
- ; at most half the entries in this vector can be
- ; instructions accepting 32-bit arguments
- (* 3 (div0 (length v) 2)))
- 65536)))
- (let ((n (length v))
- (i 0)
- (label-to-loc (table))
- (fixup-to-label (table))
- (bcode (buffer))
- (vi #f)
- (nxt #f))
- (io.write bcode #int32(0))
- (while (< i n)
- (begin
- (set! vi (aref v i))
- (if (eq? vi 'label)
- (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
- (set! i (+ i 2)))
- (begin
- (io.write bcode
- (byte
- (get Instructions
- (if long?
- (case vi
- (jmp 'jmp.l)
- (brt 'brt.l)
- (brf 'brf.l)
- (brne 'brne.l)
- (brnn 'brnn.l)
- (brn 'brn.l)
- (else vi))
- vi))))
- (set! i (+ i 1))
- (set! nxt (if (< i n) (aref v i) #f))
- (cond ((memq vi '(jmp brf brt brne brnn brn))
- (put! fixup-to-label (sizeof bcode) nxt)
- (io.write bcode ((if long? int32 int16) 0))
- (set! i (+ i 1)))
- ((eq? vi 'brbound)
- (io.write bcode (int32 nxt))
- (set! i (+ i 1)))
- ((number? nxt)
- (case vi
- ((loadv.l loadg.l setg.l loada.l seta.l
- largc lvargc call.l tcall.l)
- (io.write bcode (int32 nxt))
- (set! i (+ i 1)))
-
- ((loadc setc) ; 2 uint8 args
- (io.write bcode (uint8 nxt))
- (set! i (+ i 1))
- (io.write bcode (uint8 (aref v i)))
- (set! i (+ i 1)))
-
- ((loadc.l setc.l optargs keyargs) ; 2 int32 args
- (io.write bcode (int32 nxt))
- (set! i (+ i 1))
- (io.write bcode (int32 (aref v i)))
- (set! i (+ i 1))
- (if (eq? vi 'keyargs)
- (begin (io.write bcode (int32 (aref v i)))
- (set! i (+ i 1)))))
-
- (else
- ; other number arguments are always uint8
- (io.write bcode (uint8 nxt))
- (set! i (+ i 1)))))
- (else #f))))))
-
- (table.foreach
- (lambda (addr labl)
- (begin (io.seek bcode addr)
- (io.write bcode ((if long? int32 int16)
- (- (get label-to-loc labl)
- addr)))))
- fixup-to-label)
- (io.tostring! bcode))))
-
-(define (const-to-idx-vec e)
- (let ((cvec (vector.alloc (bcode:nconst e))))
- (table.foreach (lambda (val idx) (aset! cvec idx val))
- (bcode:ctable e))
- cvec))
-
-(define (index-of item lst start)
- (cond ((null? lst) #f)
- ((eq? item (car lst)) start)
- (else (index-of item (cdr lst) (+ start 1)))))
-
-(define (in-env? s env)
- (and (pair? env)
- (or (memq s (car env))
- (in-env? s (cdr env)))))
-
-(define (lookup-sym s env lev arg?)
- (if (null? env)
- '(global)
- (let* ((curr (car env))
- (i (index-of s curr 0)))
- (if i
- (if arg?
- i
- (cons lev i))
- (lookup-sym s
- (cdr env)
- (if (or arg? (null? curr)) lev (+ lev 1))
- #f)))))
-
-; number of non-nulls
-(define (nnn e) (count (lambda (x) (not (null? x))) e))
-
-(define (printable? x) (not (or (iostream? x)
- (eof-object? x))))
-
-(define (compile-sym g env s Is)
- (let ((loc (lookup-sym s env 0 #t)))
- (cond ((number? loc) (emit g (aref Is 0) loc))
- ((number? (car loc)) (emit g (aref Is 1) (car loc) (cdr loc))
- ; update index of most distant captured frame
- (bcode:cdepth g (- (nnn (cdr env)) 1 (car loc))))
- (else
- (if (and (constant? s)
- (printable? (top-level-value s)))
- (emit g 'loadv (top-level-value s))
- (emit g (aref Is 2) s))))))
-
-(define (compile-if g env tail? x)
- (let ((elsel (make-label g))
- (endl (make-label g))
- (test (cadr x))
- (then (caddr x))
- (else (if (pair? (cdddr x))
- (cadddr x)
- (void))))
- (cond ((eq? test #t)
- (compile-in g env tail? then))
- ((eq? test #f)
- (compile-in g env tail? else))
- (else
- (compile-in g env #f test)
- (emit g 'brf elsel)
- (compile-in g env tail? then)
- (if tail?
- (emit g 'ret)
- (emit g 'jmp endl))
- (mark-label g elsel)
- (compile-in g env tail? else)
- (mark-label g endl)))))
-
-(define (compile-begin g env tail? forms)
- (cond ((atom? forms) (compile-in g env tail? (void)))
- ((atom? (cdr forms))
- (compile-in g env tail? (car forms)))
- (else
- (compile-in g env #f (car forms))
- (emit g 'pop)
- (compile-begin g env tail? (cdr forms)))))
-
-(define (compile-prog1 g env x)
- (compile-in g env #f (cadr x))
- (if (pair? (cddr x))
- (begin (compile-begin g env #f (cddr x))
- (emit g 'pop))))
-
-(define (compile-while g env cond body)
- (let ((top (make-label g))
- (end (make-label g)))
- (compile-in g env #f (void))
- (mark-label g top)
- (compile-in g env #f cond)
- (emit g 'brf end)
- (emit g 'pop)
- (compile-in g env #f body)
- (emit g 'jmp top)
- (mark-label g end)))
-
-(define (1arg-lambda? func)
- (and (pair? func)
- (eq? (car func) 'lambda)
- (pair? (cdr func))
- (pair? (cadr func))
- (length= (cadr func) 1)))
-
-(define (compile-for g env lo hi func)
- (if (1arg-lambda? func)
- (begin (compile-in g env #f lo)
- (compile-in g env #f hi)
- (compile-in g env #f func)
- (emit g 'for))
- (error "for: third form must be a 1-argument lambda")))
-
-(define (compile-short-circuit g env tail? forms default branch)
- (cond ((atom? forms) (compile-in g env tail? default))
- ((atom? (cdr forms)) (compile-in g env tail? (car forms)))
- (else
- (let ((end (make-label g)))
- (compile-in g env #f (car forms))
- (emit g 'dup)
- (emit g branch end)
- (emit g 'pop)
- (compile-short-circuit g env tail? (cdr forms) default branch)
- (mark-label g end)))))
-
-(define (compile-and g env tail? forms)
- (compile-short-circuit g env tail? forms #t 'brf))
-(define (compile-or g env tail? forms)
- (compile-short-circuit g env tail? forms #f 'brt))
-
-(define (compile-arglist g env lst)
- (for-each (lambda (a)
- (compile-in g env #f a))
- lst)
- (length lst))
-
-(define (argc-error head count)
- (error "compile error: " head " expects " count
- (if (= count 1)
- " argument."
- " arguments.")))
-
-(define builtin->instruction
- (let ((b2i (table number? 'number? cons 'cons
- fixnum? 'fixnum? equal? 'equal?
- eq? 'eq? symbol? 'symbol?
- div0 'div0 builtin? 'builtin?
- aset! 'aset! - '- boolean? 'boolean? not 'not
- apply 'apply atom? 'atom?
- set-cdr! 'set-cdr! / '/
- function? 'function? vector 'vector
- list 'list bound? 'bound?
- < '< * '* cdr 'cdr null? 'null?
- + '+ eqv? 'eqv? compare 'compare aref 'aref
- set-car! 'set-car! car 'car
- pair? 'pair? = '= vector? 'vector?)))
- (lambda (b)
- (get b2i b #f))))
-
-(define (compile-builtin-call g env tail? x head b nargs)
- (let ((count (get arg-counts b #f)))
- (if (and count
- (not (length= (cdr x) count)))
- (argc-error head count))
- (case b ; handle special cases of vararg builtins
- (list (if (= nargs 0) (emit g 'loadnil) (emit g b nargs)))
- (+ (cond ((= nargs 0) (emit g 'load0))
- ((= nargs 2) (emit g 'add2))
- (else (emit g b nargs))))
- (- (cond ((= nargs 0) (argc-error head 1))
- ((= nargs 1) (emit g 'neg))
- ((= nargs 2) (emit g 'sub2))
- (else (emit g b nargs))))
- (* (if (= nargs 0) (emit g 'load1)
- (emit g b nargs)))
- (/ (if (= nargs 0)
- (argc-error head 1)
- (emit g b nargs)))
- (vector (if (= nargs 0)
- (emit g 'loadv [])
- (emit g b nargs)))
- (apply (if (< nargs 2)
- (argc-error head 2)
- (emit g (if tail? 'tapply 'apply) nargs)))
- (else (emit g b)))))
-
-(define (compile-app g env tail? x)
- (let ((head (car x)))
- (let ((head
- (if (and (symbol? head)
- (not (in-env? head env))
- (bound? head)
- (constant? head)
- (builtin? (top-level-value head)))
- (top-level-value head)
- head)))
- (if (length> (cdr x) 255)
- ; more than 255 arguments, need long versions of instructions
- (begin (compile-in g env #f head)
- (let ((nargs (compile-arglist g env (cdr x))))
- (emit g (if tail? 'tcall.l 'call.l) nargs)))
- (let ((b (and (builtin? head)
- (builtin->instruction head))))
- (if (and (eq? head 'cadr)
- (not (in-env? head env))
- (equal? (top-level-value 'cadr) cadr)
- (length= x 2))
- (begin (compile-in g env #f (cadr x))
- (emit g 'cadr))
- (begin
- (if (not b)
- (compile-in g env #f head))
- (let ((nargs (compile-arglist g env (cdr x))))
- (if b
- (compile-builtin-call g env tail? x head b nargs)
- (emit g (if tail? 'tcall 'call) nargs))))))))))
-
-(define (expand-define x)
- (let ((form (cadr x))
- (body (if (pair? (cddr x))
- (cddr x)
- (if (symbol? (cadr x))
- `(,(void))
- (error "compile error: invalid syntax "
- (print-to-string x))))))
- (if (symbol? form)
- `(set! ,form ,(car body))
- `(set! ,(car form)
- (lambda ,(cdr form) ,@body . ,(car form))))))
-
-(define (fits-i8 x) (and (fixnum? x) (>= x -128) (<= x 127)))
-
-(define (compile-in g env tail? x)
- (cond ((symbol? x) (compile-sym g env x [loada loadc loadg]))
- ((atom? x)
- (cond ((eq? x 0) (emit g 'load0))
- ((eq? x 1) (emit g 'load1))
- ((eq? x #t) (emit g 'loadt))
- ((eq? x #f) (emit g 'loadf))
- ((eq? x ()) (emit g 'loadnil))
- ((fits-i8 x) (emit g 'loadi8 x))
- ((eof-object? x)
- (compile-in g env tail? (list (top-level-value 'eof-object))))
- (else (emit g 'loadv x))))
- ((or (not (symbol? (car x))) (bound? (car x)) (in-env? (car x) env))
- (compile-app g env tail? x))
- (else
- (case (car x)
- (quote (if (self-evaluating? (cadr x))
- (compile-in g env tail? (cadr x))
- (emit g 'loadv (cadr x))))
- (if (compile-if g env tail? x))
- (begin (compile-begin g env tail? (cdr x)))
- (prog1 (compile-prog1 g env x))
- (lambda (receive (the-f dept) (compile-f- env x)
- (begin (emit g 'loadv the-f)
- (bcode:cdepth g dept)
- (if (< dept (nnn env))
- (emit g 'closure)))))
- (and (compile-and g env tail? (cdr x)))
- (or (compile-or g env tail? (cdr x)))
- (while (compile-while g env (cadr x) (cons 'begin (cddr x))))
- (for (compile-for g env (cadr x) (caddr x) (cadddr x)))
- (return (compile-in g env #t (cadr x))
- (emit g 'ret))
- (set! (compile-in g env #f (caddr x))
- (compile-sym g env (cadr x) [seta setc setg]))
- (define (compile-in g env tail?
- (expand-define x)))
- (trycatch (compile-in g env #f `(lambda () ,(cadr x)))
- (unless (1arg-lambda? (caddr x))
- (error "trycatch: second form must be a 1-argument lambda"))
- (compile-in g env #f (caddr x))
- (emit g 'trycatch))
- (else (compile-app g env tail? x))))))
-
-(define (compile-f env f)
- (receive (ff ignore)
- (compile-f- env f)
- ff))
-
-(define get-defined-vars
- (letrec ((get-defined-vars-
- (lambda (expr)
- (cond ((atom? expr) ())
- ((and (eq? (car expr) 'define)
- (pair? (cdr expr)))
- (or (and (symbol? (cadr expr))
- (list (cadr expr)))
- (and (pair? (cadr expr))
- (symbol? (caadr expr))
- (list (caadr expr)))
- ()))
- ((eq? (car expr) 'begin)
- (apply nconc (map get-defined-vars- (cdr expr))))
- (else ())))))
- (lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
-
-(define (keyword-arg? x) (and (pair? x) (keyword? (car x))))
-(define (keyword->symbol k)
- (if (keyword? k)
- (symbol (let ((s (string k)))
- (string.sub s 0 (string.dec s (length s)))))
- k))
-
-(define (lambda-arg-names argl)
- (map! (lambda (s) (if (pair? s) (keyword->symbol (car s)) s))
- (to-proper argl)))
-
-(define (lambda-vars l)
- (define (check-formals l o opt kw)
- (cond ((or (null? l) (symbol? l)) #t)
- ((and (pair? l) (symbol? (car l)))
- (if (or opt kw)
- (error "compile error: invalid argument list "
- o ". optional arguments must come after required.")
- (check-formals (cdr l) o opt kw)))
- ((and (pair? l) (pair? (car l)))
- (unless (and (length= (car l) 2)
- (symbol? (caar l)))
- (error "compile error: invalid optional argument " (car l)
- " in list " o))
- (if (keyword? (caar l))
- (check-formals (cdr l) o opt #t)
- (if kw
- (error "compile error: invalid argument list "
- o ". keyword arguments must come last.")
- (check-formals (cdr l) o #t kw))))
- ((pair? l)
- (error "compile error: invalid formal argument " (car l)
- " in list " o))
- (else
- (if (eq? l o)
- (error "compile error: invalid argument list " o)
- (error "compile error: invalid formal argument " l
- " in list " o)))))
- (check-formals l l #f #f)
- (lambda-arg-names l))
-
-(define (emit-optional-arg-inits g env opta vars i)
- ; i is the lexical var index of the opt arg to process next
- (if (pair? opta)
- (let ((nxt (make-label g)))
- (emit g 'brbound i)
- (emit g 'brt nxt)
- (compile-in g (cons (list-head vars i) env) #f (cadar opta))
- (emit g 'seta i)
- (emit g 'pop)
- (mark-label g nxt)
- (emit-optional-arg-inits g env (cdr opta) vars (+ i 1)))))
-
-#;(define (free-vars e)
- (cond ((symbol? e) (list e))
- ((or (atom? e) (eq? (car e) 'quote)) ())
- ((eq? (car e) 'lambda)
- (diff (free-vars (cddr e))
- (nconc (get-defined-vars (cons 'begin (cddr e)))
- (lambda-arg-names (cadr e)))))
- (else (delete-duplicates (apply nconc (map free-vars (cdr e)))))))
-
-(define compile-f-
- (let ((*defines-processed-token* (gensym)))
- ; to eval a top-level expression we need to avoid internal define
- (set-top-level-value!
- 'compile-thunk
- (lambda (expr)
- (compile `(lambda () ,expr . ,*defines-processed-token*))))
-
- (lambda (env f)
- ; convert lambda to one body expression and process internal defines
- (define (lambda-body e)
- (let ((B (if (pair? (cddr e))
- (if (pair? (cdddr e))
- (cons 'begin (cddr e))
- (caddr e))
- (void))))
- (let ((V (get-defined-vars B)))
- (if (null? V)
- B
- (cons (list* 'lambda V B *defines-processed-token*)
- (map (lambda (x) (void)) V))))))
- (define (lam:body f)
- (if (eq? (lastcdr f) *defines-processed-token*)
- (caddr f)
- (lambda-body f)))
-
- (let ((g (make-code-emitter))
- (args (cadr f))
- (atail (lastcdr (cadr f)))
- (vars (lambda-vars (cadr f)))
- (opta (filter pair? (cadr f)))
- (name (if (eq? (lastcdr f) *defines-processed-token*)
- 'lambda
- (lastcdr f))))
- (let* ((nargs (if (atom? args) 0 (length args)))
- (nreq (- nargs (length opta)))
- (kwa (filter keyword-arg? opta)))
-
- ; emit argument checking prologue
- (if (not (null? opta))
- (begin
- (if (null? kwa)
- (emit g 'optargs nreq
- (if (null? atail) nargs (- nargs)))
- (begin
- (bcode:indexfor g (make-perfect-hash-table
- (map cons
- (map car kwa)
- (iota (length kwa)))))
- (emit g 'keyargs nreq (length kwa)
- (if (null? atail) nargs (- nargs)))))
- (emit-optional-arg-inits g env opta vars nreq)))
-
- (cond ((> nargs 255) (emit g (if (null? atail)
- 'largc 'lvargc)
- nargs))
- ((not (null? atail)) (emit g 'vargc nargs))
- ((null? opta) (emit g 'argc nargs)))
-
- ; compile body and return
- (compile-in g (cons vars env) #t (lam:body f))
- (emit g 'ret)
- (values (function (encode-byte-code (bcode:code g))
- (const-to-idx-vec g) name)
- (aref g 3)))))))
-
-(define (compile f) (compile-f () f))
-
-(define (ref-int32-LE a i)
- (int32 (+ (ash (aref a (+ i 0)) 0)
- (ash (aref a (+ i 1)) 8)
- (ash (aref a (+ i 2)) 16)
- (ash (aref a (+ i 3)) 24))))
-
-(define (ref-int16-LE a i)
- (int16 (+ (ash (aref a (+ i 0)) 0)
- (ash (aref a (+ i 1)) 8))))
-
-(define (hex5 n)
- (string.lpad (number->string n 16) 5 #\0))
-
-(define (disassemble f . lev?)
- (if (null? lev?)
- (begin (disassemble f 0)
- (newline)
- (return #t)))
- (let ((lev (car lev?))
- (code (function:code f))
- (vals (function:vals f)))
- (define (print-val v)
- (if (and (function? v) (not (builtin? v)))
- (begin (princ "\n")
- (disassemble v (+ lev 1)))
- (print v)))
- (dotimes (xx lev) (princ "\t"))
- (princ "maxstack " (ref-int32-LE code 0) "\n")
- (let ((i 4)
- (N (length code)))
- (while (< i N)
- ; find key whose value matches the current byte
- (let ((inst (table.foldl (lambda (k v z)
- (or z (and (eq? v (aref code i))
- k)))
- #f Instructions)))
- (if (> i 4) (newline))
- (dotimes (xx lev) (princ "\t"))
- (princ (hex5 (- i 4)) ": "
- (string inst) "\t")
- (set! i (+ i 1))
- (case inst
- ((loadv.l loadg.l setg.l)
- (print-val (aref vals (ref-int32-LE code i)))
- (set! i (+ i 4)))
-
- ((loadv loadg setg)
- (print-val (aref vals (aref code i)))
- (set! i (+ i 1)))
-
- ((loada seta call tcall list + - * / vector
- argc vargc loadi8 apply tapply)
- (princ (number->string (aref code i)))
- (set! i (+ i 1)))
-
- ((loada.l seta.l largc lvargc call.l tcall.l)
- (princ (number->string (ref-int32-LE code i)))
- (set! i (+ i 4)))
-
- ((loadc setc)
- (princ (number->string (aref code i)) " ")
- (set! i (+ i 1))
- (princ (number->string (aref code i)))
- (set! i (+ i 1)))
-
- ((loadc.l setc.l optargs keyargs)
- (princ (number->string (ref-int32-LE code i)) " ")
- (set! i (+ i 4))
- (princ (number->string (ref-int32-LE code i)))
- (set! i (+ i 4))
- (if (eq? inst 'keyargs)
- (begin
- (princ " ")
- (princ (number->string (ref-int32-LE code i)) " ")
- (set! i (+ i 4)))))
-
- ((brbound)
- (princ (number->string (ref-int32-LE code i)) " ")
- (set! i (+ i 4)))
-
- ((jmp brf brt brne brnn brn)
- (princ "@" (hex5 (+ i -4 (ref-int16-LE code i))))
- (set! i (+ i 2)))
-
- ((jmp.l brf.l brt.l brne.l brnn.l brn.l)
- (princ "@" (hex5 (+ i -4 (ref-int32-LE code i))))
- (set! i (+ i 4)))
-
- (else #f)))))))
-
-; From SRFI 89 by Marc Feeley (http://srfi.schemers.org/srfi-89/srfi-89.html)
-; Copyright (C) Marc Feeley 2006. All Rights Reserved.
-;
-; "alist" is a list of pairs of the form "(keyword . value)"
-; The result is a perfect hash-table represented as a vector of
-; length 2*N, where N is the hash modulus. If the keyword K is in
-; the hash-table it is at index
-;
-; X = (* 2 ($hash-keyword K N))
-;
-; and the associated value is at index X+1.
-(define (make-perfect-hash-table alist)
- (define ($hash-keyword key n) (mod0 (abs (hash key)) n))
- (let loop1 ((n (length alist)))
- (let ((v (vector.alloc (* 2 n) #f)))
- (let loop2 ((lst alist))
- (if (pair? lst)
- (let ((key (caar lst)))
- (let ((x (* 2 ($hash-keyword key n))))
- (if (aref v x)
- (loop1 (+ n 1))
- (begin
- (aset! v x key)
- (aset! v (+ x 1) (cdar lst))
- (loop2 (cdr lst))))))
- v)))))
-
-#t
--- a/femtolisp/cvalues.c
+++ /dev/null
@@ -1,1533 +1,0 @@
-#ifdef BITS64
-#define NWORDS(sz) (((sz)+7)>>3)
-#else
-#define NWORDS(sz) (((sz)+3)>>2)
-#endif
-
-static int ALIGN2, ALIGN4, ALIGN8, ALIGNPTR;
-
-value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
-value_t int64sym, uint64sym;
-value_t longsym, ulongsym, bytesym, wcharsym;
-value_t floatsym, doublesym;
-value_t gftypesym, stringtypesym, wcstringtypesym;
-value_t emptystringsym;
-
-value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
-value_t unionsym;
-
-static htable_t TypeTable;
-static htable_t reverse_dlsym_lookup_table;
-static fltype_t *int8type, *uint8type;
-static fltype_t *int16type, *uint16type;
-static fltype_t *int32type, *uint32type;
-static fltype_t *int64type, *uint64type;
-static fltype_t *longtype, *ulongtype;
-static fltype_t *floattype, *doubletype;
- fltype_t *bytetype, *wchartype;
- fltype_t *stringtype, *wcstringtype;
- fltype_t *builtintype;
-
-static void cvalue_init(fltype_t *type, value_t v, void *dest);
-
-// cvalues-specific builtins
-value_t cvalue_new(value_t *args, u_int32_t nargs);
-value_t cvalue_sizeof(value_t *args, u_int32_t nargs);
-value_t cvalue_typeof(value_t *args, u_int32_t nargs);
-
-// trigger unconditional GC after this many bytes are allocated
-#define ALLOC_LIMIT_TRIGGER 67108864
-
-static size_t malloc_pressure = 0;
-
-static cvalue_t **Finalizers = NULL;
-static size_t nfinalizers=0;
-static size_t maxfinalizers=0;
-
-void add_finalizer(cvalue_t *cv)
-{- if (nfinalizers == maxfinalizers) {- size_t nn = (maxfinalizers==0 ? 256 : maxfinalizers*2);
- cvalue_t **temp = (cvalue_t**)realloc(Finalizers, nn*sizeof(value_t));
- if (temp == NULL)
- lerror(MemoryError, "out of memory");
- Finalizers = temp;
- maxfinalizers = nn;
- }
- Finalizers[nfinalizers++] = cv;
-}
-
-// remove dead objects from finalization list in-place
-static void sweep_finalizers()
-{- cvalue_t **lst = Finalizers;
- size_t n=0, ndel=0, l=nfinalizers;
- cvalue_t *tmp;
-#define SWAP_sf(a,b) (tmp=a,a=b,b=tmp,1)
- if (l == 0)
- return;
- do {- tmp = lst[n];
- if (isforwarded((value_t)tmp)) {- // object is alive
- lst[n] = (cvalue_t*)ptr(forwardloc((value_t)tmp));
- n++;
- }
- else {- fltype_t *t = cv_class(tmp);
- if (t->vtable != NULL && t->vtable->finalize != NULL) {- t->vtable->finalize(tagptr(tmp, TAG_CVALUE));
- }
- if (!isinlined(tmp) && owned(tmp)) {-#ifndef NDEBUG
- memset(cv_data(tmp), 0xbb, cv_len(tmp));
-#endif
- free(cv_data(tmp));
- }
- ndel++;
- }
- } while ((n < l-ndel) && SWAP_sf(lst[n],lst[n+ndel]));
-
- nfinalizers -= ndel;
-#ifdef VERBOSEGC
- if (ndel > 0)
- printf("GC: finalized %d objects\n", ndel);-#endif
-
- malloc_pressure = 0;
-}
-
-// compute the size of the metadata object for a cvalue
-static size_t cv_nwords(cvalue_t *cv)
-{- if (isinlined(cv)) {- size_t n = cv_len(cv);
- if (n==0 || cv_isstr(cv))
- n++;
- return CVALUE_NWORDS - 1 + NWORDS(n);
- }
- return CVALUE_NWORDS;
-}
-
-static void autorelease(cvalue_t *cv)
-{- cv->type = (fltype_t*)(((uptrint_t)cv->type) | CV_OWNED_BIT);
- add_finalizer(cv);
-}
-
-void cv_autorelease(cvalue_t *cv)
-{- autorelease(cv);
-}
-
-static value_t cprim(fltype_t *type, size_t sz)
-{- assert(!ismanaged((uptrint_t)type));
- assert(sz == type->size);
- cprim_t *pcp = (cprim_t*)alloc_words(CPRIM_NWORDS-1+NWORDS(sz));
- pcp->type = type;
- return tagptr(pcp, TAG_CPRIM);
-}
-
-value_t cvalue(fltype_t *type, size_t sz)
-{- cvalue_t *pcv;
- int str=0;
-
- if (valid_numtype(type->numtype)) {- return cprim(type, sz);
- }
- if (type->eltype == bytetype) {- if (sz == 0)
- return symbol_value(emptystringsym);
- sz++;
- str=1;
- }
- if (sz <= MAX_INL_SIZE) {- size_t nw = CVALUE_NWORDS - 1 + NWORDS(sz) + (sz==0 ? 1 : 0);
- pcv = (cvalue_t*)alloc_words(nw);
- pcv->type = type;
- pcv->data = &pcv->_space[0];
- if (type->vtable != NULL && type->vtable->finalize != NULL)
- add_finalizer(pcv);
- }
- else {- if (malloc_pressure > ALLOC_LIMIT_TRIGGER)
- gc(0);
- pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS);
- pcv->type = type;
- pcv->data = malloc(sz);
- autorelease(pcv);
- malloc_pressure += sz;
- }
- if (str) {- sz--;
- ((char*)pcv->data)[sz] = '\0';
- }
- pcv->len = sz;
- return tagptr(pcv, TAG_CVALUE);
-}
-
-value_t cvalue_from_data(fltype_t *type, void *data, size_t sz)
-{- value_t cv;
- cv = cvalue(type, sz);
- memcpy(cptr(cv), data, sz);
- return cv;
-}
-
-// this effectively dereferences a pointer
-// just like *p in C, it only removes a level of indirection from the type,
-// it doesn't copy any data.
-// this method of creating a cvalue only allocates metadata.
-// ptr is user-managed; we don't autorelease it unless the
-// user explicitly calls (autorelease ) on the result of this function.
-// 'parent' is an optional cvalue that this pointer is known to point
-// into; NIL if none.
-value_t cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent)
-{- cvalue_t *pcv;
- value_t cv;
-
- pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS);
- pcv->data = ptr;
- pcv->len = sz;
- pcv->type = type;
- if (parent != NIL) {- pcv->type = (fltype_t*)(((uptrint_t)pcv->type) | CV_PARENT_BIT);
- pcv->parent = parent;
- }
- cv = tagptr(pcv, TAG_CVALUE);
- return cv;
-}
-
-value_t cvalue_string(size_t sz)
-{- return cvalue(stringtype, sz);
-}
-
-value_t cvalue_static_cstring(const char *str)
-{- return cvalue_from_ref(stringtype, (char*)str, strlen(str), NIL);
-}
-
-value_t string_from_cstrn(char *str, size_t n)
-{- value_t v = cvalue_string(n);
- memcpy(cvalue_data(v), str, n);
- return v;
-}
-
-value_t string_from_cstr(char *str)
-{- return string_from_cstrn(str, strlen(str));
-}
-
-int fl_isstring(value_t v)
-{- return (iscvalue(v) && cv_isstr((cvalue_t*)ptr(v)));
-}
-
-// convert to malloc representation (fixed address)
-void cv_pin(cvalue_t *cv)
-{- if (!isinlined(cv))
- return;
- size_t sz = cv_len(cv);
- if (cv_isstr(cv)) sz++;
- void *data = malloc(sz);
- memcpy(data, cv_data(cv), sz);
- cv->data = data;
- autorelease(cv);
-}
-
-#define num_init(ctype, cnvt, tag) \
-static int cvalue_##ctype##_init(fltype_t *type, value_t arg, \
- void *dest) \
-{ \- fl_##ctype##_t n=0; \
- (void)type; \
- if (isfixnum(arg)) { \- n = numval(arg); \
- } \
- else if (iscprim(arg)) { \- cprim_t *cp = (cprim_t*)ptr(arg); \
- void *p = cp_data(cp); \
- n = (fl_##ctype##_t)conv_to_##cnvt(p, cp_numtype(cp)); \
- } \
- else { \- return 1; \
- } \
- *((fl_##ctype##_t*)dest) = n; \
- return 0; \
-}
-num_init(int8, int32, T_INT8)
-num_init(uint8, uint32, T_UINT8)
-num_init(int16, int32, T_INT16)
-num_init(uint16, uint32, T_UINT16)
-num_init(int32, int32, T_INT32)
-num_init(uint32, uint32, T_UINT32)
-num_init(int64, int64, T_INT64)
-num_init(uint64, uint64, T_UINT64)
-num_init(float, double, T_FLOAT)
-num_init(double, double, T_DOUBLE)
-
-#define num_ctor_init(typenam, ctype, tag) \
-value_t cvalue_##typenam(value_t *args, u_int32_t nargs) \
-{ \- if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; } \- value_t cp = cprim(typenam##type, sizeof(fl_##ctype##_t)); \
- if (cvalue_##ctype##_init(typenam##type, \
- args[0], cp_data((cprim_t*)ptr(cp)))) \
- type_error(#typenam, "number", args[0]); \
- return cp; \
-}
-
-#define num_ctor_ctor(typenam, ctype, tag) \
-value_t mk_##typenam(fl_##ctype##_t n) \
-{ \- value_t cp = cprim(typenam##type, sizeof(fl_##ctype##_t)); \
- *(fl_##ctype##_t*)cp_data((cprim_t*)ptr(cp)) = n; \
- return cp; \
-}
-
-#define num_ctor(typenam, ctype, tag) \
- num_ctor_init(typenam, ctype, tag) \
- num_ctor_ctor(typenam, ctype, tag)
-
-num_ctor(int8, int8, T_INT8)
-num_ctor(uint8, uint8, T_UINT8)
-num_ctor(int16, int16, T_INT16)
-num_ctor(uint16, uint16, T_UINT16)
-num_ctor(int32, int32, T_INT32)
-num_ctor(uint32, uint32, T_UINT32)
-num_ctor(int64, int64, T_INT64)
-num_ctor(uint64, uint64, T_UINT64)
-num_ctor(byte, uint8, T_UINT8)
-num_ctor(wchar, int32, T_INT32)
-#ifdef BITS64
-num_ctor(long, int64, T_INT64)
-num_ctor(ulong, uint64, T_UINT64)
-#else
-num_ctor(long, int32, T_INT32)
-num_ctor(ulong, uint32, T_UINT32)
-#endif
-num_ctor(float, float, T_FLOAT)
-num_ctor(double, double, T_DOUBLE)
-
-value_t size_wrap(size_t sz)
-{- if (fits_fixnum(sz))
- return fixnum(sz);
- assert(sizeof(void*) == sizeof(size_t));
- return mk_ulong(sz);
-}
-
-size_t toulong(value_t n, char *fname)
-{- if (isfixnum(n))
- return numval(n);
- if (iscprim(n)) {- cprim_t *cp = (cprim_t*)ptr(n);
- return conv_to_ulong(cp_data(cp), cp_numtype(cp));
- }
- type_error(fname, "number", n);
- return 0;
-}
-
-static int cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
-{- int n=0;
- value_t syms;
- value_t type = ft->type;
-
- syms = car(cdr(type));
- if (!isvector(syms))
- type_error("enum", "vector", syms);- if (issymbol(arg)) {- for(n=0; n < (int)vector_size(syms); n++) {- if (vector_elt(syms, n) == arg) {- *(int*)dest = n;
- return 0;
- }
- }
- lerror(ArgError, "enum: invalid enum value");
- }
- if (isfixnum(arg)) {- n = (int)numval(arg);
- }
- else if (iscprim(arg)) {- cprim_t *cp = (cprim_t*)ptr(arg);
- n = conv_to_int32(cp_data(cp), cp_numtype(cp));
- }
- else {- type_error("enum", "number", arg);- }
- if ((unsigned)n >= vector_size(syms))
- lerror(ArgError, "enum: value out of range");
- *(int*)dest = n;
- return 0;
-}
-
-value_t cvalue_enum(value_t *args, u_int32_t nargs)
-{- argcount("enum", nargs, 2);- value_t type = fl_list2(enumsym, args[0]);
- fltype_t *ft = get_type(type);
- value_t cv = cvalue(ft, sizeof(int32_t));
- cvalue_enum_init(ft, args[1], cp_data((cprim_t*)ptr(cv)));
- return cv;
-}
-
-static int isarray(value_t v)
-{- return iscvalue(v) && cv_class((cvalue_t*)ptr(v))->eltype != NULL;
-}
-
-static size_t predict_arraylen(value_t arg)
-{- if (isvector(arg))
- return vector_size(arg);
- else if (iscons(arg))
- return llength(arg);
- else if (arg == NIL)
- return 0;
- if (isarray(arg))
- return cvalue_arraylen(arg);
- return 1;
-}
-
-static int cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
-{- value_t type = ft->type;
- size_t elsize, i, cnt, sz;
- fltype_t *eltype = ft->eltype;
-
- elsize = ft->elsz;
- cnt = predict_arraylen(arg);
-
- if (iscons(cdr_(cdr_(type)))) {- size_t tc = toulong(car_(cdr_(cdr_(type))), "array");
- if (tc != cnt)
- lerror(ArgError, "array: size mismatch");
- }
-
- sz = elsize * cnt;
-
- if (isvector(arg)) {- assert(cnt <= vector_size(arg));
- for(i=0; i < cnt; i++) {- cvalue_init(eltype, vector_elt(arg,i), dest);
- dest += elsize;
- }
- return 0;
- }
- else if (iscons(arg) || arg==NIL) {- i = 0;
- while (iscons(arg)) {- if (i == cnt) { i++; break; } // trigger error- cvalue_init(eltype, car_(arg), dest);
- i++;
- dest += elsize;
- arg = cdr_(arg);
- }
- if (i != cnt)
- lerror(ArgError, "array: size mismatch");
- return 0;
- }
- else if (iscvalue(arg)) {- cvalue_t *cv = (cvalue_t*)ptr(arg);
- if (isarray(arg)) {- fltype_t *aet = cv_class(cv)->eltype;
- if (aet == eltype) {- if (cv_len(cv) == sz)
- memcpy(dest, cv_data(cv), sz);
- else
- lerror(ArgError, "array: size mismatch");
- return 0;
- }
- else {- // TODO: initialize array from different type elements
- lerror(ArgError, "array: element type mismatch");
- }
- }
- }
- if (cnt == 1)
- cvalue_init(eltype, arg, dest);
- else
- type_error("array", "sequence", arg);- return 0;
-}
-
-value_t cvalue_array(value_t *args, u_int32_t nargs)
-{- size_t elsize, cnt, sz, i;
- value_t arg;
-
- if (nargs < 1)
- argcount("array", nargs, 1);-
- cnt = nargs - 1;
- fltype_t *type = get_array_type(args[0]);
- elsize = type->elsz;
- sz = elsize * cnt;
-
- value_t cv = cvalue(type, sz);
- char *dest = cv_data((cvalue_t*)ptr(cv));
- FOR_ARGS(i,1,arg,args) {- cvalue_init(type->eltype, arg, dest);
- dest += elsize;
- }
- return cv;
-}
-
-// NOTE: v must be an array
-size_t cvalue_arraylen(value_t v)
-{- cvalue_t *cv = (cvalue_t*)ptr(v);
- return cv_len(cv)/(cv_class(cv)->elsz);
-}
-
-static size_t cvalue_struct_offs(value_t type, value_t field, int computeTotal,
- int *palign)
-{- value_t fld = car(cdr_(type));
- size_t fsz, ssz = 0;
- int al;
- *palign = 0;
-
- while (iscons(fld)) {- fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
-
- ssz = LLT_ALIGN(ssz, al);
- if (al > *palign)
- *palign = al;
-
- if (!computeTotal && field==car_(car_(fld))) {- // found target field
- return ssz;
- }
-
- ssz += fsz;
- fld = cdr_(fld);
- }
- return LLT_ALIGN(ssz, *palign);
-}
-
-static size_t cvalue_union_size(value_t type, int *palign)
-{- value_t fld = car(cdr_(type));
- size_t fsz, usz = 0;
- int al;
- *palign = 0;
-
- while (iscons(fld)) {- fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
- if (al > *palign) *palign = al;
- if (fsz > usz) usz = fsz;
- fld = cdr_(fld);
- }
- return LLT_ALIGN(usz, *palign);
-}
-
-// *palign is an output argument giving the alignment required by type
-size_t ctype_sizeof(value_t type, int *palign)
-{- if (type == int8sym || type == uint8sym || type == bytesym) {- *palign = 1;
- return 1;
- }
- if (type == int16sym || type == uint16sym) {- *palign = ALIGN2;
- return 2;
- }
- if (type == int32sym || type == uint32sym || type == wcharsym ||
- type == floatsym) {- *palign = ALIGN4;
- return 4;
- }
- if (type == int64sym || type == uint64sym || type == doublesym) {- *palign = ALIGN8;
- return 8;
- }
- if (type == longsym || type == ulongsym) {-#ifdef BITS64
- *palign = ALIGN8;
- return 8;
-#else
- *palign = ALIGN4;
- return 4;
-#endif
- }
- if (iscons(type)) {- value_t hed = car_(type);
- if (hed == pointersym || hed == cfunctionsym) {- *palign = ALIGNPTR;
- return sizeof(void*);
- }
- if (hed == arraysym) {- value_t t = car(cdr_(type));
- if (!iscons(cdr_(cdr_(type))))
- lerror(ArgError, "sizeof: incomplete type");
- value_t n = car_(cdr_(cdr_(type)));
- size_t sz = toulong(n, "sizeof");
- return sz * ctype_sizeof(t, palign);
- }
- else if (hed == structsym) {- return cvalue_struct_offs(type, NIL, 1, palign);
- }
- else if (hed == unionsym) {- return cvalue_union_size(type, palign);
- }
- else if (hed == enumsym) {- *palign = ALIGN4;
- return 4;
- }
- }
- lerror(ArgError, "sizeof: invalid c type");
- return 0;
-}
-
-extern fltype_t *iostreamtype;
-
-// get pointer and size for any plain-old-data value
-void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz)
-{- if (iscvalue(v)) {- cvalue_t *pcv = (cvalue_t*)ptr(v);
- ios_t *x = value2c(ios_t*,v);
- if (cv_class(pcv) == iostreamtype && (x->bm == bm_mem)) {- *pdata = x->buf;
- *psz = x->size;
- return;
- }
- else if (cv_isPOD(pcv)) {- *pdata = cv_data(pcv);
- *psz = cv_len(pcv);
- return;
- }
- }
- else if (iscprim(v)) {- cprim_t *pcp = (cprim_t*)ptr(v);
- *pdata = cp_data(pcp);
- *psz = cp_class(pcp)->size;
- return;
- }
- type_error(fname, "plain-old-data", v);
-}
-
-value_t cvalue_sizeof(value_t *args, u_int32_t nargs)
-{- argcount("sizeof", nargs, 1);- if (issymbol(args[0]) || iscons(args[0])) {- int a;
- return size_wrap(ctype_sizeof(args[0], &a));
- }
- size_t n; char *data;
- to_sized_ptr(args[0], "sizeof", &data, &n);
- return size_wrap(n);
-}
-
-value_t cvalue_typeof(value_t *args, u_int32_t nargs)
-{- argcount("typeof", nargs, 1);- switch(tag(args[0])) {- case TAG_CONS: return pairsym;
- case TAG_NUM1:
- case TAG_NUM: return fixnumsym;
- case TAG_SYM: return symbolsym;
- case TAG_VECTOR: return vectorsym;
- case TAG_FUNCTION:
- if (args[0] == FL_T || args[0] == FL_F)
- return booleansym;
- if (args[0] == NIL)
- return nullsym;
- if (args[0] == FL_EOF)
- return symbol("eof-object");- if (isbuiltin(args[0]))
- return builtinsym;
- return FUNCTION;
- }
- return cv_type((cvalue_t*)ptr(args[0]));
-}
-
-static value_t cvalue_relocate(value_t v)
-{- size_t nw;
- cvalue_t *cv = (cvalue_t*)ptr(v);
- cvalue_t *nv;
- value_t ncv;
-
- nw = cv_nwords(cv);
- nv = (cvalue_t*)alloc_words(nw);
- memcpy(nv, cv, nw*sizeof(value_t));
- if (isinlined(cv))
- nv->data = &nv->_space[0];
- ncv = tagptr(nv, TAG_CVALUE);
- fltype_t *t = cv_class(cv);
- if (t->vtable != NULL && t->vtable->relocate != NULL)
- t->vtable->relocate(v, ncv);
- forward(v, ncv);
- return ncv;
-}
-
-value_t cvalue_copy(value_t v)
-{- assert(iscvalue(v));
- PUSH(v);
- cvalue_t *cv = (cvalue_t*)ptr(v);
- size_t nw = cv_nwords(cv);
- cvalue_t *ncv = (cvalue_t*)alloc_words(nw);
- v = POP(); cv = (cvalue_t*)ptr(v);
- memcpy(ncv, cv, nw * sizeof(value_t));
- if (!isinlined(cv)) {- size_t len = cv_len(cv);
- if (cv_isstr(cv)) len++;
- ncv->data = malloc(len);
- memcpy(ncv->data, cv_data(cv), len);
- autorelease(ncv);
- if (hasparent(cv)) {- ncv->type = (fltype_t*)(((uptrint_t)ncv->type) & ~CV_PARENT_BIT);
- ncv->parent = NIL;
- }
- }
- else {- ncv->data = &ncv->_space[0];
- }
-
- return tagptr(ncv, TAG_CVALUE);
-}
-
-value_t fl_copy(value_t *args, u_int32_t nargs)
-{- argcount("copy", nargs, 1);- if (iscons(args[0]) || isvector(args[0]))
- lerror(ArgError, "copy: argument must be a leaf atom");
- if (!iscvalue(args[0]))
- return args[0];
- if (!cv_isPOD((cvalue_t*)ptr(args[0])))
- lerror(ArgError, "copy: argument must be a plain-old-data type");
- return cvalue_copy(args[0]);
-}
-
-value_t fl_podp(value_t *args, u_int32_t nargs)
-{- argcount("plain-old-data?", nargs, 1);- return (iscprim(args[0]) ||
- (iscvalue(args[0]) && cv_isPOD((cvalue_t*)ptr(args[0])))) ?
- FL_T : FL_F;
-}
-
-static void cvalue_init(fltype_t *type, value_t v, void *dest)
-{- cvinitfunc_t f=type->init;
-
- if (f == NULL)
- lerror(ArgError, "c-value: invalid c type");
-
- f(type, v, dest);
-}
-
-static numerictype_t sym_to_numtype(value_t type)
-{- if (type == int8sym)
- return T_INT8;
- else if (type == uint8sym || type == bytesym)
- return T_UINT8;
- else if (type == int16sym)
- return T_INT16;
- else if (type == uint16sym)
- return T_UINT16;
-#ifdef BITS64
- else if (type == int32sym || type == wcharsym)
-#else
- else if (type == int32sym || type == wcharsym || type == longsym)
-#endif
- return T_INT32;
-#ifdef BITS64
- else if (type == uint32sym)
-#else
- else if (type == uint32sym || type == ulongsym)
-#endif
- return T_UINT32;
-#ifdef BITS64
- else if (type == int64sym || type == longsym)
-#else
- else if (type == int64sym)
-#endif
- return T_INT64;
-#ifdef BITS64
- else if (type == uint64sym || type == ulongsym)
-#else
- else if (type == uint64sym)
-#endif
- return T_UINT64;
- else if (type == floatsym)
- return T_FLOAT;
- else if (type == doublesym)
- return T_DOUBLE;
- assert(0);
- return N_NUMTYPES;
-}
-
-// (new type . args)
-// this provides (1) a way to allocate values with a shared type for
-// efficiency, (2) a uniform interface for allocating cvalues of any
-// type, including user-defined.
-value_t cvalue_new(value_t *args, u_int32_t nargs)
-{- if (nargs < 1 || nargs > 2)
- argcount("c-value", nargs, 2);- value_t type = args[0];
- fltype_t *ft = get_type(type);
- value_t cv;
- if (ft->eltype != NULL) {- // special case to handle incomplete array types bla[]
- size_t elsz = ft->elsz;
- size_t cnt;
-
- if (iscons(cdr_(cdr_(type))))
- cnt = toulong(car_(cdr_(cdr_(type))), "array");
- else if (nargs == 2)
- cnt = predict_arraylen(args[1]);
- else
- cnt = 0;
- cv = cvalue(ft, elsz * cnt);
- if (nargs == 2)
- cvalue_array_init(ft, args[1], cv_data((cvalue_t*)ptr(cv)));
- }
- else {- cv = cvalue(ft, ft->size);
- if (nargs == 2)
- cvalue_init(ft, args[1], cptr(cv));
- }
- return cv;
-}
-
-// NOTE: this only compares lexicographically; it ignores numeric formats
-value_t cvalue_compare(value_t a, value_t b)
-{- cvalue_t *ca = (cvalue_t*)ptr(a);
- cvalue_t *cb = (cvalue_t*)ptr(b);
- char *adata = cv_data(ca);
- char *bdata = cv_data(cb);
- size_t asz = cv_len(ca);
- size_t bsz = cv_len(cb);
- size_t minsz = asz < bsz ? asz : bsz;
- int diff = memcmp(adata, bdata, minsz);
- if (diff == 0) {- if (asz > bsz)
- return fixnum(1);
- else if (asz < bsz)
- return fixnum(-1);
- }
- return fixnum(diff);
-}
-
-static void check_addr_args(char *fname, value_t arr, value_t ind,
- char **data, ulong_t *index)
-{- size_t numel;
- cvalue_t *cv = (cvalue_t*)ptr(arr);
- *data = cv_data(cv);
- numel = cv_len(cv)/(cv_class(cv)->elsz);
- *index = toulong(ind, fname);
- if (*index >= numel)
- bounds_error(fname, arr, ind);
-}
-
-static value_t cvalue_array_aref(value_t *args)
-{- char *data; ulong_t index;
- fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
- value_t el = 0;
- numerictype_t nt = eltype->numtype;
- if (nt >= T_INT32)
- el = cvalue(eltype, eltype->size);
- check_addr_args("aref", args[0], args[1], &data, &index);- if (nt < T_INT32) {- if (nt == T_INT8)
- return fixnum((int8_t)data[index]);
- else if (nt == T_UINT8)
- return fixnum((uint8_t)data[index]);
- else if (nt == T_INT16)
- return fixnum(((int16_t*)data)[index]);
- return fixnum(((uint16_t*)data)[index]);
- }
- char *dest = cptr(el);
- size_t sz = eltype->size;
- if (sz == 1)
- *dest = data[index];
- else if (sz == 2)
- *(int16_t*)dest = ((int16_t*)data)[index];
- else if (sz == 4)
- *(int32_t*)dest = ((int32_t*)data)[index];
- else if (sz == 8)
- *(int64_t*)dest = ((int64_t*)data)[index];
- else
- memcpy(dest, data + index*sz, sz);
- return el;
-}
-
-static value_t cvalue_array_aset(value_t *args)
-{- char *data; ulong_t index;
- fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
- check_addr_args("aset!", args[0], args[1], &data, &index);- char *dest = data + index*eltype->size;
- cvalue_init(eltype, args[2], dest);
- return args[2];
-}
-
-value_t fl_builtin(value_t *args, u_int32_t nargs)
-{- argcount("builtin", nargs, 1);- symbol_t *name = tosymbol(args[0], "builtin");
- cvalue_t *cv;
- if (ismanaged(args[0]) || (cv=name->dlcache) == NULL) {- lerrorf(ArgError, "builtin: function %s not found", name->name);
- }
- return tagptr(cv, TAG_CVALUE);
-}
-
-value_t cbuiltin(char *name, builtin_t f)
-{- cvalue_t *cv = (cvalue_t*)malloc(CVALUE_NWORDS * sizeof(value_t));
- cv->type = builtintype;
- cv->data = &cv->_space[0];
- cv->len = sizeof(value_t);
- *(void**)cv->data = f;
-
- value_t sym = symbol(name);
- ((symbol_t*)ptr(sym))->dlcache = cv;
- ptrhash_put(&reverse_dlsym_lookup_table, cv, (void*)sym);
-
- return tagptr(cv, TAG_CVALUE);
-}
-
-static value_t fl_logand(value_t *args, u_int32_t nargs);
-static value_t fl_logior(value_t *args, u_int32_t nargs);
-static value_t fl_logxor(value_t *args, u_int32_t nargs);
-static value_t fl_lognot(value_t *args, u_int32_t nargs);
-static value_t fl_ash(value_t *args, u_int32_t nargs);
-
-static builtinspec_t cvalues_builtin_info[] = {- { "c-value", cvalue_new },- { "typeof", cvalue_typeof },- { "sizeof", cvalue_sizeof },- { "builtin", fl_builtin },- { "copy", fl_copy },- { "plain-old-data?", fl_podp },-
- { "logand", fl_logand },- { "logior", fl_logior },- { "logxor", fl_logxor },- { "lognot", fl_lognot },- { "ash", fl_ash },- // todo: autorelease
- { NULL, NULL }-};
-
-#define cv_intern(tok) tok##sym = symbol(#tok)
-#define ctor_cv_intern(tok) \
- cv_intern(tok);set(tok##sym, cbuiltin(#tok, cvalue_##tok))
-
-#define mk_primtype(name) \
- name##type=get_type(name##sym);name##type->init = &cvalue_##name##_init
-
-#define mk_primtype_(name,ctype) \
- name##type=get_type(name##sym);name##type->init = &cvalue_##ctype##_init
-
-static void cvalues_init()
-{- htable_new(&TypeTable, 256);
- htable_new(&reverse_dlsym_lookup_table, 256);
-
- // compute struct field alignment required for primitives
- ALIGN2 = sizeof(struct { char a; int16_t i; }) - 2;- ALIGN4 = sizeof(struct { char a; int32_t i; }) - 4;- ALIGN8 = sizeof(struct { char a; int64_t i; }) - 8;- ALIGNPTR = sizeof(struct { char a; void *i; }) - sizeof(void*);-
- builtintype = define_opaque_type(builtinsym, sizeof(builtin_t), NULL, NULL);
-
- ctor_cv_intern(int8);
- ctor_cv_intern(uint8);
- ctor_cv_intern(int16);
- ctor_cv_intern(uint16);
- ctor_cv_intern(int32);
- ctor_cv_intern(uint32);
- ctor_cv_intern(int64);
- ctor_cv_intern(uint64);
- ctor_cv_intern(byte);
- ctor_cv_intern(wchar);
- ctor_cv_intern(long);
- ctor_cv_intern(ulong);
- ctor_cv_intern(float);
- ctor_cv_intern(double);
-
- ctor_cv_intern(array);
- ctor_cv_intern(enum);
- cv_intern(pointer);
- cv_intern(struct);
- cv_intern(union);
- cv_intern(void);
- cfunctionsym = symbol("c-function");-
- assign_global_builtins(cvalues_builtin_info);
-
- stringtypesym = symbol("*string-type*");- setc(stringtypesym, fl_list2(arraysym, bytesym));
-
- wcstringtypesym = symbol("*wcstring-type*");- setc(wcstringtypesym, fl_list2(arraysym, wcharsym));
-
- mk_primtype(int8);
- mk_primtype(uint8);
- mk_primtype(int16);
- mk_primtype(uint16);
- mk_primtype(int32);
- mk_primtype(uint32);
- mk_primtype(int64);
- mk_primtype(uint64);
-#ifdef BITS64
- mk_primtype_(long,int64);
- mk_primtype_(ulong,uint64);
-#else
- mk_primtype_(long,int32);
- mk_primtype_(ulong,uint32);
-#endif
- mk_primtype_(byte,uint8);
- mk_primtype_(wchar,int32);
- mk_primtype(float);
- mk_primtype(double);
-
- stringtype = get_type(symbol_value(stringtypesym));
- wcstringtype = get_type(symbol_value(wcstringtypesym));
-
- emptystringsym = symbol("*empty-string*");- setc(emptystringsym, cvalue_static_cstring(""));-}
-
-#define RETURN_NUM_AS(var, type) return(mk_##type((fl_##type##_t)var))
-
-value_t return_from_uint64(uint64_t Uaccum)
-{- if (fits_fixnum(Uaccum)) {- return fixnum((fixnum_t)Uaccum);
- }
- if (Uaccum > (uint64_t)S64_MAX) {- RETURN_NUM_AS(Uaccum, uint64);
- }
- else if (Uaccum > (uint64_t)UINT_MAX) {- RETURN_NUM_AS(Uaccum, int64);
- }
- else if (Uaccum > (uint64_t)INT_MAX) {- RETURN_NUM_AS(Uaccum, uint32);
- }
- RETURN_NUM_AS(Uaccum, int32);
-}
-
-value_t return_from_int64(int64_t Saccum)
-{- if (fits_fixnum(Saccum)) {- return fixnum((fixnum_t)Saccum);
- }
- if (Saccum > (int64_t)UINT_MAX || Saccum < (int64_t)INT_MIN) {- RETURN_NUM_AS(Saccum, int64);
- }
- else if (Saccum > (int64_t)INT_MAX) {- RETURN_NUM_AS(Saccum, uint32);
- }
- RETURN_NUM_AS(Saccum, int32);
-}
-
-static value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn)
-{- uint64_t Uaccum=0;
- int64_t Saccum = carryIn;
- double Faccum=0;
- uint32_t i;
- value_t arg=NIL;
-
- FOR_ARGS(i,0,arg,args) {- if (isfixnum(arg)) {- Saccum += numval(arg);
- continue;
- }
- else if (iscprim(arg)) {- cprim_t *cp = (cprim_t*)ptr(arg);
- void *a = cp_data(cp);
- int64_t i64;
- switch(cp_numtype(cp)) {- case T_INT8: Saccum += *(int8_t*)a; break;
- case T_UINT8: Saccum += *(uint8_t*)a; break;
- case T_INT16: Saccum += *(int16_t*)a; break;
- case T_UINT16: Saccum += *(uint16_t*)a; break;
- case T_INT32: Saccum += *(int32_t*)a; break;
- case T_UINT32: Saccum += *(uint32_t*)a; break;
- case T_INT64:
- i64 = *(int64_t*)a;
- if (i64 > 0)
- Uaccum += (uint64_t)i64;
- else
- Saccum += i64;
- break;
- case T_UINT64: Uaccum += *(uint64_t*)a; break;
- case T_FLOAT: Faccum += *(float*)a; break;
- case T_DOUBLE: Faccum += *(double*)a; break;
- default:
- goto add_type_error;
- }
- continue;
- }
- add_type_error:
- type_error("+", "number", arg);- }
- if (Faccum != 0) {- Faccum += Uaccum;
- Faccum += Saccum;
- return mk_double(Faccum);
- }
- else if (Saccum < 0) {- uint64_t negpart = (uint64_t)(-Saccum);
- if (negpart > Uaccum) {- Saccum += (int64_t)Uaccum;
- // return value in Saccum
- if (Saccum >= INT_MIN) {- if (fits_fixnum(Saccum)) {- return fixnum((fixnum_t)Saccum);
- }
- RETURN_NUM_AS(Saccum, int32);
- }
- RETURN_NUM_AS(Saccum, int64);
- }
- Uaccum -= negpart;
- }
- else {- Uaccum += (uint64_t)Saccum;
- }
- // return value in Uaccum
- return return_from_uint64(Uaccum);
-}
-
-static value_t fl_neg(value_t n)
-{- if (isfixnum(n)) {- return fixnum(-numval(n));
- }
- else if (iscprim(n)) {- cprim_t *cp = (cprim_t*)ptr(n);
- void *a = cp_data(cp);
- uint32_t ui32;
- int32_t i32;
- int64_t i64;
- switch(cp_numtype(cp)) {- case T_INT8: return fixnum(-(int32_t)*(int8_t*)a);
- case T_UINT8: return fixnum(-(int32_t)*(uint8_t*)a);
- case T_INT16: return fixnum(-(int32_t)*(int16_t*)a);
- case T_UINT16: return fixnum(-(int32_t)*(uint16_t*)a);
- case T_INT32:
- i32 = *(int32_t*)a;
- if (i32 == (int32_t)BIT31)
- return mk_uint32((uint32_t)BIT31);
- return mk_int32(-i32);
- case T_UINT32:
- ui32 = *(uint32_t*)a;
- if (ui32 <= ((uint32_t)INT_MAX)+1) return mk_int32(-(int32_t)ui32);
- return mk_int64(-(int64_t)ui32);
- case T_INT64:
- i64 = *(int64_t*)a;
- if (i64 == (int64_t)BIT63)
- return mk_uint64((uint64_t)BIT63);
- return mk_int64(-i64);
- case T_UINT64: return mk_int64(-(int64_t)*(uint64_t*)a);
- case T_FLOAT: return mk_float(-*(float*)a);
- case T_DOUBLE: return mk_double(-*(double*)a);
- break;
- }
- }
- type_error("-", "number", n);-}
-
-static value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum)
-{- uint64_t Uaccum=1;
- double Faccum=1;
- uint32_t i;
- value_t arg=NIL;
-
- FOR_ARGS(i,0,arg,args) {- if (isfixnum(arg)) {- Saccum *= numval(arg);
- continue;
- }
- else if (iscprim(arg)) {- cprim_t *cp = (cprim_t*)ptr(arg);
- void *a = cp_data(cp);
- int64_t i64;
- switch(cp_numtype(cp)) {- case T_INT8: Saccum *= *(int8_t*)a; break;
- case T_UINT8: Saccum *= *(uint8_t*)a; break;
- case T_INT16: Saccum *= *(int16_t*)a; break;
- case T_UINT16: Saccum *= *(uint16_t*)a; break;
- case T_INT32: Saccum *= *(int32_t*)a; break;
- case T_UINT32: Saccum *= *(uint32_t*)a; break;
- case T_INT64:
- i64 = *(int64_t*)a;
- if (i64 > 0)
- Uaccum *= (uint64_t)i64;
- else
- Saccum *= i64;
- break;
- case T_UINT64: Uaccum *= *(uint64_t*)a; break;
- case T_FLOAT: Faccum *= *(float*)a; break;
- case T_DOUBLE: Faccum *= *(double*)a; break;
- default:
- goto mul_type_error;
- }
- continue;
- }
- mul_type_error:
- type_error("*", "number", arg);- }
- if (Faccum != 1) {- Faccum *= Uaccum;
- Faccum *= Saccum;
- return mk_double(Faccum);
- }
- else if (Saccum < 0) {- Saccum *= (int64_t)Uaccum;
- if (Saccum >= INT_MIN) {- if (fits_fixnum(Saccum)) {- return fixnum((fixnum_t)Saccum);
- }
- RETURN_NUM_AS(Saccum, int32);
- }
- RETURN_NUM_AS(Saccum, int64);
- }
- else {- Uaccum *= (uint64_t)Saccum;
- }
- return return_from_uint64(Uaccum);
-}
-
-static int num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp)
-{- cprim_t *cp;
- if (isfixnum(a)) {- *pi = numval(a);
- *pp = pi;
- *pt = T_FIXNUM;
- }
- else if (iscprim(a)) {- cp = (cprim_t*)ptr(a);
- *pp = cp_data(cp);
- *pt = cp_numtype(cp);
- }
- else {- return 0;
- }
- return 1;
-}
-
-/*
- returns -1, 0, or 1 based on ordering of a and b
- eq: consider equality only, returning 0 or nonzero
- eqnans: NaNs considered equal to each other
- -0.0 not considered equal to 0.0
- inexact not considered equal to exact
- fname: if not NULL, throws type errors, else returns 2 for type errors
-*/
-int numeric_compare(value_t a, value_t b, int eq, int eqnans, char *fname)
-{- int_t ai, bi;
- numerictype_t ta, tb;
- void *aptr, *bptr;
-
- if (bothfixnums(a,b)) {- if (a==b) return 0;
- if (numval(a) < numval(b)) return -1;
- return 1;
- }
- if (!num_to_ptr(a, &ai, &ta, &aptr)) {- if (fname) type_error(fname, "number", a); else return 2;
- }
- if (!num_to_ptr(b, &bi, &tb, &bptr)) {- if (fname) type_error(fname, "number", b); else return 2;
- }
- if (eq && eqnans && ((ta >= T_FLOAT) != (tb >= T_FLOAT)))
- return 1;
- if (cmp_eq(aptr, ta, bptr, tb, eqnans))
- return 0;
- if (eq) return 1;
- if (cmp_lt(aptr, ta, bptr, tb))
- return -1;
- return 1;
-}
-
-static void DivideByZeroError() __attribute__ ((__noreturn__));
-static void DivideByZeroError()
-{- lerror(DivideError, "/: division by zero");
-}
-
-static value_t fl_div2(value_t a, value_t b)
-{- double da, db;
- int_t ai, bi;
- numerictype_t ta, tb;
- void *aptr, *bptr;
-
- if (!num_to_ptr(a, &ai, &ta, &aptr))
- type_error("/", "number", a);- if (!num_to_ptr(b, &bi, &tb, &bptr))
- type_error("/", "number", b);-
- da = conv_to_double(aptr, ta);
- db = conv_to_double(bptr, tb);
-
- if (db == 0 && tb < T_FLOAT) // exact 0
- DivideByZeroError();
-
- da = da/db;
-
- if (ta < T_FLOAT && tb < T_FLOAT && (double)(int64_t)da == da)
- return return_from_int64((int64_t)da);
- return mk_double(da);
-}
-
-static value_t fl_idiv2(value_t a, value_t b)
-{- int_t ai, bi;
- numerictype_t ta, tb;
- void *aptr, *bptr;
- int64_t a64, b64;
-
- if (!num_to_ptr(a, &ai, &ta, &aptr))
- type_error("div0", "number", a);- if (!num_to_ptr(b, &bi, &tb, &bptr))
- type_error("div0", "number", b);-
- if (ta == T_UINT64) {- if (tb == T_UINT64) {- if (*(uint64_t*)bptr == 0) goto div_error;
- return return_from_uint64(*(uint64_t*)aptr / *(uint64_t*)bptr);
- }
- b64 = conv_to_int64(bptr, tb);
- if (b64 < 0) {- return return_from_int64(-(int64_t)(*(uint64_t*)aptr /
- (uint64_t)(-b64)));
- }
- if (b64 == 0)
- goto div_error;
- return return_from_uint64(*(uint64_t*)aptr / (uint64_t)b64);
- }
- if (tb == T_UINT64) {- if (*(uint64_t*)bptr == 0) goto div_error;
- a64 = conv_to_int64(aptr, ta);
- if (a64 < 0) {- return return_from_int64(-((int64_t)((uint64_t)(-a64) /
- *(uint64_t*)bptr)));
- }
- return return_from_uint64((uint64_t)a64 / *(uint64_t*)bptr);
- }
-
- b64 = conv_to_int64(bptr, tb);
- if (b64 == 0) goto div_error;
-
- return return_from_int64(conv_to_int64(aptr, ta) / b64);
- div_error:
- DivideByZeroError();
-}
-
-static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
-{- int_t ai, bi;
- numerictype_t ta, tb, itmp;
- void *aptr=NULL, *bptr=NULL, *ptmp;
- int64_t b64;
-
- if (!num_to_ptr(a, &ai, &ta, &aptr) || ta >= T_FLOAT)
- type_error(fname, "integer", a);
- if (!num_to_ptr(b, &bi, &tb, &bptr) || tb >= T_FLOAT)
- type_error(fname, "integer", b);
-
- if (ta < tb) {- itmp = ta; ta = tb; tb = itmp;
- ptmp = aptr; aptr = bptr; bptr = ptmp;
- }
- // now a's type is larger than or same as b's
- b64 = conv_to_int64(bptr, tb);
- switch (opcode) {- case 0:
- switch (ta) {- case T_INT8: return fixnum( *(int8_t *)aptr & (int8_t )b64);
- case T_UINT8: return fixnum( *(uint8_t *)aptr & (uint8_t )b64);
- case T_INT16: return fixnum( *(int16_t*)aptr & (int16_t )b64);
- case T_UINT16: return fixnum( *(uint16_t*)aptr & (uint16_t)b64);
- case T_INT32: return mk_int32( *(int32_t*)aptr & (int32_t )b64);
- case T_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64);
- case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64);
- case T_UINT64: return mk_uint64(*(uint64_t*)aptr & (uint64_t)b64);
- case T_FLOAT:
- case T_DOUBLE: assert(0);
- }
- break;
- case 1:
- switch (ta) {- case T_INT8: return fixnum( *(int8_t *)aptr | (int8_t )b64);
- case T_UINT8: return fixnum( *(uint8_t *)aptr | (uint8_t )b64);
- case T_INT16: return fixnum( *(int16_t*)aptr | (int16_t )b64);
- case T_UINT16: return fixnum( *(uint16_t*)aptr | (uint16_t)b64);
- case T_INT32: return mk_int32( *(int32_t*)aptr | (int32_t )b64);
- case T_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64);
- case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64);
- case T_UINT64: return mk_uint64(*(uint64_t*)aptr | (uint64_t)b64);
- case T_FLOAT:
- case T_DOUBLE: assert(0);
- }
- break;
- case 2:
- switch (ta) {- case T_INT8: return fixnum( *(int8_t *)aptr ^ (int8_t )b64);
- case T_UINT8: return fixnum( *(uint8_t *)aptr ^ (uint8_t )b64);
- case T_INT16: return fixnum( *(int16_t*)aptr ^ (int16_t )b64);
- case T_UINT16: return fixnum( *(uint16_t*)aptr ^ (uint16_t)b64);
- case T_INT32: return mk_int32( *(int32_t*)aptr ^ (int32_t )b64);
- case T_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64);
- case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64);
- case T_UINT64: return mk_uint64(*(uint64_t*)aptr ^ (uint64_t)b64);
- case T_FLOAT:
- case T_DOUBLE: assert(0);
- }
- }
- assert(0);
- return NIL;
-}
-
-static value_t fl_logand(value_t *args, u_int32_t nargs)
-{- value_t v, e;
- int i;
- if (nargs == 0)
- return fixnum(-1);
- v = args[0];
- FOR_ARGS(i,1,e,args) {- if (bothfixnums(v, e))
- v = v & e;
- else
- v = fl_bitwise_op(v, e, 0, "logand");
- }
- return v;
-}
-
-static value_t fl_logior(value_t *args, u_int32_t nargs)
-{- value_t v, e;
- int i;
- if (nargs == 0)
- return fixnum(0);
- v = args[0];
- FOR_ARGS(i,1,e,args) {- if (bothfixnums(v, e))
- v = v | e;
- else
- v = fl_bitwise_op(v, e, 1, "logior");
- }
- return v;
-}
-
-static value_t fl_logxor(value_t *args, u_int32_t nargs)
-{- value_t v, e;
- int i;
- if (nargs == 0)
- return fixnum(0);
- v = args[0];
- FOR_ARGS(i,1,e,args) {- if (bothfixnums(v, e))
- v = fixnum(numval(v) ^ numval(e));
- else
- v = fl_bitwise_op(v, e, 2, "logxor");
- }
- return v;
-}
-
-static value_t fl_lognot(value_t *args, u_int32_t nargs)
-{- argcount("lognot", nargs, 1);- value_t a = args[0];
- if (isfixnum(a))
- return fixnum(~numval(a));
- cprim_t *cp;
- int ta;
- void *aptr;
-
- if (iscprim(a)) {- cp = (cprim_t*)ptr(a);
- ta = cp_numtype(cp);
- aptr = cp_data(cp);
- switch (ta) {- case T_INT8: return fixnum(~*(int8_t *)aptr);
- case T_UINT8: return fixnum(~*(uint8_t *)aptr);
- case T_INT16: return fixnum(~*(int16_t *)aptr);
- case T_UINT16: return fixnum(~*(uint16_t*)aptr);
- case T_INT32: return mk_int32(~*(int32_t *)aptr);
- case T_UINT32: return mk_uint32(~*(uint32_t*)aptr);
- case T_INT64: return mk_int64(~*(int64_t *)aptr);
- case T_UINT64: return mk_uint64(~*(uint64_t*)aptr);
- }
- }
- type_error("lognot", "integer", a);-}
-
-static value_t fl_ash(value_t *args, u_int32_t nargs)
-{- fixnum_t n;
- int64_t accum;
- argcount("ash", nargs, 2);- value_t a = args[0];
- n = tofixnum(args[1], "ash");
- if (isfixnum(a)) {- if (n <= 0)
- return fixnum(numval(a)>>(-n));
- accum = ((int64_t)numval(a))<<n;
- if (fits_fixnum(accum))
- return fixnum(accum);
- else
- return return_from_int64(accum);
- }
- cprim_t *cp;
- int ta;
- void *aptr;
- if (iscprim(a)) {- if (n == 0) return a;
- cp = (cprim_t*)ptr(a);
- ta = cp_numtype(cp);
- aptr = cp_data(cp);
- if (n < 0) {- n = -n;
- switch (ta) {- case T_INT8: return fixnum((*(int8_t *)aptr) >> n);
- case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n);
- case T_INT16: return fixnum((*(int16_t *)aptr) >> n);
- case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n);
- case T_INT32: return mk_int32((*(int32_t *)aptr) >> n);
- case T_UINT32: return mk_uint32((*(uint32_t*)aptr) >> n);
- case T_INT64: return mk_int64((*(int64_t *)aptr) >> n);
- case T_UINT64: return mk_uint64((*(uint64_t*)aptr) >> n);
- }
- }
- else {- if (ta == T_UINT64)
- return return_from_uint64((*(uint64_t*)aptr)<<n);
- else if (ta < T_FLOAT) {- int64_t i64 = conv_to_int64(aptr, ta);
- return return_from_int64(i64<<n);
- }
- }
- }
- type_error("ash", "integer", a);- return NIL;
-}
--- a/femtolisp/equal.c
+++ /dev/null
@@ -1,385 +1,0 @@
-#define BOUNDED_COMPARE_BOUND 4096
-#define BOUNDED_HASH_BOUND 16384
-
-// comparable tag
-#define cmptag(v) (isfixnum(v) ? TAG_NUM : tag(v))
-
-static value_t eq_class(htable_t *table, value_t key)
-{- value_t c = (value_t)ptrhash_get(table, (void*)key);
- if (c == (value_t)HT_NOTFOUND)
- return NIL;
- if (c == key)
- return c;
- return eq_class(table, c);
-}
-
-static void eq_union(htable_t *table, value_t a, value_t b,
- value_t c, value_t cb)
-{- value_t ca = (c==NIL ? a : c);
- if (cb != NIL)
- ptrhash_put(table, (void*)cb, (void*)ca);
- ptrhash_put(table, (void*)a, (void*)ca);
- ptrhash_put(table, (void*)b, (void*)ca);
-}
-
-static value_t bounded_compare(value_t a, value_t b, int bound, int eq);
-static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq);
-
-static value_t bounded_vector_compare(value_t a, value_t b, int bound, int eq)
-{- size_t la = vector_size(a);
- size_t lb = vector_size(b);
- size_t m, i;
- if (eq && (la!=lb)) return fixnum(1);
- m = la < lb ? la : lb;
- for (i = 0; i < m; i++) {- value_t d = bounded_compare(vector_elt(a,i), vector_elt(b,i),
- bound-1, eq);
- if (d==NIL || numval(d)!=0) return d;
- }
- if (la < lb) return fixnum(-1);
- if (la > lb) return fixnum(1);
- return fixnum(0);
-}
-
-// strange comparisons are resolved arbitrarily but consistently.
-// ordering: number < cprim < function < vector < cvalue < symbol < cons
-static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
-{- value_t d;
-
- compare_top:
- if (a == b) return fixnum(0);
- if (bound <= 0)
- return NIL;
- int taga = tag(a);
- int tagb = cmptag(b);
- int c;
- switch (taga) {- case TAG_NUM :
- case TAG_NUM1:
- if (isfixnum(b)) {- return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1);
- }
- if (iscprim(b)) {- if (cp_class((cprim_t*)ptr(b)) == wchartype)
- return fixnum(1);
- return fixnum(numeric_compare(a, b, eq, 1, NULL));
- }
- return fixnum(-1);
- case TAG_SYM:
- if (eq) return fixnum(1);
- if (tagb < TAG_SYM) return fixnum(1);
- if (tagb > TAG_SYM) return fixnum(-1);
- return fixnum(strcmp(symbol_name(a), symbol_name(b)));
- case TAG_VECTOR:
- if (isvector(b))
- return bounded_vector_compare(a, b, bound, eq);
- break;
- case TAG_CPRIM:
- if (cp_class((cprim_t*)ptr(a)) == wchartype) {- if (!iscprim(b) || cp_class((cprim_t*)ptr(b)) != wchartype)
- return fixnum(-1);
- }
- else if (iscprim(b) && cp_class((cprim_t*)ptr(b)) == wchartype) {- return fixnum(1);
- }
- c = numeric_compare(a, b, eq, 1, NULL);
- if (c != 2)
- return fixnum(c);
- break;
- case TAG_CVALUE:
- if (iscvalue(b)) {- if (cv_isPOD((cvalue_t*)ptr(a)) && cv_isPOD((cvalue_t*)ptr(b)))
- return cvalue_compare(a, b);
- return fixnum(1);
- }
- break;
- case TAG_FUNCTION:
- if (tagb == TAG_FUNCTION) {- if (uintval(a) > N_BUILTINS && uintval(b) > N_BUILTINS) {- function_t *fa = (function_t*)ptr(a);
- function_t *fb = (function_t*)ptr(b);
- d = bounded_compare(fa->bcode, fb->bcode, bound-1, eq);
- if (d==NIL || numval(d) != 0) return d;
- d = bounded_compare(fa->vals, fb->vals, bound-1, eq);
- if (d==NIL || numval(d) != 0) return d;
- d = bounded_compare(fa->env, fb->env, bound-1, eq);
- if (d==NIL || numval(d) != 0) return d;
- return fixnum(0);
- }
- return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
- }
- break;
- case TAG_CONS:
- if (tagb < TAG_CONS) return fixnum(1);
- d = bounded_compare(car_(a), car_(b), bound-1, eq);
- if (d==NIL || numval(d) != 0) return d;
- a = cdr_(a); b = cdr_(b);
- bound--;
- goto compare_top;
- }
- return (taga < tagb) ? fixnum(-1) : fixnum(1);
-}
-
-static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
- int eq)
-{- size_t la = vector_size(a);
- size_t lb = vector_size(b);
- size_t m, i;
- value_t d, xa, xb, ca, cb;
-
- // first try to prove them different with no recursion
- if (eq && (la!=lb)) return fixnum(1);
- m = la < lb ? la : lb;
- for (i = 0; i < m; i++) {- xa = vector_elt(a,i);
- xb = vector_elt(b,i);
- if (leafp(xa) || leafp(xb)) {- d = bounded_compare(xa, xb, 1, eq);
- if (d!=NIL && numval(d)!=0) return d;
- }
- else if (tag(xa) < tag(xb)) {- return fixnum(-1);
- }
- else if (tag(xa) > tag(xb)) {- return fixnum(1);
- }
- }
-
- ca = eq_class(table, a);
- cb = eq_class(table, b);
- if (ca!=NIL && ca==cb)
- return fixnum(0);
-
- eq_union(table, a, b, ca, cb);
-
- for (i = 0; i < m; i++) {- xa = vector_elt(a,i);
- xb = vector_elt(b,i);
- if (!leafp(xa) || tag(xa)==TAG_FUNCTION) {- d = cyc_compare(xa, xb, table, eq);
- if (numval(d)!=0)
- return d;
- }
- }
-
- if (la < lb) return fixnum(-1);
- if (la > lb) return fixnum(1);
- return fixnum(0);
-}
-
-static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
-{- value_t d, ca, cb;
- cyc_compare_top:
- if (a==b)
- return fixnum(0);
- if (iscons(a)) {- if (iscons(b)) {- value_t aa = car_(a); value_t da = cdr_(a);
- value_t ab = car_(b); value_t db = cdr_(b);
- int tagaa = tag(aa); int tagda = tag(da);
- int tagab = tag(ab); int tagdb = tag(db);
- if (leafp(aa) || leafp(ab)) {- d = bounded_compare(aa, ab, 1, eq);
- if (d!=NIL && numval(d)!=0) return d;
- }
- else if (tagaa < tagab)
- return fixnum(-1);
- else if (tagaa > tagab)
- return fixnum(1);
- if (leafp(da) || leafp(db)) {- d = bounded_compare(da, db, 1, eq);
- if (d!=NIL && numval(d)!=0) return d;
- }
- else if (tagda < tagdb)
- return fixnum(-1);
- else if (tagda > tagdb)
- return fixnum(1);
-
- ca = eq_class(table, a);
- cb = eq_class(table, b);
- if (ca!=NIL && ca==cb)
- return fixnum(0);
-
- eq_union(table, a, b, ca, cb);
- d = cyc_compare(aa, ab, table, eq);
- if (numval(d)!=0) return d;
- a = da;
- b = db;
- goto cyc_compare_top;
- }
- else {- return fixnum(1);
- }
- }
- else if (isvector(a) && isvector(b)) {- return cyc_vector_compare(a, b, table, eq);
- }
- else if (isclosure(a) && isclosure(b)) {- function_t *fa = (function_t*)ptr(a);
- function_t *fb = (function_t*)ptr(b);
- d = bounded_compare(fa->bcode, fb->bcode, 1, eq);
- if (numval(d) != 0) return d;
-
- ca = eq_class(table, a);
- cb = eq_class(table, b);
- if (ca!=NIL && ca==cb)
- return fixnum(0);
-
- eq_union(table, a, b, ca, cb);
- d = cyc_compare(fa->vals, fb->vals, table, eq);
- if (numval(d) != 0) return d;
- a = fa->env;
- b = fb->env;
- goto cyc_compare_top;
- }
- return bounded_compare(a, b, 1, eq);
-}
-
-static htable_t equal_eq_hashtable;
-void comparehash_init()
-{- htable_new(&equal_eq_hashtable, 512);
-}
-
-// 'eq' means unordered comparison is sufficient
-static value_t compare_(value_t a, value_t b, int eq)
-{- value_t guess = bounded_compare(a, b, BOUNDED_COMPARE_BOUND, eq);
- if (guess == NIL) {- guess = cyc_compare(a, b, &equal_eq_hashtable, eq);
- htable_reset(&equal_eq_hashtable, 512);
- }
- return guess;
-}
-
-value_t fl_compare(value_t a, value_t b)
-{- return compare_(a, b, 0);
-}
-
-value_t fl_equal(value_t a, value_t b)
-{- if (eq_comparable(a, b))
- return (a == b) ? FL_T : FL_F;
- return (numval(compare_(a,b,1))==0 ? FL_T : FL_F);
-}
-
-/*
- optimizations:
- - use hash updates instead of calling lookup then insert. i.e. get the
- bp once and use it twice.
- * preallocate hash table and call reset() instead of new/free
- * less redundant tag checking, 3-bit tags
-*/
-
-#ifdef BITS64
-#define MIX(a, b) int64hash((int64_t)(a) ^ (int64_t)(b));
-#define doublehash(a) int64hash(a)
-#else
-#define MIX(a, b) int64to32hash(((int64_t)(a))<<32 | ((int64_t)(b)))
-#define doublehash(a) int64to32hash(a)
-#endif
-
-// *oob: output argument, means we hit the limit specified by 'bound'
-static uptrint_t bounded_hash(value_t a, int bound, int *oob)
-{- *oob = 0;
- union {- double d;
- int64_t i64;
- } u;
- numerictype_t nt;
- size_t i, len;
- cvalue_t *cv;
- cprim_t *cp;
- void *data;
- uptrint_t h = 0;
- int oob2, tg = tag(a);
- switch(tg) {- case TAG_NUM :
- case TAG_NUM1:
- u.d = (double)numval(a);
- return doublehash(u.i64);
- case TAG_FUNCTION:
- if (uintval(a) > N_BUILTINS)
- return bounded_hash(((function_t*)ptr(a))->bcode, bound, oob);
- return inthash(a);
- case TAG_SYM:
- return ((symbol_t*)ptr(a))->hash;
- case TAG_CPRIM:
- cp = (cprim_t*)ptr(a);
- data = cp_data(cp);
- if (cp_class(cp) == wchartype)
- return inthash(*(int32_t*)data);
- nt = cp_numtype(cp);
- u.d = conv_to_double(data, nt);
- return doublehash(u.i64);
- case TAG_CVALUE:
- cv = (cvalue_t*)ptr(a);
- data = cv_data(cv);
- return memhash(data, cv_len(cv));
-
- case TAG_VECTOR:
- if (bound <= 0) {- *oob = 1;
- return 1;
- }
- len = vector_size(a);
- for(i=0; i < len; i++) {- h = MIX(h, bounded_hash(vector_elt(a,i), bound/2, &oob2)^1);
- if (oob2)
- bound/=2;
- *oob = *oob || oob2;
- }
- return h;
-
- case TAG_CONS:
- do {- if (bound <= 0) {- *oob = 1;
- return h;
- }
- h = MIX(h, bounded_hash(car_(a), bound/2, &oob2));
- // bounds balancing: try to share the bounds efficiently
- // so we can hash better when a list is cdr-deep (a common case)
- if (oob2)
- bound/=2;
- else
- bound--;
- // recursive OOB propagation. otherwise this case is slow:
- // (hash '#2=((#0=(#1=(#1#) . #0#)) . #2#))
- *oob = *oob || oob2;
- a = cdr_(a);
- } while (iscons(a));
- h = MIX(h, bounded_hash(a, bound-1, &oob2)^2);
- *oob = *oob || oob2;
- return h;
- }
- return 0;
-}
-
-int equal_lispvalue(value_t a, value_t b)
-{- if (eq_comparable(a, b))
- return (a==b);
- return (numval(compare_(a,b,1))==0);
-}
-
-uptrint_t hash_lispvalue(value_t a)
-{- int oob=0;
- uptrint_t n = bounded_hash(a, BOUNDED_HASH_BOUND, &oob);
- return n;
-}
-
-value_t fl_hash(value_t *args, u_int32_t nargs)
-{- argcount("hash", nargs, 1);- return fixnum(hash_lispvalue(args[0]));
-}
--- a/femtolisp/equalhash.c
+++ /dev/null
@@ -1,16 +1,0 @@
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <assert.h>
-#include <limits.h>
-#include <setjmp.h>
-
-#include "llt.h"
-#include "flisp.h"
-#include "equalhash.h"
-
-#include "htable.inc"
-
-#define _equal_lispvalue_(x,y) equal_lispvalue((value_t)(x),(value_t)(y))
-
-HTIMPL(equalhash, hash_lispvalue, _equal_lispvalue_)
--- a/femtolisp/equalhash.h
+++ /dev/null
@@ -1,8 +1,0 @@
-#ifndef __EQUALHASH_H_
-#define __EQUALHASH_H_
-
-#include "htableh.inc"
-
-HTPROT(equalhash)
-
-#endif
--- a/femtolisp/examples/bq.scm
+++ /dev/null
@@ -1,122 +1,0 @@
-(define (bq-process2 x d)
- (define (splice-form? x)
- (or (and (pair? x) (or (eq? (car x) 'unquote-splicing)
- (eq? (car x) 'unquote-nsplicing)
- (and (eq? (car x) 'unquote)
- (length> x 2))))
- (eq? x 'unquote)))
- ;; bracket without splicing
- (define (bq-bracket1 x)
- (if (and (pair? x) (eq? (car x) 'unquote))
- (if (= d 0)
- (cadr x)
- (list cons ''unquote
- (bq-process2 (cdr x) (- d 1))))
- (bq-process2 x d)))
- (define (bq-bracket x)
- (cond ((atom? x) (list list (bq-process2 x d)))
- ((eq? (car x) 'unquote)
- (if (= d 0)
- (cons list (cdr x))
- (list list (list cons ''unquote
- (bq-process2 (cdr x) (- d 1))))))
- ((eq? (car x) 'unquote-splicing)
- (if (= d 0)
- (list 'copy-list (cadr x))
- (list list (list list ''unquote-splicing
- (bq-process2 (cadr x) (- d 1))))))
- ((eq? (car x) 'unquote-nsplicing)
- (if (= d 0)
- (cadr x)
- (list list (list list ''unquote-nsplicing
- (bq-process2 (cadr x) (- d 1))))))
- (else (list list (bq-process2 x d)))))
- (cond ((symbol? x) (list 'quote x))
- ((vector? x)
- (let ((body (bq-process2 (vector->list x) d)))
- (if (eq? (car body) list)
- (cons vector (cdr body))
- (list apply vector body))))
- ((atom? x) x)
- ((eq? (car x) 'quasiquote)
- (list list ''quasiquote (bq-process2 (cadr x) (+ d 1))))
- ((eq? (car x) 'unquote)
- (if (and (= d 0) (length= x 2))
- (cadr x)
- (list cons ''unquote (bq-process2 (cdr x) (- d 1)))))
- ((or (> d 0) (not (any splice-form? x)))
- (let ((lc (lastcdr x))
- (forms (map bq-bracket1 x)))
- (if (null? lc)
- (cons list forms)
- (if (null? (cdr forms))
- (list cons (car forms) (bq-process2 lc d))
- (nconc (cons list* forms) (list (bq-process2 lc d)))))))
- (else
- (let loop ((p x) (q ()))
- (cond ((null? p) ;; proper list
- (cons 'nconc (reverse! q)))
- ((pair? p)
- (cond ((eq? (car p) 'unquote)
- ;; (... . ,x)
- (cons 'nconc
- (nreconc q
- (if (= d 0)
- (cdr p)
- (list (list list ''unquote)
- (bq-process2 (cdr p)
- (- d 1)))))))
- (else
- (loop (cdr p) (cons (bq-bracket (car p)) q)))))
- (else
- ;; (... . x)
- (cons 'nconc (reverse! (cons (bq-process2 p d) q)))))))))
-
-#|
-tests
-
-> ``(,a ,,a ,b ,@b ,,@b)
-`(,a ,1 ,b ,@b (unquote 2 3))
-> `(,a ,1 ,b ,@b (unquote 2 3))
-(1 1 (2 3) 2 3 2 3)
-
-(define a 1)
-
-(bq-process2 '`(,a (unquote unquote a)) 0)
-
-(define b '(unquote a))
-(define unquote 88)
-(bq-process2 '``(,a ,,,@b) 0)
-; etc. => (1 88 1)
-
-(define b '(a a))
-(bq-process2 '``(,a ,,,@b) 0)
-; etc. => (1 1 1)
-|#
-
-;; minimal version with no optimizations, vectors, or dotted lists
-(define (bq-process0 x d)
- (define (bq-bracket x)
- (cond ((and (pair? x) (eq? (car x) 'unquote))
- (if (= d 0)
- (cons list (cdr x))
- (list list (list cons ''unquote
- (bq-process0 (cdr x) (- d 1))))))
- ((and (pair? x) (eq? (car x) 'unquote-splicing))
- (if (= d 0)
- (list 'copy-list (cadr x))
- (list list (list list ''unquote-splicing
- (bq-process0 (cadr x) (- d 1))))))
- (else (list list (bq-process0 x d)))))
- (cond ((symbol? x) (list 'quote x))
- ((atom? x) x)
- ((eq? (car x) 'quasiquote)
- (list list ''quasiquote (bq-process0 (cadr x) (+ d 1))))
- ((eq? (car x) 'unquote)
- (if (and (= d 0) (length= x 2))
- (cadr x)
- (list cons ''unquote (bq-process0 (cdr x) (- d 1)))))
- (else
- (cons 'nconc (map bq-bracket x)))))
-
-#t
--- a/femtolisp/examples/cps.lsp
+++ /dev/null
@@ -1,308 +1,0 @@
-; -*- scheme -*-
-(define (begin->cps forms k)
- (cond ((atom? forms) `(,k ,forms))
- ((null? (cdr forms)) (cps- (car forms) k))
- (#t (let ((_ (gensym))) ; var to bind ignored value
- (cps- (car forms) `(lambda (,_)
- ,(begin->cps (cdr forms) k)))))))
-
-(define-macro (lambda/cc args body)
- `(cons 'lambda/cc (lambda ,args ,body)))
-
-; a utility used at run time to dispatch a call with or without
-; the continuation argument, depending on the function
-(define (funcall/cc f k . args)
- (if (and (pair? f) (eq (car f) 'lambda/cc))
- (apply (cdr f) (cons k args))
- (k (apply f args))))
-(define *funcall/cc-names*
- (list->vector
- (map (lambda (i) (symbol (string 'funcall/cc- i)))
- (iota 6))))
-(define-macro (def-funcall/cc-n args)
- (let ((name (aref *funcall/cc-names* (length args))))
- `(define (,name f k ,@args)
- (if (and (pair? f) (eq (car f) 'lambda/cc))
- ((cdr f) k ,@args)
- (k (f ,@args))))))
-(def-funcall/cc-n ())
-(def-funcall/cc-n (a0))
-(def-funcall/cc-n (a0 a1))
-(def-funcall/cc-n (a0 a1 a2))
-(def-funcall/cc-n (a0 a1 a2 a3))
-(def-funcall/cc-n (a0 a1 a2 a3 a4))
-
-(define (rest->cps xformer form k argsyms)
- (let ((el (car form)))
- (if (or (atom? el) (constant? el))
- (xformer (cdr form) k (cons el argsyms))
- (let ((g (gensym)))
- (cps- el `(lambda (,g)
- ,(xformer (cdr form) k (cons g argsyms))))))))
-
-(define (make-funcall/cc head ke args)
- (let ((n (length args)))
- (if (< n 6)
- `(,(aref *funcall/cc-names* n) ,head ,ke ,@args)
- `(funcall/cc ,head ,ke ,@args))))
-
-; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X)))))
-(define (app->cps form k argsyms)
- (cond ((atom? form)
- (let ((r (reverse argsyms)))
- (make-funcall/cc (car r) k (cdr r))))
- (#t (rest->cps app->cps form k argsyms))))
-
-; (+ x) => (cps- x `(lambda (X) (,k (+ X))))
-(define (builtincall->cps form k)
- (prim->cps (cdr form) k (list (car form))))
-(define (prim->cps form k argsyms)
- (cond ((atom? form) `(,k ,(reverse argsyms)))
- (#t (rest->cps prim->cps form k argsyms))))
-
-(define *top-k* (gensym))
-(set-top-level-value! *top-k* identity)
-
-(define (cps form)
- (η-reduce
- (β-reduce
- (expand
- (cps- (expand form) *top-k*)))))
-(define (cps- form k)
- (let ((g (gensym)))
- (cond ((or (atom? form) (constant? form))
- `(,k ,form))
-
- ((eq (car form) 'lambda)
- `(,k (lambda/cc ,(cons g (cadr form)) ,(cps- (caddr form) g))))
-
- ((eq (car form) 'begin)
- (begin->cps (cdr form) k))
-
- ((eq (car form) 'if)
- (let ((test (cadr form))
- (then (caddr form))
- (else (cadddr form)))
- (if (atom? k)
- (cps- test `(lambda (,g)
- (if ,g
- ,(cps- then k)
- ,(cps- else k))))
- `(let ((,g ,k))
- ,(cps- form g)))))
-
- ((eq (car form) 'and)
- (cond ((atom? (cdr form)) `(,k #t))
- ((atom? (cddr form)) (cps- (cadr form) k))
- (#t
- (if (atom? k)
- (cps- (cadr form)
- `(lambda (,g)
- (if ,g ,(cps- `(and ,@(cddr form)) k)
- (,k ,g))))
- `(let ((,g ,k))
- ,(cps- form g))))))
-
- ((eq (car form) 'or)
- (cond ((atom? (cdr form)) `(,k #f))
- ((atom? (cddr form)) (cps- (cadr form) k))
- (#t
- (if (atom? k)
- (cps- (cadr form)
- `(lambda (,g)
- (if ,g (,k ,g)
- ,(cps- `(or ,@(cddr form)) k))))
- `(let ((,g ,k))
- ,(cps- form g))))))
-
- ((eq (car form) 'while)
- (let ((test (cadr form))
- (body (caddr form))
- (lastval (gensym)))
- (cps- (expand
- `(let ((,lastval #f))
- ((label ,g (lambda ()
- (if ,test
- (begin (set! ,lastval ,body)
- (,g))
- ,lastval))))))
- k)))
-
- ((eq (car form) 'set!)
- (let ((var (cadr form))
- (E (caddr form)))
- (cps- E `(lambda (,g) (,k (set! ,var ,g))))))
-
- ((eq (car form) 'reset)
- `(,k ,(cps- (cadr form) *top-k*)))
-
- ((eq (car form) 'shift)
- (let ((v (cadr form))
- (E (caddr form))
- (val (gensym)))
- `(let ((,v (lambda/cc (,g ,val) (,g (,k ,val)))))
- ,(cps- E *top-k*))))
-
- ((eq (car form) 'without-delimited-continuations)
- `(,k ,(cadr form)))
-
- ((and (constant? (car form))
- (builtin? (eval (car form))))
- (builtincall->cps form k))
-
- ; ((lambda (...) body) ...)
- ((and (pair? (car form))
- (eq (caar form) 'lambda))
- (let ((largs (cadr (car form)))
- (lbody (caddr (car form))))
- (cond ((null? largs) ; ((lambda () body))
- (cps- lbody k))
- ((symbol? largs) ; ((lambda x body) args...)
- (cps- `((lambda (,largs) ,lbody) (list ,@(cdr form))) k))
- (#t
- (cps- (cadr form) `(lambda (,(car largs))
- ,(cps- `((lambda ,(cdr largs) ,lbody)
- ,@(cddr form))
- k)))))))
-
- (#t
- (app->cps form k ())))))
-
-; (lambda (args...) (f args...)) => f
-; but only for constant, builtin f
-(define (η-reduce form)
- (cond ((or (atom? form) (constant? form)) form)
- ((and (eq (car form) 'lambda)
- (let ((body (caddr form))
- (args (cadr form)))
- (and (pair? body)
- (equal? (cdr body) args)
- (constant? (car (caddr form))))))
- (car (caddr form)))
- (#t (map η-reduce form))))
-
-(define (contains x form)
- (or (eq form x)
- (any (lambda (p) (contains x p)) form)))
-
-(define (β-reduce form)
- (if (or (atom? form) (constant? form))
- form
- (β-reduce- (map β-reduce form))))
-
-(define (β-reduce- form)
- ; ((lambda (f) (f arg)) X) => (X arg)
- (cond ((and (length= form 2)
- (pair? (car form))
- (eq (caar form) 'lambda)
- (let ((args (cadr (car form)))
- (body (caddr (car form))))
- (and (pair? body) (pair? args)
- (length= body 2)
- (length= args 1)
- (eq (car body) (car args))
- (not (eq (cadr body) (car args)))
- (symbol? (cadr body)))))
- `(,(cadr form)
- ,(cadr (caddr (car form)))))
-
- ; (identity x) => x
- ((eq (car form) *top-k*)
- (cadr form))
-
- ; uncurry:
- ; ((lambda (p1) ((lambda (args...) body) exprs...)) s) =>
- ; ((lambda (p1 args...) body) s exprs...)
- ; where exprs... doesn't contain p1
- ((and (length= form 2)
- (pair? (car form))
- (eq (caar form) 'lambda)
- (or (atom? (cadr form)) (constant? (cadr form)))
- (let ((args (cadr (car form)))
- (s (cadr form))
- (body (caddr (car form))))
- (and (pair? args) (length= args 1)
- (pair? body)
- (pair? (car body))
- (eq (caar body) 'lambda)
- (let ((innerargs (cadr (car body)))
- (innerbody (caddr (car body)))
- (params (cdr body)))
- (and (not (contains (car args) params))
- `((lambda ,(cons (car args) innerargs)
- ,innerbody)
- ,s
- ,@params)))))))
-
- (#t form)))
-
-(define-macro (with-delimited-continuations . code)
- (cps `((lambda () ,@code))))
-
-(define-macro (define-generator form . body)
- (let ((ko (gensym))
- (cur (gensym))
- (name (car form))
- (args (cdr form)))
- `(define (,name ,@args)
- (let ((,ko #f)
- (,cur #f))
- (lambda ()
- (with-delimited-continuations
- (if ,ko (,ko ,cur)
- (reset
- (let ((yield
- (lambda (v)
- (shift yk
- (begin (set! ,ko yk)
- (set! ,cur v))))))
- ,@body)))))))))
-
-; a test case
-(define-generator (range-iterator lo hi)
- ((label loop
- (lambda (i)
- (if (< hi i)
- 'done
- (begin (yield i)
- (loop (+ 1 i))))))
- lo))
-
-; example from Chung-chieh Shan's paper
-(assert (equal?
- (with-delimited-continuations
- (cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c ())))))))))
- '(a 1 b b c)))
-
-#t
-
-#|
-todo:
-* tag lambdas that accept continuation arguments, compile computed
- calls to calls to funcall/cc that does the right thing for both
- cc-lambdas and normal lambdas
-
-* handle dotted arglists in lambda
-
-- optimize constant functions, e.g. (funcall/cc-0 #:g65 (lambda (#:g58) 'done))
-
-- implement CPS version of apply
-
-- use fewer gensyms
-
- here's an alternate way to transform a while loop:
-
- (let ((x 0))
- (while (< x 10)
- (begin (print x) (set! x (+ 1 x)))))
- =>
- (let ((x 0))
- (reset
- (let ((l #f))
- (let ((k (shift k (k k))))
- (if (< x 10)
- (begin (set! l (begin (print x)
- (set! x (+ 1 x))))
- (k k))
- l)))))
-|#
--- a/femtolisp/examples/rule30.lsp
+++ /dev/null
@@ -1,25 +1,0 @@
-; -*- scheme -*-
-
-(define (rule30-step b)
- (let ((L (ash b -1))
- (R (ash b 1)))
- (let ((~b (lognot b))
- (~L (lognot L))
- (~R (lognot R)))
- (logior (logand L ~b ~R)
- (logand ~L b R)
- (logand ~L b ~R)
- (logand ~L ~b R)))))
-
-(define (bin-draw s)
- (string.map (lambda (c) (case c
- (#\1 #\#)
- (#\0 #\ )
- (else c)))
- s))
-
-(for-each (lambda (n)
- (begin
- (princ (bin-draw (string.lpad (number->string n 2) 63 #\0)))
- (newline)))
- (nestlist rule30-step (uint64 0x0000000080000000) 32))
--- a/femtolisp/flisp.boot
+++ /dev/null
@@ -1,431 +1,0 @@
-(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n"
- *builtins* [0 0 0 0 0 0 0 0 0 0 0 0 #fn("7000r2|}<;" [])- #fn("7000r2|}=;" [])- #fn("7000r2|}>;" [])- #fn("6000r1|?;" [])- #fn("6000r1|@;" [])- #fn("6000r1|A;" [])- #fn("6000r1|B;" [])- #fn("6000r1|C;" [])- #fn("6000r1|D;" [])- #fn("6000r1|E;" [])- #fn("6000r1|F;" [])- #fn("6000r1|G;" [])- #fn("6000r1|H;" [])- #fn("6000r1|I;" [])- #fn("6000r1|J;" [])- #fn("7000r2|}K;" [])- #fn("9000s0c0|v2;" [#.list])- #fn("6000r1|M;" [])- #fn("6000r1|N;" [])- #fn("7000r2|}O;" [])- #fn("7000r2|}P;" [])- #fn("9000s0c0|v2;" [#.apply])- #fn("9000s0c0|v2;" [#.+])- #fn("9000s0c0|v2;" [#.-])- #fn("9000s0c0|v2;" [#.*])- #fn("9000s0c0|v2;" [#./])- #fn("9000s0c0|v2;" [#.div0])- #fn("7000r2|}W;" [])- #fn("7000r2|}X;" [])- #fn("7000r2|}Y;" [])- #fn("9000s0c0|v2;" [#.vector])- #fn("7000r2|}[;" [])- #fn("8000r3|}g2\\;" [])]- *interactive* #f *syntax-environment*
- #table(with-bindings #fn(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#fn("B000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6e0c7L1e4\x7f3132e0c7L1e4e2c8|g2333132L3L144;" [nconc- let map #.list copy-list #fn("8000r2c0|}L3;" [set!]) unwind-protect begin #fn("8000r2c0|}L3;" [set!])])- map #.car cadr #fn("6000r1e040;" [gensym])]) letrec #fn("?000s1e0e0c1L1e2c3|32L1e2c4|32e5}3134L1e2c6|3242;" [nconc- lambda map #.car #fn("9000r1e0c1L1e2|3142;" [nconc set! copy-list]) copy-list- #fn("6000r1e040;" [void])]) assert #fn("<000r1c0|]c1c2c3|L2L2L2L4;" [if- raise quote assert-failed]) do #fn("A000s2c0qe130}Me2c3|32e2e4|32e2c5|3245;" [#fn("B000r5c0|c1g2c2}e3c4L1e5\x7fN3132e3c4L1e5i0231e3|L1g432L133L4L3L2L1e3|L1g332L3;" [letrec- lambda if nconc begin copy-list]) gensym map #.car cadr #fn("7000r1e0|31F680e1|41;|M;" [cddr- caddr])]) quasiquote #fn("8000r1e0|`42;" [bq-process]) when #fn("<000s1c0|c1}K^L4;" [if- begin]) with-input-from #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc- with-bindings
- *input-stream*
- copy-list]) unwind-protect #fn("8000r2c0qe130e13042;" [#fn("@000r2c0}c1_\x7fL3L2L1c2c3~c1|L1c4}L1c5|L2L3L3L3}L1L3L3;" [let- lambda prog1 trycatch begin raise]) gensym]) dotimes #fn(";000s1c0q|M|\x8442;" [#fn("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for- - nconc lambda copy-list])]) define-macro #fn("?000s1c0c1|ML2e2c3L1|NL1e4}3133L3;" [set-syntax!- quote nconc lambda copy-list]) receive #fn("@000s2c0c1_}L3e2c1L1|L1e3g23133L3;" [call-with-values- lambda nconc copy-list]) unless #fn("=000s1c0|^c1}KL4;" [if begin]) let #fn(":000s1c0q^41;" [#fn("<000r1~C6D0~m02\x7fMo002\x7fNo01530]2c0qe1c2L1e3c4~32L1e5\x7f3133e3c6~3242;" [#fn("8000r2~6@0c0~|L2L1~L3530|}K;" [letrec])- nconc lambda map #fn("6000r1|F650|M;|;" []) copy-list #fn("6000r1|F650|\x84;e040;" [void])])]) cond #fn("9000s0c0q]41;" [#fn("7000r1c0qm02|~41;" [#fn("7000r1|?640^;c0q|M41;" [#fn(":000r1|Mc0<17702|M]<6@0|N\x8550|M;c1|NK;|N\x85@0c2|Mi10~N31L3;|\x84c3\x82W0e4e5|31316A0c6qe7e5|313141;c8qe93041;c:|Mc1|NKi10~N31L4;" [else- begin or => 1arg-lambda? caddr #fn("=000r1c0|~ML2L1c1|c2e3e4~3131Ki20i10N31L4L3;" [let- if begin cddr caddr]) caadr #fn("<000r1c0|~ML2L1c1|e2~31|L2i20i10N31L4L3;" [let- if caddr]) gensym if])] cond-clauses->if)])]) throw #fn(":000r2c0c1c2c3L2|}L4L2;" [raise- list quote thrown-value]) time #fn("7000r1c0qe13041;" [#fn(">000r1c0|c1L1L2L1c2~c3c4c5c1L1|L3c6L4L3L3;" [let- time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #fn("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc- lambda copy-list caar let* cadar]) case #fn(":000s1c0q]41;" [#fn("7000r1c0m02c1qe23041;" [#fn("9000r2}c0\x8250c0;}\x8540^;}C6=0c1|e2}31L3;}?6=0c3|e2}31L3;}N\x85>0c3|e2}M31L3;e4c5}326=0c6|c7}L2L3;c8|c7}L2L3;" [else- eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond)
- #fn("<000r1c0|i10L2L1e1c2L1e3c4qi113232L3;" [let nconc cond map #fn("8000r1i10~|M32|NK;" [])])- gensym])]) with-output-to #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc- with-bindings
- *output-stream*
- copy-list]) catch #fn("7000r2c0qe13041;" [#fn("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch- lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym]))
- *whitespace* "\t\n\v\f\r \u0085 \u2028\u2029 " 1+
- #fn("7000r1|aw;" [] 1+) 1- #fn("7000r1|ax;" [] 1-) 1arg-lambda?- #fn("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda- length=] 1arg-lambda?)
- <= #fn("7000r2|}X17602|}W;" [] <=) >- #fn("7000r2}|X;" [] >) >= #fn("7000r2}|X17602|}W;" [] >=)- Instructions #table(not 16 vargc 67 load1 49 = 39 setc.l 64 sub2 72 brne.l 83 largc 74 brnn 85 loadc.l 58 loadi8 50 < 40 nop 0 set-cdr! 32 loada 55 bound? 21 / 37 neg 73 brn.l 88 lvargc 75 brt 7 trycatch 68 null? 17 load0 48 jmp.l 8 loadv 51 seta 61 keyargs 91 * 36 function? 26 builtin? 23 aref 43 optargs 89 vector? 24 loadt 45 brf 6 symbol? 19 cdr 30 for 69 loadc00 78 pop 2 pair? 22 cadr 84 closure 65 loadf 46 compare 41 loadv.l 52 setg.l 60 brn 87 eqv? 13 aset! 44 eq? 12 atom? 15 boolean? 18 brt.l 10 tapply 70 dummy_nil 94 loada0 76 brbound 90 list 28 dup 1 apply 33 loadc 57 loadc01 79 dummy_t 92 setg 59 loada1 77 tcall.l 81 jmp 5 fixnum? 25 cons 27 loadg.l 54 tcall 4 call 3 - 35 brf.l 9 + 34 dummy_f 93 add2 71 seta.l 62 loadnil 47 brnn.l 86 setc 63 set-car! 31 vector 42 loadg 53 loada.l 56 argc 66 div0 38 ret 11 number? 20 equal? 14 car 29 call.l 80 brne 82)
- __init_globals #fn("7000r0e0c1<17B02e0c2<17802e0c3<6>0c4k52c6k75;0c8k52c9k72e:k;2e<k=2e>k?;" [*os-name*- win32 win64 windows "\\" *directory-separator* "\r\n" *linefeed* "/" "\n"
- *stdout* *output-stream* *stdin* *input-stream* *stderr* *error-stream*] __init_globals)
- __script #fn("7000r1c0qc1t;" [#fn("7000r0e0~41;" [load])- #fn("7000r1e0|312e1a41;" [top-level-exception-handler- exit])] __script)
- __start #fn("8000r1e0302|NF6D0|Nk12^k22e3|\x84315E0|k12]k22e4e5312e6302e7`41;" [__init_globals- *argv* *interactive* __script princ *banner* repl exit] __start)
- abs #fn("7000r1|`X650|y;|;" [] abs) any- #fn("8000r2}F16D02|}M3117:02e0|}N42;" [any] any) arg-counts #table(#.not 1 #.atom? 1 #.number? 1 #.cons 2 #.set-cdr! 2 #.equal? 2 #.fixnum? 1 #.bound? 1 #.eq? 2 #.symbol? 1 #.builtin? 1 #.< 2 #.aset! 3 #.div0 2 #.cdr 1 #.null? 1 #.eqv? 2 #.compare 2 #.aref 2 #.car 1 #.set-car! 2 #.pair? 1 #.= 2 #.vector? 1 #.boolean? 1)- argc-error #fn("<000r2e0c1|c2}}aW670c3540c445;" [error "compile error: "- " expects " " argument."
- " arguments."] argc-error)
- array? #fn("8000r1|H17<02c0e1|3141;" [#fn("7000r1|F16802|Mc0<;" [array])- typeof] array?)
- assoc #fn("8000r2}?640^;e0}31|>650}M;e1|}N42;" [caar assoc] assoc)- assv #fn("8000r2}?640^;e0}31|=650}M;e1|}N42;" [caar assv] assv)- bcode:cdepth #fn(":000r2|b3e0|b3[}32\\;" [min] bcode:cdepth)- bcode:code #fn("7000r1|`[;" [] bcode:code) bcode:ctable- #fn("7000r1|a[;" [] bcode:ctable) bcode:indexfor #fn("9000r2c0qe1|31e2|3142;" [#fn(":000r2e0|\x7f32690e1|\x7f42;e2|\x7f}332}~b2}aw\\2;" [has?- get put!]) bcode:ctable bcode:nconst] bcode:indexfor)
- bcode:nconst #fn("7000r1|b2[;" [] bcode:nconst) bq-bracket- #fn("<000r2|?6=0c0e1|}32L2;|Mc2\x82R0}`W680c0|NK;c0c3c4e1|N}ax32L3L2;|Mc5\x82S0}`W690c6|\x84L2;c0c0c7e1|\x84}ax32L3L2;|Mc8\x82O0}`W650|\x84;c0c0c9e1|\x84}ax32L3L2;c0e1|}32L2;" [#.list- bq-process unquote #.cons 'unquote unquote-splicing copy-list 'unquote-splicing
- unquote-nsplicing 'unquote-nsplicing] bq-bracket)
- bq-bracket1 #fn(";000r2|F16802|Mc0<6K0}`W650|\x84;c1c2e3|N}ax32L3;e3|}42;" [unquote- #.cons 'unquote bq-process] bq-bracket1)
- bq-process #fn(";000r2|C680c0|L2;|H6A0c1e2e3|31}3241;|?640|;|Mc4\x82B0c5c6e2|\x84}aw32L3;|Mc7\x82W0}`W16:02e8|b232650|\x84;c9c:e2|N}ax32L3;e;}`3217;02e<e=|32@6E0c>qe?|31e@cAq|3242;cBq]31|_42;" [quote- #fn("8000r1|Mc0\x8280c1|NK;c2c1|L3;" [#.list #.vector #.apply]) bq-process- vector->list quasiquote #.list 'quasiquote unquote length= #.cons 'unquote >
- any splice-form? #fn(":000r2|\x8570c0}K;}N\x85?0c1}Me2|\x7f32L3;e3e4}Ke2|\x7f32L142;" [#.list- #.cons bq-process nconc list*]) lastcdr map #fn("8000r1e0|\x7f42;" [bq-bracket1])- #fn("6000r1c0qm02|;" [#fn(">000r2|\x85;0c0e1}31K;|F6s0|Mc2\x82[0c0e3}i11`W670|N5E0c4c5L2e6|Ni11ax32L232K;~|Ne7|Mi1132}K42;c0e1e6|i1132}K31K;" [nconc- reverse! unquote nreconc #.list 'unquote bq-process bq-bracket])])] bq-process)
- builtin->instruction #fn("9000r1e0~|^43;" [get] [#table(#.number? number? #.cons cons #.fixnum? fixnum? #.equal? equal? #.eq? eq? #.symbol? symbol? #.div0 div0 #.builtin? builtin? #.aset! aset! #.- - #.boolean? boolean? #.not not #.apply apply #.atom? atom? #.set-cdr! set-cdr! #./ / #.function? function? #.vector vector #.list list #.bound? bound? #.< < #.* * #.cdr cdr #.null? null? #.+ + #.eqv? eqv? #.compare compare #.aref aref #.set-car! set-car! #.car car #.pair? pair? #.= = #.vector? vector?)- ()])
- caaaar #fn("6000r1|MMMM;" [] caaaar) caaadr- #fn("6000r1|\x84MM;" [] caaadr) caaar #fn("6000r1|MMM;" [] caaar)- caadar #fn("6000r1|M\x84M;" [] caadar) caaddr- #fn("6000r1|N\x84M;" [] caaddr) caadr #fn("6000r1|\x84M;" [] caadr)- caar #fn("6000r1|MM;" [] caar) cadaar- #fn("6000r1|MM\x84;" [] cadaar) cadadr #fn("6000r1|\x84\x84;" [] cadadr)- cadar #fn("6000r1|M\x84;" [] cadar) caddar- #fn("6000r1|MN\x84;" [] caddar) cadddr #fn("6000r1|NN\x84;" [] cadddr)- caddr #fn("6000r1|N\x84;" [] caddr) cadr- #fn("6000r1|\x84;" [] cadr) call-with-values #fn("7000r2c0q|3041;" [#fn("7000r1|F16902i10|M<680\x7f|Nv2;\x7f|41;" [])] #2=[(*values*)- ()])
- cdaaar #fn("6000r1|MMMN;" [] cdaaar) cdaadr- #fn("6000r1|\x84MN;" [] cdaadr) cdaar #fn("6000r1|MMN;" [] cdaar)- cdadar #fn("6000r1|M\x84N;" [] cdadar) cdaddr- #fn("6000r1|N\x84N;" [] cdaddr) cdadr #fn("6000r1|\x84N;" [] cdadr)- cdar #fn("6000r1|MN;" [] cdar) cddaar- #fn("6000r1|MMNN;" [] cddaar) cddadr #fn("6000r1|\x84NN;" [] cddadr)- cddar #fn("6000r1|MNN;" [] cddar) cdddar- #fn("6000r1|MNNN;" [] cdddar) cddddr #fn("6000r1|NNNN;" [] cddddr)- cdddr #fn("6000r1|NNN;" [] cdddr) cddr- #fn("6000r1|NN;" [] cddr) char? #fn("7000r1e0|31c1<;" [typeof wchar] char?)- closure? #fn("7000r1|J16602|G@;" [] closure?) compile- #fn("8000r1e0_|42;" [compile-f] compile) compile-and #fn("<000r4e0|}g2g3]c146;" [compile-short-circuit- brf] compile-and)
- compile-app #fn("7000r4c0qg3M41;" [#fn("9000r1c0q|C16V02e1|\x7f32@16J02|E16C02e2|3116902e3|31G6:0e3|31530|41;" [#fn(":000r1e0i13Nc1326S0e2i10i11^|342c3qe4i10i11i13N3341;c5q|G16802e6|3141;" [length>- 255 compile-in #fn(":000r1e0i20i22670c1540c2|43;" [emit tcall.l call.l])- compile-arglist #fn(";000r1~c0<16X02e1~i2132@16J02e2c031e0>16<02e3i23b2326L0e4i20i21^i23\x84342e5i20c042;|7A0e4i20i21^~34530]2c6qe7i20i21i23N3341;" [cadr- in-env? top-level-value length= compile-in emit #fn("=000r1~6H0e0i30i31i32i33i10~|47;e1i30i32670c2540c3|43;" [compile-builtin-call- emit tcall call]) compile-arglist]) builtin->instruction]) in-env? constant?
- top-level-value])] compile-app)
- compile-arglist #fn("8000r3e0c1qg2322e2g241;" [for-each #fn(":000r1e0~\x7f^|44;" [compile-in])- length] compile-arglist)
- compile-begin #fn(":000r4g3?6?0e0|}g2e13044;g3N?6>0e0|}g2g3M44;e0|}^g3M342e2|c3322e4|}g2g3N44;" [compile-in- void emit pop compile-begin] compile-begin)
- compile-builtin-call #fn(":000r7c0qe1e2g5^3341;" [#fn("8000r1|16=02e0i03N|32@6=0e1i04|32530]2c2qi0541;" [length=- argc-error #fn(":000r1|c0\x82R0i16`W6<0e1i10c242;e1i10i15i1643;|c3\x82e0i16`W6<0e1i10c442;i16b2W6<0e1i10c542;e1i10i15i1643;|c6\x82v0i16`W6;0e7i14a42;i16aW6<0e1i10c842;i16b2W6<0e1i10c942;e1i10i15i1643;|c:\x82R0i16`W6<0e1i10c;42;e1i10i15i1643;|c<\x82Q0i16`W6;0e7i14a42;e1i10i15i1643;|c=\x82T0i16`W6>0e1i10c>c?43;e1i10i15i1643;|c@\x82]0i16b2X6<0e7i14b242;e1i10i12670cA540c@i1643;e1i10i1542;" [list- emit loadnil + load0 add2 - argc-error neg sub2 * load1 / vector loadv []
- apply tapply])]) get arg-counts] compile-builtin-call)
- compile-f #fn("8000r2e0c1qc242;" [call-with-values #fn("8000r0e0~\x7f42;" [compile-f-])- #fn("6000r2|;" [])] compile-f)- compile-f- #fn("8000r2c0q]]42;" [#fn(">000r2c0qm02c1qm12c2qe330\x7f\x84e4\x7f\x8431e5\x7f\x8431e6c7\x7f\x8432e4\x7f31i10\x8270c8570e4\x7f3146;" [#fn("9000r1c0qe1|31F6N0e2|31F6=0c3e1|31K570e4|31560e53041;" [#fn("8000r1c0qe1|3141;" [#fn(":000r1|\x8540~;e0c1|~i4034e2c3|32K;" [list*- lambda map #fn("6000r1e040;" [void])]) get-defined-vars]) cddr cdddr begin- caddr void] lambda-body) #fn("7000r1e0|31i20\x8280e1|41;~|41;" [lastcdr caddr] lam:body)- #fn("9000r6c0q}?660`570e1}3141;" [#fn("9000r1c0q|e1i0431x41;" [#fn("9000r1c0qe1e2i143241;" [#fn("C000r1i24\x87\xa90|\x85O0e0i20c1~i22\x8580i10560i10y345s0e2i20e3e4c5e4c6|32e7e8|31313331322e0i20c9~e8|31i22\x8580i10560i10y352e:i20i40i24i23~35530]2e;i10c<326L0e0i20i22\x8570c=540c>i10335]0i22\x87A0e0i20c?i10335H0i24\x85A0e0i20c@i1033530^2eAi20i23i40K]i31i4131342e0i20cB322eCeDeEeFi203131eGi2031i2533i20b3[42;" [emit- optargs bcode:indexfor make-perfect-hash-table map #.cons #.car iota length
- keyargs emit-optional-arg-inits > 255 largc lvargc vargc argc compile-in ret
- values function encode-byte-code bcode:code const-to-idx-vec]) filter
- keyword-arg?]) length]) length]) make-code-emitter lastcdr lambda-vars filter
- #.pair? lambda])] #0=[#:g709 ()])
- compile-for #fn(":000r5e0g4316X0e1|}^g2342e1|}^g3342e1|}^g4342e2|c342;e4c541;" [1arg-lambda?- compile-in emit for error "for: third form must be a 1-argument lambda"] compile-for)
- compile-if #fn("<000r4c0qe1|31e1|31g3\x84e2g331e3g331F6;0e4g331560e53045;" [#fn(";000r5g2]\x82>0e0~\x7fi02g344;g2^\x82>0e0~\x7fi02g444;e0~\x7f^g2342e1~c2|332e0~\x7fi02g3342i026<0e1~c3325:0e1~c4}332e5~|322e0~\x7fi02g4342e5~}42;" [compile-in- emit brf ret jmp mark-label]) make-label caddr cdddr cadddr void] compile-if)
- compile-in #fn(";000r4g3C6=0e0|}g3c144;g3?6\xaf0g3`\x82:0e2|c342;g3a\x82:0e2|c442;g3]\x82:0e2|c542;g3^\x82:0e2|c642;g3_\x82:0e2|c742;e8g3316<0e2|c9g343;e:g3316C0e;|}g2e<c=31L144;e2|c>g343;g3MC@17D02g3ME17;02e?g3M}326=0e@|}g2g344;cAqg3M41;" [compile-sym- [loada loadc loadg] emit load0 load1 loadt loadf loadnil fits-i8 loadi8
- eof-object? compile-in top-level-value eof-object loadv in-env? compile-app
- #fn("<000r1|c0\x82W0e1i03\x84316@0e2~\x7fi02i03\x8444;e3~c4i03\x8443;|c5\x82?0e6~\x7fi02i0344;|c7\x82@0e8~\x7fi02i03N44;|c9\x82<0e:~\x7fi0343;|c;\x82=0e<c=qc>q42;|c?\x82@0e@~\x7fi02i03N44;|cA\x82@0eB~\x7fi02i03N44;|cC\x82G0eD~\x7fi03\x84c7eEi0331K44;|cF\x82K0eG~\x7fi03\x84eHi0331eIi033145;|cJ\x82F0e2~\x7f]i03\x84342e3~cK42;|cL\x82N0e2~\x7f^eHi0331342eM~\x7fi03\x84cN44;|cO\x82C0e2~\x7fi02ePi033144;|cQ\x82s0e2~\x7f^c;_i03\x84L3342eReHi033131660^580eScT312e2~\x7f^eHi0331342e3~cQ42;eU~\x7fi02i0344;" [quote- self-evaluating? compile-in emit loadv if compile-if begin compile-begin
- prog1 compile-prog1 lambda call-with-values #fn("8000r0e0i11i1342;" [compile-f-])- #fn("9000r2e0i10c1|332e2i10}322}e3i1131X6<0e0i10c442;];" [emit loadv- bcode:cdepth nnn
- closure]) and
- compile-and or compile-or while compile-while cddr for compile-for caddr
- cadddr return ret set! compile-sym [seta setc setg] define expand-define
- trycatch 1arg-lambda? error "trycatch: second form must be a 1-argument lambda"
- compile-app])] compile-in)
- compile-or #fn("<000r4e0|}g2g3^c146;" [compile-short-circuit brt] compile-or)- compile-prog1 #fn(";000r3e0|}^g2\x84342e1g231F6H0e2|}^e1g231342e3|c442;];" [compile-in- cddr compile-begin emit pop] compile-prog1)
- compile-short-circuit #fn(":000r6g3?6=0e0|}g2g444;g3N?6>0e0|}g2g3M44;c1qe2|3141;" [compile-in- #fn("<000r1e0~\x7f^i03M342e1~c2322e1~i05|332e1~c3322e4~\x7fi02i03Ni04i05362e5~|42;" [compile-in- emit dup pop compile-short-circuit mark-label]) make-label] compile-short-circuit)
- compile-sym #fn(";000r4c0qe1g2}`]3441;" [#fn(":000r1|D6>0e0~i03`[|43;|MD6R0e0~i03a[|M|N342e1~e2\x7fN31a|MS342;e3i023116>02e4e5i0231316A0e0~c6e5i023143;e0~i03b2[i0243;" [emit- bcode:cdepth nnn constant? printable? top-level-value loadv]) lookup-sym] compile-sym)
- compile-thunk #fn(";000r1e0e1c2L1_L1|L1~3441;" [compile nconc lambda] #0#)- compile-while #fn("9000r4c0qe1|31e1|3142;" [#fn(":000r2e0~\x7f^e130342e2~|322e0~\x7f^i02342e3~c4}332e3~c5322e0~\x7f^i03342e3~c6|332e2~}42;" [compile-in- void mark-label emit brf pop jmp]) make-label] compile-while)
- const-to-idx-vec #fn("9000r1c0qe1e2|313141;" [#fn("9000r1e0c1qe2~31322|;" [table.foreach- #fn("8000r2~}|\\;" []) bcode:ctable]) vector.alloc bcode:nconst] const-to-idx-vec)- copy-tree #fn("8000r1|?640|;e0|M31e0|N31K;" [copy-tree] copy-tree)- count #fn("7000r2c0q]41;" [#fn("9000r1c0qm02|~\x7f`43;" [#fn(":000r3}\x8550g2;~|}N|}M31690g2aw540g243;" [] count-)])] count)- delete-duplicates #fn("8000r1|?640|;c0|M|N42;" [#fn("8000r2e0|}32680e1}41;|e1}31K;" [member- delete-duplicates])] delete-duplicates)
- disassemble #fn("=000s1}\x85C0e0|`322e1302];530]2c2}Me3|31e4|3143;" [disassemble- newline #fn("7000r3c0q]41;" [#fn(":000r1c0qm02`~axc1u2e2c3e4\x7f`32c5332c6qb4e7\x7f3142;" [#fn("9000r1|J16602|G@6D0e0c1312e2|i10aw42;e3|41;" [princ- "\n" disassemble print] print-val) #fn("7000r1e0c141;" [princ "\t"]) princ "maxstack "- ref-int32-LE "\n" #fn(":000r2]|}X6E02c0qe1c2q^e333315\x19/;" [#fn(";000r1e0~b432690e130530]2`i20axc2u2e3e4~b4x31c5e6|31c7342~awo002c8q|41;" [>- newline #fn("7000r1e0c141;" [princ "\t"]) princ hex5 ": " string "\t" #fn("=000r1e0|c1326P0i20i32e2i31i1032[312i10b4wo10;e0|c3326L0i20i32i31i10[[312i10awo10;e0|c4326K0e5e6i31i10[31312i10awo10;e0|c7326O0e5e6e2i31i103231312i10b4wo10;e0|c8326f0e5e6i31i10[31c9322i10awo102e5e6i31i10[31312i10awo10;e0|c:326\x9c0e5e6e2i31i103231c9322i10b4wo102e5e6e2i31i103231312i10b4wo102~c;\x82X0e5c9312e5e6e2i31i103231c9322i10b4wo10;];|c<=6Q0e5e6e2i31i103231c9322i10b4wo10;e0|c=326X0e5c>e?i10b,e@i31i1032R331322i10b2wo10;e0|cA326X0e5c>e?i10b,e2i31i1032R331322i10b4wo10;^;" [memq- (loadv.l loadg.l setg.l) ref-int32-LE (loadv loadg setg)
- (loada seta call tcall list + - * / vector argc vargc loadi8 apply tapply)
- princ number->string (loada.l seta.l largc lvargc call.l tcall.l) (loadc setc)
- " " (loadc.l setc.l optargs keyargs) keyargs brbound (jmp brf brt brne brnn
- brn) "@" hex5
- ref-int16-LE (jmp.l brf.l brt.l brne.l brnn.l brn.l)])]) table.foldl #fn("8000r3g217@02}i21~[<16402|;" [])- Instructions])
- length])]) function:code function:vals] disassemble)
- div #fn("8000r2|}V|`X16C02}`X16402a17502b/17402`w;" [] div) emit- #fn("G000s2g2\x85b0}c0<16C02|`[F16:02|`[Mc1<6;0|`[c2O5:0|`}|`[K\\5\xe20e3}c4326A0e5|g2M32L1m2530]2c6qe7}c832312c9qe7}c:32312}c;\x82\\0g2c<>6=0c=m12_m25F0g2c>>6=0c?m12_m2530^530]2}c@\x82\\0g2cA>6=0cBm12_m25F0g2cC>6=0cDm12_m2530^530]2cEq|`[F690|`[M530_|`[322|;" [car- cdr cadr memq (loadv loadg setg) bcode:indexfor #fn("8000r1|16=02e0i02Mc132680|\x84o01;];" [>- 255]) assq ((loadv loadv.l) (loadg loadg.l) (setg setg.l) (loada loada.l) (seta
- seta.l)) #fn("8000r1|16L02e0i02Mc13217=02e0i02\x84c132680|\x84o01;];" [> 255])- ((loadc loadc.l) (setc setc.l)) loada (0) loada0 (1) loada1 loadc (0 0)
- loadc00 (0 1) loadc01 #fn(">000r2\x7fc0<16\x9a02|c1<16802}\x84c2<6E0~`i02Mc3e4}31KK\\5u0|c1\x82B0~`i02Mc5}NKK\\5_0|c6\x82B0~`i02Mc7}NKK\\5I0|c2\x82B0~`i02Mc8}NKK\\530^17^02\x7fc5<16702|c2<6@0~`i02Mc3}NKK\\;~`e9\x7fi02K}32\\;" [brf- not null? brn cddr brt eq? brne brnn nreconc])] emit)
- emit-optional-arg-inits #fn("8000r5g2F6=0c0qe1|3141;];" [#fn("<000r1e0~c1i04332e0~c2|332e3~e4i03i0432\x7fK^e5i0231342e0~c6i04332e0~c7322e8~|322e9~\x7fi02Ni03i04aw45;" [emit- brbound brt compile-in list-head cadar seta pop mark-label
- emit-optional-arg-inits]) make-label] emit-optional-arg-inits)
- encode-byte-code #fn("8000r1c0e1|3141;" [#fn("8000r1c0e1|3141;" [#fn(";000r1c0qe1e2|31b3e2|31b2VT2wc33241;" [#fn("=000r1c0qe1~31`e230e230e330^^47;" [#fn("?000r7e0g4c1322]}|X6\xff02i10}[m52g5c2\x82O0e3g2i10}aw[e4g431332}b2wm15\xcf0e0g4e5e6e7~6<0c8qg531540g53231322}awm12}|X6:0i10}[530^m62e9g5c:326^0e3g3e4g431g6332e0g4~670e;540e<`31322}awm15_0g5c=\x82G0e0g4e;g631322}awm15C0g6D6<0c>qg531530^5_/2e?c@qg3322eAg441;" [io.write- #int32(0) label put! sizeof byte get Instructions #fn("7000r1|c0\x8250c1;|c2\x8250c3;|c4\x8250c5;|c6\x8250c7;|c8\x8250c9;|c:\x8250c;;i05;" [jmp- jmp.l brt brt.l brf brf.l brne brne.l brnn brnn.l brn brn.l]) memq (jmp brf
- brt brne brnn brn) int32 int16 brbound #fn(":000r1e0|c1326H0e2i04e3i0631322\x7fawo01;e0|c4326`0e2i04e5i0631322\x7fawo012e2i04e5i20\x7f[31322\x7fawo01;e0|c6326\x820e2i04e3i0631322\x7fawo012e2i04e3i20\x7f[31322\x7fawo012i05c7\x82J0e2i04e3i20\x7f[31322\x7fawo01;];e2i04e5i0631322\x7fawo01;" [memq- (loadv.l loadg.l setg.l loada.l seta.l largc lvargc call.l tcall.l) io.write
- int32 (loadc setc) uint8 (loadc.l setc.l optargs keyargs) keyargs])
- table.foreach #fn("<000r2e0i04|322e1i04i10670e2540e3e4i02}32|x3142;" [io.seek- io.write int32 int16 get]) io.tostring!]) length table buffer]) >= length 65536])
- list->vector]) reverse!] encode-byte-code)
- error #fn(":000s0e0c1|K41;" [raise error] error) eval- #fn("8000r1e0e1|313140;" [compile-thunk expand] eval) even? #fn("8000r1e0|a32`W;" [logand] even?)- every #fn("8000r2}?17D02|}M3116:02e0|}N42;" [every] every) expand- #fn("A000r1c0q]]]]]]]]]]]4;;" [#fn("8000r;c0m02c1qm12c2L1m22c3qm32c4qm42c5qm52c6qm62c7qm72c8qm82c9m92c:qm:2g:~_42;" [#fn("8000r2|E17902e0|}32@;" [assq] top?)- #fn("9000r1|?640|;|c0>640|;|MF16;02e1|31c2<6D0e3\x7fe4|3131\x7f|N3142;|M\x7f|N31K;" [((begin))- caar begin append cdar] splice-begin) *expanded* #fn("9000r2|?640|;c0q~c1}32690\x7f|31530|41;" [#fn("9000r1c0qi10c1\x7f3241;" [#fn("8000r1c0q|6:0e1~31530_41;" [#fn(":000r1c0qe1e2c3|32i213241;" [#fn("8000r1i107=0e0c1qi2042;c2qc3q]31i203141;" [map- #fn("8000r1i5:|~42;" []) #fn("7000r1c0q|41;" [#fn("9000r1]|F6]02i62e0|31<7A0|i6:|Mi1032O590|e1|31O2|Nm05\x02/2~;" [caar- cdar])]) #fn("6000r1c0qm02|;" [#fn("9000r1|?640|;|MF16;02c0e1|31<6;0|M~|N31K;c2qi6:|Mi103241;" [define- caar #fn(":000r1e0e1c2e3|3132i2032o202i72|Ki10~N31K;" [nconc map #.list- get-defined-vars])])])])
- nconc map #.list]) get-defined-vars]) define]) begin] expand-body)
- #fn(":000r2|?640|;|MF16702|MNF6G0e0|31i0:e1|31}32L2540|Mi04|N}32K;" [caar- cadar] expand-lambda-list) #fn("8000r1|?660|L1;|MF6@0e0|31i05|N31K;|Mi05|N31K;" [caar] l-vars)- #fn(";000r2c0q|\x84e1|31e2|31i05|\x843144;" [#fn(":000r4c0qe1e2c3g332\x7f3241;" [#fn(";000r1e0c1L1i24~|32L1i23i02|32\x7f44;" [nconc- lambda]) nconc map #.list]) lastcdr cddr] expand-lambda)
- #fn("<000r2|NA17602|\x84?6N0e0|31\x8540|;c1|\x84i0:e2|31}32L3;c3qe4|31e5|31e0|31i05e4|313144;" [cddr- define caddr #fn(":000r4c0qe1e2c3g332\x7f3241;" [#fn(";000r1e0c1L1\x7fi24~|32KL1i23i02|3243;" [nconc- define]) nconc map #.list]) cdadr caadr] expand-define)
- #fn("7000r2c0q|\x8441;" [#fn("<000r1c0i13e1~31e2e3c4q|32\x7f3232K;" [begin- cddr nconc map #fn(":000r1|Me0i2:|\x84i11323130i11L3;" [compile-thunk])])] expand-let-syntax)- #fn("6000r2|;" [] local-expansion-env) #fn("7000r2|?640|;c0q|M41;" [#fn("9000r1c0qe1|\x7f3241;" [#fn("7000r1c0qc1q41;" [#fn(":000r1~16602~NF6M0i3:~\x84i20NQ2i39e0~31i213242;~17A02i10C@17702i10E660|40;c1qe2i203141;" [caddr- #fn("8000r1|6B0i4:|i30NQ2i3142;i20c0\x8260i30;i20c1\x82>0i46i30i3142;i20c2\x82>0i47i30i3142;i20c3\x82>0i48i30i3142;~40;" [quote- lambda define let-syntax]) macrocall?])
- #fn("7000r0c0q]31i2041;" [#fn("6000r1c0qm02|;" [#fn("9000r1|?640|;|M?670|M5<0i4:|Mi3132~|N31K;" [])])])])- assq])] expand-in)])] expand)
- expand-define #fn("=000r1c0|\x84e1|31F6:0e1|315L0|\x84C6;0e230L15=0e3c4e5|313242;" [#fn("<000r2|C6:0c0|}ML3;c0|Me1c2L1|NL1e3}31|M34L3;" [set!- nconc lambda copy-list]) cddr void error "compile error: invalid syntax "
- print-to-string] expand-define)
- filter #fn("7000r2c0q]41;" [#fn("9000r1c0qm02|~\x7f_L143;" [#fn("9000r3g2]}F6S02i10}M316?0g2}M_KPNm2530]2}Nm15\f/2N;" [] filter-)])] filter)- fits-i8 #fn("8000r1|I16F02e0|b\xb03216:02e1|b\xaf42;" [>= <=] fits-i8)- foldl #fn(":000r3g2\x8540};e0||g2M}32g2N43;" [foldl] foldl) foldr- #fn(";000r3g2\x8540};|g2Me0|}g2N3342;" [foldr] foldr) for-each #fn(";000s2c0q]41;" [#fn(":000r1c0qm02i02\x85J0]\x7fF6A02~\x7fM312\x7fNo015\x1e/5;0|~\x7fi02K322];" [#fn(":000r2}MF6I0|e0c1}32Q22~|e0c2}3242;];" [map- #.car #.cdr] for-each-n)])] for-each)
- get-defined-vars #fn("8000r1e0~|3141;" [delete-duplicates] #1=[#fn("9000r1|?640_;|Mc0<16602|NF6d0|\x84C16702|\x84L117S02|\x84F16E02e1|31C16:02e1|31L117402_;|Mc2\x82>0e3e4~|N32v2;_;" [define- caadr begin nconc map] #1#) ()])
- hex5 #fn("9000r1e0e1|b@32b5c243;" [string.lpad number->string #\0] hex5)- identity #fn("6000r1|;" [] identity) in-env?- #fn("8000r2}F16F02e0|}M3217:02e1|}N42;" [memq in-env?] in-env?)- index-of #fn(":000r3}\x8540^;|}M\x8250g2;e0|}Ng2aw43;" [index-of] index-of)- io.readall #fn("7000r1c0qe13041;" [#fn("8000r1e0|~322c1qe2|3141;" [io.copy- #fn("7000r1|c0>16:02e1i1031670e240;|;" ["" io.eof? eof-object]) io.tostring!])- buffer] io.readall)
- io.readline #fn("8000r1e0|c142;" [io.readuntil #\linefeed] io.readline)- io.readlines #fn("8000r1e0e1|42;" [read-all-of io.readline] io.readlines)- iota #fn("8000r1e0e1|42;" [map-int identity] iota) keyword->symbol- #fn("9000r1e0|316@0e1c2e3|313141;|;" [keyword? symbol #fn("<000r1e0|`e1|e2|313243;" [string.sub- string.dec length]) string] keyword->symbol)
- keyword-arg? #fn("7000r1|F16902e0|M41;" [keyword?] keyword-arg?)- lambda-arg-names #fn("9000r1e0c1e2|3142;" [map! #fn("7000r1|F690e0|M41;|;" [keyword->symbol])- to-proper] lambda-arg-names)
- lambda-vars #fn("7000r1c0q]41;" [#fn(":000r1c0qm02|~~^^342e1~41;" [#fn(";000r4|A17502|C640];|F16602|MC6S0g217502g36<0e0c1}c243;~|N}g2g344;|F16602|MF6\x870e3|Mb23216902e4|31C660^5=0e0c5|Mc6}342e7e4|31316<0~|N}g2]44;g36<0e0c1}c843;~|N}]g344;|F6>0e0c9|Mc6}44;|}\x82:0e0c1}42;e0c9|c6}44;" [error- "compile error: invalid argument list "
- ". optional arguments must come after required." length= caar "compile error: invalid optional argument "
- " in list " keyword? ". keyword arguments must come last."
- "compile error: invalid formal argument "] check-formals) lambda-arg-names])] lambda-vars)
- last-pair #fn("7000r1|N?640|;e0|N41;" [last-pair] last-pair) lastcdr- #fn("7000r1|?640|;e0|31N;" [last-pair] lastcdr) length= #fn("9000r2}`X640^;}`W650|?;|?660}`W;e0|N}ax42;" [length=] length=)- length> #fn("9000r2}`X640|;}`W6;0|F16402|;|?660}`X;e0|N}ax42;" [length>] length>)- list->vector #fn("7000r1c0|v2;" [#.vector] list->vector) list-head- #fn(":000r2e0}`32640_;|Me1|N}ax32K;" [<= list-head] list-head)- list-ref #fn("8000r2e0|}32M;" [list-tail] list-ref) list-tail- #fn("9000r2e0}`32640|;e1|N}ax42;" [<= list-tail] list-tail) list? #fn("7000r1|A17@02|F16902e0|N41;" [list?] list?)- load #fn("9000r1c0qe1|c23241;" [#fn("7000r1c0qc1qt;" [#fn("9000r0c0q]31]]]43;" [#fn("6000r1c0qm02|;" [#fn(":000r3e0i10317C0~e1i1031|e2}3143;e3i10312e2}41;" [io.eof?- read load-process io.close])])]) #fn("9000r1e0~312e1c2i10|L341;" [io.close- raise
- load-error])])
- file :read] load)
- load-process #fn("7000r1e0|41;" [eval] load-process) lookup-sym- #fn("7000r4}\x8550c0;c1q}M41;" [(global)- #fn(":000r1c0qe1~|`3341;" [#fn(";000r1|6@0i13640|;i12|K;e0i10i11Ni1317502~A680i12570i12aw^44;" [lookup-sym])- index-of])] lookup-sym)
- macrocall? #fn("7000r1|MC16902e0|M41;" [symbol-syntax] macrocall?)- macroexpand-1 #fn("8000r1|?640|;c0qe1|3141;" [#fn("7000r1|680|~Nv2;~;" [])- macrocall?] macroexpand-1)
- make-code-emitter #fn("9000r0_e030`c1Z4;" [table +inf.0] make-code-emitter)- make-label #fn("6000r1e040;" [gensym] make-label)- make-perfect-hash-table #fn("7000r1c0q]41;" [#fn("8000r1c0m02c1q]31e2~3141;" [#fn("9000r2e0e1e2|3131}42;" [mod0- abs hash] $hash-keyword) #fn("6000r1c0qm02|;" [#fn("9000r1c0qe1b2|T2^3241;" [#fn("7000r1c0q]31i3041;" [#fn("6000r1c0qm02|;" [#fn("8000r1|F6=0c0qe1|3141;i10;" [#fn(":000r1c0qb2i50|i3032T241;" [#fn("9000r1i30|[6=0i50i40aw41;i30|~\\2i30|awe0i1031\\2i20i10N41;" [cdar])])- caar])])]) vector.alloc])]) length])] make-perfect-hash-table)
- make-system-image #fn(";000r1c0e1|c2c3c434c542;" [#fn("8000r2c0qe1e242;" [#fn("7000r2]k02]k12c2qc3q41;" [*print-pretty*- *print-readably* #fn("7000r1c0qc1qt|302;" [#fn(":000r0c0qe1c2qe3e4303132312e5i2041;" [#fn("=000r1e0e1e2c3|e2e4|3233Q2i20322e5i20e642;" [write- nconc map #.list top-level-value io.write *linefeed*]) filter #fn("9000r1|E16w02e0|31@16l02e1|31G@17C02e2|31e2e1|3131>@16K02e3|i2132@16=02e4e1|3131@;" [constant?- top-level-value string memq iostream?]) simple-sort environment io.close])
- #fn("7000r1~302e0|41;" [raise])])- #fn("6000r0~k02\x7fk1;" [*print-pretty* *print-readably*])]) *print-pretty*- *print-readably*]) file :write :create :truncate (*linefeed*
- *directory-separator*
- *argv* that *print-pretty*
- *print-width*
- *print-readably*
- *print-level*
- *print-length* *os-name*)] make-system-image)
- map! #fn("9000r2}]}F6B02}|}M31O2}Nm15\x1d/2;" [] map!) map-int- #fn("8000r2e0}`32640_;c1q|`31_K_42;" [<= #fn(":000r2|m12a\x7faxc0qu2|;" [#fn("8000r1\x7fi10|31_KP2\x7fNo01;" [])])] map-int)- mark-label #fn("9000r2e0|c1}43;" [emit label] mark-label) max- #fn("<000s1}\x8540|;e0c1|}43;" [foldl #fn("7000r2|}X640};|;" [])] max)- member #fn("8000r2}?640^;}M|>640};e0|}N42;" [member] member) memv- #fn("8000r2}?640^;}M|=640};e0|}N42;" [memv] memv) min #fn("<000s1}\x8540|;e0c1|}43;" [foldl- #fn("7000r2|}X640|;};" [])] min)- mod #fn("9000r2|e0|}32}T2x;" [div] mod) mod0- #fn("8000r2||}V}T2x;" [] mod0) negative? #fn("7000r1|`X;" [] negative?)- nestlist #fn(";000r3e0g2`32640_;}e1||}31g2ax33K;" [<= nestlist] nestlist)- newline #fn("9000\x8900001000\x8a0000770e0m02e1|e2322];" [*output-stream*- io.write
- *linefeed*] newline)
- nnn #fn("8000r1e0c1|42;" [count #fn("6000r1|A@;" [])] nnn) nreconc- #fn("8000r2e0}|42;" [reverse!-] nreconc) odd? #fn("7000r1e0|31@;" [even?] odd?)- positive? #fn("8000r1e0|`42;" [>] positive?) princ- #fn("9000s0c0qe141;" [#fn("7000r1^k02c1qc2q41;" [*print-readably* #fn("7000r1c0qc1qt|302;" [#fn("8000r0e0e1i2042;" [for-each- write]) #fn("7000r1~302e0|41;" [raise])])- #fn("6000r0~k0;" [*print-readably*])])- *print-readably*] princ)
- print #fn(":000s0e0e1|42;" [for-each write] print) print-exception- #fn("=000r1|F16D02|Mc0<16:02e1|b4326P0e2c3|\x84c4e5|31c6352e7e8|31315\x070|F16D02|Mc9<16:02e1|b4326N0e2|\x84c:e8|31c;342e7e5|31315\xd00|F16@02|Mc<<16602|NF6?0e2c=|\x84c>335\xac0|F16802|Mc?<6B0e2c@312e2|NQ25\x8d0|F16802|McA<6G0eBe5|31312e2cC|\x84325i0eD|3116:02e1|b2326I0e7|M312e2cE312cF|\x84315>0e2cG312e7|312e2eH41;" [type-error- length= princ "type error: " ": expected " caddr ", got " print cadddr
- bounds-error ": index " " out of bounds for " unbound-error "eval: variable "
- " has no value" error "error: " load-error print-exception "in file " list?
- ": " #fn("8000r1e0|3117502|C670e1540e2|41;" [string? princ print])- "*** Unhandled exception: " *linefeed*] print-exception)
- print-stack-trace #fn("8000r1c0q]]42;" [#fn("=000r2c0qm02c1qm12c2qe3e4~e5670b5540b43231e6e7e8c9e:303232`43;" [#fn("8000r3c0qe1|31g2K41;" [#fn("9000r1e0~31e0\x7f31\x82>0e1c2c3|L341;c4qe5~3141;" [function:code- raise thrown-value ffound #fn(":000r1`e0e1|3131c2qu;" [1- length #fn("9000r1e0~|[316A0i30~|[i21i1043;];" [closure?])])- function:vals]) function:name] find-in-f)
- #fn("8000r2c0c1qc2t41;" [#fn(";000r1|6H0e0e1e2e3e4|3132c53241;c6;" [symbol- string.join map string reverse! "/" lambda])
- #fn("8000r0e0c1q\x7f322^;" [for-each #fn("9000r1i10|~_43;" [])])- #fn("7000r1|F16B02|Mc0<16802|\x84c1<680e2|41;e3|41;" [thrown-value- ffound caddr raise])] fn-name) #fn("8000r3e0c1q|42;" [for-each #fn("9000r1e0c1i02c2332e3i11|`[\x7f32e4|31NK312e5302i02awo02;" [princ- "#" " " print vector->list newline])]) reverse! list-tail *interactive*
- filter closure? map #fn("7000r1|E16802e0|41;" [top-level-value]) environment])] print-stack-trace)- print-to-string #fn("7000r1c0qe13041;" [#fn("8000r1e0~|322e1|41;" [write- io.tostring!]) buffer] print-to-string)
- printable? #fn("7000r1e0|3117802e1|31@;" [iostream? eof-object?] printable?)- quote-value #fn("7000r1e0|31640|;c1|L2;" [self-evaluating? quote] quote-value)- random #fn("8000r1e0|316<0e1e230|42;e330|T2;" [integer? mod rand- rand.double] random)
- read-all #fn("8000r1e0e1|42;" [read-all-of read] read-all)- read-all-of #fn("9000r2c0q]31_|}3142;" [#fn("6000r1c0qm02|;" [#fn("9000r2e0i1131680e1|41;~}|Ki10i113142;" [io.eof?- reverse!])])] read-all-of)
- ref-int16-LE #fn(";000r2e0e1|}`w[`32e1|}aw[b832w41;" [int16 ash] ref-int16-LE)- ref-int32-LE #fn("=000r2e0e1|}`w[`32e1|}aw[b832e1|}b2w[b@32e1|}b3w[bH32R441;" [int32- ash] ref-int32-LE)
- repl #fn("8000r0c0]]42;" [#fn("6000r2c0m02c1qm12}302e240;" [#fn("8000r0e0c1312e2e3312c4c5c6t41;" [princ- "> " io.flush *output-stream* #fn("8000r1e0e131@16<02c2e3|3141;" [io.eof?- *input-stream*
- #fn("7000r1e0|312|k12];" [print- that]) load-process]) #fn("6000r0e040;" [read])- #fn("7000r1e0e1312e2|41;" [io.discardbuffer *input-stream* raise])] prompt)- #fn("7000r0c0qc1t6;0e2302\x7f40;^;" [#fn("7000r0~3016702e040;" [newline])- #fn("7000r1e0|312];" [top-level-exception-handler])- newline] reploop) newline])] repl)
- revappend #fn("8000r2e0}|42;" [reverse-] revappend) reverse- #fn("8000r1e0_|42;" [reverse-] reverse) reverse! #fn("8000r1e0_|42;" [reverse!-] reverse!)- reverse!- #fn("9000r2]}F6B02}N}|}m02P2m15\x1d/2|;" [] reverse!-)- reverse- #fn("8000r2}\x8540|;e0}M|K}N42;" [reverse-] reverse-)- self-evaluating? #fn("8000r1|?16602|C@17K02e0|3116A02|C16:02|e1|31<;" [constant?- top-level-value] self-evaluating?)
- separate #fn("7000r2c0q]41;" [#fn(":000r1c0m02|~\x7f_L1_L144;" [#fn(";000r4c0g2g3K]}F6Z02|}M316?0g2}M_KPNm25<0g3}M_KPNm32}Nm15\x05/241;" [#fn("8000r1e0|MN|NN42;" [values])] separate-)])] separate)- set-syntax! #fn("9000r2e0e1|}43;" [put! *syntax-environment*] set-syntax!)- simple-sort #fn("7000r1|A17602|NA640|;c0q|M41;" [#fn("8000r1e0c1qc2q42;" [call-with-values- #fn("8000r0e0c1qi10N42;" [separate #fn("7000r1|~X;" [])])- #fn(":000r2e0e1|31~L1e1}3143;" [nconc simple-sort])])] simple-sort)- splice-form? #fn("8000r1|F16X02|Mc0<17N02|Mc1<17D02|Mc2<16:02e3|b23217702|c2<;" [unquote-splicing- unquote-nsplicing unquote length>] splice-form?)
- string.join #fn("7000r2|\x8550c0;c1qe23041;" ["" #fn("8000r1e0|~M322e1c2q~N322e3|41;" [io.write- for-each #fn("8000r1e0~i11322e0~|42;" [io.write]) io.tostring!]) buffer] string.join)- string.lpad #fn(";000r3e0e1g2}e2|31x32|42;" [string string.rep- string.count] string.lpad)
- string.map #fn("9000r2c0qe130e2}3142;" [#fn("7000r2c0q`312e1|41;" [#fn(";000r1]|\x7fX6S02e0~i10e1i11|3231322e2i11|32m05\v/;" [io.putc- string.char string.inc]) io.tostring!]) buffer length] string.map)
- string.rep #fn(";000r2}b4X6`0e0}`32650c1;}aW680e2|41;}b2W690e2||42;e2|||43;e3}316@0e2|e4|}ax3242;e4e2||32}b2U242;" [<=- "" string odd? string.rep] string.rep)
- string.rpad #fn("<000r3e0|e1g2}e2|31x3242;" [string string.rep- string.count] string.rpad)
- string.tail #fn(";000r2e0|e1|`}3342;" [string.sub string.inc] string.tail)- string.trim #fn("8000r3c0q]]42;" [#fn("8000r2c0qm02c1qm12c2qe3~3141;" [#fn(";000r4g2g3X16?02e0}e1|g232326A0~|}e2|g232g344;g2;" [string.find- string.char string.inc] trim-start) #fn("<000r3e0g2`3216D02e1}e2|e3|g23232326?0\x7f|}e3|g23243;g2;" [>- string.find string.char string.dec] trim-end)
- #fn("<000r1e0i10~i10i11`|34\x7fi10i12|3343;" [string.sub]) length])] string.trim)- symbol-syntax #fn("9000r1e0e1|^43;" [get *syntax-environment*] symbol-syntax)- table.clone #fn("7000r1c0qe13041;" [#fn("9000r1e0c1q_~332|;" [table.foldl- #fn("9000r3e0~|}43;" [put!])]) table] table.clone)- table.foreach #fn("9000r2e0c1q_}43;" [table.foldl #fn("8000r3~|}322];" [])] table.foreach)- table.invert #fn("7000r1c0qe13041;" [#fn("9000r1e0c1q_~332|;" [table.foldl- #fn("9000r3e0~}|43;" [put!])]) table] table.invert)- table.keys #fn("9000r1e0c1_|43;" [table.foldl #fn("7000r3|g2K;" [])] table.keys)- table.pairs #fn("9000r1e0c1_|43;" [table.foldl #fn("7000r3|}Kg2K;" [])] table.pairs)- table.values #fn("9000r1e0c1_|43;" [table.foldl #fn("7000r3}g2K;" [])] table.values)- to-proper #fn("8000r1|\x8540|;|?660|L1;|Me0|N31K;" [to-proper] to-proper)- top-level-exception-handler #fn("7000r1c0qe141;" [#fn("7000r1e0k12c2qc3q41;" [*stderr*- *output-stream* #fn("7000r1c0qc1qt|302;" [#fn("7000r0e0i20312e1e23041;" [print-exception- print-stack-trace stacktrace]) #fn("7000r1~302e0|41;" [raise])])- #fn("6000r0~k0;" [*output-stream*])]) *output-stream*] top-level-exception-handler)- trace #fn("8000r1c0qe1|31312c2;" [#fn("7000r1c0qe13041;" [#fn("@000r1e0~317e0e1i10e2c3|c4c5c6c7i10L2|L3L2c8L1c9c7~L2|L3L4L33142;];" [traced?- set-top-level-value! eval lambda begin write cons quote newline apply])
- gensym])
- top-level-value ok] trace)
- traced? #fn("8000r1e0|3116>02e1|31e1~31>;" [closure? function:code] [#fn(":000s0e0c1|K312e2302c3|v2;" [write- x newline #.apply]) ()])
- untrace #fn("8000r1c0qe1|3141;" [#fn("9000r1e0|316@0e1~e2|31b2[42;];" [traced?- set-top-level-value! function:vals]) top-level-value] untrace)
- values #fn("9000s0|F16602|NA650|M;~|K;" [] #2#) vector->list- #fn("8000r1c0qe1|31_42;" [#fn(":000r2a|c0qu2};" [#fn("8000r1i10~|x[\x7fKo01;" [])])- length] vector->list)
- vector.map #fn("8000r2c0qe1}3141;" [#fn("8000r1c0qe1|3141;" [#fn(":000r1`~axc0qu2|;" [#fn(":000r1~|i20i21|[31\\;" [])])- vector.alloc]) length] vector.map)
- void #fn("6000r0];" [] void) zero?- #fn("7000r1|`W;" [] zero?))--- a/femtolisp/flisp.c
+++ /dev/null
@@ -1,2382 +1,0 @@
-/*
- femtoLisp
-
- a compact interpreter for a minimal lisp/scheme dialect
-
- characteristics:
- * lexical scope, lisp-1
- * unrestricted macros
- * data types: 30-bit integer, symbol, pair, vector, char, string, table
- iostream, procedure, low-level data types
- * case-sensitive
- * simple compacting copying garbage collector
- * Scheme-style varargs (dotted formal argument lists)
- * "human-readable" bytecode with self-hosted compiler
-
- extra features:
- * circular structure can be printed and read
- * #. read macro for eval-when-read and readably printing builtins
- * read macros for backquote
- * symbol character-escaping printer
- * exceptions
- * gensyms (can be usefully read back in, too)
- * #| multiline comments |#, lots of other lexical syntax
- * generic compare function, cyclic equal
- * cvalues system providing C data types and a C FFI
- * constructor notation for nicely printing arbitrary values
-
- by Jeff Bezanson (C) 2009
- Distributed under the BSD License
-*/
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <setjmp.h>
-#include <stdarg.h>
-#include <assert.h>
-#include <ctype.h>
-#include <wctype.h>
-#include <sys/types.h>
-#include <locale.h>
-#include <limits.h>
-#include <errno.h>
-#include <math.h>
-#include "llt.h"
-#include "flisp.h"
-#include "opcodes.h"
-
-static char *builtin_names[] =
- { NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL,- NULL, NULL, NULL, NULL,
- // predicates
- "eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
- "number?", "bound?", "pair?", "builtin?", "vector?", "fixnum?",
- "function?",
-
- // lists
- "cons", "list", "car", "cdr", "set-car!", "set-cdr!",
-
- // execution
- "apply",
-
- // arithmetic
- "+", "-", "*", "/", "div0", "=", "<", "compare",
-
- // sequences
- "vector", "aref", "aset!",
- "", "", "" };
-
-#define ANYARGS -10000
-
-static short builtin_arg_counts[] =
- { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,- 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 2, ANYARGS, 1, 1, 2, 2,
- -2,
- ANYARGS, -1, ANYARGS, -1, 2, 2, 2, 2,
- ANYARGS, 2, 3 };
-
-static uint32_t N_STACK;
-static value_t *Stack;
-static uint32_t SP = 0;
-static uint32_t curr_frame = 0;
-#define PUSH(v) (Stack[SP++] = (v))
-#define POP() (Stack[--SP])
-#define POPN(n) (SP-=(n))
-
-#define N_GC_HANDLES 1024
-static value_t *GCHandleStack[N_GC_HANDLES];
-static uint32_t N_GCHND = 0;
-
-value_t FL_NIL, FL_T, FL_F, FL_EOF, QUOTE;
-value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
-value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
-value_t printwidthsym, printreadablysym, printprettysym, printlengthsym;
-value_t printlevelsym, builtins_table_sym;
-
-static value_t NIL, LAMBDA, IF, TRYCATCH;
-static value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
-
-static value_t pairsym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym;
-static value_t definesym, defmacrosym, forsym, setqsym;
-static value_t tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym, fnsym;
-// for reading characters
-static value_t nulsym, alarmsym, backspacesym, tabsym, linefeedsym, newlinesym;
-static value_t vtabsym, pagesym, returnsym, escsym, spacesym, deletesym;
-
-static value_t apply_cl(uint32_t nargs);
-static value_t *alloc_words(int n);
-static value_t relocate(value_t v);
-
-static fl_readstate_t *readstate = NULL;
-
-static void free_readstate(fl_readstate_t *rs)
-{- htable_free(&rs->backrefs);
- htable_free(&rs->gensyms);
-}
-
-static unsigned char *fromspace;
-static unsigned char *tospace;
-static unsigned char *curheap;
-static unsigned char *lim;
-static uint32_t heapsize;//bytes
-static uint32_t *consflags;
-
-// error utilities ------------------------------------------------------------
-
-// saved execution state for an unwind target
-fl_exception_context_t *fl_ctx = NULL;
-uint32_t fl_throwing_frame=0; // active frame when exception was thrown
-value_t fl_lasterror;
-
-#define FL_TRY \
- fl_exception_context_t _ctx; int l__tr, l__ca; \
- _ctx.sp=SP; _ctx.frame=curr_frame; _ctx.rdst=readstate; _ctx.prev=fl_ctx; \
- _ctx.ngchnd = N_GCHND; fl_ctx = &_ctx; \
- if (!setjmp(_ctx.buf)) \
- for (l__tr=1; l__tr; l__tr=0, (void)(fl_ctx=fl_ctx->prev))
-
-#define FL_CATCH \
- else \
- for(l__ca=1; l__ca; l__ca=0, \
- fl_lasterror=FL_NIL,fl_throwing_frame=0,SP=_ctx.sp,curr_frame=_ctx.frame)
-
-void fl_savestate(fl_exception_context_t *_ctx)
-{- _ctx->sp = SP;
- _ctx->frame = curr_frame;
- _ctx->rdst = readstate;
- _ctx->prev = fl_ctx;
- _ctx->ngchnd = N_GCHND;
-}
-
-void fl_restorestate(fl_exception_context_t *_ctx)
-{- fl_lasterror = FL_NIL;
- fl_throwing_frame = 0;
- SP = _ctx->sp;
- curr_frame = _ctx->frame;
-}
-
-void fl_raise(value_t e)
-{- fl_lasterror = e;
- // unwind read state
- while (readstate != fl_ctx->rdst) {- free_readstate(readstate);
- readstate = readstate->prev;
- }
- if (fl_throwing_frame == 0)
- fl_throwing_frame = curr_frame;
- N_GCHND = fl_ctx->ngchnd;
- fl_exception_context_t *thisctx = fl_ctx;
- if (fl_ctx->prev) // don't throw past toplevel
- fl_ctx = fl_ctx->prev;
- longjmp(thisctx->buf, 1);
-}
-
-static value_t make_error_msg(char *format, va_list args)
-{- char msgbuf[512];
- vsnprintf(msgbuf, sizeof(msgbuf), format, args);
- return string_from_cstr(msgbuf);
-}
-
-void lerrorf(value_t e, char *format, ...)
-{- va_list args;
- PUSH(e);
- va_start(args, format);
- value_t msg = make_error_msg(format, args);
- va_end(args);
-
- e = POP();
- fl_raise(fl_list2(e, msg));
-}
-
-void lerror(value_t e, const char *msg)
-{- PUSH(e);
- value_t m = cvalue_static_cstring(msg);
- e = POP();
- fl_raise(fl_list2(e, m));
-}
-
-void type_error(char *fname, char *expected, value_t got)
-{- fl_raise(fl_listn(4, TypeError, symbol(fname), symbol(expected), got));
-}
-
-void bounds_error(char *fname, value_t arr, value_t ind)
-{- fl_raise(fl_listn(4, BoundsError, symbol(fname), arr, ind));
-}
-
-// safe cast operators --------------------------------------------------------
-
-#define isstring fl_isstring
-#define SAFECAST_OP(type,ctype,cnvt) \
-ctype to##type(value_t v, char *fname) \
-{ \- if (is##type(v)) \
- return (ctype)cnvt(v); \
- type_error(fname, #type, v); \
-}
-SAFECAST_OP(cons, cons_t*, ptr)
-SAFECAST_OP(symbol,symbol_t*,ptr)
-SAFECAST_OP(fixnum,fixnum_t, numval)
-SAFECAST_OP(cvalue,cvalue_t*,ptr)
-SAFECAST_OP(string,char*, cvalue_data)
-#undef isstring
-
-// symbol table ---------------------------------------------------------------
-
-symbol_t *symtab = NULL;
-
-int fl_is_keyword_name(char *str, size_t len)
-{- return ((str[0] == ':' || str[len-1] == ':') && str[1] != '\0');
-}
-
-static symbol_t *mk_symbol(char *str)
-{- symbol_t *sym;
- size_t len = strlen(str);
-
- sym = (symbol_t*)malloc(sizeof(symbol_t)-sizeof(void*) + len + 1);
- assert(((uptrint_t)sym & 0x7) == 0); // make sure malloc aligns 8
- sym->left = sym->right = NULL;
- sym->flags = 0;
- if (fl_is_keyword_name(str, len)) {- value_t s = tagptr(sym, TAG_SYM);
- setc(s, s);
- sym->flags |= 0x2;
- }
- else {- sym->binding = UNBOUND;
- }
- sym->type = sym->dlcache = NULL;
- sym->hash = memhash32(str, len)^0xAAAAAAAA;
- strcpy(&sym->name[0], str);
- return sym;
-}
-
-static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
-{- int x;
-
- while(*ptree != NULL) {- x = strcmp(str, (*ptree)->name);
- if (x == 0)
- return ptree;
- if (x < 0)
- ptree = &(*ptree)->left;
- else
- ptree = &(*ptree)->right;
- }
- return ptree;
-}
-
-value_t symbol(char *str)
-{- symbol_t **pnode;
-
- pnode = symtab_lookup(&symtab, str);
- if (*pnode == NULL)
- *pnode = mk_symbol(str);
- return tagptr(*pnode, TAG_SYM);
-}
-
-static uint32_t _gensym_ctr=0;
-// two static buffers for gensym printing so there can be two
-// gensym names available at a time, mostly for compare()
-static char gsname[2][16];
-static int gsnameno=0;
-value_t fl_gensym(value_t *args, uint32_t nargs)
-{- argcount("gensym", nargs, 0);- (void)args;
- gensym_t *gs = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
- gs->id = _gensym_ctr++;
- gs->binding = UNBOUND;
- gs->isconst = 0;
- gs->type = NULL;
- return tagptr(gs, TAG_SYM);
-}
-
-int fl_isgensym(value_t v)
-{- return isgensym(v);
-}
-
-static value_t fl_gensymp(value_t *args, u_int32_t nargs)
-{- argcount("gensym?", nargs, 1);- return isgensym(args[0]) ? FL_T : FL_F;
-}
-
-char *symbol_name(value_t v)
-{- if (ismanaged(v)) {- gensym_t *gs = (gensym_t*)ptr(v);
- gsnameno = 1-gsnameno;
- char *n = uint2str(gsname[gsnameno]+1, sizeof(gsname[0])-1, gs->id, 10);
- *(--n) = 'g';
- return n;
- }
- return ((symbol_t*)ptr(v))->name;
-}
-
-// conses ---------------------------------------------------------------------
-
-void gc(int mustgrow);
-
-static value_t mk_cons(void)
-{- cons_t *c;
-
- if (__unlikely(curheap > lim))
- gc(0);
- c = (cons_t*)curheap;
- curheap += sizeof(cons_t);
- return tagptr(c, TAG_CONS);
-}
-
-static value_t *alloc_words(int n)
-{- value_t *first;
-
- assert(n > 0);
- n = LLT_ALIGN(n, 2); // only allocate multiples of 2 words
- if (__unlikely((value_t*)curheap > ((value_t*)lim)+2-n)) {- gc(0);
- while ((value_t*)curheap > ((value_t*)lim)+2-n) {- gc(1);
- }
- }
- first = (value_t*)curheap;
- curheap += (n*sizeof(value_t));
- return first;
-}
-
-// allocate n consecutive conses
-#define cons_reserve(n) tagptr(alloc_words((n)*2), TAG_CONS)
-
-#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace))
-#define ismarked(c) bitvector_get(consflags, cons_index(c))
-#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
-#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
-
-static value_t the_empty_vector;
-
-value_t alloc_vector(size_t n, int init)
-{- if (n == 0) return the_empty_vector;
- value_t *c = alloc_words(n+1);
- value_t v = tagptr(c, TAG_VECTOR);
- vector_setsize(v, n);
- if (init) {- unsigned int i;
- for(i=0; i < n; i++)
- vector_elt(v, i) = FL_UNSPECIFIED;
- }
- return v;
-}
-
-// cvalues --------------------------------------------------------------------
-
-#include "cvalues.c"
-#include "types.c"
-
-// print ----------------------------------------------------------------------
-
-static int isnumtok(char *tok, value_t *pval);
-static inline int symchar(char c);
-
-#include "print.c"
-
-// collector ------------------------------------------------------------------
-
-void fl_gc_handle(value_t *pv)
-{- if (N_GCHND >= N_GC_HANDLES)
- lerror(MemoryError, "out of gc handles");
- GCHandleStack[N_GCHND++] = pv;
-}
-
-void fl_free_gc_handles(uint32_t n)
-{- assert(N_GCHND >= n);
- N_GCHND -= n;
-}
-
-static value_t relocate(value_t v)
-{- value_t a, d, nc, first, *pcdr;
- uptrint_t t = tag(v);
-
- if (t == TAG_CONS) {- // iterative implementation allows arbitrarily long cons chains
- pcdr = &first;
- do {- if ((a=car_(v)) == TAG_FWD) {- *pcdr = cdr_(v);
- return first;
- }
- *pcdr = nc = tagptr((cons_t*)curheap, TAG_CONS);
- curheap += sizeof(cons_t);
- d = cdr_(v);
- car_(v) = TAG_FWD; cdr_(v) = nc;
- car_(nc) = relocate(a);
- pcdr = &cdr_(nc);
- v = d;
- } while (iscons(v));
- *pcdr = (d==NIL) ? NIL : relocate(d);
- return first;
- }
-
- if ((t&3) == 0) return v;
- if (!ismanaged(v)) return v;
- if (isforwarded(v)) return forwardloc(v);
-
- if (t == TAG_VECTOR) {- // N.B.: 0-length vectors secretly have space for a first element
- size_t i, sz = vector_size(v);
- if (vector_elt(v,-1) & 0x1) {- // grown vector
- nc = relocate(vector_elt(v,0));
- forward(v, nc);
- }
- else {- nc = tagptr(alloc_words(sz+1), TAG_VECTOR);
- vector_setsize(nc, sz);
- a = vector_elt(v,0);
- forward(v, nc);
- if (sz > 0) {- vector_elt(nc,0) = relocate(a);
- for(i=1; i < sz; i++)
- vector_elt(nc,i) = relocate(vector_elt(v,i));
- }
- }
- return nc;
- }
- else if (t == TAG_CPRIM) {- cprim_t *pcp = (cprim_t*)ptr(v);
- size_t nw = CPRIM_NWORDS-1+NWORDS(cp_class(pcp)->size);
- cprim_t *ncp = (cprim_t*)alloc_words(nw);
- while (nw--)
- ((value_t*)ncp)[nw] = ((value_t*)pcp)[nw];
- nc = tagptr(ncp, TAG_CPRIM);
- forward(v, nc);
- return nc;
- }
- else if (t == TAG_CVALUE) {- return cvalue_relocate(v);
- }
- else if (t == TAG_FUNCTION) {- function_t *fn = (function_t*)ptr(v);
- function_t *nfn = (function_t*)alloc_words(4);
- nfn->bcode = fn->bcode;
- nfn->vals = fn->vals;
- nc = tagptr(nfn, TAG_FUNCTION);
- forward(v, nc);
- nfn->env = relocate(fn->env);
- nfn->vals = relocate(nfn->vals);
- nfn->bcode = relocate(nfn->bcode);
- assert(!ismanaged(fn->name));
- nfn->name = fn->name;
- return nc;
- }
- else if (t == TAG_SYM) {- gensym_t *gs = (gensym_t*)ptr(v);
- gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
- ng->id = gs->id;
- ng->binding = gs->binding;
- ng->isconst = 0;
- nc = tagptr(ng, TAG_SYM);
- forward(v, nc);
- if (ng->binding != UNBOUND)
- ng->binding = relocate(ng->binding);
- return nc;
- }
- return v;
-}
-
-value_t relocate_lispvalue(value_t v)
-{- return relocate(v);
-}
-
-static void trace_globals(symbol_t *root)
-{- while (root != NULL) {- if (root->binding != UNBOUND)
- root->binding = relocate(root->binding);
- trace_globals(root->left);
- root = root->right;
- }
-}
-
-static value_t memory_exception_value;
-
-void gc(int mustgrow)
-{- static int grew = 0;
- void *temp;
- uint32_t i, f, top;
- fl_readstate_t *rs;
-
- curheap = tospace;
- if (grew)
- lim = curheap+heapsize*2-sizeof(cons_t);
- else
- lim = curheap+heapsize-sizeof(cons_t);
-
- if (fl_throwing_frame > curr_frame) {- top = fl_throwing_frame - 4;
- f = Stack[fl_throwing_frame-4];
- }
- else {- top = SP;
- f = curr_frame;
- }
- while (1) {- for (i=f; i < top; i++)
- Stack[i] = relocate(Stack[i]);
- if (f == 0) break;
- top = f - 4;
- f = Stack[f-4];
- }
- for (i=0; i < N_GCHND; i++)
- *GCHandleStack[i] = relocate(*GCHandleStack[i]);
- trace_globals(symtab);
- relocate_typetable();
- rs = readstate;
- while (rs) {- value_t ent;
- for(i=0; i < rs->backrefs.size; i++) {- ent = (value_t)rs->backrefs.table[i];
- if (ent != (value_t)HT_NOTFOUND)
- rs->backrefs.table[i] = (void*)relocate(ent);
- }
- for(i=0; i < rs->gensyms.size; i++) {- ent = (value_t)rs->gensyms.table[i];
- if (ent != (value_t)HT_NOTFOUND)
- rs->gensyms.table[i] = (void*)relocate(ent);
- }
- rs->source = relocate(rs->source);
- rs = rs->prev;
- }
- fl_lasterror = relocate(fl_lasterror);
- memory_exception_value = relocate(memory_exception_value);
- the_empty_vector = relocate(the_empty_vector);
-
- sweep_finalizers();
-
-#ifdef VERBOSEGC
- printf("GC: found %d/%d live conses\n",- (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t));
-#endif
- temp = tospace;
- tospace = fromspace;
- fromspace = temp;
-
- // if we're using > 80% of the space, resize tospace so we have
- // more space to fill next time. if we grew tospace last time,
- // grow the other half of the heap this time to catch up.
- if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {- temp = LLT_REALLOC(tospace, heapsize*2);
- if (temp == NULL)
- fl_raise(memory_exception_value);
- tospace = temp;
- if (grew) {- heapsize*=2;
- temp = bitvector_resize(consflags, 0, heapsize/sizeof(cons_t), 1);
- if (temp == NULL)
- fl_raise(memory_exception_value);
- consflags = (uint32_t*)temp;
- }
- grew = !grew;
- }
- if (curheap > lim) // all data was live
- gc(0);
-}
-
-static void grow_stack()
-{- size_t newsz = N_STACK + (N_STACK>>1);
- value_t *ns = realloc(Stack, newsz*sizeof(value_t));
- if (ns == NULL)
- lerror(MemoryError, "stack overflow");
- Stack = ns;
- N_STACK = newsz;
-}
-
-// utils ----------------------------------------------------------------------
-
-// apply function with n args on the stack
-static value_t _applyn(uint32_t n)
-{- value_t f = Stack[SP-n-1];
- uint32_t saveSP = SP;
- value_t v;
- if (iscbuiltin(f)) {- v = ((builtin_t*)ptr(f))[3](&Stack[SP-n], n);
- }
- else if (isfunction(f)) {- v = apply_cl(n);
- }
- else if (isbuiltin(f)) {- value_t tab = symbol_value(builtins_table_sym);
- Stack[SP-n-1] = vector_elt(tab, uintval(f));
- v = apply_cl(n);
- }
- else {- type_error("apply", "function", f);- }
- SP = saveSP;
- return v;
-}
-
-value_t fl_apply(value_t f, value_t l)
-{- value_t v = l;
- uint32_t n = SP;
-
- PUSH(f);
- while (iscons(v)) {- if (SP >= N_STACK)
- grow_stack();
- PUSH(car_(v));
- v = cdr_(v);
- }
- n = SP - n - 1;
- v = _applyn(n);
- POPN(n+1);
- return v;
-}
-
-value_t fl_applyn(uint32_t n, value_t f, ...)
-{- va_list ap;
- va_start(ap, f);
- size_t i;
-
- PUSH(f);
- while (SP+n > N_STACK)
- grow_stack();
- for(i=0; i < n; i++) {- value_t a = va_arg(ap, value_t);
- PUSH(a);
- }
- value_t v = _applyn(n);
- POPN(n+1);
- va_end(ap);
- return v;
-}
-
-value_t fl_listn(size_t n, ...)
-{- va_list ap;
- va_start(ap, n);
- uint32_t si = SP;
- size_t i;
-
- while (SP+n > N_STACK)
- grow_stack();
- for(i=0; i < n; i++) {- value_t a = va_arg(ap, value_t);
- PUSH(a);
- }
- cons_t *c = (cons_t*)alloc_words(n*2);
- cons_t *l = c;
- for(i=0; i < n; i++) {- c->car = Stack[si++];
- c->cdr = tagptr(c+1, TAG_CONS);
- c++;
- }
- (c-1)->cdr = NIL;
-
- POPN(n);
- va_end(ap);
- return tagptr(l, TAG_CONS);
-}
-
-value_t fl_list2(value_t a, value_t b)
-{- PUSH(a);
- PUSH(b);
- cons_t *c = (cons_t*)alloc_words(4);
- b = POP();
- a = POP();
- c[0].car = a;
- c[0].cdr = tagptr(c+1, TAG_CONS);
- c[1].car = b;
- c[1].cdr = NIL;
- return tagptr(c, TAG_CONS);
-}
-
-value_t fl_cons(value_t a, value_t b)
-{- PUSH(a);
- PUSH(b);
- value_t c = mk_cons();
- cdr_(c) = POP();
- car_(c) = POP();
- return c;
-}
-
-int fl_isnumber(value_t v)
-{- if (isfixnum(v)) return 1;
- if (iscprim(v)) {- cprim_t *c = (cprim_t*)ptr(v);
- return c->type != wchartype;
- }
- return 0;
-}
-
-// read -----------------------------------------------------------------------
-
-#include "read.c"
-
-// equal ----------------------------------------------------------------------
-
-#include "equal.c"
-
-// eval -----------------------------------------------------------------------
-
-#define list(a,n) _list((a),(n),0)
-
-static value_t _list(value_t *args, uint32_t nargs, int star)
-{- cons_t *c;
- uint32_t i;
- value_t v;
- v = cons_reserve(nargs);
- c = (cons_t*)ptr(v);
- for(i=0; i < nargs; i++) {- c->car = args[i];
- c->cdr = tagptr(c+1, TAG_CONS);
- c++;
- }
- if (star)
- (c-2)->cdr = (c-1)->car;
- else
- (c-1)->cdr = NIL;
- return v;
-}
-
-static value_t copy_list(value_t L)
-{- if (!iscons(L))
- return NIL;
- PUSH(NIL);
- PUSH(L);
- value_t *plcons = &Stack[SP-2];
- value_t *pL = &Stack[SP-1];
- value_t c;
- c = mk_cons(); PUSH(c); // save first cons
- car_(c) = car_(*pL);
- cdr_(c) = NIL;
- *plcons = c;
- *pL = cdr_(*pL);
- while (iscons(*pL)) {- c = mk_cons();
- car_(c) = car_(*pL);
- cdr_(c) = NIL;
- cdr_(*plcons) = c;
- *plcons = c;
- *pL = cdr_(*pL);
- }
- c = POP(); // first cons
- POPN(2);
- return c;
-}
-
-static value_t do_trycatch()
-{- uint32_t saveSP = SP;
- value_t v;
- value_t thunk = Stack[SP-2];
- Stack[SP-2] = Stack[SP-1];
- Stack[SP-1] = thunk;
-
- FL_TRY {- v = apply_cl(0);
- }
- FL_CATCH {- v = Stack[saveSP-2];
- PUSH(v);
- PUSH(fl_lasterror);
- v = apply_cl(1);
- }
- SP = saveSP;
- return v;
-}
-
-/*
- argument layout on stack is
- |--required args--|--opt args--|--kw args--|--rest args...
-*/
-static uint32_t process_keys(value_t kwtable,
- uint32_t nreq, uint32_t nkw, uint32_t nopt,
- uint32_t bp, uint32_t nargs, int va)
-{- uint32_t extr = nopt+nkw;
- uint32_t ntot = nreq+extr;
- value_t args[extr], v;
- uint32_t i, a = 0, nrestargs;
- value_t s1 = Stack[SP-1];
- value_t s2 = Stack[SP-2];
- value_t s4 = Stack[SP-4];
- value_t s5 = Stack[SP-5];
- if (nargs < nreq)
- lerror(ArgError, "apply: too few arguments");
- for (i=0; i < extr; i++) args[i] = UNBOUND;
- for (i=nreq; i < nargs; i++) {- v = Stack[bp+i];
- if (issymbol(v) && iskeyword((symbol_t*)ptr(v)))
- break;
- if (a >= nopt)
- goto no_kw;
- args[a++] = v;
- }
- if (i >= nargs) goto no_kw;
- // now process keywords
- uptrint_t n = vector_size(kwtable)/2;
- do {- i++;
- if (i >= nargs)
- lerrorf(ArgError, "keyword %s requires an argument",
- symbol_name(v));
- value_t hv = fixnum(((symbol_t*)ptr(v))->hash);
- uptrint_t x = 2*(labs(numval(hv)) % n);
- if (vector_elt(kwtable, x) == v) {- uptrint_t idx = numval(vector_elt(kwtable, x+1));
- assert(idx < nkw);
- idx += nopt;
- if (args[idx] == UNBOUND) {- // if duplicate key, keep first value
- args[idx] = Stack[bp+i];
- }
- }
- else {- lerrorf(ArgError, "unsupported keyword %s", symbol_name(v));
- }
- i++;
- if (i >= nargs) break;
- v = Stack[bp+i];
- } while (issymbol(v) && iskeyword((symbol_t*)ptr(v)));
- no_kw:
- nrestargs = nargs - i;
- if (!va && nrestargs > 0)
- lerror(ArgError, "apply: too many arguments");
- nargs = ntot + nrestargs;
- if (nrestargs)
- memmove(&Stack[bp+ntot], &Stack[bp+i], nrestargs*sizeof(value_t));
- memcpy(&Stack[bp+nreq], args, extr*sizeof(value_t));
- SP = bp + nargs;
- assert(SP < N_STACK-5);
- PUSH(s5);
- PUSH(s4);
- PUSH(nargs);
- PUSH(s2);
- PUSH(s1);
- curr_frame = SP;
- return nargs;
-}
-
-#if BYTE_ORDER == BIG_ENDIAN
-#define GET_INT32(a) \
- ((int32_t) \
- ((((int32_t)a[0])<<0) | \
- (((int32_t)a[1])<<8) | \
- (((int32_t)a[2])<<16) | \
- (((int32_t)a[3])<<24)))
-#define GET_INT16(a) \
- ((int16_t) \
- ((((int16_t)a[0])<<0) | \
- (((int16_t)a[1])<<8)))
-#define PUT_INT32(a,i) (*(int32_t*)(a) = bswap_32((int32_t)(i)))
-#else
-#define GET_INT32(a) (*(int32_t*)a)
-#define GET_INT16(a) (*(int16_t*)a)
-#define PUT_INT32(a,i) (*(int32_t*)(a) = (int32_t)(i))
-#endif
-#define SWAP_INT32(a) (*(int32_t*)(a) = bswap_32(*(int32_t*)(a)))
-#define SWAP_INT16(a) (*(int16_t*)(a) = bswap_16(*(int16_t*)(a)))
-
-#ifdef USE_COMPUTED_GOTO
-#define OP(x) L_##x:
-#define NEXT_OP goto *vm_labels[*ip++]
-#else
-#define OP(x) case x:
-#define NEXT_OP goto next_op
-#endif
-
-/*
- stack on entry: <func> <nargs args...>
- caller's responsibility:
- - put the stack in this state
- - provide arg count
- - respect tail position
- - restore SP
-
- callee's responsibility:
- - check arg counts
- - allocate vararg array
- - push closed env, set up new environment
-*/
-static value_t apply_cl(uint32_t nargs)
-{- VM_LABELS;
- VM_APPLY_LABELS;
- uint32_t top_frame = curr_frame;
- // frame variables
- uint32_t n=0, captured;
- uint32_t bp;
- const uint8_t *ip;
- fixnum_t s, hi;
-
- // temporary variables (not necessary to preserve across calls)
-#ifndef USE_COMPUTED_GOTO
- uint32_t op;
-#endif
- uint32_t i;
- symbol_t *sym;
- static cons_t *c;
- static value_t *pv;
- static int64_t accum;
- static value_t func, v, e;
-
- apply_cl_top:
- captured = 0;
- func = Stack[SP-nargs-1];
- ip = cv_data((cvalue_t*)ptr(fn_bcode(func)));
- assert(!ismanaged((uptrint_t)ip));
- while (SP+GET_INT32(ip) > N_STACK) {- grow_stack();
- }
- ip += 4;
-
- bp = SP-nargs;
- PUSH(fn_env(func));
- PUSH(curr_frame);
- PUSH(nargs);
- SP++;//PUSH(0); //ip
- PUSH(0); //captured?
- curr_frame = SP;
-
- {-#ifdef USE_COMPUTED_GOTO
- {- NEXT_OP;
-#else
- next_op:
- op = *ip++;
- dispatch:
- switch (op) {-#endif
- OP(OP_ARGC)
- n = *ip++;
- do_argc:
- if (nargs != n) {- if (nargs > n)
- lerror(ArgError, "apply: too many arguments");
- else
- lerror(ArgError, "apply: too few arguments");
- }
- NEXT_OP;
- OP(OP_VARGC)
- i = *ip++;
- do_vargc:
- s = (fixnum_t)nargs - (fixnum_t)i;
- if (s > 0) {- v = list(&Stack[bp+i], s);
- Stack[bp+i] = v;
- if (s > 1) {- Stack[bp+i+1] = Stack[bp+nargs+0];
- Stack[bp+i+2] = Stack[bp+nargs+1];
- Stack[bp+i+3] = i+1;
- //Stack[bp+i+4] = 0;
- Stack[bp+i+5] = 0;
- SP = bp+i+6;
- curr_frame = SP;
- }
- }
- else if (s < 0) {- lerror(ArgError, "apply: too few arguments");
- }
- else {- PUSH(0);
- Stack[SP-3] = i+1;
- Stack[SP-4] = Stack[SP-5];
- Stack[SP-5] = Stack[SP-6];
- Stack[SP-6] = NIL;
- curr_frame = SP;
- }
- nargs = i+1;
- NEXT_OP;
- OP(OP_LARGC)
- n = GET_INT32(ip); ip+=4;
- goto do_argc;
- OP(OP_LVARGC)
- i = GET_INT32(ip); ip+=4;
- goto do_vargc;
- OP(OP_BRBOUND)
- i = GET_INT32(ip); ip+=4;
- if (captured)
- v = vector_elt(Stack[bp], i);
- else
- v = Stack[bp+i];
- if (v != UNBOUND) PUSH(FL_T);
- else PUSH(FL_F);
- NEXT_OP;
- OP(OP_DUP) SP++; Stack[SP-1] = Stack[SP-2]; NEXT_OP;
- OP(OP_POP) POPN(1); NEXT_OP;
- OP(OP_TCALL)
- n = *ip++; // nargs
- do_tcall:
- func = Stack[SP-n-1];
- if (tag(func) == TAG_FUNCTION) {- if (func > (N_BUILTINS<<3)) {- curr_frame = Stack[curr_frame-4];
- for(s=-1; s < (fixnum_t)n; s++)
- Stack[bp+s] = Stack[SP-n+s];
- SP = bp+n;
- nargs = n;
- goto apply_cl_top;
- }
- else {- i = uintval(func);
- if (i <= OP_ASET) {- s = builtin_arg_counts[i];
- if (s >= 0)
- argcount(builtin_names[i], n, s);
- else if (s != ANYARGS && (signed)n < -s)
- argcount(builtin_names[i], n, -s);
- // remove function arg
- for(s=SP-n-1; s < (int)SP-1; s++)
- Stack[s] = Stack[s+1];
- SP--;
-#ifdef USE_COMPUTED_GOTO
- if (i == OP_APPLY)
- goto apply_tapply;
- goto *vm_apply_labels[i];
-#else
- switch (i) {- case OP_LIST: goto apply_list;
- case OP_VECTOR: goto apply_vector;
- case OP_APPLY: goto apply_tapply;
- case OP_ADD: goto apply_add;
- case OP_SUB: goto apply_sub;
- case OP_MUL: goto apply_mul;
- case OP_DIV: goto apply_div;
- default:
- op = (uint8_t)i;
- goto dispatch;
- }
-#endif
- }
- }
- }
- else if (iscbuiltin(func)) {- s = SP;
- v = ((builtin_t)(((void**)ptr(func))[3]))(&Stack[SP-n], n);
- SP = s-n;
- Stack[SP-1] = v;
- NEXT_OP;
- }
- type_error("apply", "function", func);- // WARNING: repeated code ahead
- OP(OP_CALL)
- n = *ip++; // nargs
- do_call:
- func = Stack[SP-n-1];
- if (tag(func) == TAG_FUNCTION) {- if (func > (N_BUILTINS<<3)) {- Stack[curr_frame-2] = (uptrint_t)ip;
- nargs = n;
- goto apply_cl_top;
- }
- else {- i = uintval(func);
- if (i <= OP_ASET) {- s = builtin_arg_counts[i];
- if (s >= 0)
- argcount(builtin_names[i], n, s);
- else if (s != ANYARGS && (signed)n < -s)
- argcount(builtin_names[i], n, -s);
- // remove function arg
- for(s=SP-n-1; s < (int)SP-1; s++)
- Stack[s] = Stack[s+1];
- SP--;
-#ifdef USE_COMPUTED_GOTO
- goto *vm_apply_labels[i];
-#else
- switch (i) {- case OP_LIST: goto apply_list;
- case OP_VECTOR: goto apply_vector;
- case OP_APPLY: goto apply_apply;
- case OP_ADD: goto apply_add;
- case OP_SUB: goto apply_sub;
- case OP_MUL: goto apply_mul;
- case OP_DIV: goto apply_div;
- default:
- op = (uint8_t)i;
- goto dispatch;
- }
-#endif
- }
- }
- }
- else if (iscbuiltin(func)) {- s = SP;
- v = ((builtin_t)(((void**)ptr(func))[3]))(&Stack[SP-n], n);
- SP = s-n;
- Stack[SP-1] = v;
- NEXT_OP;
- }
- type_error("apply", "function", func);- OP(OP_TCALLL) n = GET_INT32(ip); ip+=4; goto do_tcall;
- OP(OP_CALLL) n = GET_INT32(ip); ip+=4; goto do_call;
- OP(OP_JMP) ip += (ptrint_t)GET_INT16(ip); NEXT_OP;
- OP(OP_BRF)
- v = POP();
- if (v == FL_F) ip += (ptrint_t)GET_INT16(ip);
- else ip += 2;
- NEXT_OP;
- OP(OP_BRT)
- v = POP();
- if (v != FL_F) ip += (ptrint_t)GET_INT16(ip);
- else ip += 2;
- NEXT_OP;
- OP(OP_JMPL) ip += (ptrint_t)GET_INT32(ip); NEXT_OP;
- OP(OP_BRFL)
- v = POP();
- if (v == FL_F) ip += (ptrint_t)GET_INT32(ip);
- else ip += 4;
- NEXT_OP;
- OP(OP_BRTL)
- v = POP();
- if (v != FL_F) ip += (ptrint_t)GET_INT32(ip);
- else ip += 4;
- NEXT_OP;
- OP(OP_BRNE)
- if (Stack[SP-2] != Stack[SP-1]) ip += (ptrint_t)GET_INT16(ip);
- else ip += 2;
- POPN(2);
- NEXT_OP;
- OP(OP_BRNEL)
- if (Stack[SP-2] != Stack[SP-1]) ip += (ptrint_t)GET_INT32(ip);
- else ip += 4;
- POPN(2);
- NEXT_OP;
- OP(OP_BRNN)
- v = POP();
- if (v != NIL) ip += (ptrint_t)GET_INT16(ip);
- else ip += 2;
- NEXT_OP;
- OP(OP_BRNNL)
- v = POP();
- if (v != NIL) ip += (ptrint_t)GET_INT32(ip);
- else ip += 4;
- NEXT_OP;
- OP(OP_BRN)
- v = POP();
- if (v == NIL) ip += (ptrint_t)GET_INT16(ip);
- else ip += 2;
- NEXT_OP;
- OP(OP_BRNL)
- v = POP();
- if (v == NIL) ip += (ptrint_t)GET_INT32(ip);
- else ip += 4;
- NEXT_OP;
- OP(OP_RET)
- v = POP();
- SP = curr_frame;
- curr_frame = Stack[SP-4];
- if (curr_frame == top_frame) return v;
- SP -= (5+nargs);
- captured = Stack[curr_frame-1];
- ip = (uint8_t*)Stack[curr_frame-2];
- nargs = Stack[curr_frame-3];
- bp = curr_frame - 5 - nargs;
- Stack[SP-1] = v;
- NEXT_OP;
-
- OP(OP_EQ)
- Stack[SP-2] = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F);
- POPN(1); NEXT_OP;
- OP(OP_EQV)
- if (Stack[SP-2] == Stack[SP-1]) {- v = FL_T;
- }
- else if (!leafp(Stack[SP-2]) || !leafp(Stack[SP-1])) {- v = FL_F;
- }
- else {- v = (compare_(Stack[SP-2], Stack[SP-1], 1)==0 ? FL_T : FL_F);
- }
- Stack[SP-2] = v; POPN(1);
- NEXT_OP;
- OP(OP_EQUAL)
- if (Stack[SP-2] == Stack[SP-1]) {- v = FL_T;
- }
- else {- v = (compare_(Stack[SP-2], Stack[SP-1], 1)==0 ? FL_T : FL_F);
- }
- Stack[SP-2] = v; POPN(1);
- NEXT_OP;
- OP(OP_PAIRP)
- Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_T : FL_F); NEXT_OP;
- OP(OP_ATOMP)
- Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_F : FL_T); NEXT_OP;
- OP(OP_NOT)
- Stack[SP-1] = ((Stack[SP-1]==FL_F) ? FL_T : FL_F); NEXT_OP;
- OP(OP_NULLP)
- Stack[SP-1] = ((Stack[SP-1]==NIL) ? FL_T : FL_F); NEXT_OP;
- OP(OP_BOOLEANP)
- v = Stack[SP-1];
- Stack[SP-1] = ((v == FL_T || v == FL_F) ? FL_T:FL_F); NEXT_OP;
- OP(OP_SYMBOLP)
- Stack[SP-1] = (issymbol(Stack[SP-1]) ? FL_T : FL_F); NEXT_OP;
- OP(OP_NUMBERP)
- v = Stack[SP-1];
- Stack[SP-1] = (fl_isnumber(v) ? FL_T:FL_F); NEXT_OP;
- OP(OP_FIXNUMP)
- Stack[SP-1] = (isfixnum(Stack[SP-1]) ? FL_T : FL_F); NEXT_OP;
- OP(OP_BOUNDP)
- sym = tosymbol(Stack[SP-1], "bound?");
- Stack[SP-1] = ((sym->binding == UNBOUND) ? FL_F : FL_T);
- NEXT_OP;
- OP(OP_BUILTINP)
- v = Stack[SP-1];
- Stack[SP-1] = (isbuiltin(v) || iscbuiltin(v)) ? FL_T : FL_F;
- NEXT_OP;
- OP(OP_FUNCTIONP)
- v = Stack[SP-1];
- Stack[SP-1] = ((tag(v)==TAG_FUNCTION &&
- (uintval(v)<=OP_ASET || v>(N_BUILTINS<<3))) ||
- iscbuiltin(v)) ? FL_T : FL_F;
- NEXT_OP;
- OP(OP_VECTORP)
- Stack[SP-1] = (isvector(Stack[SP-1]) ? FL_T : FL_F); NEXT_OP;
-
- OP(OP_CONS)
- if (curheap > lim)
- gc(0);
- c = (cons_t*)curheap;
- curheap += sizeof(cons_t);
- c->car = Stack[SP-2];
- c->cdr = Stack[SP-1];
- Stack[SP-2] = tagptr(c, TAG_CONS);
- POPN(1); NEXT_OP;
- OP(OP_CAR)
- v = Stack[SP-1];
- if (!iscons(v)) type_error("car", "cons", v);- Stack[SP-1] = car_(v);
- NEXT_OP;
- OP(OP_CDR)
- v = Stack[SP-1];
- if (!iscons(v)) type_error("cdr", "cons", v);- Stack[SP-1] = cdr_(v);
- NEXT_OP;
- OP(OP_CADR)
- v = Stack[SP-1];
- if (!iscons(v)) type_error("cdr", "cons", v);- v = cdr_(v);
- if (!iscons(v)) type_error("car", "cons", v);- Stack[SP-1] = car_(v);
- NEXT_OP;
- OP(OP_SETCAR)
- car(Stack[SP-2]) = Stack[SP-1];
- POPN(1); NEXT_OP;
- OP(OP_SETCDR)
- cdr(Stack[SP-2]) = Stack[SP-1];
- POPN(1); NEXT_OP;
- OP(OP_LIST)
- n = *ip++;
- apply_list:
- if (n > 0) {- v = list(&Stack[SP-n], n);
- POPN(n);
- PUSH(v);
- }
- else {- PUSH(NIL);
- }
- NEXT_OP;
-
- OP(OP_TAPPLY)
- n = *ip++;
- apply_tapply:
- v = POP(); // arglist
- n = SP-(n-2); // n-2 == # leading arguments not in the list
- while (iscons(v)) {- if (SP >= N_STACK)
- grow_stack();
- PUSH(car_(v));
- v = cdr_(v);
- }
- n = SP-n;
- goto do_tcall;
- OP(OP_APPLY)
- n = *ip++;
- apply_apply:
- v = POP(); // arglist
- n = SP-(n-2); // n-2 == # leading arguments not in the list
- while (iscons(v)) {- if (SP >= N_STACK)
- grow_stack();
- PUSH(car_(v));
- v = cdr_(v);
- }
- n = SP-n;
- goto do_call;
-
- OP(OP_ADD)
- n = *ip++;
- apply_add:
- s = 0;
- i = SP-n;
- for (; i < SP; i++) {- if (isfixnum(Stack[i])) {- s += numval(Stack[i]);
- if (!fits_fixnum(s)) {- i++;
- goto add_ovf;
- }
- }
- else {- add_ovf:
- v = fl_add_any(&Stack[i], SP-i, s);
- break;
- }
- }
- if (i==SP)
- v = fixnum(s);
- POPN(n);
- PUSH(v);
- NEXT_OP;
- OP(OP_ADD2)
- if (bothfixnums(Stack[SP-1], Stack[SP-2])) {- s = numval(Stack[SP-1]) + numval(Stack[SP-2]);
- if (fits_fixnum(s))
- v = fixnum(s);
- else
- v = mk_long(s);
- }
- else {- v = fl_add_any(&Stack[SP-2], 2, 0);
- }
- POPN(1);
- Stack[SP-1] = v;
- NEXT_OP;
- OP(OP_SUB)
- n = *ip++;
- apply_sub:
- if (n == 2) goto do_sub2;
- if (n == 1) goto do_neg;
- i = SP-n;
- // we need to pass the full arglist on to fl_add_any
- // so it can handle rest args properly
- PUSH(Stack[i]);
- Stack[i] = fixnum(0);
- Stack[i+1] = fl_neg(fl_add_any(&Stack[i], n, 0));
- Stack[i] = POP();
- v = fl_add_any(&Stack[i], 2, 0);
- POPN(n);
- PUSH(v);
- NEXT_OP;
- OP(OP_NEG)
- do_neg:
- if (isfixnum(Stack[SP-1]))
- Stack[SP-1] = fixnum(-numval(Stack[SP-1]));
- else
- Stack[SP-1] = fl_neg(Stack[SP-1]);
- NEXT_OP;
- OP(OP_SUB2)
- do_sub2:
- if (bothfixnums(Stack[SP-2], Stack[SP-1])) {- s = numval(Stack[SP-2]) - numval(Stack[SP-1]);
- if (fits_fixnum(s))
- v = fixnum(s);
- else
- v = mk_long(s);
- }
- else {- Stack[SP-1] = fl_neg(Stack[SP-1]);
- v = fl_add_any(&Stack[SP-2], 2, 0);
- }
- POPN(1);
- Stack[SP-1] = v;
- NEXT_OP;
- OP(OP_MUL)
- n = *ip++;
- apply_mul:
- accum = 1;
- i = SP-n;
- for (; i < SP; i++) {- if (isfixnum(Stack[i])) {- accum *= numval(Stack[i]);
- }
- else {- v = fl_mul_any(&Stack[i], SP-i, accum);
- break;
- }
- }
- if (i == SP) {- if (fits_fixnum(accum))
- v = fixnum(accum);
- else
- v = return_from_int64(accum);
- }
- POPN(n);
- PUSH(v);
- NEXT_OP;
- OP(OP_DIV)
- n = *ip++;
- apply_div:
- i = SP-n;
- if (n == 1) {- Stack[SP-1] = fl_div2(fixnum(1), Stack[i]);
- }
- else {- if (n > 2) {- PUSH(Stack[i]);
- Stack[i] = fixnum(1);
- Stack[i+1] = fl_mul_any(&Stack[i], n, 1);
- Stack[i] = POP();
- }
- v = fl_div2(Stack[i], Stack[i+1]);
- POPN(n);
- PUSH(v);
- }
- NEXT_OP;
- OP(OP_IDIV)
- v = Stack[SP-2]; e = Stack[SP-1];
- if (bothfixnums(v, e)) {- if (e==0) DivideByZeroError();
- v = fixnum(numval(v) / numval(e));
- }
- else
- v = fl_idiv2(v, e);
- POPN(1);
- Stack[SP-1] = v;
- NEXT_OP;
- OP(OP_NUMEQ)
- v = Stack[SP-2]; e = Stack[SP-1];
- if (bothfixnums(v, e))
- v = (v == e) ? FL_T : FL_F;
- else
- v = (!numeric_compare(v,e,1,0,"=")) ? FL_T : FL_F;
- POPN(1);
- Stack[SP-1] = v;
- NEXT_OP;
- OP(OP_LT)
- if (bothfixnums(Stack[SP-2], Stack[SP-1])) {- v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? FL_T : FL_F;
- }
- else {- v = (numval(fl_compare(Stack[SP-2], Stack[SP-1])) < 0) ?
- FL_T : FL_F;
- }
- POPN(1);
- Stack[SP-1] = v;
- NEXT_OP;
- OP(OP_COMPARE)
- Stack[SP-2] = compare_(Stack[SP-2], Stack[SP-1], 0);
- POPN(1);
- NEXT_OP;
-
- OP(OP_VECTOR)
- n = *ip++;
- apply_vector:
- v = alloc_vector(n, 0);
- if (n) {- memcpy(&vector_elt(v,0), &Stack[SP-n], n*sizeof(value_t));
- POPN(n);
- }
- PUSH(v);
- NEXT_OP;
-
- OP(OP_AREF)
- v = Stack[SP-2];
- if (isvector(v)) {- e = Stack[SP-1];
- if (isfixnum(e))
- i = numval(e);
- else
- i = (uint32_t)toulong(e, "aref");
- if ((unsigned)i >= vector_size(v))
- bounds_error("aref", v, e);- v = vector_elt(v, i);
- }
- else if (isarray(v)) {- v = cvalue_array_aref(&Stack[SP-2]);
- }
- else {- type_error("aref", "sequence", v);- }
- POPN(1);
- Stack[SP-1] = v;
- NEXT_OP;
- OP(OP_ASET)
- e = Stack[SP-3];
- if (isvector(e)) {- i = tofixnum(Stack[SP-2], "aset!");
- if ((unsigned)i >= vector_size(e))
- bounds_error("aset!", v, Stack[SP-1]);- vector_elt(e, i) = (v=Stack[SP-1]);
- }
- else if (isarray(e)) {- v = cvalue_array_aset(&Stack[SP-3]);
- }
- else {- type_error("aset!", "sequence", e);- }
- POPN(2);
- Stack[SP-1] = v;
- NEXT_OP;
- OP(OP_FOR)
- s = tofixnum(Stack[SP-3], "for");
- hi = tofixnum(Stack[SP-2], "for");
- //f = Stack[SP-1];
- v = FL_UNSPECIFIED;
- SP += 2;
- n = SP;
- for(; s <= hi; s++) {- Stack[SP-2] = Stack[SP-3];
- Stack[SP-1] = fixnum(s);
- v = apply_cl(1);
- SP = n;
- }
- POPN(4);
- Stack[SP-1] = v;
- NEXT_OP;
-
- OP(OP_LOADT) PUSH(FL_T); NEXT_OP;
- OP(OP_LOADF) PUSH(FL_F); NEXT_OP;
- OP(OP_LOADNIL) PUSH(NIL); NEXT_OP;
- OP(OP_LOAD0) PUSH(fixnum(0)); NEXT_OP;
- OP(OP_LOAD1) PUSH(fixnum(1)); NEXT_OP;
- OP(OP_LOADI8) s = (int8_t)*ip++; PUSH(fixnum(s)); NEXT_OP;
- OP(OP_LOADV)
- v = fn_vals(Stack[bp-1]);
- assert(*ip < vector_size(v));
- v = vector_elt(v, *ip); ip++;
- PUSH(v);
- NEXT_OP;
- OP(OP_LOADVL)
- v = fn_vals(Stack[bp-1]);
- v = vector_elt(v, GET_INT32(ip)); ip+=4;
- PUSH(v);
- NEXT_OP;
- OP(OP_LOADGL)
- v = fn_vals(Stack[bp-1]);
- v = vector_elt(v, GET_INT32(ip)); ip+=4;
- goto do_loadg;
- OP(OP_LOADG)
- v = fn_vals(Stack[bp-1]);
- assert(*ip < vector_size(v));
- v = vector_elt(v, *ip); ip++;
- do_loadg:
- assert(issymbol(v));
- sym = (symbol_t*)ptr(v);
- if (sym->binding == UNBOUND)
- fl_raise(fl_list2(UnboundError, v));
- PUSH(sym->binding);
- NEXT_OP;
-
- OP(OP_SETGL)
- v = fn_vals(Stack[bp-1]);
- v = vector_elt(v, GET_INT32(ip)); ip+=4;
- goto do_setg;
- OP(OP_SETG)
- v = fn_vals(Stack[bp-1]);
- assert(*ip < vector_size(v));
- v = vector_elt(v, *ip); ip++;
- do_setg:
- assert(issymbol(v));
- sym = (symbol_t*)ptr(v);
- v = Stack[SP-1];
- if (!isconstant(sym))
- sym->binding = v;
- NEXT_OP;
-
- OP(OP_LOADA)
- assert(nargs > 0);
- i = *ip++;
- if (captured) {- e = Stack[bp];
- assert(isvector(e));
- assert(i < vector_size(e));
- v = vector_elt(e, i);
- }
- else {- v = Stack[bp+i];
- }
- PUSH(v);
- NEXT_OP;
- OP(OP_LOADA0)
- if (captured)
- v = vector_elt(Stack[bp], 0);
- else
- v = Stack[bp];
- PUSH(v);
- NEXT_OP;
- OP(OP_LOADA1)
- if (captured)
- v = vector_elt(Stack[bp], 1);
- else
- v = Stack[bp+1];
- PUSH(v);
- NEXT_OP;
- OP(OP_LOADAL)
- assert(nargs > 0);
- i = GET_INT32(ip); ip+=4;
- if (captured)
- v = vector_elt(Stack[bp], i);
- else
- v = Stack[bp+i];
- PUSH(v);
- NEXT_OP;
- OP(OP_SETA)
- assert(nargs > 0);
- v = Stack[SP-1];
- i = *ip++;
- if (captured) {- e = Stack[bp];
- assert(isvector(e));
- assert(i < vector_size(e));
- vector_elt(e, i) = v;
- }
- else {- Stack[bp+i] = v;
- }
- NEXT_OP;
- OP(OP_SETAL)
- assert(nargs > 0);
- v = Stack[SP-1];
- i = GET_INT32(ip); ip+=4;
- if (captured)
- vector_elt(Stack[bp], i) = v;
- else
- Stack[bp+i] = v;
- NEXT_OP;
- OP(OP_LOADC)
- s = *ip++;
- i = *ip++;
- v = Stack[bp+nargs];
- while (s--)
- v = vector_elt(v, vector_size(v)-1);
- assert(isvector(v));
- assert(i < vector_size(v));
- PUSH(vector_elt(v, i));
- NEXT_OP;
- OP(OP_SETC)
- s = *ip++;
- i = *ip++;
- v = Stack[bp+nargs];
- while (s--)
- v = vector_elt(v, vector_size(v)-1);
- assert(isvector(v));
- assert(i < vector_size(v));
- vector_elt(v, i) = Stack[SP-1];
- NEXT_OP;
- OP(OP_LOADC00)
- PUSH(vector_elt(Stack[bp+nargs], 0));
- NEXT_OP;
- OP(OP_LOADC01)
- PUSH(vector_elt(Stack[bp+nargs], 1));
- NEXT_OP;
- OP(OP_LOADCL)
- s = GET_INT32(ip); ip+=4;
- i = GET_INT32(ip); ip+=4;
- v = Stack[bp+nargs];
- while (s--)
- v = vector_elt(v, vector_size(v)-1);
- PUSH(vector_elt(v, i));
- NEXT_OP;
- OP(OP_SETCL)
- s = GET_INT32(ip); ip+=4;
- i = GET_INT32(ip); ip+=4;
- v = Stack[bp+nargs];
- while (s--)
- v = vector_elt(v, vector_size(v)-1);
- assert(i < vector_size(v));
- vector_elt(v, i) = Stack[SP-1];
- NEXT_OP;
-
- OP(OP_CLOSURE)
- // build a closure (lambda args body . env)
- if (nargs > 0 && !captured) {- // save temporary environment to the heap
- n = nargs;
- pv = alloc_words(n + 2);
- PUSH(tagptr(pv, TAG_VECTOR));
- pv[0] = fixnum(n+1);
- pv++;
- do {- pv[n] = Stack[bp+n];
- } while (n--);
- // environment representation changed; install
- // the new representation so everybody can see it
- captured = 1;
- Stack[curr_frame-1] = 1;
- Stack[bp] = Stack[SP-1];
- }
- else {- PUSH(Stack[bp]); // env has already been captured; share
- }
- if (curheap > lim-2)
- gc(0);
- pv = (value_t*)curheap;
- curheap += (4*sizeof(value_t));
- e = Stack[SP-2]; // closure to copy
- assert(isfunction(e));
- pv[0] = ((value_t*)ptr(e))[0];
- pv[1] = ((value_t*)ptr(e))[1];
- pv[2] = Stack[SP-1]; // env
- pv[3] = ((value_t*)ptr(e))[3];
- POPN(1);
- Stack[SP-1] = tagptr(pv, TAG_FUNCTION);
- NEXT_OP;
-
- OP(OP_TRYCATCH)
- v = do_trycatch();
- POPN(1);
- Stack[SP-1] = v;
- NEXT_OP;
-
- OP(OP_OPTARGS)
- i = GET_INT32(ip); ip+=4;
- n = GET_INT32(ip); ip+=4;
- if (nargs < i)
- lerror(ArgError, "apply: too few arguments");
- if ((int32_t)n > 0) {- if (nargs > n)
- lerror(ArgError, "apply: too many arguments");
- }
- else n = -n;
- if (n > nargs) {- n -= nargs;
- SP += n;
- Stack[SP-1] = Stack[SP-n-1];
- Stack[SP-2] = Stack[SP-n-2];
- Stack[SP-3] = nargs+n;
- Stack[SP-4] = Stack[SP-n-4];
- Stack[SP-5] = Stack[SP-n-5];
- curr_frame = SP;
- for(i=0; i < n; i++) {- Stack[bp+nargs+i] = UNBOUND;
- }
- nargs += n;
- }
- NEXT_OP;
- OP(OP_KEYARGS)
- v = fn_vals(Stack[bp-1]);
- v = vector_elt(v, 0);
- i = GET_INT32(ip); ip+=4;
- n = GET_INT32(ip); ip+=4;
- s = GET_INT32(ip); ip+=4;
- nargs = process_keys(v, i, n, abs(s)-(i+n), bp, nargs, s<0);
- NEXT_OP;
-
-#ifndef USE_COMPUTED_GOTO
- default:
- goto dispatch;
-#endif
- }
- }
-#ifdef USE_COMPUTED_GOTO
- return UNBOUND; // not reached
-#else
- goto dispatch;
-#endif
-}
-
-static uint32_t compute_maxstack(uint8_t *code, size_t len, int bswap)
-{- uint8_t *ip = code+4, *end = code+len;
- uint8_t op;
- uint32_t i, n, sp = 0, maxsp = 0;
-
- while (1) {- if ((int32_t)sp > (int32_t)maxsp) maxsp = sp;
- if (ip >= end) break;
- op = *ip++;
- switch (op) {- case OP_ARGC:
- n = *ip++;
- break;
- case OP_VARGC:
- n = *ip++;
- sp += (n+2);
- break;
- case OP_LARGC:
- if (bswap) SWAP_INT32(ip);
- n = GET_INT32(ip); ip+=4;
- break;
- case OP_LVARGC:
- if (bswap) SWAP_INT32(ip);
- n = GET_INT32(ip); ip+=4;
- sp += (n+2);
- break;
- case OP_OPTARGS:
- if (bswap) SWAP_INT32(ip);
- i = GET_INT32(ip); ip+=4;
- if (bswap) SWAP_INT32(ip);
- n = abs(GET_INT32(ip)); ip+=4;
- sp += (n-i);
- break;
- case OP_KEYARGS:
- if (bswap) SWAP_INT32(ip);
- i = GET_INT32(ip); ip+=4;
- if (bswap) SWAP_INT32(ip);
- n = GET_INT32(ip); ip+=4;
- if (bswap) SWAP_INT32(ip);
- n = abs(GET_INT32(ip)); ip+=4;
- sp += (n-i);
- break;
- case OP_BRBOUND:
- if (bswap) SWAP_INT32(ip);
- ip+=4;
- sp++;
- break;
-
- case OP_TCALL: case OP_CALL:
- n = *ip++; // nargs
- sp -= n;
- break;
- case OP_TCALLL: case OP_CALLL:
- if (bswap) SWAP_INT32(ip);
- n = GET_INT32(ip); ip+=4;
- sp -= n;
- break;
- case OP_JMP:
- if (bswap) SWAP_INT16(ip);
- ip += 2; break;
- case OP_JMPL:
- if (bswap) SWAP_INT32(ip);
- ip += 4; break;
- case OP_BRF: case OP_BRT:
- if (bswap) SWAP_INT16(ip);
- ip+=2;
- sp--;
- break;
- case OP_BRFL: case OP_BRTL:
- if (bswap) SWAP_INT32(ip);
- ip += 4;
- sp--;
- break;
- case OP_BRNE:
- if (bswap) SWAP_INT16(ip);
- ip += 2;
- sp -= 2;
- break;
- case OP_BRNEL:
- if (bswap) SWAP_INT32(ip);
- ip += 4;
- sp -= 2;
- break;
- case OP_BRNN: case OP_BRN:
- if (bswap) SWAP_INT16(ip);
- ip += 2;
- sp--;
- break;
- case OP_BRNNL: case OP_BRNL:
- if (bswap) SWAP_INT32(ip);
- ip += 4;
- sp--;
- break;
- case OP_RET: sp--; break;
-
- case OP_CONS: case OP_SETCAR: case OP_SETCDR: case OP_POP:
- case OP_EQ: case OP_EQV: case OP_EQUAL: case OP_ADD2: case OP_SUB2:
- case OP_IDIV: case OP_NUMEQ: case OP_LT: case OP_COMPARE:
- case OP_AREF: case OP_TRYCATCH:
- sp--;
- break;
-
- case OP_PAIRP: case OP_ATOMP: case OP_NOT: case OP_NULLP:
- case OP_BOOLEANP: case OP_SYMBOLP: case OP_NUMBERP: case OP_FIXNUMP:
- case OP_BOUNDP: case OP_BUILTINP: case OP_FUNCTIONP: case OP_VECTORP:
- case OP_NOP: case OP_CAR: case OP_CDR: case OP_NEG: case OP_CLOSURE:
- break;
-
- case OP_TAPPLY: case OP_APPLY:
- n = *ip++;
- sp -= (n-1);
- break;
-
- case OP_LIST: case OP_ADD: case OP_SUB: case OP_MUL: case OP_DIV:
- case OP_VECTOR:
- n = *ip++;
- sp -= (n-1);
- break;
-
- case OP_ASET:
- sp -= 2;
- break;
- case OP_FOR:
- if (sp+2 > maxsp) maxsp = sp+2;
- sp -=2;
- break;
-
- case OP_LOADT: case OP_LOADF: case OP_LOADNIL: case OP_LOAD0:
- case OP_LOAD1: case OP_LOADA0: case OP_LOADA1: case OP_LOADC00:
- case OP_LOADC01: case OP_DUP:
- sp++;
- break;
-
- case OP_LOADI8: case OP_LOADV: case OP_LOADG: case OP_LOADA:
- ip++;
- sp++;
- break;
- case OP_LOADVL: case OP_LOADGL: case OP_LOADAL:
- if (bswap) SWAP_INT32(ip);
- ip+=4;
- sp++;
- break;
-
- case OP_SETG: case OP_SETA:
- ip++;
- break;
- case OP_SETGL: case OP_SETAL:
- if (bswap) SWAP_INT32(ip);
- ip+=4;
- break;
-
- case OP_LOADC: ip+=2; sp++; break;
- case OP_SETC:
- ip+=2;
- break;
- case OP_LOADCL:
- if (bswap) SWAP_INT32(ip);
- ip+=4;
- if (bswap) SWAP_INT32(ip);
- ip+=4;
- sp++; break;
- case OP_SETCL:
- if (bswap) SWAP_INT32(ip);
- ip+=4;
- if (bswap) SWAP_INT32(ip);
- ip+=4;
- break;
- }
- }
- return maxsp+5;
-}
-
-// top = top frame pointer to start at
-static value_t _stacktrace(uint32_t top)
-{- uint32_t bp, sz;
- value_t v, lst = NIL;
- fl_gc_handle(&lst);
- while (top > 0) {- sz = Stack[top-3]+1;
- bp = top-5-sz;
- v = alloc_vector(sz, 0);
- if (Stack[top-1] /*captured*/) {- vector_elt(v, 0) = Stack[bp];
- memcpy(&vector_elt(v, 1),
- &vector_elt(Stack[bp+1],0), (sz-1)*sizeof(value_t));
- }
- else {- memcpy(&vector_elt(v,0), &Stack[bp], sz*sizeof(value_t));
- }
- lst = fl_cons(v, lst);
- top = Stack[top-4];
- }
- fl_free_gc_handles(1);
- return lst;
-}
-
-// builtins -------------------------------------------------------------------
-
-void assign_global_builtins(builtinspec_t *b)
-{- while (b->name != NULL) {- set(symbol(b->name), cbuiltin(b->name, b->fptr));
- b++;
- }
-}
-
-static value_t fl_function(value_t *args, uint32_t nargs)
-{- if (nargs == 1 && issymbol(args[0]))
- return fl_builtin(args, nargs);
- if (nargs < 2 || nargs > 4)
- argcount("function", nargs, 2);- if (!fl_isstring(args[0]))
- type_error("function", "string", args[0]);- if (!isvector(args[1]))
- type_error("function", "vector", args[1]);- cvalue_t *arr = (cvalue_t*)ptr(args[0]);
- cv_pin(arr);
- char *data = cv_data(arr);
- int swap = 0;
- if ((uint8_t)data[4] >= N_OPCODES) {- // read syntax, shifted 48 for compact text representation
- size_t i, sz = cv_len(arr);
- for(i=0; i < sz; i++)
- data[i] -= 48;
- }
- else {-#if BYTE_ORDER == BIG_ENDIAN
- swap = 1;
-#endif
- }
- uint32_t ms = compute_maxstack((uint8_t*)data, cv_len(arr), swap);
- PUT_INT32(data, ms);
- function_t *fn = (function_t*)alloc_words(4);
- value_t fv = tagptr(fn, TAG_FUNCTION);
- fn->bcode = args[0];
- fn->vals = args[1];
- fn->env = NIL;
- fn->name = LAMBDA;
- if (nargs > 2) {- if (issymbol(args[2])) {- fn->name = args[2];
- if (nargs > 3)
- fn->env = args[3];
- }
- else {- fn->env = args[2];
- if (nargs > 3) {- if (!issymbol(args[3]))
- type_error("function", "symbol", args[3]);- fn->name = args[3];
- }
- }
- if (isgensym(fn->name))
- lerror(ArgError, "function: name should not be a gensym");
- }
- return fv;
-}
-
-static value_t fl_function_code(value_t *args, uint32_t nargs)
-{- argcount("function:code", nargs, 1);- value_t v = args[0];
- if (!isclosure(v)) type_error("function:code", "function", v);- return fn_bcode(v);
-}
-static value_t fl_function_vals(value_t *args, uint32_t nargs)
-{- argcount("function:vals", nargs, 1);- value_t v = args[0];
- if (!isclosure(v)) type_error("function:vals", "function", v);- return fn_vals(v);
-}
-static value_t fl_function_env(value_t *args, uint32_t nargs)
-{- argcount("function:env", nargs, 1);- value_t v = args[0];
- if (!isclosure(v)) type_error("function:env", "function", v);- return fn_env(v);
-}
-static value_t fl_function_name(value_t *args, uint32_t nargs)
-{- argcount("function:name", nargs, 1);- value_t v = args[0];
- if (!isclosure(v)) type_error("function:name", "function", v);- return fn_name(v);
-}
-
-value_t fl_copylist(value_t *args, u_int32_t nargs)
-{- argcount("copy-list", nargs, 1);- return copy_list(args[0]);
-}
-
-value_t fl_append(value_t *args, u_int32_t nargs)
-{- if (nargs == 0)
- return NIL;
- value_t first=NIL, lst, lastcons=NIL;
- fl_gc_handle(&first);
- fl_gc_handle(&lastcons);
- uint32_t i=0;
- while (1) {- lst = args[i++];
- if (i >= nargs) break;
- if (iscons(lst)) {- lst = copy_list(lst);
- if (first == NIL)
- first = lst;
- else
- cdr_(lastcons) = lst;
- lastcons = tagptr((((cons_t*)curheap)-1), TAG_CONS);
- }
- else if (lst != NIL) {- type_error("append", "cons", lst);- }
- }
- if (first == NIL)
- first = lst;
- else
- cdr_(lastcons) = lst;
- fl_free_gc_handles(2);
- return first;
-}
-
-value_t fl_liststar(value_t *args, u_int32_t nargs)
-{- if (nargs == 1) return args[0];
- else if (nargs == 0) argcount("list*", nargs, 1);- return _list(args, nargs, 1);
-}
-
-value_t fl_stacktrace(value_t *args, u_int32_t nargs)
-{- (void)args;
- argcount("stacktrace", nargs, 0);- return _stacktrace(fl_throwing_frame ? fl_throwing_frame : curr_frame);
-}
-
-value_t fl_map1(value_t *args, u_int32_t nargs)
-{- if (nargs < 2)
- lerror(ArgError, "map: too few arguments");
- if (!iscons(args[1])) return NIL;
- value_t first, last, v;
- if (nargs == 2) {- if (SP+3 > N_STACK) grow_stack();
- PUSH(args[0]);
- PUSH(car_(args[1]));
- v = _applyn(1);
- PUSH(v);
- v = mk_cons();
- car_(v) = POP(); cdr_(v) = NIL;
- last = first = v;
- args[1] = cdr_(args[1]);
- fl_gc_handle(&first);
- fl_gc_handle(&last);
- while (iscons(args[1])) {- Stack[SP-2] = args[0];
- Stack[SP-1] = car_(args[1]);
- v = _applyn(1);
- PUSH(v);
- v = mk_cons();
- car_(v) = POP(); cdr_(v) = NIL;
- cdr_(last) = v;
- last = v;
- args[1] = cdr_(args[1]);
- }
- POPN(2);
- fl_free_gc_handles(2);
- }
- else {- size_t i;
- while (SP+nargs+1 > N_STACK) grow_stack();
- PUSH(args[0]);
- for(i=1; i < nargs; i++) {- PUSH(car(args[i]));
- args[i] = cdr_(args[i]);
- }
- v = _applyn(nargs-1);
- PUSH(v);
- v = mk_cons();
- car_(v) = POP(); cdr_(v) = NIL;
- last = first = v;
- fl_gc_handle(&first);
- fl_gc_handle(&last);
- while (iscons(args[1])) {- Stack[SP-nargs] = args[0];
- for(i=1; i < nargs; i++) {- Stack[SP-nargs+i] = car(args[i]);
- args[i] = cdr_(args[i]);
- }
- v = _applyn(nargs-1);
- PUSH(v);
- v = mk_cons();
- car_(v) = POP(); cdr_(v) = NIL;
- cdr_(last) = v;
- last = v;
- }
- POPN(nargs);
- fl_free_gc_handles(2);
- }
- return first;
-}
-
-static builtinspec_t core_builtin_info[] = {- { "function", fl_function },- { "function:code", fl_function_code },- { "function:vals", fl_function_vals },- { "function:env", fl_function_env },- { "function:name", fl_function_name },- { "stacktrace", fl_stacktrace },- { "gensym", fl_gensym },- { "gensym?", fl_gensymp },- { "hash", fl_hash },- { "copy-list", fl_copylist },- { "append", fl_append },- { "list*", fl_liststar },- { "map", fl_map1 },- { NULL, NULL }-};
-
-// initialization -------------------------------------------------------------
-
-extern void builtins_init();
-extern void comparehash_init();
-
-static void lisp_init(size_t initial_heapsize)
-{- int i;
-
- llt_init();
-
- heapsize = initial_heapsize;
-
- fromspace = LLT_ALLOC(heapsize);
- tospace = LLT_ALLOC(heapsize);
- curheap = fromspace;
- lim = curheap+heapsize-sizeof(cons_t);
- consflags = bitvector_new(heapsize/sizeof(cons_t), 1);
- htable_new(&printconses, 32);
- comparehash_init();
- N_STACK = 262144;
- Stack = malloc(N_STACK*sizeof(value_t));
-
- FL_NIL = NIL = builtin(OP_THE_EMPTY_LIST);
- FL_T = builtin(OP_BOOL_CONST_T);
- FL_F = builtin(OP_BOOL_CONST_F);
- FL_EOF = builtin(OP_EOF_OBJECT);
- LAMBDA = symbol("lambda"); FUNCTION = symbol("function");- QUOTE = symbol("quote"); TRYCATCH = symbol("trycatch");- BACKQUOTE = symbol("quasiquote"); COMMA = symbol("unquote");- COMMAAT = symbol("unquote-splicing"); COMMADOT = symbol("unquote-nsplicing");- IOError = symbol("io-error"); ParseError = symbol("parse-error");- TypeError = symbol("type-error"); ArgError = symbol("arg-error");- UnboundError = symbol("unbound-error");- KeyError = symbol("key-error"); MemoryError = symbol("memory-error");- BoundsError = symbol("bounds-error");- DivideError = symbol("divide-error");- EnumerationError = symbol("enumeration-error");- Error = symbol("error"); pairsym = symbol("pair");- symbolsym = symbol("symbol"); fixnumsym = symbol("fixnum");- vectorsym = symbol("vector"); builtinsym = symbol("builtin");- booleansym = symbol("boolean"); nullsym = symbol("null");- definesym = symbol("define"); defmacrosym = symbol("define-macro");- forsym = symbol("for");- setqsym = symbol("set!"); evalsym = symbol("eval");- vu8sym = symbol("vu8"); fnsym = symbol("fn");- nulsym = symbol("nul"); alarmsym = symbol("alarm");- backspacesym = symbol("backspace"); tabsym = symbol("tab");- linefeedsym = symbol("linefeed"); vtabsym = symbol("vtab");- pagesym = symbol("page"); returnsym = symbol("return");- escsym = symbol("esc"); spacesym = symbol("space");- deletesym = symbol("delete"); newlinesym = symbol("newline");- tsym = symbol("t"); Tsym = symbol("T");- fsym = symbol("f"); Fsym = symbol("F");- set(printprettysym=symbol("*print-pretty*"), FL_T);- set(printreadablysym=symbol("*print-readably*"), FL_T);- set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));- set(printlengthsym=symbol("*print-length*"), FL_F);- set(printlevelsym=symbol("*print-level*"), FL_F);- builtins_table_sym = symbol("*builtins*");- fl_lasterror = NIL;
- i = 0;
- for (i=OP_EQ; i <= OP_ASET; i++) {- setc(symbol(builtin_names[i]), builtin(i));
- }
- setc(symbol("eq"), builtin(OP_EQ));- setc(symbol("procedure?"), builtin(OP_FUNCTIONP));- setc(symbol("top-level-bound?"), builtin(OP_BOUNDP));-
-#ifdef LINUX
- set(symbol("*os-name*"), symbol("linux"));-#elif defined(WIN32) || defined(WIN64)
- set(symbol("*os-name*"), symbol("win32"));-#elif defined(MACOSX)
- set(symbol("*os-name*"), symbol("macos"));-#else
- set(symbol("*os-name*"), symbol("unknown"));-#endif
-
- the_empty_vector = tagptr(alloc_words(1), TAG_VECTOR);
- vector_setsize(the_empty_vector, 0);
-
- cvalues_init();
-
- char buf[1024];
- char *exename = get_exename(buf, sizeof(buf));
- if (exename != NULL) {- path_to_dirname(exename);
- setc(symbol("*install-dir*"), cvalue_static_cstring(strdup(exename)));- }
-
- memory_exception_value = fl_list2(MemoryError,
- cvalue_static_cstring("out of memory"));-
- assign_global_builtins(core_builtin_info);
-
- builtins_init();
-}
-
-// top level ------------------------------------------------------------------
-
-value_t fl_toplevel_eval(value_t expr)
-{- return fl_applyn(1, symbol_value(evalsym), expr);
-}
-
-void fl_init(size_t initial_heapsize)
-{-#ifdef BOEHM_GC
- GC_init();
-#endif
- lisp_init(initial_heapsize);
-}
-
-int fl_load_system_image(value_t sys_image_iostream)
-{- value_t e;
- int saveSP;
- symbol_t *sym;
-
- PUSH(sys_image_iostream);
- saveSP = SP;
- FL_TRY {- while (1) {- e = fl_read_sexpr(Stack[SP-1]);
- if (ios_eof(value2c(ios_t*,Stack[SP-1]))) break;
- if (isfunction(e)) {- // stage 0 format: series of thunks
- PUSH(e);
- (void)_applyn(0);
- SP = saveSP;
- }
- else {- // stage 1 format: list alternating symbol/value
- while (iscons(e)) {- sym = tosymbol(car_(e), "bootstrap");
- e = cdr_(e);
- (void)tocons(e, "bootstrap");
- sym->binding = car_(e);
- e = cdr_(e);
- }
- break;
- }
- }
- }
- FL_CATCH {- ios_puts("fatal error during bootstrap:\n", ios_stderr);- fl_print(ios_stderr, fl_lasterror);
- ios_putc('\n', ios_stderr);- return 1;
- }
- ios_close(value2c(ios_t*,Stack[SP-1]));
- POPN(1);
- return 0;
-}
--- a/femtolisp/flisp.h
+++ /dev/null
@@ -1,369 +1,0 @@
-#ifndef _FLISP_H_
-#define _FLISP_H_
-
-typedef uptrint_t value_t;
-typedef int_t fixnum_t;
-#ifdef BITS64
-#define T_FIXNUM T_INT64
-#else
-#define T_FIXNUM T_INT32
-#endif
-
-typedef struct {- value_t car;
- value_t cdr;
-} cons_t;
-
-typedef struct _symbol_t {- uptrint_t flags;
- value_t binding; // global value binding
- struct _fltype_t *type;
- uint32_t hash;
- void *dlcache; // dlsym address
- // below fields are private
- struct _symbol_t *left;
- struct _symbol_t *right;
- union {- char name[1];
- void *_pad; // ensure field aligned to pointer size
- };
-} symbol_t;
-
-typedef struct {- value_t isconst;
- value_t binding; // global value binding
- struct _fltype_t *type;
- uint32_t id;
-} gensym_t;
-
-#define TAG_NUM 0x0
-#define TAG_CPRIM 0x1
-#define TAG_FUNCTION 0x2
-#define TAG_VECTOR 0x3
-#define TAG_NUM1 0x4
-#define TAG_CVALUE 0x5
-#define TAG_SYM 0x6
-#define TAG_CONS 0x7
-#define UNBOUND ((value_t)0x1) // an invalid value
-#define TAG_FWD UNBOUND
-#define tag(x) ((x)&0x7)
-#define ptr(x) ((void*)((x)&(~(value_t)0x7)))
-#define tagptr(p,t) (((value_t)(p)) | (t))
-#define fixnum(x) ((value_t)(((fixnum_t)(x))<<2))
-#define numval(x) (((fixnum_t)(x))>>2)
-#ifdef BITS64
-#define fits_fixnum(x) (((x)>>61) == 0 || (~((x)>>61)) == 0)
-#else
-#define fits_fixnum(x) (((x)>>29) == 0 || (~((x)>>29)) == 0)
-#endif
-#define fits_bits(x,b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
-#define uintval(x) (((unsigned int)(x))>>3)
-#define builtin(n) tagptr((((int)n)<<3), TAG_FUNCTION)
-#define iscons(x) (tag(x) == TAG_CONS)
-#define issymbol(x) (tag(x) == TAG_SYM)
-#define isfixnum(x) (((x)&3) == TAG_NUM)
-#define bothfixnums(x,y) ((((x)|(y))&3) == TAG_NUM)
-#define isbuiltin(x) ((tag(x) == TAG_FUNCTION) && uintval(x) <= OP_ASET)
-#define isvector(x) (tag(x) == TAG_VECTOR)
-#define iscvalue(x) (tag(x) == TAG_CVALUE)
-#define iscprim(x) (tag(x) == TAG_CPRIM)
-#define selfevaluating(x) (tag(x)<6)
-// comparable with ==
-#define eq_comparable(a,b) (!(((a)|(b))&1))
-#define eq_comparablep(a) (!((a)&1))
-// doesn't lead to other values
-#define leafp(a) (((a)&3) != 3)
-
-#define isforwarded(v) (((value_t*)ptr(v))[0] == TAG_FWD)
-#define forwardloc(v) (((value_t*)ptr(v))[1])
-#define forward(v,to) do { (((value_t*)ptr(v))[0] = TAG_FWD); \- (((value_t*)ptr(v))[1] = to); } while (0)
-
-#define vector_size(v) (((size_t*)ptr(v))[0]>>2)
-#define vector_setsize(v,n) (((size_t*)ptr(v))[0] = ((n)<<2))
-#define vector_elt(v,i) (((value_t*)ptr(v))[1+(i)])
-#define vector_grow_amt(x) ((x)<8 ? 5 : 6*((x)>>3))
-// functions ending in _ are unsafe, faster versions
-#define car_(v) (((cons_t*)ptr(v))->car)
-#define cdr_(v) (((cons_t*)ptr(v))->cdr)
-#define car(v) (tocons((v),"car")->car)
-#define cdr(v) (tocons((v),"cdr")->cdr)
-#define fn_bcode(f) (((value_t*)ptr(f))[0])
-#define fn_vals(f) (((value_t*)ptr(f))[1])
-#define fn_env(f) (((value_t*)ptr(f))[2])
-#define fn_name(f) (((value_t*)ptr(f))[3])
-
-#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
-#define setc(s, v) do { ((symbol_t*)ptr(s))->flags |= 1; \- ((symbol_t*)ptr(s))->binding = (v); } while (0)
-#define isconstant(s) ((s)->flags&0x1)
-#define iskeyword(s) ((s)->flags&0x2)
-#define symbol_value(s) (((symbol_t*)ptr(s))->binding)
-#define ismanaged(v) ((((unsigned char*)ptr(v)) >= fromspace) && \
- (((unsigned char*)ptr(v)) < fromspace+heapsize))
-#define isgensym(x) (issymbol(x) && ismanaged(x))
-
-#define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS<<3))
-#define isclosure(x) isfunction(x)
-#define iscbuiltin(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==builtintype))
-
-void fl_gc_handle(value_t *pv);
-void fl_free_gc_handles(uint32_t n);
-
-#include "opcodes.h"
-
-// utility for iterating over all arguments in a builtin
-// i=index, i0=start index, arg = var for each arg, args = arg array
-// assumes "nargs" is the argument count
-#define FOR_ARGS(i, i0, arg, args) \
- for(i=i0; ((size_t)i)<nargs && ((arg=args[i]) || 1); i++)
-
-#define N_BUILTINS ((int)N_OPCODES)
-
-extern value_t FL_NIL, FL_T, FL_F, FL_EOF;
-
-#define FL_UNSPECIFIED FL_T
-
-/* read, eval, print main entry points */
-value_t fl_read_sexpr(value_t f);
-void fl_print(ios_t *f, value_t v);
-value_t fl_toplevel_eval(value_t expr);
-value_t fl_apply(value_t f, value_t l);
-value_t fl_applyn(uint32_t n, value_t f, ...);
-
-extern value_t printprettysym, printreadablysym, printwidthsym;
-
-/* object model manipulation */
-value_t fl_cons(value_t a, value_t b);
-value_t fl_list2(value_t a, value_t b);
-value_t fl_listn(size_t n, ...);
-value_t symbol(char *str);
-char *symbol_name(value_t v);
-int fl_is_keyword_name(char *str, size_t len);
-value_t alloc_vector(size_t n, int init);
-size_t llength(value_t v);
-value_t fl_compare(value_t a, value_t b); // -1, 0, or 1
-value_t fl_equal(value_t a, value_t b); // T or nil
-int equal_lispvalue(value_t a, value_t b);
-uptrint_t hash_lispvalue(value_t a);
-int isnumtok_base(char *tok, value_t *pval, int base);
-
-/* safe casts */
-cons_t *tocons(value_t v, char *fname);
-symbol_t *tosymbol(value_t v, char *fname);
-fixnum_t tofixnum(value_t v, char *fname);
-char *tostring(value_t v, char *fname);
-
-/* error handling */
-typedef struct _fl_readstate_t {- htable_t backrefs;
- htable_t gensyms;
- value_t source;
- struct _fl_readstate_t *prev;
-} fl_readstate_t;
-
-typedef struct _ectx_t {- jmp_buf buf;
- uint32_t sp;
- uint32_t frame;
- uint32_t ngchnd;
- fl_readstate_t *rdst;
- struct _ectx_t *prev;
-} fl_exception_context_t;
-
-extern fl_exception_context_t *fl_ctx;
-extern uint32_t fl_throwing_frame;
-extern value_t fl_lasterror;
-
-#define FL_TRY_EXTERN \
- fl_exception_context_t _ctx; int l__tr, l__ca; \
- fl_savestate(&_ctx); fl_ctx = &_ctx; \
- if (!setjmp(_ctx.buf)) \
- for (l__tr=1; l__tr; l__tr=0, (void)(fl_ctx=fl_ctx->prev))
-
-#define FL_CATCH_EXTERN \
- else \
- for(l__ca=1; l__ca; l__ca=0, fl_restorestate(&_ctx))
-
-void lerrorf(value_t e, char *format, ...) __attribute__ ((__noreturn__));
-void lerror(value_t e, const char *msg) __attribute__ ((__noreturn__));
-void fl_savestate(fl_exception_context_t *_ctx);
-void fl_restorestate(fl_exception_context_t *_ctx);
-void fl_raise(value_t e) __attribute__ ((__noreturn__));
-void type_error(char *fname, char *expected, value_t got) __attribute__ ((__noreturn__));
-void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noreturn__));
-extern value_t ArgError, IOError, KeyError, MemoryError, EnumerationError;
-extern value_t UnboundError;
-static inline void argcount(char *fname, uint32_t nargs, uint32_t c)
-{- if (__unlikely(nargs != c))
- lerrorf(ArgError,"%s: too %s arguments", fname, nargs<c ? "few":"many");
-}
-
-typedef struct {- void (*print)(value_t self, ios_t *f);
- void (*relocate)(value_t oldv, value_t newv);
- void (*finalize)(value_t self);
- void (*print_traverse)(value_t self);
-} cvtable_t;
-
-/* functions needed to implement the value interface (cvtable_t) */
-value_t relocate_lispvalue(value_t v);
-void print_traverse(value_t v);
-void fl_print_chr(char c, ios_t *f);
-void fl_print_str(char *s, ios_t *f);
-void fl_print_child(ios_t *f, value_t v);
-
-typedef int (*cvinitfunc_t)(struct _fltype_t*, value_t, void*);
-
-typedef struct _fltype_t {- value_t type;
- numerictype_t numtype;
- size_t size;
- size_t elsz;
- cvtable_t *vtable;
- struct _fltype_t *eltype; // for arrays
- struct _fltype_t *artype; // (array this)
- int marked;
- cvinitfunc_t init;
-} fltype_t;
-
-typedef struct {- fltype_t *type;
- void *data;
- size_t len; // length of *data in bytes
- union {- value_t parent; // optional
- char _space[1]; // variable size
- };
-} cvalue_t;
-
-#define CVALUE_NWORDS 4
-
-typedef struct {- fltype_t *type;
- char _space[1];
-} cprim_t;
-
-typedef struct {- value_t bcode;
- value_t vals;
- value_t env;
- value_t name;
-} function_t;
-
-#define CPRIM_NWORDS 2
-#define MAX_INL_SIZE 384
-
-#define CV_OWNED_BIT 0x1
-#define CV_PARENT_BIT 0x2
-#define owned(cv) ((uptrint_t)(cv)->type & CV_OWNED_BIT)
-#define hasparent(cv) ((uptrint_t)(cv)->type & CV_PARENT_BIT)
-#define isinlined(cv) ((cv)->data == &(cv)->_space[0])
-#define cv_class(cv) ((fltype_t*)(((uptrint_t)(cv)->type)&~3))
-#define cv_len(cv) ((cv)->len)
-#define cv_type(cv) (cv_class(cv)->type)
-#define cv_data(cv) ((cv)->data)
-#define cv_isstr(cv) (cv_class(cv)->eltype == bytetype)
-#define cv_isPOD(cv) (cv_class(cv)->init != NULL)
-
-#define cvalue_data(v) cv_data((cvalue_t*)ptr(v))
-#define cvalue_len(v) cv_len((cvalue_t*)ptr(v))
-#define value2c(type, v) ((type)cv_data((cvalue_t*)ptr(v)))
-
-#define valid_numtype(v) ((v) < N_NUMTYPES)
-#define cp_class(cp) ((cp)->type)
-#define cp_type(cp) (cp_class(cp)->type)
-#define cp_numtype(cp) (cp_class(cp)->numtype)
-#define cp_data(cp) (&(cp)->_space[0])
-
-// WARNING: multiple evaluation!
-#define cptr(v) \
- (iscprim(v) ? cp_data((cprim_t*)ptr(v)) : cv_data((cvalue_t*)ptr(v)))
-
-/* C type names corresponding to cvalues type names */
-typedef int8_t fl_int8_t;
-typedef uint8_t fl_uint8_t;
-typedef int16_t fl_int16_t;
-typedef uint16_t fl_uint16_t;
-typedef int32_t fl_int32_t;
-typedef uint32_t fl_uint32_t;
-typedef int64_t fl_int64_t;
-typedef uint64_t fl_uint64_t;
-typedef char fl_char_t;
-typedef char char_t;
-typedef long fl_long_t;
-typedef long long_t;
-typedef unsigned long fl_ulong_t;
-typedef unsigned long ulong_t;
-typedef double fl_double_t;
-typedef float fl_float_t;
-
-typedef value_t (*builtin_t)(value_t*, uint32_t);
-
-extern value_t QUOTE;
-extern value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
-extern value_t int64sym, uint64sym;
-extern value_t longsym, ulongsym, bytesym, wcharsym;
-extern value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
-extern value_t stringtypesym, wcstringtypesym, emptystringsym;
-extern value_t unionsym, floatsym, doublesym;
-extern fltype_t *bytetype, *wchartype;
-extern fltype_t *stringtype, *wcstringtype;
-extern fltype_t *builtintype;
-
-value_t cvalue(fltype_t *type, size_t sz);
-void add_finalizer(cvalue_t *cv);
-void cv_autorelease(cvalue_t *cv);
-void cv_pin(cvalue_t *cv);
-size_t ctype_sizeof(value_t type, int *palign);
-value_t cvalue_copy(value_t v);
-value_t cvalue_from_data(fltype_t *type, void *data, size_t sz);
-value_t cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent);
-value_t cbuiltin(char *name, builtin_t f);
-size_t cvalue_arraylen(value_t v);
-value_t size_wrap(size_t sz);
-size_t toulong(value_t n, char *fname);
-value_t cvalue_string(size_t sz);
-value_t cvalue_static_cstring(const char *str);
-value_t string_from_cstr(char *str);
-value_t string_from_cstrn(char *str, size_t n);
-int fl_isstring(value_t v);
-int fl_isnumber(value_t v);
-int fl_isgensym(value_t v);
-int fl_isiostream(value_t v);
-ios_t *fl_toiostream(value_t v, char *fname);
-value_t cvalue_compare(value_t a, value_t b);
-int numeric_compare(value_t a, value_t b, int eq, int eqnans, char *fname);
-
-void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz);
-
-fltype_t *get_type(value_t t);
-fltype_t *get_array_type(value_t eltype);
-fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab,
- cvinitfunc_t init);
-
-value_t mk_double(fl_double_t n);
-value_t mk_float(fl_float_t n);
-value_t mk_uint32(uint32_t n);
-value_t mk_uint64(uint64_t n);
-value_t mk_wchar(int32_t n);
-value_t return_from_uint64(uint64_t Uaccum);
-value_t return_from_int64(int64_t Saccum);
-
-typedef struct {- char *name;
- builtin_t fptr;
-} builtinspec_t;
-
-void assign_global_builtins(builtinspec_t *b);
-
-/* builtins */
-value_t fl_hash(value_t *args, u_int32_t nargs);
-value_t cvalue_byte(value_t *args, uint32_t nargs);
-value_t cvalue_wchar(value_t *args, uint32_t nargs);
-
-void fl_init(size_t initial_heapsize);
-int fl_load_system_image(value_t ios);
-
-#endif
--- a/femtolisp/flmain.c
+++ /dev/null
@@ -1,71 +1,0 @@
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <setjmp.h>
-#include <stdarg.h>
-#include <assert.h>
-#include <ctype.h>
-#include <wctype.h>
-#include <sys/types.h>
-#include <locale.h>
-#include <limits.h>
-#include <errno.h>
-#include <math.h>
-#include "llt.h"
-#include "flisp.h"
-#include "opcodes.h"
-
-static value_t argv_list(int argc, char *argv[])
-{- int i;
- value_t lst=FL_NIL, temp;
- fl_gc_handle(&lst);
- fl_gc_handle(&temp);
- for(i=argc-1; i >= 0; i--) {- temp = cvalue_static_cstring(argv[i]);
- lst = fl_cons(temp, lst);
- }
- fl_free_gc_handles(2);
- return lst;
-}
-
-extern value_t fl_file(value_t *args, uint32_t nargs);
-
-int main(int argc, char *argv[])
-{- char fname_buf[1024];
-
- fl_init(512*1024);
-
- fname_buf[0] = '\0';
- value_t str = symbol_value(symbol("*install-dir*"));- char *exedir = (str == UNBOUND ? NULL : cvalue_data(str));
- if (exedir != NULL) {- strcat(fname_buf, exedir);
- strcat(fname_buf, PATHSEPSTRING);
- }
- strcat(fname_buf, "flisp.boot");
-
- value_t args[2];
- fl_gc_handle(&args[0]);
- fl_gc_handle(&args[1]);
- FL_TRY_EXTERN {- args[0] = cvalue_static_cstring(fname_buf);
- args[1] = symbol(":read");- value_t f = fl_file(&args[0], 2);
- fl_free_gc_handles(2);
-
- if (fl_load_system_image(f))
- return 1;
-
- (void)fl_applyn(1, symbol_value(symbol("__start")),- argv_list(argc, argv));
- }
- FL_CATCH_EXTERN {- ios_puts("fatal error:\n", ios_stderr);- fl_print(ios_stderr, fl_lasterror);
- ios_putc('\n', ios_stderr);- return 1;
- }
- return 0;
-}
--- a/femtolisp/iostream.c
+++ /dev/null
@@ -1,451 +1,0 @@
-#include <stdlib.h>
-#include <stdio.h>
-#include <stdarg.h>
-#include <string.h>
-#include <assert.h>
-#include <sys/types.h>
-#include <setjmp.h>
-#include "llt.h"
-#include "flisp.h"
-
-static value_t iostreamsym, rdsym, wrsym, apsym, crsym, truncsym;
-static value_t instrsym, outstrsym;
-fltype_t *iostreamtype;
-
-void print_iostream(value_t v, ios_t *f)
-{- (void)v;
- fl_print_str("#<io stream>", f);-}
-
-void free_iostream(value_t self)
-{- ios_t *s = value2c(ios_t*, self);
- ios_close(s);
-}
-
-void relocate_iostream(value_t oldv, value_t newv)
-{- ios_t *olds = value2c(ios_t*, oldv);
- ios_t *news = value2c(ios_t*, newv);
- cvalue_t *cv = (cvalue_t*)ptr(oldv);
- if (isinlined(cv)) {- if (olds->buf == &olds->local[0]) {- news->buf = &news->local[0];
- }
- }
-}
-
-cvtable_t iostream_vtable = { print_iostream, relocate_iostream,- free_iostream, NULL };
-
-int fl_isiostream(value_t v)
-{- return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == iostreamtype;
-}
-
-value_t fl_iostreamp(value_t *args, uint32_t nargs)
-{- argcount("iostream?", nargs, 1);- return fl_isiostream(args[0]) ? FL_T : FL_F;
-}
-
-value_t fl_eof_object(value_t *args, uint32_t nargs)
-{- (void)args;
- argcount("eof-object", nargs, 0);- return FL_EOF;
-}
-
-value_t fl_eof_objectp(value_t *args, uint32_t nargs)
-{- argcount("eof-object?", nargs, 1);- return (FL_EOF == args[0]) ? FL_T : FL_F;
-}
-
-static ios_t *toiostream(value_t v, char *fname)
-{- if (!fl_isiostream(v))
- type_error(fname, "iostream", v);
- return value2c(ios_t*, v);
-}
-
-ios_t *fl_toiostream(value_t v, char *fname)
-{- return toiostream(v, fname);
-}
-
-value_t fl_file(value_t *args, uint32_t nargs)
-{- if (nargs < 1)
- argcount("file", nargs, 1);- int i, r=0, w=0, c=0, t=0, a=0;
- for(i=1; i < (int)nargs; i++) {- if (args[i] == wrsym) w = 1;
- else if (args[i] == apsym) { a = 1; w = 1; }- else if (args[i] == crsym) { c = 1; w = 1; }- else if (args[i] == truncsym) { t = 1; w = 1; }- else if (args[i] == rdsym) r = 1;
- }
- if ((r|w|c|t|a) == 0) r = 1; // default to reading
- value_t f = cvalue(iostreamtype, sizeof(ios_t));
- char *fname = tostring(args[0], "file");
- ios_t *s = value2c(ios_t*, f);
- if (ios_file(s, fname, r, w, c, t) == NULL)
- lerrorf(IOError, "file: could not open \"%s\"", fname);
- if (a) ios_seek_end(s);
- return f;
-}
-
-value_t fl_buffer(value_t *args, u_int32_t nargs)
-{- argcount("buffer", nargs, 0);- (void)args;
- value_t f = cvalue(iostreamtype, sizeof(ios_t));
- ios_t *s = value2c(ios_t*, f);
- if (ios_mem(s, 0) == NULL)
- lerror(MemoryError, "buffer: could not allocate stream");
- return f;
-}
-
-value_t fl_read(value_t *args, u_int32_t nargs)
-{- value_t arg;
- if (nargs > 1) {- argcount("read", nargs, 1);- }
- else if (nargs == 0) {- arg = symbol_value(instrsym);
- }
- else {- arg = args[0];
- }
- (void)toiostream(arg, "read");
- fl_gc_handle(&arg);
- value_t v = fl_read_sexpr(arg);
- fl_free_gc_handles(1);
- if (ios_eof(value2c(ios_t*,arg)))
- return FL_EOF;
- return v;
-}
-
-value_t fl_iogetc(value_t *args, u_int32_t nargs)
-{- argcount("io.getc", nargs, 1);- ios_t *s = toiostream(args[0], "io.getc");
- uint32_t wc;
- if (ios_getutf8(s, &wc) == IOS_EOF)
- //lerror(IOError, "io.getc: end of file reached");
- return FL_EOF;
- return mk_wchar(wc);
-}
-
-value_t fl_iopeekc(value_t *args, u_int32_t nargs)
-{- argcount("io.peekc", nargs, 1);- ios_t *s = toiostream(args[0], "io.peekc");
- uint32_t wc;
- if (ios_peekutf8(s, &wc) == IOS_EOF)
- return FL_EOF;
- return mk_wchar(wc);
-}
-
-value_t fl_ioputc(value_t *args, u_int32_t nargs)
-{- argcount("io.putc", nargs, 2);- ios_t *s = toiostream(args[0], "io.putc");
- if (!iscprim(args[1]) || ((cprim_t*)ptr(args[1]))->type != wchartype)
- type_error("io.putc", "wchar", args[1]);- uint32_t wc = *(uint32_t*)cp_data((cprim_t*)ptr(args[1]));
- return fixnum(ios_pututf8(s, wc));
-}
-
-value_t fl_ioflush(value_t *args, u_int32_t nargs)
-{- argcount("io.flush", nargs, 1);- ios_t *s = toiostream(args[0], "io.flush");
- if (ios_flush(s) != 0)
- return FL_F;
- return FL_T;
-}
-
-value_t fl_ioclose(value_t *args, u_int32_t nargs)
-{- argcount("io.close", nargs, 1);- ios_t *s = toiostream(args[0], "io.close");
- ios_close(s);
- return FL_T;
-}
-
-value_t fl_iopurge(value_t *args, u_int32_t nargs)
-{- argcount("io.discardbuffer", nargs, 1);- ios_t *s = toiostream(args[0], "io.discardbuffer");
- ios_purge(s);
- return FL_T;
-}
-
-value_t fl_ioeof(value_t *args, u_int32_t nargs)
-{- argcount("io.eof?", nargs, 1);- ios_t *s = toiostream(args[0], "io.eof?");
- return (ios_eof(s) ? FL_T : FL_F);
-}
-
-value_t fl_ioseek(value_t *args, u_int32_t nargs)
-{- argcount("io.seek", nargs, 2);- ios_t *s = toiostream(args[0], "io.seek");
- size_t pos = toulong(args[1], "io.seek");
- off_t res = ios_seek(s, (off_t)pos);
- if (res == -1)
- return FL_F;
- return FL_T;
-}
-
-value_t fl_iopos(value_t *args, u_int32_t nargs)
-{- argcount("io.pos", nargs, 1);- ios_t *s = toiostream(args[0], "io.pos");
- off_t res = ios_pos(s);
- if (res == -1)
- return FL_F;
- return size_wrap((size_t)res);
-}
-
-value_t fl_write(value_t *args, u_int32_t nargs)
-{- if (nargs < 1 || nargs > 2)
- argcount("write", nargs, 1);- ios_t *s;
- if (nargs == 2)
- s = toiostream(args[1], "write");
- else
- s = toiostream(symbol_value(outstrsym), "write");
- fl_print(s, args[0]);
- return args[0];
-}
-
-value_t fl_ioread(value_t *args, u_int32_t nargs)
-{- if (nargs != 3)
- argcount("io.read", nargs, 2);- (void)toiostream(args[0], "io.read");
- size_t n;
- fltype_t *ft;
- if (nargs == 3) {- // form (io.read s type count)
- ft = get_array_type(args[1]);
- n = toulong(args[2], "io.read") * ft->elsz;
- }
- else {- ft = get_type(args[1]);
- if (ft->eltype != NULL && !iscons(cdr_(cdr_(args[1]))))
- lerror(ArgError, "io.read: incomplete type");
- n = ft->size;
- }
- value_t cv = cvalue(ft, n);
- char *data;
- if (iscvalue(cv)) data = cv_data((cvalue_t*)ptr(cv));
- else data = cp_data((cprim_t*)ptr(cv));
- size_t got = ios_read(value2c(ios_t*,args[0]), data, n);
- if (got < n)
- //lerror(IOError, "io.read: end of input reached");
- return FL_EOF;
- return cv;
-}
-
-// args must contain data[, offset[, count]]
-static void get_start_count_args(value_t *args, uint32_t nargs, size_t sz,
- size_t *offs, size_t *nb, char *fname)
-{- if (nargs > 1) {- *offs = toulong(args[1], fname);
- if (nargs > 2)
- *nb = toulong(args[2], fname);
- else
- *nb = sz - *offs;
- if (*offs >= sz || *offs + *nb > sz)
- bounds_error(fname, args[0], args[1]);
- }
-}
-
-value_t fl_iowrite(value_t *args, u_int32_t nargs)
-{- if (nargs < 2 || nargs > 4)
- argcount("io.write", nargs, 2);- ios_t *s = toiostream(args[0], "io.write");
- if (iscprim(args[1]) && ((cprim_t*)ptr(args[1]))->type == wchartype) {- if (nargs > 2)
- lerror(ArgError,
- "io.write: offset argument not supported for characters");
- uint32_t wc = *(uint32_t*)cp_data((cprim_t*)ptr(args[1]));
- return fixnum(ios_pututf8(s, wc));
- }
- char *data;
- size_t sz, offs=0;
- to_sized_ptr(args[1], "io.write", &data, &sz);
- size_t nb = sz;
- if (nargs > 2) {- get_start_count_args(&args[1], nargs-1, sz, &offs, &nb, "io.write");
- data += offs;
- }
- return size_wrap(ios_write(s, data, nb));
-}
-
-value_t fl_dump(value_t *args, u_int32_t nargs)
-{- if (nargs < 1 || nargs > 3)
- argcount("dump", nargs, 1);- ios_t *s = toiostream(symbol_value(outstrsym), "dump");
- char *data;
- size_t sz, offs=0;
- to_sized_ptr(args[0], "dump", &data, &sz);
- size_t nb = sz;
- if (nargs > 1) {- get_start_count_args(args, nargs, sz, &offs, &nb, "dump");
- data += offs;
- }
- hexdump(s, data, nb, offs);
- return FL_T;
-}
-
-static char get_delim_arg(value_t arg, char *fname)
-{- size_t uldelim = toulong(arg, fname);
- if (uldelim > 0x7f) {- // wchars > 0x7f, or anything else > 0xff, are out of range
- if ((iscprim(arg) && cp_class((cprim_t*)ptr(arg))==wchartype) ||
- uldelim > 0xff)
- lerrorf(ArgError, "%s: delimiter out of range", fname);
- }
- return (char)uldelim;
-}
-
-value_t fl_ioreaduntil(value_t *args, u_int32_t nargs)
-{- argcount("io.readuntil", nargs, 2);- value_t str = cvalue_string(80);
- cvalue_t *cv = (cvalue_t*)ptr(str);
- char *data = cv_data(cv);
- ios_t dest;
- ios_mem(&dest, 0);
- ios_setbuf(&dest, data, 80, 0);
- char delim = get_delim_arg(args[1], "io.readuntil");
- ios_t *src = toiostream(args[0], "io.readuntil");
- size_t n = ios_copyuntil(&dest, src, delim);
- cv->len = n;
- if (dest.buf != data) {- // outgrew initial space
- cv->data = dest.buf;
-#ifndef BOEHM_GC
- cv_autorelease(cv);
-#endif
- }
- ((char*)cv->data)[n] = '\0';
- if (n == 0 && ios_eof(src))
- return FL_EOF;
- return str;
-}
-
-value_t fl_iocopyuntil(value_t *args, u_int32_t nargs)
-{- argcount("io.copyuntil", nargs, 3);- ios_t *dest = toiostream(args[0], "io.copyuntil");
- ios_t *src = toiostream(args[1], "io.copyuntil");
- char delim = get_delim_arg(args[2], "io.copyuntil");
- return size_wrap(ios_copyuntil(dest, src, delim));
-}
-
-value_t fl_iocopy(value_t *args, u_int32_t nargs)
-{- if (nargs < 2 || nargs > 3)
- argcount("io.copy", nargs, 2);- ios_t *dest = toiostream(args[0], "io.copy");
- ios_t *src = toiostream(args[1], "io.copy");
- if (nargs == 3) {- size_t n = toulong(args[2], "io.copy");
- return size_wrap(ios_copy(dest, src, n));
- }
- return size_wrap(ios_copyall(dest, src));
-}
-
-value_t stream_to_string(value_t *ps)
-{- value_t str;
- size_t n;
- ios_t *st = value2c(ios_t*,*ps);
- if (st->buf == &st->local[0]) {- n = st->size;
- str = cvalue_string(n);
- memcpy(cvalue_data(str), value2c(ios_t*,*ps)->buf, n);
- ios_trunc(st, 0);
- }
- else {- char *b = ios_takebuf(st, &n); n--;
- b[n] = '\0';
- str = cvalue_from_ref(stringtype, b, n, FL_NIL);
-#ifndef BOEHM_GC
- cv_autorelease((cvalue_t*)ptr(str));
-#endif
- }
- return str;
-}
-
-value_t fl_iotostring(value_t *args, u_int32_t nargs)
-{- argcount("io.tostring!", nargs, 1);- ios_t *src = toiostream(args[0], "io.tostring!");
- if (src->bm != bm_mem)
- lerror(ArgError, "io.tostring!: requires memory stream");
- return stream_to_string(&args[0]);
-}
-
-static builtinspec_t iostreamfunc_info[] = {- { "iostream?", fl_iostreamp },- { "eof-object", fl_eof_object },- { "eof-object?", fl_eof_objectp },- { "dump", fl_dump },- { "file", fl_file },- { "buffer", fl_buffer },- { "read", fl_read },- { "write", fl_write },- { "io.flush", fl_ioflush },- { "io.close", fl_ioclose },- { "io.eof?" , fl_ioeof },- { "io.seek" , fl_ioseek },- { "io.pos", fl_iopos },- { "io.getc" , fl_iogetc },- { "io.putc" , fl_ioputc },- { "io.peekc" , fl_iopeekc },- { "io.discardbuffer", fl_iopurge },- { "io.read", fl_ioread },- { "io.write", fl_iowrite },- { "io.copy", fl_iocopy },- { "io.readuntil", fl_ioreaduntil },- { "io.copyuntil", fl_iocopyuntil },- { "io.tostring!", fl_iotostring },- { NULL, NULL }-};
-
-void iostream_init()
-{- iostreamsym = symbol("iostream");- rdsym = symbol(":read");- wrsym = symbol(":write");- apsym = symbol(":append");- crsym = symbol(":create");- truncsym = symbol(":truncate");- instrsym = symbol("*input-stream*");- outstrsym = symbol("*output-stream*");- iostreamtype = define_opaque_type(iostreamsym, sizeof(ios_t),
- &iostream_vtable, NULL);
- assign_global_builtins(iostreamfunc_info);
-
- setc(symbol("*stdout*"), cvalue_from_ref(iostreamtype, ios_stdout,- sizeof(ios_t), FL_NIL));
- setc(symbol("*stderr*"), cvalue_from_ref(iostreamtype, ios_stderr,- sizeof(ios_t), FL_NIL));
- setc(symbol("*stdin*" ), cvalue_from_ref(iostreamtype, ios_stdin,- sizeof(ios_t), FL_NIL));
-}
--- a/femtolisp/lib/lazy.scm
+++ /dev/null
@@ -1,47 +1,0 @@
-; SRFI 45: Primitives for Expressing Iterative Lazy Algorithms
-; by André van Tonder
-;=========================================================================
-; Boxes
-
-(define (box x) (list x))
-(define unbox car)
-(define set-box! set-car!)
-
-;=========================================================================
-; Primitives for lazy evaluation:
-
-(define (eager x)
- (box (cons 'eager x)))
-
-#|
-(define-syntax lazy
- (syntax-rules ()
- ((lazy exp)
- (box (cons 'lazy (lambda () exp))))))
-
-(define-syntax delay
- (syntax-rules ()
- ((delay exp) (lazy (eager exp)))))
-|#
-
-(define-macro (lazy exp)
- `(box (cons 'lazy (lambda () ,exp))))
-
-(define-macro (delay exp)
- `(lazy (eager ,exp)))
-
-(define (force promise)
- (let ((content (unbox promise)))
- (case (car content)
- ((eager) (cdr content))
- ((lazy) (let* ((promise* ((cdr content)))
- (content (unbox promise))) ; *
- (if (not (eqv? (car content) 'eager)) ; *
- (begin (set-car! content (car (unbox promise*)))
- (set-cdr! content (cdr (unbox promise*)))
- (set-box! promise* content)))
- (force promise))))))
-
-; (*) These two lines re-fetch and check the original promise in case
-; the first line of the let* caused it to be forced. For an example
-; where this happens, see reentrancy test 3 below.
--- a/femtolisp/lib/psyntax.pp
+++ /dev/null
@@ -1,10858 +1,0 @@
-;;; psyntax.pp
-;;; automatically generated from psyntax.ss
-;;; Mon Feb 26 23:22:05 EST 2007
-;;; see copyright notice in psyntax.ss
-
-((lambda ()
- (letrec ((noexpand62 '"noexpand")
- (make-syntax-object63 (lambda (expression2530 wrap2529)
- (vector
- 'syntax-object
- expression2530
- wrap2529)))
- (syntax-object?64 (lambda (x2528)
- (if (vector? x2528)
- (if (= (vector-length x2528) '3)
- (eq? (vector-ref x2528 '0)
- 'syntax-object)
- '#f)
- '#f)))
- (syntax-object-expression65 (lambda (x2527)
- (vector-ref x2527 '1)))
- (syntax-object-wrap66 (lambda (x2526)
- (vector-ref x2526 '2)))
- (set-syntax-object-expression!67 (lambda (x2525 update2524)
- (vector-set!
- x2525
- '1
- update2524)))
- (set-syntax-object-wrap!68 (lambda (x2523 update2522)
- (vector-set!
- x2523
- '2
- update2522)))
- (annotation?132 (lambda (x2521) '#f))
- (top-level-eval-hook133 (lambda (x2520)
- (eval (list noexpand62 x2520))))
- (local-eval-hook134 (lambda (x2519)
- (eval (list noexpand62 x2519))))
- (define-top-level-value-hook135 (lambda (sym2518 val2517)
- (top-level-eval-hook133
- (list
- 'define
- sym2518
- (list 'quote val2517)))))
- (error-hook136 (lambda (who2516 why2515 what2514)
- (error who2516 '"~a ~s" why2515 what2514)))
- (put-cte-hook137 (lambda (symbol2513 val2512)
- ($sc-put-cte symbol2513 val2512 '*top*)))
- (get-global-definition-hook138 (lambda (symbol2511)
- (getprop
- symbol2511
- '*sc-expander*)))
- (put-global-definition-hook139 (lambda (symbol2510 x2509)
- (if (not x2509)
- (remprop
- symbol2510
- '*sc-expander*)
- (putprop
- symbol2510
- '*sc-expander*
- x2509))))
- (read-only-binding?140 (lambda (symbol2508) '#f))
- (get-import-binding141 (lambda (symbol2507 token2506)
- (getprop symbol2507 token2506)))
- (update-import-binding!142 (lambda (symbol2504 token2503
- p2502)
- ((lambda (x2505)
- (if (not x2505)
- (remprop
- symbol2504
- token2503)
- (putprop
- symbol2504
- token2503
- x2505)))
- (p2502
- (get-import-binding141
- symbol2504
- token2503)))))
- (generate-id143 ((lambda (digits2488)
- ((lambda (base2490 session-key2489)
- (letrec ((make-digit2491 (lambda (x2501)
- (string-ref
- digits2488
- x2501)))
- (fmt2492 (lambda (n2495)
- ((letrec ((fmt2496 (lambda (n2498
- a2497)
- (if (< n2498
- base2490)
- (list->string
- (cons
- (make-digit2491
- n2498)
- a2497))
- ((lambda (r2500
- rest2499)
- (fmt2496
- rest2499
- (cons
- (make-digit2491
- r2500)
- a2497)))
- (modulo
- n2498
- base2490)
- (quotient
- n2498
- base2490))))))
- fmt2496)
- n2495
- '()))))
- ((lambda (n2493)
- (lambda (name2494)
- (begin
- (set! n2493 (+ n2493 '1))
- (string->symbol
- (string-append
- session-key2489
- (fmt2492 n2493))))))
- '-1)))
- (string-length digits2488)
- '"_"))
- '"0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?~_^.+-"))
- (built-lambda?217 (lambda (x2487)
- (if (pair? x2487)
- (eq? (car x2487) 'lambda)
- '#f)))
- (build-sequence235 (lambda (ae2484 exps2483)
- ((letrec ((loop2485 (lambda (exps2486)
- (if (null?
- (cdr exps2486))
- (car exps2486)
- (if (equal?
- (car exps2486)
- '(void))
- (loop2485
- (cdr exps2486))
- (cons
- 'begin
- exps2486))))))
- loop2485)
- exps2483)))
- (build-letrec236 (lambda (ae2482 vars2481 val-exps2480
- body-exp2479)
- (if (null? vars2481)
- body-exp2479
- (list
- 'letrec
- (map list vars2481 val-exps2480)
- body-exp2479))))
- (build-body237 (lambda (ae2478 vars2477 val-exps2476
- body-exp2475)
- (build-letrec236
- ae2478
- vars2477
- val-exps2476
- body-exp2475)))
- (build-top-module238 (lambda (ae2463 types2462 vars2461
- val-exps2460 body-exp2459)
- (call-with-values
- (lambda ()
- ((letrec ((f2467 (lambda (types2469
- vars2468)
- (if (null?
- types2469)
- (values
- '()
- '()
- '())
- ((lambda (var2470)
- (call-with-values
- (lambda ()
- (f2467
- (cdr types2469)
- (cdr vars2468)))
- (lambda (vars2473
- defns2472
- sets2471)
- (if (eq? (car types2469)
- 'global)
- ((lambda (x2474)
- (values
- (cons
- x2474
- vars2473)
- (cons
- (list
- 'define
- var2470
- (chi-void518))
- defns2472)
- (cons
- (list
- 'set!
- var2470
- x2474)
- sets2471)))
- (gensym))
- (values
- (cons
- var2470
- vars2473)
- defns2472
- sets2471)))))
- (car vars2468))))))
- f2467)
- types2462
- vars2461))
- (lambda (vars2466 defns2465 sets2464)
- (if (null? defns2465)
- (build-letrec236
- ae2463
- vars2466
- val-exps2460
- body-exp2459)
- (build-sequence235
- '#f
- (append
- defns2465
- (list
- (build-letrec236
- ae2463
- vars2466
- val-exps2460
- (build-sequence235
- '#f
- (append
- sets2464
- (list
- body-exp2459))))))))))))
- (sanitize-binding271 (lambda (b2455)
- (if (procedure? b2455)
- (cons 'macro b2455)
- (if (binding?285 b2455)
- (if ((lambda (t2456)
- (if (memv
- t2456
- '(core
- macro
- macro!
- deferred))
- (procedure?
- (binding-value282
- b2455))
- (if (memv
- t2456
- '($module))
- (interface?452
- (binding-value282
- b2455))
- (if (memv
- t2456
- '(lexical))
- '#f
- (if (memv
- t2456
- '(global
- meta-variable))
- (symbol?
- (binding-value282
- b2455))
- (if (memv
- t2456
- '(syntax))
- ((lambda (x2457)
- (if (pair?
- x2457)
- (if '#f
- ((lambda (n2458)
- (if (integer?
- n2458)
- (if (exact?
- n2458)
- (>= n2458
- '0)
- '#f)
- '#f))
- (cdr x2457))
- '#f)
- '#f))
- (binding-value282
- b2455))
- (if (memv
- t2456
- '(begin
- define
- define-syntax
- set!
- $module-key
- $import
- eval-when
- meta))
- (null?
- (binding-value282
- b2455))
- (if (memv
- t2456
- '(local-syntax))
- (boolean?
- (binding-value282
- b2455))
- (if (memv
- t2456
- '(displaced-lexical))
- (eq? (binding-value282
- b2455)
- '#f)
- '#t)))))))))
- (binding-type281 b2455))
- b2455
- '#f)
- '#f))))
- (binding-type281 car)
- (binding-value282 cdr)
- (set-binding-type!283 set-car!)
- (set-binding-value!284 set-cdr!)
- (binding?285 (lambda (x2454)
- (if (pair? x2454) (symbol? (car x2454)) '#f)))
- (extend-env295 (lambda (label2453 binding2452 r2451)
- (cons (cons label2453 binding2452) r2451)))
- (extend-env*296 (lambda (labels2450 bindings2449 r2448)
- (if (null? labels2450)
- r2448
- (extend-env*296
- (cdr labels2450)
- (cdr bindings2449)
- (extend-env295
- (car labels2450)
- (car bindings2449)
- r2448)))))
- (extend-var-env*297 (lambda (labels2447 vars2446 r2445)
- (if (null? labels2447)
- r2445
- (extend-var-env*297
- (cdr labels2447)
- (cdr vars2446)
- (extend-env295
- (car labels2447)
- (cons 'lexical (car vars2446))
- r2445)))))
- (displaced-lexical?298 (lambda (id2442 r2441)
- ((lambda (n2443)
- (if n2443
- ((lambda (b2444)
- (eq? (binding-type281 b2444)
- 'displaced-lexical))
- (lookup301 n2443 r2441))
- '#f))
- (id-var-name434 id2442 '(())))))
- (displaced-lexical-error299 (lambda (id2440)
- (syntax-error
- id2440
- (if (id-var-name434
- id2440
- '(()))
- '"identifier out of context"
- '"identifier not visible"))))
- (lookup*300 (lambda (x2437 r2436)
- ((lambda (t2438)
- (if t2438
- (cdr t2438)
- (if (symbol? x2437)
- ((lambda (t2439)
- (if t2439
- t2439
- (cons 'global x2437)))
- (get-global-definition-hook138
- x2437))
- '(displaced-lexical . #f))))
- (assq x2437 r2436))))
- (lookup301 (lambda (x2431 r2430)
- (letrec ((whack-binding!2432 (lambda (b2435
- *b2434)
- (begin
- (set-binding-type!283
- b2435
- (binding-type281
- *b2434))
- (set-binding-value!284
- b2435
- (binding-value282
- *b2434))))))
- ((lambda (b2433)
- (begin
- (if (eq? (binding-type281 b2433) 'deferred)
- (whack-binding!2432
- b2433
- (make-transformer-binding302
- ((binding-value282 b2433))))
- (void))
- b2433))
- (lookup*300 x2431 r2430)))))
- (make-transformer-binding302 (lambda (b2428)
- ((lambda (t2429)
- (if t2429
- t2429
- (syntax-error
- b2428
- '"invalid transformer")))
- (sanitize-binding271 b2428))))
- (defer-or-eval-transformer303 (lambda (eval2427 x2426)
- (if (built-lambda?217 x2426)
- (cons
- 'deferred
- (lambda ()
- (eval2427 x2426)))
- (make-transformer-binding302
- (eval2427 x2426)))))
- (global-extend304 (lambda (type2425 sym2424 val2423)
- (put-cte-hook137
- sym2424
- (cons type2425 val2423))))
- (nonsymbol-id?305 (lambda (x2421)
- (if (syntax-object?64 x2421)
- (symbol?
- ((lambda (e2422)
- (if (annotation?132 e2422)
- (annotation-expression e2422)
- e2422))
- (syntax-object-expression65
- x2421)))
- '#f)))
- (id?306 (lambda (x2419)
- (if (symbol? x2419)
- '#t
- (if (syntax-object?64 x2419)
- (symbol?
- ((lambda (e2420)
- (if (annotation?132 e2420)
- (annotation-expression e2420)
- e2420))
- (syntax-object-expression65 x2419)))
- (if (annotation?132 x2419)
- (symbol? (annotation-expression x2419))
- '#f)))))
- (id-marks312 (lambda (id2418)
- (if (syntax-object?64 id2418)
- (wrap-marks316
- (syntax-object-wrap66 id2418))
- (wrap-marks316 '((top))))))
- (id-subst313 (lambda (id2417)
- (if (syntax-object?64 id2417)
- (wrap-subst317
- (syntax-object-wrap66 id2417))
- (wrap-marks316 '((top))))))
- (id-sym-name&marks314 (lambda (x2414 w2413)
- (if (syntax-object?64 x2414)
- (values
- ((lambda (e2415)
- (if (annotation?132 e2415)
- (annotation-expression
- e2415)
- e2415))
- (syntax-object-expression65
- x2414))
- (join-marks423
- (wrap-marks316 w2413)
- (wrap-marks316
- (syntax-object-wrap66
- x2414))))
- (values
- ((lambda (e2416)
- (if (annotation?132 e2416)
- (annotation-expression
- e2416)
- e2416))
- x2414)
- (wrap-marks316 w2413)))))
- (make-wrap315 cons)
- (wrap-marks316 car)
- (wrap-subst317 cdr)
- (make-indirect-label355 (lambda (label2412)
- (vector 'indirect-label label2412)))
- (indirect-label?356 (lambda (x2411)
- (if (vector? x2411)
- (if (= (vector-length x2411) '2)
- (eq? (vector-ref x2411 '0)
- 'indirect-label)
- '#f)
- '#f)))
- (indirect-label-label357 (lambda (x2410)
- (vector-ref x2410 '1)))
- (set-indirect-label-label!358 (lambda (x2409 update2408)
- (vector-set!
- x2409
- '1
- update2408)))
- (gen-indirect-label359 (lambda ()
- (make-indirect-label355
- (gen-label362))))
- (get-indirect-label360 (lambda (x2407)
- (indirect-label-label357 x2407)))
- (set-indirect-label!361 (lambda (x2406 v2405)
- (set-indirect-label-label!358
- x2406
- v2405)))
- (gen-label362 (lambda () (string '#\i)))
- (label?363 (lambda (x2402)
- ((lambda (t2403)
- (if t2403
- t2403
- ((lambda (t2404)
- (if t2404
- t2404
- (indirect-label?356 x2402)))
- (symbol? x2402))))
- (string? x2402))))
- (gen-labels364 (lambda (ls2401)
- (if (null? ls2401)
- '()
- (cons
- (gen-label362)
- (gen-labels364 (cdr ls2401))))))
- (make-ribcage365 (lambda (symnames2400 marks2399 labels2398)
- (vector
- 'ribcage
- symnames2400
- marks2399
- labels2398)))
- (ribcage?366 (lambda (x2397)
- (if (vector? x2397)
- (if (= (vector-length x2397) '4)
- (eq? (vector-ref x2397 '0) 'ribcage)
- '#f)
- '#f)))
- (ribcage-symnames367 (lambda (x2396) (vector-ref x2396 '1)))
- (ribcage-marks368 (lambda (x2395) (vector-ref x2395 '2)))
- (ribcage-labels369 (lambda (x2394) (vector-ref x2394 '3)))
- (set-ribcage-symnames!370 (lambda (x2393 update2392)
- (vector-set! x2393 '1 update2392)))
- (set-ribcage-marks!371 (lambda (x2391 update2390)
- (vector-set! x2391 '2 update2390)))
- (set-ribcage-labels!372 (lambda (x2389 update2388)
- (vector-set! x2389 '3 update2388)))
- (make-top-ribcage373 (lambda (key2387 mutable?2386)
- (vector
- 'top-ribcage
- key2387
- mutable?2386)))
- (top-ribcage?374 (lambda (x2385)
- (if (vector? x2385)
- (if (= (vector-length x2385) '3)
- (eq? (vector-ref x2385 '0)
- 'top-ribcage)
- '#f)
- '#f)))
- (top-ribcage-key375 (lambda (x2384) (vector-ref x2384 '1)))
- (top-ribcage-mutable?376 (lambda (x2383)
- (vector-ref x2383 '2)))
- (set-top-ribcage-key!377 (lambda (x2382 update2381)
- (vector-set! x2382 '1 update2381)))
- (set-top-ribcage-mutable?!378 (lambda (x2380 update2379)
- (vector-set!
- x2380
- '2
- update2379)))
- (make-import-interface379 (lambda (interface2378
- new-marks2377)
- (vector
- 'import-interface
- interface2378
- new-marks2377)))
- (import-interface?380 (lambda (x2376)
- (if (vector? x2376)
- (if (= (vector-length x2376) '3)
- (eq? (vector-ref x2376 '0)
- 'import-interface)
- '#f)
- '#f)))
- (import-interface-interface381 (lambda (x2375)
- (vector-ref x2375 '1)))
- (import-interface-new-marks382 (lambda (x2374)
- (vector-ref x2374 '2)))
- (set-import-interface-interface!383 (lambda (x2373
- update2372)
- (vector-set!
- x2373
- '1
- update2372)))
- (set-import-interface-new-marks!384 (lambda (x2371
- update2370)
- (vector-set!
- x2371
- '2
- update2370)))
- (make-env385 (lambda (top-ribcage2369 wrap2368)
- (vector 'env top-ribcage2369 wrap2368)))
- (env?386 (lambda (x2367)
- (if (vector? x2367)
- (if (= (vector-length x2367) '3)
- (eq? (vector-ref x2367 '0) 'env)
- '#f)
- '#f)))
- (env-top-ribcage387 (lambda (x2366) (vector-ref x2366 '1)))
- (env-wrap388 (lambda (x2365) (vector-ref x2365 '2)))
- (set-env-top-ribcage!389 (lambda (x2364 update2363)
- (vector-set! x2364 '1 update2363)))
- (set-env-wrap!390 (lambda (x2362 update2361)
- (vector-set! x2362 '2 update2361)))
- (anti-mark400 (lambda (w2360)
- (make-wrap315
- (cons '#f (wrap-marks316 w2360))
- (cons 'shift (wrap-subst317 w2360)))))
- (barrier-marker405 '#f)
- (extend-ribcage!410 (lambda (ribcage2358 id2357 label2356)
- (begin
- (set-ribcage-symnames!370
- ribcage2358
- (cons
- ((lambda (e2359)
- (if (annotation?132 e2359)
- (annotation-expression
- e2359)
- e2359))
- (syntax-object-expression65
- id2357))
- (ribcage-symnames367 ribcage2358)))
- (set-ribcage-marks!371
- ribcage2358
- (cons
- (wrap-marks316
- (syntax-object-wrap66 id2357))
- (ribcage-marks368 ribcage2358)))
- (set-ribcage-labels!372
- ribcage2358
- (cons
- label2356
- (ribcage-labels369
- ribcage2358))))))
- (import-extend-ribcage!411 (lambda (ribcage2354
- new-marks2353 id2352
- label2351)
- (begin
- (set-ribcage-symnames!370
- ribcage2354
- (cons
- ((lambda (e2355)
- (if (annotation?132
- e2355)
- (annotation-expression
- e2355)
- e2355))
- (syntax-object-expression65
- id2352))
- (ribcage-symnames367
- ribcage2354)))
- (set-ribcage-marks!371
- ribcage2354
- (cons
- (join-marks423
- new-marks2353
- (wrap-marks316
- (syntax-object-wrap66
- id2352)))
- (ribcage-marks368
- ribcage2354)))
- (set-ribcage-labels!372
- ribcage2354
- (cons
- label2351
- (ribcage-labels369
- ribcage2354))))))
- (extend-ribcage-barrier!412 (lambda (ribcage2350
- killer-id2349)
- (extend-ribcage-barrier-help!413
- ribcage2350
- (syntax-object-wrap66
- killer-id2349))))
- (extend-ribcage-barrier-help!413 (lambda (ribcage2348
- wrap2347)
- (begin
- (set-ribcage-symnames!370
- ribcage2348
- (cons
- barrier-marker405
- (ribcage-symnames367
- ribcage2348)))
- (set-ribcage-marks!371
- ribcage2348
- (cons
- (wrap-marks316
- wrap2347)
- (ribcage-marks368
- ribcage2348))))))
- (extend-ribcage-subst!414 (lambda (ribcage2346
- import-iface2345)
- (set-ribcage-symnames!370
- ribcage2346
- (cons
- import-iface2345
- (ribcage-symnames367
- ribcage2346)))))
- (lookup-import-binding-name415 (lambda (sym2340 marks2339
- token2338
- new-marks2337)
- ((lambda (new2341)
- (if new2341
- ((letrec ((f2342 (lambda (new2343)
- (if (pair?
- new2343)
- ((lambda (t2344)
- (if t2344
- t2344
- (f2342
- (cdr new2343))))
- (f2342
- (car new2343)))
- (if (symbol?
- new2343)
- (if (same-marks?425
- marks2339
- (join-marks423
- new-marks2337
- (wrap-marks316
- '((top)))))
- new2343
- '#f)
- (if (same-marks?425
- marks2339
- (join-marks423
- new-marks2337
- (wrap-marks316
- (syntax-object-wrap66
- new2343))))
- new2343
- '#f))))))
- f2342)
- new2341)
- '#f))
- (get-import-binding141
- sym2340
- token2338))))
- (store-import-binding416 (lambda (id2321 token2320
- new-marks2319)
- (letrec ((cons-id2322 (lambda (id2336
- x2335)
- (if (not x2335)
- id2336
- (cons
- id2336
- x2335))))
- (weed2323 (lambda (marks2334
- x2333)
- (if (pair?
- x2333)
- (if (same-marks?425
- (id-marks312
- (car x2333))
- marks2334)
- (weed2323
- marks2334
- (cdr x2333))
- (cons-id2322
- (car x2333)
- (weed2323
- marks2334
- (cdr x2333))))
- (if x2333
- (if (not (same-marks?425
- (id-marks312
- x2333)
- marks2334))
- x2333
- '#f)
- '#f)))))
- ((lambda (id2324)
- ((lambda (sym2325)
- (if (not (eq? id2324
- sym2325))
- ((lambda (marks2326)
- (update-import-binding!142
- sym2325
- token2320
- (lambda (old-binding2327)
- ((lambda (x2328)
- (cons-id2322
- (if (same-marks?425
- marks2326
- (wrap-marks316
- '((top))))
- (resolved-id-var-name420
- id2324)
- id2324)
- x2328))
- (weed2323
- marks2326
- old-binding2327)))))
- (id-marks312 id2324))
- (void)))
- ((lambda (x2329)
- ((lambda (e2330)
- (if (annotation?132
- e2330)
- (annotation-expression
- e2330)
- e2330))
- (if (syntax-object?64
- x2329)
- (syntax-object-expression65
- x2329)
- x2329)))
- id2324)))
- (if (null? new-marks2319)
- id2321
- (make-syntax-object63
- ((lambda (x2331)
- ((lambda (e2332)
- (if (annotation?132
- e2332)
- (annotation-expression
- e2332)
- e2332))
- (if (syntax-object?64
- x2331)
- (syntax-object-expression65
- x2331)
- x2331)))
- id2321)
- (make-wrap315
- (join-marks423
- new-marks2319
- (id-marks312 id2321))
- (id-subst313
- id2321))))))))
- (make-binding-wrap417 (lambda (ids2309 labels2308 w2307)
- (if (null? ids2309)
- w2307
- (make-wrap315
- (wrap-marks316 w2307)
- (cons
- ((lambda (labelvec2310)
- ((lambda (n2311)
- ((lambda (symnamevec2313
- marksvec2312)
- (begin
- ((letrec ((f2314 (lambda (ids2316
- i2315)
- (if (not (null?
- ids2316))
- (call-with-values
- (lambda ()
- (id-sym-name&marks314
- (car ids2316)
- w2307))
- (lambda (symname2318
- marks2317)
- (begin
- (vector-set!
- symnamevec2313
- i2315
- symname2318)
- (vector-set!
- marksvec2312
- i2315
- marks2317)
- (f2314
- (cdr ids2316)
- (+ i2315
- '1)))))
- (void)))))
- f2314)
- ids2309
- '0)
- (make-ribcage365
- symnamevec2313
- marksvec2312
- labelvec2310)))
- (make-vector n2311)
- (make-vector n2311)))
- (vector-length
- labelvec2310)))
- (list->vector labels2308))
- (wrap-subst317 w2307))))))
- (make-resolved-id418 (lambda (fromsym2306 marks2305
- tosym2304)
- (make-syntax-object63
- fromsym2306
- (make-wrap315
- marks2305
- (list
- (make-ribcage365
- (vector fromsym2306)
- (vector marks2305)
- (vector tosym2304)))))))
- (id->resolved-id419 (lambda (id2299)
- (call-with-values
- (lambda ()
- (id-var-name&marks432 id2299 '(())))
- (lambda (tosym2301 marks2300)
- (begin
- (if (not tosym2301)
- (syntax-error
- id2299
- '"identifier not visible for export")
- (void))
- (make-resolved-id418
- ((lambda (x2302)
- ((lambda (e2303)
- (if (annotation?132 e2303)
- (annotation-expression
- e2303)
- e2303))
- (if (syntax-object?64 x2302)
- (syntax-object-expression65
- x2302)
- x2302)))
- id2299)
- marks2300
- tosym2301))))))
- (resolved-id-var-name420 (lambda (id2298)
- (vector-ref
- (ribcage-labels369
- (car (wrap-subst317
- (syntax-object-wrap66
- id2298))))
- '0)))
- (smart-append421 (lambda (m12297 m22296)
- (if (null? m22296)
- m12297
- (append m12297 m22296))))
- (join-wraps422 (lambda (w12293 w22292)
- ((lambda (m12295 s12294)
- (if (null? m12295)
- (if (null? s12294)
- w22292
- (make-wrap315
- (wrap-marks316 w22292)
- (join-subst424
- s12294
- (wrap-subst317 w22292))))
- (make-wrap315
- (join-marks423
- m12295
- (wrap-marks316 w22292))
- (join-subst424
- s12294
- (wrap-subst317 w22292)))))
- (wrap-marks316 w12293)
- (wrap-subst317 w12293))))
- (join-marks423 (lambda (m12291 m22290)
- (smart-append421 m12291 m22290)))
- (join-subst424 (lambda (s12289 s22288)
- (smart-append421 s12289 s22288)))
- (same-marks?425 (lambda (x2286 y2285)
- ((lambda (t2287)
- (if t2287
- t2287
- (if (not (null? x2286))
- (if (not (null? y2285))
- (if (eq? (car x2286)
- (car y2285))
- (same-marks?425
- (cdr x2286)
- (cdr y2285))
- '#f)
- '#f)
- '#f)))
- (eq? x2286 y2285))))
- (diff-marks426 (lambda (m12279 m22278)
- ((lambda (n12281 n22280)
- ((letrec ((f2282 (lambda (n12284 m12283)
- (if (> n12284 n22280)
- (cons
- (car m12283)
- (f2282
- (- n12284 '1)
- (cdr m12283)))
- (if (equal?
- m12283
- m22278)
- '()
- (error 'sc-expand
- '"internal error in diff-marks: ~s is not a tail of ~s"
- m12283
- m22278))))))
- f2282)
- n12281
- m12279))
- (length m12279)
- (length m22278))))
- (leave-implicit?427 (lambda (token2277)
- (eq? token2277 '*top*)))
- (new-binding428 (lambda (sym2274 marks2273 token2272)
- ((lambda (loc2275)
- ((lambda (id2276)
- (begin
- (store-import-binding416
- id2276
- token2272
- '())
- (values loc2275 id2276)))
- (make-resolved-id418
- sym2274
- marks2273
- loc2275)))
- (if (if (leave-implicit?427 token2272)
- (same-marks?425
- marks2273
- (wrap-marks316 '((top))))
- '#f)
- sym2274
- (generate-id143 sym2274)))))
- (top-id-bound-var-name429 (lambda (sym2268 marks2267
- top-ribcage2266)
- ((lambda (token2269)
- ((lambda (t2270)
- (if t2270
- ((lambda (id2271)
- (if (symbol? id2271)
- (if (read-only-binding?140
- id2271)
- (new-binding428
- sym2268
- marks2267
- token2269)
- (values
- id2271
- (make-resolved-id418
- sym2268
- marks2267
- id2271)))
- (values
- (resolved-id-var-name420
- id2271)
- id2271)))
- t2270)
- (new-binding428
- sym2268
- marks2267
- token2269)))
- (lookup-import-binding-name415
- sym2268
- marks2267
- token2269
- '())))
- (top-ribcage-key375
- top-ribcage2266))))
- (top-id-free-var-name430 (lambda (sym2260 marks2259
- top-ribcage2258)
- ((lambda (token2261)
- ((lambda (t2262)
- (if t2262
- ((lambda (id2263)
- (if (symbol? id2263)
- id2263
- (resolved-id-var-name420
- id2263)))
- t2262)
- (if (if (top-ribcage-mutable?376
- top-ribcage2258)
- (same-marks?425
- marks2259
- (wrap-marks316
- '((top))))
- '#f)
- (call-with-values
- (lambda ()
- (new-binding428
- sym2260
- (wrap-marks316
- '((top)))
- token2261))
- (lambda (sym2265
- id2264)
- sym2265))
- '#f)))
- (lookup-import-binding-name415
- sym2260
- marks2259
- token2261
- '())))
- (top-ribcage-key375
- top-ribcage2258))))
- (id-var-name-loc&marks431 (lambda (id2209 w2208)
- (letrec ((search2210 (lambda (sym2253
- subst2252
- marks2251)
- (if (null?
- subst2252)
- (values
- '#f
- marks2251)
- ((lambda (fst2254)
- (if (eq? fst2254
- 'shift)
- (search2210
- sym2253
- (cdr subst2252)
- (cdr marks2251))
- (if (ribcage?366
- fst2254)
- ((lambda (symnames2255)
- (if (vector?
- symnames2255)
- (search-vector-rib2212
- sym2253
- subst2252
- marks2251
- symnames2255
- fst2254)
- (search-list-rib2211
- sym2253
- subst2252
- marks2251
- symnames2255
- fst2254)))
- (ribcage-symnames367
- fst2254))
- (if (top-ribcage?374
- fst2254)
- ((lambda (t2256)
- (if t2256
- ((lambda (var-name2257)
- (values
- var-name2257
- marks2251))
- t2256)
- (search2210
- sym2253
- (cdr subst2252)
- marks2251)))
- (top-id-free-var-name430
- sym2253
- marks2251
- fst2254))
- (error 'sc-expand
- '"internal error in id-var-name-loc&marks: improper subst ~s"
- subst2252)))))
- (car subst2252)))))
- (search-list-rib2211 (lambda (sym2231
- subst2230
- marks2229
- symnames2228
- ribcage2227)
- ((letrec ((f2232 (lambda (symnames2234
- i2233)
- (if (null?
- symnames2234)
- (search2210
- sym2231
- (cdr subst2230)
- marks2229)
- ((lambda (x2235)
- (if (if (eq? x2235
- sym2231)
- (same-marks?425
- marks2229
- (list-ref
- (ribcage-marks368
- ribcage2227)
- i2233))
- '#f)
- (values
- (list-ref
- (ribcage-labels369
- ribcage2227)
- i2233)
- marks2229)
- (if (import-interface?380
- x2235)
- ((lambda (iface2237
- new-marks2236)
- ((lambda (t2238)
- (if t2238
- ((lambda (token2239)
- ((lambda (t2240)
- (if t2240
- ((lambda (id2241)
- (values
- (if (symbol?
- id2241)
- id2241
- (resolved-id-var-name420
- id2241))
- marks2229))
- t2240)
- (f2232
- (cdr symnames2234)
- i2233)))
- (lookup-import-binding-name415
- sym2231
- marks2229
- token2239
- new-marks2236)))
- t2238)
- ((lambda (ie2242)
- ((lambda (n2243)
- ((lambda ()
- ((letrec ((g2244 (lambda (j2245)
- (if (= j2245
- n2243)
- (f2232
- (cdr symnames2234)
- i2233)
- ((lambda (id2246)
- ((lambda (id.sym2248
- id.marks2247)
- (if (help-bound-id=?437
- id.sym2248
- id.marks2247
- sym2231
- marks2229)
- (values
- (lookup-import-label506
- id2246)
- marks2229)
- (g2244
- (+ j2245
- '1))))
- ((lambda (x2249)
- ((lambda (e2250)
- (if (annotation?132
- e2250)
- (annotation-expression
- e2250)
- e2250))
- (if (syntax-object?64
- x2249)
- (syntax-object-expression65
- x2249)
- x2249)))
- id2246)
- (join-marks423
- new-marks2236
- (id-marks312
- id2246))))
- (vector-ref
- ie2242
- j2245))))))
- g2244)
- '0))))
- (vector-length
- ie2242)))
- (interface-exports454
- iface2237))))
- (interface-token455
- iface2237)))
- (import-interface-interface381
- x2235)
- (import-interface-new-marks382
- x2235))
- (if (if (eq? x2235
- barrier-marker405)
- (same-marks?425
- marks2229
- (list-ref
- (ribcage-marks368
- ribcage2227)
- i2233))
- '#f)
- (values
- '#f
- marks2229)
- (f2232
- (cdr symnames2234)
- (+ i2233
- '1))))))
- (car symnames2234))))))
- f2232)
- symnames2228
- '0)))
- (search-vector-rib2212 (lambda (sym2223
- subst2222
- marks2221
- symnames2220
- ribcage2219)
- ((lambda (n2224)
- ((letrec ((f2225 (lambda (i2226)
- (if (= i2226
- n2224)
- (search2210
- sym2223
- (cdr subst2222)
- marks2221)
- (if (if (eq? (vector-ref
- symnames2220
- i2226)
- sym2223)
- (same-marks?425
- marks2221
- (vector-ref
- (ribcage-marks368
- ribcage2219)
- i2226))
- '#f)
- (values
- (vector-ref
- (ribcage-labels369
- ribcage2219)
- i2226)
- marks2221)
- (f2225
- (+ i2226
- '1)))))))
- f2225)
- '0))
- (vector-length
- symnames2220)))))
- (if (symbol? id2209)
- (search2210
- id2209
- (wrap-subst317 w2208)
- (wrap-marks316 w2208))
- (if (syntax-object?64 id2209)
- ((lambda (sym2214 w12213)
- (call-with-values
- (lambda ()
- (search2210
- sym2214
- (wrap-subst317
- w2208)
- (join-marks423
- (wrap-marks316
- w2208)
- (wrap-marks316
- w12213))))
- (lambda (name2216
- marks2215)
- (if name2216
- (values
- name2216
- marks2215)
- (search2210
- sym2214
- (wrap-subst317
- w12213)
- marks2215)))))
- ((lambda (e2217)
- (if (annotation?132
- e2217)
- (annotation-expression
- e2217)
- e2217))
- (syntax-object-expression65
- id2209))
- (syntax-object-wrap66
- id2209))
- (if (annotation?132
- id2209)
- (search2210
- ((lambda (e2218)
- (if (annotation?132
- e2218)
- (annotation-expression
- e2218)
- e2218))
- id2209)
- (wrap-subst317
- w2208)
- (wrap-marks316
- w2208))
- (error-hook136
- 'id-var-name
- '"invalid id"
- id2209)))))))
- (id-var-name&marks432 (lambda (id2205 w2204)
- (call-with-values
- (lambda ()
- (id-var-name-loc&marks431
- id2205
- w2204))
- (lambda (label2207 marks2206)
- (values
- (if (indirect-label?356
- label2207)
- (get-indirect-label360
- label2207)
- label2207)
- marks2206)))))
- (id-var-name-loc433 (lambda (id2201 w2200)
- (call-with-values
- (lambda ()
- (id-var-name-loc&marks431
- id2201
- w2200))
- (lambda (label2203 marks2202)
- label2203))))
- (id-var-name434 (lambda (id2197 w2196)
- (call-with-values
- (lambda ()
- (id-var-name-loc&marks431 id2197 w2196))
- (lambda (label2199 marks2198)
- (if (indirect-label?356 label2199)
- (get-indirect-label360 label2199)
- label2199)))))
- (free-id=?435 (lambda (i2191 j2190)
- (if (eq? ((lambda (x2194)
- ((lambda (e2195)
- (if (annotation?132 e2195)
- (annotation-expression
- e2195)
- e2195))
- (if (syntax-object?64 x2194)
- (syntax-object-expression65
- x2194)
- x2194)))
- i2191)
- ((lambda (x2192)
- ((lambda (e2193)
- (if (annotation?132 e2193)
- (annotation-expression
- e2193)
- e2193))
- (if (syntax-object?64 x2192)
- (syntax-object-expression65
- x2192)
- x2192)))
- j2190))
- (eq? (id-var-name434 i2191 '(()))
- (id-var-name434 j2190 '(())))
- '#f)))
- (literal-id=?436 (lambda (id2180 literal2179)
- (if (eq? ((lambda (x2183)
- ((lambda (e2184)
- (if (annotation?132 e2184)
- (annotation-expression
- e2184)
- e2184))
- (if (syntax-object?64 x2183)
- (syntax-object-expression65
- x2183)
- x2183)))
- id2180)
- ((lambda (x2181)
- ((lambda (e2182)
- (if (annotation?132 e2182)
- (annotation-expression
- e2182)
- e2182))
- (if (syntax-object?64 x2181)
- (syntax-object-expression65
- x2181)
- x2181)))
- literal2179))
- ((lambda (n-id2186 n-literal2185)
- ((lambda (t2187)
- (if t2187
- t2187
- (if ((lambda (t2188)
- (if t2188
- t2188
- (symbol?
- n-id2186)))
- (not n-id2186))
- ((lambda (t2189)
- (if t2189
- t2189
- (symbol?
- n-literal2185)))
- (not n-literal2185))
- '#f)))
- (eq? n-id2186 n-literal2185)))
- (id-var-name434 id2180 '(()))
- (id-var-name434 literal2179 '(())))
- '#f)))
- (help-bound-id=?437 (lambda (i.sym2178 i.marks2177 j.sym2176
- j.marks2175)
- (if (eq? i.sym2178 j.sym2176)
- (same-marks?425
- i.marks2177
- j.marks2175)
- '#f)))
- (bound-id=?438 (lambda (i2170 j2169)
- (help-bound-id=?437
- ((lambda (x2173)
- ((lambda (e2174)
- (if (annotation?132 e2174)
- (annotation-expression e2174)
- e2174))
- (if (syntax-object?64 x2173)
- (syntax-object-expression65 x2173)
- x2173)))
- i2170)
- (id-marks312 i2170)
- ((lambda (x2171)
- ((lambda (e2172)
- (if (annotation?132 e2172)
- (annotation-expression e2172)
- e2172))
- (if (syntax-object?64 x2171)
- (syntax-object-expression65 x2171)
- x2171)))
- j2169)
- (id-marks312 j2169))))
- (valid-bound-ids?439 (lambda (ids2165)
- (if ((letrec ((all-ids?2166 (lambda (ids2167)
- ((lambda (t2168)
- (if t2168
- t2168
- (if (id?306
- (car ids2167))
- (all-ids?2166
- (cdr ids2167))
- '#f)))
- (null?
- ids2167)))))
- all-ids?2166)
- ids2165)
- (distinct-bound-ids?440 ids2165)
- '#f)))
- (distinct-bound-ids?440 (lambda (ids2161)
- ((letrec ((distinct?2162 (lambda (ids2163)
- ((lambda (t2164)
- (if t2164
- t2164
- (if (not (bound-id-member?442
- (car ids2163)
- (cdr ids2163)))
- (distinct?2162
- (cdr ids2163))
- '#f)))
- (null?
- ids2163)))))
- distinct?2162)
- ids2161)))
- (invalid-ids-error441 (lambda (ids2157 exp2156 class2155)
- ((letrec ((find2158 (lambda (ids2160
- gooduns2159)
- (if (null?
- ids2160)
- (syntax-error
- exp2156)
- (if (id?306
- (car ids2160))
- (if (bound-id-member?442
- (car ids2160)
- gooduns2159)
- (syntax-error
- (car ids2160)
- '"duplicate "
- class2155)
- (find2158
- (cdr ids2160)
- (cons
- (car ids2160)
- gooduns2159)))
- (syntax-error
- (car ids2160)
- '"invalid "
- class2155))))))
- find2158)
- ids2157
- '())))
- (bound-id-member?442 (lambda (x2153 list2152)
- (if (not (null? list2152))
- ((lambda (t2154)
- (if t2154
- t2154
- (bound-id-member?442
- x2153
- (cdr list2152))))
- (bound-id=?438
- x2153
- (car list2152)))
- '#f)))
- (wrap443 (lambda (x2151 w2150)
- (if (if (null? (wrap-marks316 w2150))
- (null? (wrap-subst317 w2150))
- '#f)
- x2151
- (if (syntax-object?64 x2151)
- (make-syntax-object63
- (syntax-object-expression65 x2151)
- (join-wraps422
- w2150
- (syntax-object-wrap66 x2151)))
- (if (null? x2151)
- x2151
- (make-syntax-object63 x2151 w2150))))))
- (source-wrap444 (lambda (x2149 w2148 ae2147)
- (wrap443
- (if (annotation?132 ae2147)
- (begin
- (if (not (eq? (annotation-expression
- ae2147)
- x2149))
- (error 'sc-expand
- '"internal error in source-wrap: ae/x mismatch")
- (void))
- ae2147)
- x2149)
- w2148)))
- (chi-when-list445 (lambda (when-list2145 w2144)
- (map (lambda (x2146)
- (if (literal-id=?436
- x2146
- '#(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(when-list w) #((top) (top)) #("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (to\ No newline at end of file
- 'compile
- (if (literal-id=?436
- x2146
- '#(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(when-list w) #((top) (top)) #("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (t\ No newline at end of file
- 'load
- (if (literal-id=?436
- x2146
- '#(syntax-object visit ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(when-list w) #((top) (top)) #("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (to\ No newline at end of file
- 'visit
- (if (literal-id=?436
- x2146
- '#(syntax-object revisit ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(when-list w) #((top) (top)) #("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (to\ No newline at end of file
- 'revisit
- (if (literal-id=?436
- x2146
- '#(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(when-list w) #((top) (top)) #("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (t\ No newline at end of file
- 'eval
- (syntax-error
- (wrap443
- x2146
- w2144)
- '"invalid eval-when situation")))))))
- when-list2145)))
- (syntax-type446 (lambda (e2129 r2128 w2127 ae2126 rib2125)
- (if (symbol? e2129)
- ((lambda (n2130)
- ((lambda (b2131)
- ((lambda (type2132)
- ((lambda ()
- ((lambda (t2133)
- (if (memv
- t2133
- '(macro macro!))
- (syntax-type446
- (chi-macro502
- (binding-value282
- b2131)
- e2129 r2128 w2127
- ae2126 rib2125)
- r2128 '(()) '#f
- rib2125)
- (values type2132
- (binding-value282
- b2131)
- e2129 w2127
- ae2126)))
- type2132))))
- (binding-type281 b2131)))
- (lookup301 n2130 r2128)))
- (id-var-name434 e2129 w2127))
- (if (pair? e2129)
- ((lambda (first2134)
- (if (id?306 first2134)
- ((lambda (n2135)
- ((lambda (b2136)
- ((lambda (type2137)
- ((lambda ()
- ((lambda (t2138)
- (if (memv
- t2138
- '(lexical))
- (values
- 'lexical-call
- (binding-value282
- b2136)
- e2129
- w2127
- ae2126)
- (if (memv
- t2138
- '(macro
- macro!))
- (syntax-type446
- (chi-macro502
- (binding-value282
- b2136)
- e2129
- r2128
- w2127
- ae2126
- rib2125)
- r2128
- '(())
- '#f
- rib2125)
- (if (memv
- t2138
- '(core))
- (values
- type2137
- (binding-value282
- b2136)
- e2129
- w2127
- ae2126)
- (if (memv
- t2138
- '(begin))
- (values
- 'begin-form
- '#f
- e2129
- w2127
- ae2126)
- (if (memv
- t2138
- '(alias))
- (values
- 'alias-form
- '#f
- e2129
- w2127
- ae2126)
- (if (memv
- t2138
- '(define))
- (values
- 'define-form
- '#f
- e2129
- w2127
- ae2126)
- (if (memv
- t2138
- '(define-syntax))
- (values
- 'define-syntax-form
- '#f
- e2129
- w2127
- ae2126)
- (if (memv
- t2138
- '(set!))
- (chi-set!501
- e2129
- r2128
- w2127
- ae2126
- rib2125)
- (if (memv
- t2138
- '($module-key))
- (values
- '$module-form
- '#f
- e2129
- w2127
- ae2126)
- (if (memv
- t2138
- '($import))
- (values
- '$import-form
- '#f
- e2129
- w2127
- ae2126)
- (if (memv
- t2138
- '(eval-when))
- (values
- 'eval-when-form
- '#f
- e2129
- w2127
- ae2126)
- (if (memv
- t2138
- '(meta))
- (values
- 'meta-form
- '#f
- e2129
- w2127
- ae2126)
- (if (memv
- t2138
- '(local-syntax))
- (values
- 'local-syntax-form
- (binding-value282
- b2136)
- e2129
- w2127
- ae2126)
- (values
- 'call
- '#f
- e2129
- w2127
- ae2126)))))))))))))))
- type2137))))
- (binding-type281
- b2136)))
- (lookup301 n2135 r2128)))
- (id-var-name434
- first2134
- w2127))
- (values 'call '#f e2129 w2127
- ae2126)))
- (car e2129))
- (if (syntax-object?64 e2129)
- (syntax-type446
- (syntax-object-expression65
- e2129)
- r2128
- (join-wraps422
- w2127
- (syntax-object-wrap66 e2129))
- '#f rib2125)
- (if (annotation?132 e2129)
- (syntax-type446
- (annotation-expression
- e2129)
- r2128 w2127 e2129 rib2125)
- (if ((lambda (x2139)
- ((lambda (t2140)
- (if t2140
- t2140
- ((lambda (t2141)
- (if t2141
- t2141
- ((lambda (t2142)
- (if t2142
- t2142
- ((lambda (t2143)
- (if t2143
- t2143
- (null?
- x2139)))
- (char?
- x2139))))
- (string?
- x2139))))
- (number?
- x2139))))
- (boolean? x2139)))
- e2129)
- (values 'constant '#f
- e2129 w2127 ae2126)
- (values 'other '#f e2129
- w2127 ae2126))))))))
- (chi-top*447 (lambda (e2120 r2119 w2118 ctem2117 rtem2116
- meta?2115 top-ribcage2114)
- ((lambda (meta-residuals2121)
- (letrec ((meta-residualize!2122 (lambda (x2124)
- (set! meta-residuals2121
- (cons
- x2124
- meta-residuals2121)))))
- ((lambda (e2123)
- (build-sequence235
- '#f
- (reverse
- (cons e2123 meta-residuals2121))))
- (chi-top449 e2120 r2119 w2118 ctem2117
- rtem2116 meta?2115 top-ribcage2114
- meta-residualize!2122 '#f))))
- '())))
- (chi-top-sequence448 (lambda (body2110 r2109 w2108 ae2107
- ctem2106 rtem2105 meta?2104
- ribcage2103
- meta-residualize!2102)
- (build-sequence235
- ae2107
- ((letrec ((dobody2111 (lambda (body2112)
- (if (null?
- body2112)
- '()
- ((lambda (first2113)
- (cons
- first2113
- (dobody2111
- (cdr body2112))))
- (chi-top449
- (car body2112)
- r2109
- w2108
- ctem2106
- rtem2105
- meta?2104
- ribcage2103
- meta-residualize!2102
- '#f))))))
- dobody2111)
- body2110))))
- (chi-top449 (lambda (e2047 r2046 w2045 ctem2044 rtem2043
- meta?2042 top-ribcage2041
- meta-residualize!2040 meta-seen?2039)
- (call-with-values
- (lambda ()
- (syntax-type446 e2047 r2046 w2045 '#f
- top-ribcage2041))
- (lambda (type2052 value2051 e2050 w2049 ae2048)
- ((lambda (t2053)
- (if (memv t2053 '(begin-form))
- ((lambda (forms2054)
- (if (null? forms2054)
- (chi-void518)
- (chi-top-sequence448 forms2054
- r2046 w2049 ae2048 ctem2044
- rtem2043 meta?2042
- top-ribcage2041
- meta-residualize!2040)))
- (parse-begin515
- e2050
- w2049
- ae2048
- '#t))
- (if (memv t2053 '(local-syntax-form))
- (call-with-values
- (lambda ()
- (chi-local-syntax517 value2051
- e2050 r2046 r2046 w2049
- ae2048))
- (lambda (forms2059 r2058 mr2057
- w2056 ae2055)
- (chi-top-sequence448 forms2059
- r2058 w2056 ae2055 ctem2044
- rtem2043 meta?2042
- top-ribcage2041
- meta-residualize!2040)))
- (if (memv t2053 '(eval-when-form))
- (call-with-values
- (lambda ()
- (parse-eval-when513
- e2050
- w2049
- ae2048))
- (lambda (when-list2061
- forms2060)
- ((lambda (ctem2063
- rtem2062)
- (if (if (null?
- ctem2063)
- (null?
- rtem2062)
- '#f)
- (chi-void518)
- (chi-top-sequence448
- forms2060 r2046
- w2049 ae2048
- ctem2063 rtem2062
- meta?2042
- top-ribcage2041
- meta-residualize!2040)))
- (update-mode-set490
- when-list2061
- ctem2044)
- (update-mode-set490
- when-list2061
- rtem2043))))
- (if (memv t2053 '(meta-form))
- (chi-top449
- (parse-meta512
- e2050
- w2049
- ae2048)
- r2046 w2049 ctem2044
- rtem2043 '#t
- top-ribcage2041
- meta-residualize!2040
- '#t)
- (if (memv
- t2053
- '(define-syntax-form))
- (call-with-values
- (lambda ()
- (parse-define-syntax511
- e2050
- w2049
- ae2048))
- (lambda (id2066
- rhs2065
- w2064)
- ((lambda (id2067)
- (begin
- (if (displaced-lexical?298
- id2067
- r2046)
- (displaced-lexical-error299
- id2067)
- (void))
- (if (not (top-ribcage-mutable?376
- top-ribcage2041))
- (syntax-error
- (source-wrap444
- e2050
- w2064
- ae2048)
- '"invalid definition in read-only environment")
- (void))
- ((lambda (sym2068)
- (call-with-values
- (lambda ()
- (top-id-bound-var-name429
- sym2068
- (wrap-marks316
- (syntax-object-wrap66
- id2067))
- top-ribcage2041))
- (lambda (valsym2070
- bound-id2069)
- (begin
- (if (not (eq? (id-var-name434
- id2067
- '(()))
- valsym2070))
- (syntax-error
- (source-wrap444
- e2050
- w2064
- ae2048)
- '"definition not permitted")
- (void))
- (if (read-only-binding?140
- valsym2070)
- (syntax-error
- (source-wrap444
- e2050
- w2064
- ae2048)
- '"invalid definition of read-only identifier")
- (void))
- (ct-eval/residualize2493
- ctem2044
- (lambda ()
- (list
- '$sc-put-cte
- (list
- 'quote
- bound-id2069)
- (chi498
- rhs2065
- r2046
- r2046
- w2064
- '#t)
- (list
- 'quote
- (top-ribcage-key375
- top-ribcage2041)))))))))
- ((lambda (x2071)
- ((lambda (e2072)
- (if (annotation?132
- e2072)
- (annotation-expression
- e2072)
- e2072))
- (if (syntax-object?64
- x2071)
- (syntax-object-expression65
- x2071)
- x2071)))
- id2067))))
- (wrap443
- id2066
- w2064))))
- (if (memv
- t2053
- '(define-form))
- (call-with-values
- (lambda ()
- (parse-define510
- e2050
- w2049
- ae2048))
- (lambda (id2075
- rhs2074
- w2073)
- ((lambda (id2076)
- (begin
- (if (displaced-lexical?298
- id2076
- r2046)
- (displaced-lexical-error299
- id2076)
- (void))
- (if (not (top-ribcage-mutable?376
- top-ribcage2041))
- (syntax-error
- (source-wrap444
- e2050
- w2073
- ae2048)
- '"invalid definition in read-only environment")
- (void))
- ((lambda (sym2077)
- (call-with-values
- (lambda ()
- (top-id-bound-var-name429
- sym2077
- (wrap-marks316
- (syntax-object-wrap66
- id2076))
- top-ribcage2041))
- (lambda (valsym2079
- bound-id2078)
- (begin
- (if (not (eq? (id-var-name434
- id2076
- '(()))
- valsym2079))
- (syntax-error
- (source-wrap444
- e2050
- w2073
- ae2048)
- '"definition not permitted")
- (void))
- (if (read-only-binding?140
- valsym2079)
- (syntax-error
- (source-wrap444
- e2050
- w2073
- ae2048)
- '"invalid definition of read-only identifier")
- (void))
- (if meta?2042
- (ct-eval/residualize2493
- ctem2044
- (lambda ()
- (build-sequence235
- '#f
- (list
- (list
- '$sc-put-cte
- (list
- 'quote
- bound-id2078)
- (list
- 'quote
- (cons
- 'meta-variable
- valsym2079))
- (list
- 'quote
- (top-ribcage-key375
- top-ribcage2041)))
- (list
- 'define
- valsym2079
- (chi498
- rhs2074
- r2046
- r2046
- w2073
- '#t))))))
- ((lambda (x2080)
- (build-sequence235
- '#f
- (list
- x2080
- (rt-eval/residualize492
- rtem2043
- (lambda ()
- (list
- 'define
- valsym2079
- (chi498
- rhs2074
- r2046
- r2046
- w2073
- '#f)))))))
- (ct-eval/residualize2493
- ctem2044
- (lambda ()
- (list
- '$sc-put-cte
- (list
- 'quote
- bound-id2078)
- (list
- 'quote
- (cons
- 'global
- valsym2079))
- (list
- 'quote
- (top-ribcage-key375
- top-ribcage2041)))))))))))
- ((lambda (x2081)
- ((lambda (e2082)
- (if (annotation?132
- e2082)
- (annotation-expression
- e2082)
- e2082))
- (if (syntax-object?64
- x2081)
- (syntax-object-expression65
- x2081)
- x2081)))
- id2076))))
- (wrap443
- id2075
- w2073))))
- (if (memv
- t2053
- '($module-form))
- ((lambda (ribcage2083)
- (call-with-values
- (lambda ()
- (parse-module508
- e2050
- w2049
- ae2048
- (make-wrap315
- (wrap-marks316
- w2049)
- (cons
- ribcage2083
- (wrap-subst317
- w2049)))))
- (lambda (orig2087
- id2086
- exports2085
- forms2084)
- (begin
- (if (displaced-lexical?298
- id2086
- r2046)
- (displaced-lexical-error299
- (wrap443
- id2086
- w2049))
- (void))
- (if (not (top-ribcage-mutable?376
- top-ribcage2041))
- (syntax-error
- orig2087
- '"invalid definition in read-only environment")
- (void))
- (chi-top-module482
- orig2087
- r2046
- r2046
- top-ribcage2041
- ribcage2083
- ctem2044
- rtem2043
- meta?2042
- id2086
- exports2085
- forms2084
- meta-residualize!2040)))))
- (make-ribcage365
- '()
- '()
- '()))
- (if (memv
- t2053
- '($import-form))
- (call-with-values
- (lambda ()
- (parse-import509
- e2050
- w2049
- ae2048))
- (lambda (orig2090
- only?2089
- mid2088)
- (begin
- (if (not (top-ribcage-mutable?376
- top-ribcage2041))
- (syntax-error
- orig2090
- '"invalid definition in read-only environment")
- (void))
- (ct-eval/residualize2493
- ctem2044
- (lambda ()
- ((lambda (binding2091)
- ((lambda (t2092)
- (if (memv
- t2092
- '($module))
- (do-top-import489
- only?2089
- top-ribcage2041
- mid2088
- (interface-token455
- (binding-value282
- binding2091)))
- (if (memv
- t2092
- '(displaced-lexical))
- (displaced-lexical-error299
- mid2088)
- (syntax-error
- mid2088
- '"unknown module"))))
- (binding-type281
- binding2091)))
- (lookup301
- (id-var-name434
- mid2088
- '(()))
- '())))))))
- (if (memv
- t2053
- '(alias-form))
- (call-with-values
- (lambda ()
- (parse-alias514
- e2050
- w2049
- ae2048))
- (lambda (new-id2094
- old-id2093)
- ((lambda (new-id2095)
- (begin
- (if (displaced-lexical?298
- new-id2095
- r2046)
- (displaced-lexical-error299
- new-id2095)
- (void))
- (if (not (top-ribcage-mutable?376
- top-ribcage2041))
- (syntax-error
- (source-wrap444
- e2050
- w2049
- ae2048)
- '"invalid definition in read-only environment")
- (void))
- ((lambda (sym2096)
- (call-with-values
- (lambda ()
- (top-id-bound-var-name429
- sym2096
- (wrap-marks316
- (syntax-object-wrap66
- new-id2095))
- top-ribcage2041))
- (lambda (valsym2098
- bound-id2097)
- (begin
- (if (not (eq? (id-var-name434
- new-id2095
- '(()))
- valsym2098))
- (syntax-error
- (source-wrap444
- e2050
- w2049
- ae2048)
- '"definition not permitted")
- (void))
- (if (read-only-binding?140
- valsym2098)
- (syntax-error
- (source-wrap444
- e2050
- w2049
- ae2048)
- '"invalid definition of read-only identifier")
- (void))
- (ct-eval/residualize2493
- ctem2044
- (lambda ()
- (list
- '$sc-put-cte
- (list
- 'quote
- (make-resolved-id418
- sym2096
- (wrap-marks316
- (syntax-object-wrap66
- new-id2095))
- (id-var-name434
- old-id2093
- w2049)))
- (list
- 'quote
- '(do-alias
- .
- #f))
- (list
- 'quote
- (top-ribcage-key375
- top-ribcage2041)))))))))
- ((lambda (x2099)
- ((lambda (e2100)
- (if (annotation?132
- e2100)
- (annotation-expression
- e2100)
- e2100))
- (if (syntax-object?64
- x2099)
- (syntax-object-expression65
- x2099)
- x2099)))
- new-id2095))))
- (wrap443
- new-id2094
- w2049))))
- (begin
- (if meta-seen?2039
- (syntax-error
- (source-wrap444
- e2050
- w2049
- ae2048)
- '"invalid meta definition")
- (void))
- (if meta?2042
- ((lambda (x2101)
- (begin
- (top-level-eval-hook133
- x2101)
- (ct-eval/residualize3494
- ctem2044
- void
- (lambda ()
- x2101))))
- (chi-expr499
- type2052
- value2051
- e2050
- r2046
- r2046
- w2049
- ae2048
- '#t))
- (rt-eval/residualize492
- rtem2043
- (lambda ()
- (chi-expr499
- type2052
- value2051
- e2050
- r2046
- r2046
- w2049
- ae2048
- '#f)))))))))))))))
- type2052)))))
- (flatten-exports450 (lambda (exports2035)
- ((letrec ((loop2036 (lambda (exports2038
- ls2037)
- (if (null?
- exports2038)
- ls2037
- (loop2036
- (cdr exports2038)
- (if (pair?
- (car exports2038))
- (loop2036
- (car exports2038)
- ls2037)
- (cons
- (car exports2038)
- ls2037)))))))
- loop2036)
- exports2035
- '())))
- (make-interface451 (lambda (marks2034 exports2033 token2032)
- (vector
- 'interface
- marks2034
- exports2033
- token2032)))
- (interface?452 (lambda (x2031)
- (if (vector? x2031)
- (if (= (vector-length x2031) '4)
- (eq? (vector-ref x2031 '0) 'interface)
- '#f)
- '#f)))
- (interface-marks453 (lambda (x2030) (vector-ref x2030 '1)))
- (interface-exports454 (lambda (x2029)
- (vector-ref x2029 '2)))
- (interface-token455 (lambda (x2028) (vector-ref x2028 '3)))
- (set-interface-marks!456 (lambda (x2027 update2026)
- (vector-set! x2027 '1 update2026)))
- (set-interface-exports!457 (lambda (x2025 update2024)
- (vector-set!
- x2025
- '2
- update2024)))
- (set-interface-token!458 (lambda (x2023 update2022)
- (vector-set! x2023 '3 update2022)))
- (make-unresolved-interface459 (lambda (mid2020 exports2019)
- (make-interface451
- (wrap-marks316
- (syntax-object-wrap66
- mid2020))
- (list->vector
- (map (lambda (x2021)
- (if (pair? x2021)
- (car x2021)
- x2021))
- exports2019))
- '#f)))
- (make-resolved-interface460 (lambda (mid2017 exports2016
- token2015)
- (make-interface451
- (wrap-marks316
- (syntax-object-wrap66
- mid2017))
- (list->vector
- (map (lambda (x2018)
- (id->resolved-id419
- (if (pair? x2018)
- (car x2018)
- x2018)))
- exports2016))
- token2015)))
- (make-module-binding461 (lambda (type2014 id2013 label2012
- imps2011 val2010 exported2009)
- (vector 'module-binding type2014
- id2013 label2012 imps2011 val2010
- exported2009)))
- (module-binding?462 (lambda (x2008)
- (if (vector? x2008)
- (if (= (vector-length x2008) '7)
- (eq? (vector-ref x2008 '0)
- 'module-binding)
- '#f)
- '#f)))
- (module-binding-type463 (lambda (x2007)
- (vector-ref x2007 '1)))
- (module-binding-id464 (lambda (x2006)
- (vector-ref x2006 '2)))
- (module-binding-label465 (lambda (x2005)
- (vector-ref x2005 '3)))
- (module-binding-imps466 (lambda (x2004)
- (vector-ref x2004 '4)))
- (module-binding-val467 (lambda (x2003)
- (vector-ref x2003 '5)))
- (module-binding-exported468 (lambda (x2002)
- (vector-ref x2002 '6)))
- (set-module-binding-type!469 (lambda (x2001 update2000)
- (vector-set!
- x2001
- '1
- update2000)))
- (set-module-binding-id!470 (lambda (x1999 update1998)
- (vector-set!
- x1999
- '2
- update1998)))
- (set-module-binding-label!471 (lambda (x1997 update1996)
- (vector-set!
- x1997
- '3
- update1996)))
- (set-module-binding-imps!472 (lambda (x1995 update1994)
- (vector-set!
- x1995
- '4
- update1994)))
- (set-module-binding-val!473 (lambda (x1993 update1992)
- (vector-set!
- x1993
- '5
- update1992)))
- (set-module-binding-exported!474 (lambda (x1991 update1990)
- (vector-set!
- x1991
- '6
- update1990)))
- (create-module-binding475 (lambda (type1989 id1988 label1987
- imps1986 val1985)
- (make-module-binding461 type1989
- id1988 label1987 imps1986 val1985
- '#f)))
- (make-frob476 (lambda (e1984 meta?1983)
- (vector 'frob e1984 meta?1983)))
- (frob?477 (lambda (x1982)
- (if (vector? x1982)
- (if (= (vector-length x1982) '3)
- (eq? (vector-ref x1982 '0) 'frob)
- '#f)
- '#f)))
- (frob-e478 (lambda (x1981) (vector-ref x1981 '1)))
- (frob-meta?479 (lambda (x1980) (vector-ref x1980 '2)))
- (set-frob-e!480 (lambda (x1979 update1978)
- (vector-set! x1979 '1 update1978)))
- (set-frob-meta?!481 (lambda (x1977 update1976)
- (vector-set! x1977 '2 update1976)))
- (chi-top-module482 (lambda (orig1917 r1916 mr1915
- top-ribcage1914 ribcage1913
- ctem1912 rtem1911 meta?1910 id1909
- exports1908 forms1907
- meta-residualize!1906)
- ((lambda (fexports1918)
- (call-with-values
- (lambda ()
- (chi-external486 ribcage1913
- orig1917
- (map (lambda (d1975)
- (make-frob476
- d1975
- meta?1910))
- forms1907)
- r1916 mr1915 ctem1912 exports1908
- fexports1918
- meta-residualize!1906))
- (lambda (r1922 mr1921 bindings1920
- inits1919)
- ((letrec ((process-exports1923 (lambda (fexports1925
- ctdefs1924)
- (if (null?
- fexports1925)
- ((letrec ((process-locals1926 (lambda (bs1931
- r1930
- dts1929
- dvs1928
- des1927)
- (if (null?
- bs1931)
- ((lambda (des1933
- inits1932)
- (build-sequence235
- '#f
- (append
- (ctdefs1924)
- (list
- (ct-eval/residualize2493
- ctem1912
- (lambda ()
- ((lambda (sym1934)
- ((lambda (token1935)
- ((lambda (b1936)
- ((lambda ()
- (call-with-values
- (lambda ()
- (top-id-bound-var-name429
- sym1934
- (wrap-marks316
- (syntax-object-wrap66
- id1909))
- top-ribcage1914))
- (lambda (valsym1938
- bound-id1937)
- (begin
- (if (not (eq? (id-var-name434
- id1909
- '(()))
- valsym1938))
- (syntax-error
- orig1917
- '"definition not permitted")
- (void))
- (if (read-only-binding?140
- valsym1938)
- (syntax-error
- orig1917
- '"invalid definition of read-only identifier")
- (void))
- (list
- '$sc-put-cte
- (list
- 'quote
- bound-id1937)
- b1936
- (list
- 'quote
- (top-ribcage-key375
- top-ribcage1914)))))))))
- (list
- 'quote
- (cons
- '$module
- (make-resolved-interface460
- id1909
- exports1908
- token1935)))))
- (generate-id143
- sym1934)))
- ((lambda (x1939)
- ((lambda (e1940)
- (if (annotation?132
- e1940)
- (annotation-expression
- e1940)
- e1940))
- (if (syntax-object?64
- x1939)
- (syntax-object-expression65
- x1939)
- x1939)))
- id1909))))
- (rt-eval/residualize492
- rtem1911
- (lambda ()
- (build-top-module238
- '#f
- dts1929
- dvs1928
- des1933
- (if (null?
- inits1932)
- (chi-void518)
- (build-sequence235
- '#f
- (append
- inits1932
- (list
- (chi-void518))))))))))))
- (chi-frobs495
- des1927
- r1930
- mr1921
- '#f)
- (chi-frobs495
- inits1919
- r1930
- mr1921
- '#f))
- ((lambda (b1942
- bs1941)
- ((lambda (t1943)
- ((lambda (t1944)
- (if (memv
- t1944
- '(define-form))
- ((lambda (label1945)
- (if (module-binding-exported468
- b1942)
- ((lambda (var1946)
- (process-locals1926
- bs1941
- r1930
- (cons
- 'global
- dts1929)
- (cons
- label1945
- dvs1928)
- (cons
- (module-binding-val467
- b1942)
- des1927)))
- (module-binding-id464
- b1942))
- ((lambda (var1947)
- (process-locals1926
- bs1941
- (extend-env295
- label1945
- (cons
- 'lexical
- var1947)
- r1930)
- (cons
- 'local
- dts1929)
- (cons
- var1947
- dvs1928)
- (cons
- (module-binding-val467
- b1942)
- des1927)))
- (gen-var523
- (module-binding-id464
- b1942)))))
- (get-indirect-label360
- (module-binding-label465
- b1942)))
- (if (memv
- t1944
- '(ctdefine-form
- define-syntax-form
- $module-form
- alias-form))
- (process-locals1926
- bs1941
- r1930
- dts1929
- dvs1928
- des1927)
- (error 'sc-expand-internal
- '"unexpected module binding type ~s"
- t1943))))
- (module-binding-type463
- b1942)))
- (module-binding-type463
- b1942)))
- (car bs1931)
- (cdr bs1931))))))
- process-locals1926)
- bindings1920
- r1922
- '()
- '()
- '())
- ((lambda (id1949
- fexports1948)
- ((letrec ((loop1950 (lambda (bs1951)
- (if (null?
- bs1951)
- (process-exports1923
- fexports1948
- ctdefs1924)
- ((lambda (b1953
- bs1952)
- (if (free-id=?435
- (module-binding-id464
- b1953)
- id1949)
- (if (module-binding-exported468
- b1953)
- (process-exports1923
- fexports1948
- ctdefs1924)
- ((lambda (t1954)
- ((lambda (label1955)
- ((lambda (imps1956)
- ((lambda (fexports1957)
- ((lambda ()
- (begin
- (set-module-binding-exported!474
- b1953
- '#t)
- ((lambda (t1958)
- (if (memv
- t1958
- '(define-form))
- ((lambda (sym1959)
- (begin
- (set-indirect-label!361
- label1955
- sym1959)
- (process-exports1923
- fexports1957
- ctdefs1924)))
- (generate-id143
- ((lambda (x1960)
- ((lambda (e1961)
- (if (annotation?132
- e1961)
- (annotation-expression
- e1961)
- e1961))
- (if (syntax-object?64
- x1960)
- (syntax-object-expression65
- x1960)
- x1960)))
- id1949)))
- (if (memv
- t1958
- '(ctdefine-form))
- ((lambda (b1962)
- (process-exports1923
- fexports1957
- (lambda ()
- ((lambda (sym1963)
- (begin
- (set-indirect-label!361
- label1955
- sym1963)
- (cons
- (ct-eval/residualize3494
- ctem1912
- (lambda ()
- (put-cte-hook137
- sym1963
- b1962))
- (lambda ()
- (list
- '$sc-put-cte
- (list
- 'quote
- sym1963)
- (list
- 'quote
- b1962)
- (list
- 'quote
- '#f))))
- (ctdefs1924))))
- (binding-value282
- b1962)))))
- (module-binding-val467
- b1953))
- (if (memv
- t1958
- '(define-syntax-form))
- ((lambda (sym1964)
- (process-exports1923
- fexports1957
- (lambda ()
- ((lambda (local-label1965)
- (begin
- (set-indirect-label!361
- label1955
- sym1964)
- (cons
- (ct-eval/residualize3494
- ctem1912
- (lambda ()
- (put-cte-hook137
- sym1964
- (car (module-binding-val467
- b1953))))
- (lambda ()
- (list
- '$sc-put-cte
- (list
- 'quote
- sym1964)
- (cdr (module-binding-val467
- b1953))
- (list
- 'quote
- '#f))))
- (ctdefs1924))))
- (get-indirect-label360
- label1955)))))
- (generate-id143
- ((lambda (x1966)
- ((lambda (e1967)
- (if (annotation?132
- e1967)
- (annotation-expression
- e1967)
- e1967))
- (if (syntax-object?64
- x1966)
- (syntax-object-expression65
- x1966)
- x1966)))
- id1949)))
- (if (memv
- t1958
- '($module-form))
- ((lambda (sym1969
- exports1968)
- (process-exports1923
- (append
- (flatten-exports450
- exports1968)
- fexports1957)
- (lambda ()
- (begin
- (set-indirect-label!361
- label1955
- sym1969)
- ((lambda (rest1970)
- ((lambda (x1971)
- (cons
- (ct-eval/residualize3494
- ctem1912
- (lambda ()
- (put-cte-hook137
- sym1969
- x1971))
- (lambda ()
- (list
- '$sc-put-cte
- (list
- 'quote
- sym1969)
- (list
- 'quote
- x1971)
- (list
- 'quote
- '#f))))
- rest1970))
- (cons
- '$module
- (make-resolved-interface460
- id1949
- exports1968
- sym1969))))
- (ctdefs1924))))))
- (generate-id143
- ((lambda (x1972)
- ((lambda (e1973)
- (if (annotation?132
- e1973)
- (annotation-expression
- e1973)
- e1973))
- (if (syntax-object?64
- x1972)
- (syntax-object-expression65
- x1972)
- x1972)))
- id1949))
- (module-binding-val467
- b1953))
- (if (memv
- t1958
- '(alias-form))
- (process-exports1923
- fexports1957
- (lambda ()
- ((lambda (rest1974)
- (begin
- (if (indirect-label?356
- label1955)
- (if (not (symbol?
- (get-indirect-label360
- label1955)))
- (syntax-error
- (module-binding-id464
- b1953)
- '"unexported target of alias")
- (void))
- (void))
- rest1974))
- (ctdefs1924))))
- (error 'sc-expand-internal
- '"unexpected module binding type ~s"
- t1954)))))))
- t1954)))))
- (append
- imps1956
- fexports1948)))
- (module-binding-imps466
- b1953)))
- (module-binding-label465
- b1953)))
- (module-binding-type463
- b1953)))
- (loop1950
- bs1952)))
- (car bs1951)
- (cdr bs1951))))))
- loop1950)
- bindings1920))
- (car fexports1925)
- (cdr fexports1925))))))
- process-exports1923)
- fexports1918
- (lambda () '())))))
- (flatten-exports450 exports1908))))
- (id-set-diff483 (lambda (exports1905 defs1904)
- (if (null? exports1905)
- '()
- (if (bound-id-member?442
- (car exports1905)
- defs1904)
- (id-set-diff483
- (cdr exports1905)
- defs1904)
- (cons
- (car exports1905)
- (id-set-diff483
- (cdr exports1905)
- defs1904))))))
- (check-module-exports484 (lambda (source-exp1879
- fexports1878 ids1877)
- (letrec ((defined?1880 (lambda (e1887
- ids1886)
- (ormap
- (lambda (x1888)
- (if (import-interface?380
- x1888)
- ((lambda (x.iface1890
- x.new-marks1889)
- ((lambda (t1891)
- (if t1891
- ((lambda (token1892)
- (lookup-import-binding-name415
- ((lambda (x1893)
- ((lambda (e1894)
- (if (annotation?132
- e1894)
- (annotation-expression
- e1894)
- e1894))
- (if (syntax-object?64
- x1893)
- (syntax-object-expression65
- x1893)
- x1893)))
- e1887)
- (id-marks312
- e1887)
- token1892
- x.new-marks1889))
- t1891)
- ((lambda (v1895)
- ((letrec ((lp1896 (lambda (i1897)
- (if (>= i1897
- '0)
- ((lambda (t1898)
- (if t1898
- t1898
- (lp1896
- (- i1897
- '1))))
- ((lambda (id1899)
- (help-bound-id=?437
- ((lambda (x1902)
- ((lambda (e1903)
- (if (annotation?132
- e1903)
- (annotation-expression
- e1903)
- e1903))
- (if (syntax-object?64
- x1902)
- (syntax-object-expression65
- x1902)
- x1902)))
- id1899)
- (join-marks423
- x.new-marks1889
- (id-marks312
- id1899))
- ((lambda (x1900)
- ((lambda (e1901)
- (if (annotation?132
- e1901)
- (annotation-expression
- e1901)
- e1901))
- (if (syntax-object?64
- x1900)
- (syntax-object-expression65
- x1900)
- x1900)))
- e1887)
- (id-marks312
- e1887)))
- (vector-ref
- v1895
- i1897)))
- '#f))))
- lp1896)
- (- (vector-length
- v1895)
- '1)))
- (interface-exports454
- x.iface1890))))
- (interface-token455
- x.iface1890)))
- (import-interface-interface381
- x1888)
- (import-interface-new-marks382
- x1888))
- (bound-id=?438
- e1887
- x1888)))
- ids1886))))
- ((letrec ((loop1881 (lambda (fexports1883
- missing1882)
- (if (null?
- fexports1883)
- (if (not (null?
- missing1882))
- (syntax-error
- (car missing1882)
- (if (= (length
- missing1882)
- '1)
- '"missing definition for export"
- '"missing definition for multiple exports, including"))
- (void))
- ((lambda (e1885
- fexports1884)
- (if (defined?1880
- e1885
- ids1877)
- (loop1881
- fexports1884
- missing1882)
- (loop1881
- fexports1884
- (cons
- e1885
- missing1882))))
- (car fexports1883)
- (cdr fexports1883))))))
- loop1881)
- fexports1878
- '()))))
- (check-defined-ids485 (lambda (source-exp1826 ls1825)
- (letrec ((vfold1827 (lambda (v1872
- p1871
- cls1870)
- ((lambda (len1873)
- ((letrec ((lp1874 (lambda (i1876
- cls1875)
- (if (= i1876
- len1873)
- cls1875
- (lp1874
- (+ i1876
- '1)
- (p1871
- (vector-ref
- v1872
- i1876)
- cls1875))))))
- lp1874)
- '0
- cls1870))
- (vector-length
- v1872))))
- (conflicts1828 (lambda (x1857
- y1856
- cls1855)
- (if (import-interface?380
- x1857)
- ((lambda (x.iface1859
- x.new-marks1858)
- (if (import-interface?380
- y1856)
- ((lambda (y.iface1861
- y.new-marks1860)
- ((lambda (xe1863
- ye1862)
- (if (> (vector-length
- xe1863)
- (vector-length
- ye1862))
- (vfold1827
- ye1862
- (lambda (id1865
- cls1864)
- (id-iface-conflicts1829
- id1865
- y.new-marks1860
- x.iface1859
- x.new-marks1858
- cls1864))
- cls1855)
- (vfold1827
- xe1863
- (lambda (id1867
- cls1866)
- (id-iface-conflicts1829
- id1867
- x.new-marks1858
- y.iface1861
- y.new-marks1860
- cls1866))
- cls1855)))
- (interface-exports454
- x.iface1859)
- (interface-exports454
- y.iface1861)))
- (import-interface-interface381
- y1856)
- (import-interface-new-marks382
- y1856))
- (id-iface-conflicts1829
- y1856
- '()
- x.iface1859
- x.new-marks1858
- cls1855)))
- (import-interface-interface381
- x1857)
- (import-interface-new-marks382
- x1857))
- (if (import-interface?380
- y1856)
- ((lambda (y.iface1869
- y.new-marks1868)
- (id-iface-conflicts1829
- x1857
- '()
- y.iface1869
- y.new-marks1868
- cls1855))
- (import-interface-interface381
- y1856)
- (import-interface-new-marks382
- y1856))
- (if (bound-id=?438
- x1857
- y1856)
- (cons
- x1857
- cls1855)
- cls1855)))))
- (id-iface-conflicts1829 (lambda (id1842
- id.new-marks1841
- iface1840
- iface.new-marks1839
- cls1838)
- ((lambda (id.sym1844
- id.marks1843)
- ((lambda (t1845)
- (if t1845
- ((lambda (token1846)
- (if (lookup-import-binding-name415
- id.sym1844
- id.marks1843
- token1846
- iface.new-marks1839)
- (cons
- id1842
- cls1838)
- cls1838))
- t1845)
- (vfold1827
- (interface-exports454
- iface1840)
- (lambda (*id1848
- cls1847)
- ((lambda (*id.sym1850
- *id.marks1849)
- (if (help-bound-id=?437
- *id.sym1850
- *id.marks1849
- id.sym1844
- id.marks1843)
- (cons
- *id1848
- cls1847)
- cls1847))
- ((lambda (x1851)
- ((lambda (e1852)
- (if (annotation?132
- e1852)
- (annotation-expression
- e1852)
- e1852))
- (if (syntax-object?64
- x1851)
- (syntax-object-expression65
- x1851)
- x1851)))
- *id1848)
- (join-marks423
- iface.new-marks1839
- (id-marks312
- *id1848))))
- cls1838)))
- (interface-token455
- iface1840)))
- ((lambda (x1853)
- ((lambda (e1854)
- (if (annotation?132
- e1854)
- (annotation-expression
- e1854)
- e1854))
- (if (syntax-object?64
- x1853)
- (syntax-object-expression65
- x1853)
- x1853)))
- id1842)
- (join-marks423
- id.new-marks1841
- (id-marks312
- id1842))))))
- (if (not (null? ls1825))
- ((letrec ((lp1830 (lambda (x1833
- ls1832
- cls1831)
- (if (null?
- ls1832)
- (if (not (null?
- cls1831))
- ((lambda (cls1834)
- (syntax-error
- source-exp1826
- '"duplicate definition for "
- (symbol->string
- (car cls1834))
- '" in"))
- (syntax-object->datum
- cls1831))
- (void))
- ((letrec ((lp21835 (lambda (ls21837
- cls1836)
- (if (null?
- ls21837)
- (lp1830
- (car ls1832)
- (cdr ls1832)
- cls1836)
- (lp21835
- (cdr ls21837)
- (conflicts1828
- x1833
- (car ls21837)
- cls1836))))))
- lp21835)
- ls1832
- cls1831)))))
- lp1830)
- (car ls1825)
- (cdr ls1825)
- '())
- (void)))))
- (chi-external486 (lambda (ribcage1721 source-exp1720
- body1719 r1718 mr1717 ctem1716
- exports1715 fexports1714
- meta-residualize!1713)
- (letrec ((return1722 (lambda (r1824 mr1823
- bindings1822
- ids1821
- inits1820)
- (begin
- (check-defined-ids485
- source-exp1720
- ids1821)
- (check-module-exports484
- source-exp1720
- fexports1714
- ids1821)
- (values
- r1824
- mr1823
- bindings1822
- inits1820))))
- (get-implicit-exports1723 (lambda (id1817)
- ((letrec ((f1818 (lambda (exports1819)
- (if (null?
- exports1819)
- '()
- (if (if (pair?
- (car exports1819))
- (bound-id=?438
- id1817
- (caar
- exports1819))
- '#f)
- (flatten-exports450
- (cdar
- exports1819))
- (f1818
- (cdr exports1819)))))))
- f1818)
- exports1715)))
- (update-imp-exports1724 (lambda (bindings1812
- exports1811)
- ((lambda (exports1813)
- (map (lambda (b1814)
- ((lambda (id1815)
- (if (not (bound-id-member?442
- id1815
- exports1813))
- b1814
- (create-module-binding475
- (module-binding-type463
- b1814)
- id1815
- (module-binding-label465
- b1814)
- (append
- (get-implicit-exports1723
- id1815)
- (module-binding-imps466
- b1814))
- (module-binding-val467
- b1814))))
- (module-binding-id464
- b1814)))
- bindings1812))
- (map (lambda (x1816)
- (if (pair?
- x1816)
- (car x1816)
- x1816))
- exports1811)))))
- ((letrec ((parse1725 (lambda (body1732
- r1731 mr1730
- ids1729
- bindings1728
- inits1727
- meta-seen?1726)
- (if (null?
- body1732)
- (return1722
- r1731 mr1730
- bindings1728
- ids1729
- inits1727)
- ((lambda (fr1733)
- ((lambda (e1734)
- ((lambda (meta?1735)
- ((lambda ()
- (call-with-values
- (lambda ()
- (syntax-type446
- e1734
- r1731
- '(())
- '#f
- ribcage1721))
- (lambda (type1740
- value1739
- e1738
- w1737
- ae1736)
- ((lambda (t1741)
- (if (memv
- t1741
- '(define-form))
- (call-with-values
- (lambda ()
- (parse-define510
- e1738
- w1737
- ae1736))
- (lambda (id1744
- rhs1743
- w1742)
- ((lambda (id1745)
- ((lambda (label1746)
- ((lambda (imps1747)
- ((lambda ()
- (begin
- (extend-ribcage!410
- ribcage1721
- id1745
- label1746)
- (if meta?1735
- ((lambda (sym1748)
- ((lambda (b1749)
- ((lambda ()
- ((lambda (mr1750)
- ((lambda (exp1751)
- (begin
- (define-top-level-value-hook135
- sym1748
- (top-level-eval-hook133
- exp1751))
- (meta-residualize!1713
- (ct-eval/residualize3494
- ctem1716
- void
- (lambda ()
- (list
- 'define
- sym1748
- exp1751))))
- (parse1725
- (cdr body1732)
- r1731
- mr1750
- (cons
- id1745
- ids1729)
- (cons
- (create-module-binding475
- 'ctdefine-form
- id1745
- label1746
- imps1747
- b1749)
- bindings1728)
- inits1727
- '#f)))
- (chi498
- rhs1743
- mr1750
- mr1750
- w1742
- '#t)))
- (extend-env295
- (get-indirect-label360
- label1746)
- b1749
- mr1730)))))
- (cons
- 'meta-variable
- sym1748)))
- (generate-id143
- ((lambda (x1752)
- ((lambda (e1753)
- (if (annotation?132
- e1753)
- (annotation-expression
- e1753)
- e1753))
- (if (syntax-object?64
- x1752)
- (syntax-object-expression65
- x1752)
- x1752)))
- id1745)))
- (parse1725
- (cdr body1732)
- r1731
- mr1730
- (cons
- id1745
- ids1729)
- (cons
- (create-module-binding475
- type1740
- id1745
- label1746
- imps1747
- (make-frob476
- (wrap443
- rhs1743
- w1742)
- meta?1735))
- bindings1728)
- inits1727
- '#f))))))
- (get-implicit-exports1723
- id1745)))
- (gen-indirect-label359)))
- (wrap443
- id1744
- w1742))))
- (if (memv
- t1741
- '(define-syntax-form))
- (call-with-values
- (lambda ()
- (parse-define-syntax511
- e1738
- w1737
- ae1736))
- (lambda (id1756
- rhs1755
- w1754)
- ((lambda (id1757)
- ((lambda (label1758)
- ((lambda (imps1759)
- ((lambda (exp1760)
- ((lambda ()
- (begin
- (extend-ribcage!410
- ribcage1721
- id1757
- label1758)
- ((lambda (l1762
- b1761)
- (parse1725
- (cdr body1732)
- (extend-env295
- l1762
- b1761
- r1731)
- (extend-env295
- l1762
- b1761
- mr1730)
- (cons
- id1757
- ids1729)
- (cons
- (create-module-binding475
- type1740
- id1757
- label1758
- imps1759
- (cons
- b1761
- exp1760))
- bindings1728)
- inits1727
- '#f))
- (get-indirect-label360
- label1758)
- (defer-or-eval-transformer303
- top-level-eval-hook133
- exp1760))))))
- (chi498
- rhs1755
- mr1730
- mr1730
- w1754
- '#t)))
- (get-implicit-exports1723
- id1757)))
- (gen-indirect-label359)))
- (wrap443
- id1756
- w1754))))
- (if (memv
- t1741
- '($module-form))
- ((lambda (*ribcage1763)
- ((lambda (*w1764)
- ((lambda ()
- (call-with-values
- (lambda ()
- (parse-module508
- e1738
- w1737
- ae1736
- *w1764))
- (lambda (orig1768
- id1767
- *exports1766
- forms1765)
- (call-with-values
- (lambda ()
- (chi-external486
- *ribcage1763
- orig1768
- (map (lambda (d1780)
- (make-frob476
- d1780
- meta?1735))
- forms1765)
- r1731
- mr1730
- ctem1716
- *exports1766
- (flatten-exports450
- *exports1766)
- meta-residualize!1713))
- (lambda (r1772
- mr1771
- *bindings1770
- *inits1769)
- ((lambda (iface1777
- bindings1776
- inits1775
- label1774
- imps1773)
- (begin
- (extend-ribcage!410
- ribcage1721
- id1767
- label1774)
- ((lambda (l1779
- b1778)
- (parse1725
- (cdr body1732)
- (extend-env295
- l1779
- b1778
- r1772)
- (extend-env295
- l1779
- b1778
- mr1771)
- (cons
- id1767
- ids1729)
- (cons
- (create-module-binding475
- type1740
- id1767
- label1774
- imps1773
- *exports1766)
- bindings1776)
- inits1775
- '#f))
- (get-indirect-label360
- label1774)
- (cons
- '$module
- iface1777))))
- (make-unresolved-interface459
- id1767
- *exports1766)
- (append
- *bindings1770
- bindings1728)
- (append
- inits1727
- *inits1769)
- (gen-indirect-label359)
- (get-implicit-exports1723
- id1767)))))))))
- (make-wrap315
- (wrap-marks316
- w1737)
- (cons
- *ribcage1763
- (wrap-subst317
- w1737)))))
- (make-ribcage365
- '()
- '()
- '()))
- (if (memv
- t1741
- '($import-form))
- (call-with-values
- (lambda ()
- (parse-import509
- e1738
- w1737
- ae1736))
- (lambda (orig1783
- only?1782
- mid1781)
- ((lambda (mlabel1784)
- ((lambda (binding1785)
- ((lambda (t1786)
- (if (memv
- t1786
- '($module))
- ((lambda (iface1787)
- ((lambda (import-iface1788)
- ((lambda ()
- (begin
- (if only?1782
- (extend-ribcage-barrier!412
- ribcage1721
- mid1781)
- (void))
- (do-import!507
- import-iface1788
- ribcage1721)
- (parse1725
- (cdr body1732)
- r1731
- mr1730
- (cons
- import-iface1788
- ids1729)
- (update-imp-exports1724
- bindings1728
- (vector->list
- (interface-exports454
- iface1787)))
- inits1727
- '#f)))))
- (make-import-interface379
- iface1787
- (import-mark-delta505
- mid1781
- iface1787))))
- (binding-value282
- binding1785))
- (if (memv
- t1786
- '(displaced-lexical))
- (displaced-lexical-error299
- mid1781)
- (syntax-error
- mid1781
- '"unknown module"))))
- (binding-type281
- binding1785)))
- (lookup301
- mlabel1784
- r1731)))
- (id-var-name434
- mid1781
- '(())))))
- (if (memv
- t1741
- '(alias-form))
- (call-with-values
- (lambda ()
- (parse-alias514
- e1738
- w1737
- ae1736))
- (lambda (new-id1790
- old-id1789)
- ((lambda (new-id1791)
- ((lambda (label1792)
- ((lambda (imps1793)
- ((lambda ()
- (begin
- (extend-ribcage!410
- ribcage1721
- new-id1791
- label1792)
- (parse1725
- (cdr body1732)
- r1731
- mr1730
- (cons
- new-id1791
- ids1729)
- (cons
- (create-module-binding475
- type1740
- new-id1791
- label1792
- imps1793
- '#f)
- bindings1728)
- inits1727
- '#f)))))
- (get-implicit-exports1723
- new-id1791)))
- (id-var-name-loc433
- old-id1789
- w1737)))
- (wrap443
- new-id1790
- w1737))))
- (if (memv
- t1741
- '(begin-form))
- (parse1725
- ((letrec ((f1794 (lambda (forms1795)
- (if (null?
- forms1795)
- (cdr body1732)
- (cons
- (make-frob476
- (wrap443
- (car forms1795)
- w1737)
- meta?1735)
- (f1794
- (cdr forms1795)))))))
- f1794)
- (parse-begin515
- e1738
- w1737
- ae1736
- '#t))
- r1731
- mr1730
- ids1729
- bindings1728
- inits1727
- '#f)
- (if (memv
- t1741
- '(eval-when-form))
- (call-with-values
- (lambda ()
- (parse-eval-when513
- e1738
- w1737
- ae1736))
- (lambda (when-list1797
- forms1796)
- (parse1725
- (if (memq
- 'eval
- when-list1797)
- ((letrec ((f1798 (lambda (forms1799)
- (if (null?
- forms1799)
- (cdr body1732)
- (cons
- (make-frob476
- (wrap443
- (car forms1799)
- w1737)
- meta?1735)
- (f1798
- (cdr forms1799)))))))
- f1798)
- forms1796)
- (cdr body1732))
- r1731
- mr1730
- ids1729
- bindings1728
- inits1727
- '#f)))
- (if (memv
- t1741
- '(meta-form))
- (parse1725
- (cons
- (make-frob476
- (wrap443
- (parse-meta512
- e1738
- w1737
- ae1736)
- w1737)
- '#t)
- (cdr body1732))
- r1731
- mr1730
- ids1729
- bindings1728
- inits1727
- '#t)
- (if (memv
- t1741
- '(local-syntax-form))
- (call-with-values
- (lambda ()
- (chi-local-syntax517
- value1739
- e1738
- r1731
- mr1730
- w1737
- ae1736))
- (lambda (forms1804
- r1803
- mr1802
- w1801
- ae1800)
- (parse1725
- ((letrec ((f1805 (lambda (forms1806)
- (if (null?
- forms1806)
- (cdr body1732)
- (cons
- (make-frob476
- (wrap443
- (car forms1806)
- w1801)
- meta?1735)
- (f1805
- (cdr forms1806)))))))
- f1805)
- forms1804)
- r1803
- mr1802
- ids1729
- bindings1728
- inits1727
- '#f)))
- (begin
- (if meta-seen?1726
- (syntax-error
- (source-wrap444
- e1738
- w1737
- ae1736)
- '"invalid meta definition")
- (void))
- ((letrec ((f1807 (lambda (body1808)
- (if ((lambda (t1809)
- (if t1809
- t1809
- (not (frob-meta?479
- (car body1808)))))
- (null?
- body1808))
- (return1722
- r1731
- mr1730
- bindings1728
- ids1729
- (append
- inits1727
- body1808))
- (begin
- ((lambda (x1810)
- (begin
- (top-level-eval-hook133
- x1810)
- (meta-residualize!1713
- (ct-eval/residualize3494
- ctem1716
- void
- (lambda ()
- x1810)))))
- (chi-meta-frob496
- (car body1808)
- mr1730))
- (f1807
- (cdr body1808)))))))
- f1807)
- (cons
- (make-frob476
- (source-wrap444
- e1738
- w1737
- ae1736)
- meta?1735)
- (cdr body1732))))))))))))))
- type1740))))))
- (frob-meta?479
- fr1733)))
- (frob-e478
- fr1733)))
- (car body1732))))))
- parse1725) body1719 r1718 mr1717 '()
- '() '() '#f))))
- (vmap487 (lambda (fn1709 v1708)
- ((letrec ((do1710 (lambda (i1712 ls1711)
- (if (< i1712 '0)
- ls1711
- (do1710
- (- i1712 '1)
- (cons
- (fn1709
- (vector-ref
- v1708
- i1712))
- ls1711))))))
- do1710)
- (- (vector-length v1708) '1)
- '())))
- (vfor-each488 (lambda (fn1704 v1703)
- ((lambda (len1705)
- ((letrec ((do1706 (lambda (i1707)
- (if (not (= i1707
- len1705))
- (begin
- (fn1704
- (vector-ref
- v1703
- i1707))
- (do1706
- (+ i1707 '1)))
- (void)))))
- do1706)
- '0))
- (vector-length v1703))))
- (do-top-import489 (lambda (import-only?1702 top-ribcage1701
- mid1700 token1699)
- (list
- '$sc-put-cte
- (list 'quote mid1700)
- (list 'quote (cons 'do-import token1699))
- (list
- 'quote
- (top-ribcage-key375
- top-ribcage1701)))))
- (update-mode-set490 ((lambda (table1690)
- (lambda (when-list1692 mode-set1691)
- (letrec ((remq1693 (lambda (x1698
- ls1697)
- (if (null?
- ls1697)
- '()
- (if (eq? (car ls1697)
- x1698)
- (remq1693
- x1698
- (cdr ls1697))
- (cons
- (car ls1697)
- (remq1693
- x1698
- (cdr ls1697))))))))
- (remq1693
- '-
- (apply
- append
- (map (lambda (m1694)
- ((lambda (row1695)
- (map (lambda (s1696)
- (cdr (assq
- s1696
- row1695)))
- when-list1692))
- (cdr (assq
- m1694
- table1690))))
- mode-set1691))))))
- '((l (load . l) (compile . c) (visit . v)
- (revisit . r) (eval . -))
- (c (load . -) (compile . -)
- (visit . -) (revisit . -)
- (eval . c))
- (v (load . v) (compile . c)
- (visit . v) (revisit . -)
- (eval . -))
- (r (load . r) (compile . c)
- (visit . -) (revisit . r)
- (eval . -))
- (e (load . -) (compile . -)
- (visit . -) (revisit . -)
- (eval . e)))))
- (initial-mode-set491 (lambda (when-list1686
- compiling-a-file1685)
- (apply
- append
- (map (lambda (s1687)
- (if compiling-a-file1685
- ((lambda (t1688)
- (if (memv
- t1688
- '(compile))
- '(c)
- (if (memv
- t1688
- '(load))
- '(l)
- (if (memv
- t1688
- '(visit))
- '(v)
- (if (memv
- t1688
- '(revisit))
- '(r)
- '())))))
- s1687)
- ((lambda (t1689)
- (if (memv t1689 '(eval))
- '(e)
- '()))
- s1687)))
- when-list1686))))
- (rt-eval/residualize492 (lambda (rtem1680 thunk1679)
- (if (memq 'e rtem1680)
- (thunk1679)
- ((lambda (thunk1681)
- (if (memq 'v rtem1680)
- (if ((lambda (t1682)
- (if t1682
- t1682
- (memq
- 'r
- rtem1680)))
- (memq 'l rtem1680))
- (thunk1681)
- (thunk1681))
- (if ((lambda (t1683)
- (if t1683
- t1683
- (memq
- 'r
- rtem1680)))
- (memq 'l rtem1680))
- (thunk1681)
- (chi-void518))))
- (if (memq 'c rtem1680)
- ((lambda (x1684)
- (begin
- (top-level-eval-hook133
- x1684)
- (lambda () x1684)))
- (thunk1679))
- thunk1679)))))
- (ct-eval/residualize2493 (lambda (ctem1676 thunk1675)
- ((lambda (t1677)
- (ct-eval/residualize3494
- ctem1676
- (lambda ()
- (begin
- (if (not t1677)
- (set! t1677
- (thunk1675))
- (void))
- (top-level-eval-hook133
- t1677)))
- (lambda ()
- ((lambda (t1678)
- (if t1678
- t1678
- (thunk1675)))
- t1677))))
- '#f)))
- (ct-eval/residualize3494 (lambda (ctem1672 eval-thunk1671
- residualize-thunk1670)
- (if (memq 'e ctem1672)
- (begin
- (eval-thunk1671)
- (chi-void518))
- (begin
- (if (memq 'c ctem1672)
- (eval-thunk1671)
- (void))
- (if (memq 'r ctem1672)
- (if ((lambda (t1673)
- (if t1673
- t1673
- (memq
- 'v
- ctem1672)))
- (memq 'l ctem1672))
- (residualize-thunk1670)
- (residualize-thunk1670))
- (if ((lambda (t1674)
- (if t1674
- t1674
- (memq
- 'v
- ctem1672)))
- (memq 'l ctem1672))
- (residualize-thunk1670)
- (chi-void518)))))))
- (chi-frobs495 (lambda (frob*1668 r1667 mr1666 m?1665)
- (map (lambda (x1669)
- (chi498 (frob-e478 x1669) r1667 mr1666
- '(()) m?1665))
- frob*1668)))
- (chi-meta-frob496 (lambda (x1664 mr1663)
- (chi498 (frob-e478 x1664) mr1663 mr1663
- '(()) '#t)))
- (chi-sequence497 (lambda (body1659 r1658 mr1657 w1656 ae1655
- m?1654)
- (build-sequence235
- ae1655
- ((letrec ((dobody1660 (lambda (body1661)
- (if (null?
- body1661)
- '()
- ((lambda (first1662)
- (cons
- first1662
- (dobody1660
- (cdr body1661))))
- (chi498
- (car body1661)
- r1658
- mr1657
- w1656
- m?1654))))))
- dobody1660)
- body1659))))
- (chi498 (lambda (e1648 r1647 mr1646 w1645 m?1644)
- (call-with-values
- (lambda ()
- (syntax-type446 e1648 r1647 w1645 '#f '#f))
- (lambda (type1653 value1652 e1651 w1650 ae1649)
- (chi-expr499 type1653 value1652 e1651 r1647
- mr1646 w1650 ae1649 m?1644)))))
- (chi-expr499 (lambda (type1628 value1627 e1626 r1625 mr1624
- w1623 ae1622 m?1621)
- ((lambda (t1629)
- (if (memv t1629 '(lexical))
- value1627
- (if (memv t1629 '(core))
- (value1627 e1626 r1625 mr1624 w1623
- ae1622 m?1621)
- (if (memv t1629 '(lexical-call))
- (chi-application500 value1627
- e1626 r1625 mr1624 w1623 ae1622
- m?1621)
- (if (memv t1629 '(constant))
- (list
- 'quote
- (strip522
- (source-wrap444
- e1626
- w1623
- ae1622)
- '(())))
- (if (memv t1629 '(global))
- value1627
- (if (memv
- t1629
- '(meta-variable))
- (if m?1621
- value1627
- (displaced-lexical-error299
- (source-wrap444
- e1626
- w1623
- ae1622)))
- (if (memv
- t1629
- '(call))
- (chi-application500
- (chi498
- (car e1626)
- r1625 mr1624
- w1623 m?1621)
- e1626 r1625
- mr1624 w1623
- ae1622 m?1621)
- (if (memv
- t1629
- '(begin-form))
- (chi-sequence497
- (parse-begin515
- e1626
- w1623
- ae1622
- '#f)
- r1625
- mr1624
- w1623
- ae1622
- m?1621)
- (if (memv
- t1629
- '(local-syntax-form))
- (call-with-values
- (lambda ()
- (chi-local-syntax517
- value1627
- e1626
- r1625
- mr1624
- w1623
- ae1622))
- (lambda (forms1634
- r1633
- mr1632
- w1631
- ae1630)
- (chi-sequence497
- forms1634
- r1633
- mr1632
- w1631
- ae1630
- m?1621)))
- (if (memv
- t1629
- '(eval-when-form))
- (call-with-values
- (lambda ()
- (parse-eval-when513
- e1626
- w1623
- ae1622))
- (lambda (when-list1636
- forms1635)
- (if (memq
- 'eval
- when-list1636)
- (chi-sequence497
- forms1635
- r1625
- mr1624
- w1623
- ae1622
- m?1621)
- (chi-void518))))
- (if (memv
- t1629
- '(meta-form))
- (syntax-error
- (source-wrap444
- e1626
- w1623
- ae1622)
- '"invalid context for meta definition")
- (if (memv
- t1629
- '(define-form))
- (begin
- (parse-define510
- e1626
- w1623
- ae1622)
- (syntax-error
- (source-wrap444
- e1626
- w1623
- ae1622)
- '"invalid context for definition"))
- (if (memv
- t1629
- '(define-syntax-form))
- (begin
- (parse-define-syntax511
- e1626
- w1623
- ae1622)
- (syntax-error
- (source-wrap444
- e1626
- w1623
- ae1622)
- '"invalid context for definition"))
- (if (memv
- t1629
- '($module-form))
- (call-with-values
- (lambda ()
- (parse-module508
- e1626
- w1623
- ae1622
- w1623))
- (lambda (orig1640
- id1639
- exports1638
- forms1637)
- (syntax-error
- orig1640
- '"invalid context for definition")))
- (if (memv
- t1629
- '($import-form))
- (call-with-values
- (lambda ()
- (parse-import509
- e1626
- w1623
- ae1622))
- (lambda (orig1643
- only?1642
- mid1641)
- (syntax-error
- orig1643
- '"invalid context for definition")))
- (if (memv
- t1629
- '(alias-form))
- (begin
- (parse-alias514
- e1626
- w1623
- ae1622)
- (syntax-error
- (source-wrap444
- e1626
- w1623
- ae1622)
- '"invalid context for definition"))
- (if (memv
- t1629
- '(syntax))
- (syntax-error
- (source-wrap444
- e1626
- w1623
- ae1622)
- '"reference to pattern variable outside syntax form")
- (if (memv
- t1629
- '(displaced-lexical))
- (displaced-lexical-error299
- (source-wrap444
- e1626
- w1623
- ae1622))
- (syntax-error
- (source-wrap444
- e1626
- w1623
- ae1622)))))))))))))))))))))
- type1628)))
- (chi-application500 (lambda (x1613 e1612 r1611 mr1610 w1609
- ae1608 m?1607)
- ((lambda (tmp1614)
- ((lambda (tmp1615)
- (if tmp1615
- (apply
- (lambda (e01617 e11616)
- (cons
- x1613
- (map (lambda (e1619)
- (chi498 e1619
- r1611 mr1610
- w1609 m?1607))
- e11616)))
- tmp1615)
- ((lambda (_1620)
- (syntax-error
- (source-wrap444
- e1612
- w1609
- ae1608)))
- tmp1614)))
- ($syntax-dispatch
- tmp1614
- '(any . each-any))))
- e1612)))
- (chi-set!501 (lambda (e1581 r1580 w1579 ae1578 rib1577)
- ((lambda (tmp1582)
- ((lambda (tmp1583)
- (if (if tmp1583
- (apply
- (lambda (_1586 id1585 val1584)
- (id?306 id1585))
- tmp1583)
- '#f)
- (apply
- (lambda (_1589 id1588 val1587)
- ((lambda (n1590)
- ((lambda (b1591)
- ((lambda (t1592)
- (if (memv
- t1592
- '(macro!))
- ((lambda (id1594
- val1593)
- (syntax-type446
- (chi-macro502
- (binding-value282
- b1591)
- (list
- '#(syntax-object set! ((top) #(ribcage () () ()) #(ribcage #(id val) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage #(_ id val) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w ae rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap s\ No newline at end of file
- id1594
- val1593)
- r1580 '(())
- '#f rib1577)
- r1580 '(()) '#f
- rib1577))
- (wrap443
- id1588
- w1579)
- (wrap443
- val1587
- w1579))
- (values 'core
- (lambda (e1600
- r1599
- mr1598
- w1597
- ae1596
- m?1595)
- ((lambda (val1602
- n1601)
- ((lambda (b1603)
- ((lambda (t1604)
- (if (memv
- t1604
- '(lexical))
- (list
- 'set!
- (binding-value282
- b1603)
- val1602)
- (if (memv
- t1604
- '(global))
- ((lambda (sym1605)
- (begin
- (if (read-only-binding?140
- n1601)
- (syntax-error
- (source-wrap444
- e1600
- w1597
- ae1596)
- '"invalid assignment to read-only variable")
- (void))
- (list
- 'set!
- sym1605
- val1602)))
- (binding-value282
- b1603))
- (if (memv
- t1604
- '(meta-variable))
- (if m?1595
- (list
- 'set!
- (binding-value282
- b1603)
- val1602)
- (displaced-lexical-error299
- (wrap443
- id1588
- w1597)))
- (if (memv
- t1604
- '(displaced-lexical))
- (displaced-lexical-error299
- (wrap443
- id1588
- w1597))
- (syntax-error
- (source-wrap444
- e1600
- w1597
- ae1596)))))))
- (binding-type281
- b1603)))
- (lookup301
- n1601
- r1599)))
- (chi498 val1587
- r1599 mr1598
- w1597 m?1595)
- (id-var-name434
- id1588
- w1597)))
- e1581 w1579
- ae1578)))
- (binding-type281 b1591)))
- (lookup301 n1590 r1580)))
- (id-var-name434 id1588 w1579)))
- tmp1583)
- ((lambda (_1606)
- (syntax-error
- (source-wrap444
- e1581
- w1579
- ae1578)))
- tmp1582)))
- ($syntax-dispatch tmp1582 '(any any any))))
- e1581)))
- (chi-macro502 (lambda (p1564 e1563 r1562 w1561 ae1560
- rib1559)
- (letrec ((rebuild-macro-output1565 (lambda (x1569
- m1568)
- (if (pair?
- x1569)
- (cons
- (rebuild-macro-output1565
- (car x1569)
- m1568)
- (rebuild-macro-output1565
- (cdr x1569)
- m1568))
- (if (syntax-object?64
- x1569)
- ((lambda (w1570)
- ((lambda (ms1572
- s1571)
- (make-syntax-object63
- (syntax-object-expression65
- x1569)
- (if (if (pair?
- ms1572)
- (eq? (car ms1572)
- '#f)
- '#f)
- (make-wrap315
- (cdr ms1572)
- (cdr s1571))
- (make-wrap315
- (cons
- m1568
- ms1572)
- (if rib1559
- (cons
- rib1559
- (cons
- 'shift
- s1571))
- (cons
- 'shift
- s1571))))))
- (wrap-marks316
- w1570)
- (wrap-subst317
- w1570)))
- (syntax-object-wrap66
- x1569))
- (if (vector?
- x1569)
- ((lambda (n1573)
- ((lambda (v1574)
- ((lambda ()
- ((letrec ((do1575 (lambda (i1576)
- (if (= i1576
- n1573)
- v1574
- (begin
- (vector-set!
- v1574
- i1576
- (rebuild-macro-output1565
- (vector-ref
- x1569
- i1576)
- m1568))
- (do1575
- (+ i1576
- '1)))))))
- do1575)
- '0))))
- (make-vector
- n1573)))
- (vector-length
- x1569))
- (if (symbol?
- x1569)
- (syntax-error
- (source-wrap444
- e1563
- w1561
- ae1560)
- '"encountered raw symbol "
- (symbol->string
- x1569)
- '" in output of macro")
- x1569)))))))
- (rebuild-macro-output1565
- ((lambda (out1566)
- (if (procedure? out1566)
- (out1566
- (lambda (id1567)
- (begin
- (if (not (identifier? id1567))
- (syntax-error
- id1567
- '"environment argument is not an identifier")
- (void))
- (lookup301
- (id-var-name434
- id1567
- '(()))
- r1562))))
- out1566))
- (p1564
- (source-wrap444
- e1563
- (anti-mark400 w1561)
- ae1560)))
- (string '#\m)))))
- (chi-body503 (lambda (body1547 outer-form1546 r1545 mr1544
- w1543 m?1542)
- ((lambda (ribcage1548)
- ((lambda (w1549)
- ((lambda (body1550)
- ((lambda ()
- (call-with-values
- (lambda ()
- (chi-internal504 ribcage1548
- outer-form1546 body1550 r1545
- mr1544 m?1542))
- (lambda (r1557 mr1556 exprs1555
- ids1554 vars1553 vals1552
- inits1551)
- (begin
- (if (null? exprs1555)
- (syntax-error
- outer-form1546
- '"no expressions in body")
- (void))
- (build-body237
- '#f
- (reverse vars1553)
- (chi-frobs495
- (reverse vals1552)
- r1557
- mr1556
- m?1542)
- (build-sequence235
- '#f
- (chi-frobs495
- (append
- inits1551
- exprs1555)
- r1557
- mr1556
- m?1542)))))))))
- (map (lambda (x1558)
- (make-frob476
- (wrap443 x1558 w1549)
- '#f))
- body1547)))
- (make-wrap315
- (wrap-marks316 w1543)
- (cons
- ribcage1548
- (wrap-subst317 w1543)))))
- (make-ribcage365 '() '() '()))))
- (chi-internal504 (lambda (ribcage1451 source-exp1450
- body1449 r1448 mr1447 m?1446)
- (letrec ((return1452 (lambda (r1541 mr1540
- exprs1539
- ids1538
- vars1537
- vals1536
- inits1535)
- (begin
- (check-defined-ids485
- source-exp1450
- ids1538)
- (values r1541
- mr1540 exprs1539
- ids1538 vars1537
- vals1536
- inits1535)))))
- ((letrec ((parse1453 (lambda (body1461
- r1460 mr1459
- ids1458
- vars1457
- vals1456
- inits1455
- meta-seen?1454)
- (if (null?
- body1461)
- (return1452
- r1460 mr1459
- body1461
- ids1458
- vars1457
- vals1456
- inits1455)
- ((lambda (fr1462)
- ((lambda (e1463)
- ((lambda (meta?1464)
- ((lambda ()
- (call-with-values
- (lambda ()
- (syntax-type446
- e1463
- r1460
- '(())
- '#f
- ribcage1451))
- (lambda (type1469
- value1468
- e1467
- w1466
- ae1465)
- ((lambda (t1470)
- (if (memv
- t1470
- '(define-form))
- (call-with-values
- (lambda ()
- (parse-define510
- e1467
- w1466
- ae1465))
- (lambda (id1473
- rhs1472
- w1471)
- ((lambda (id1475
- label1474)
- (if meta?1464
- ((lambda (sym1476)
- (begin
- (extend-ribcage!410
- ribcage1451
- id1475
- label1474)
- ((lambda (mr1477)
- (begin
- (define-top-level-value-hook135
- sym1476
- (top-level-eval-hook133
- (chi498
- rhs1472
- mr1477
- mr1477
- w1471
- '#t)))
- (parse1453
- (cdr body1461)
- r1460
- mr1477
- (cons
- id1475
- ids1458)
- vars1457
- vals1456
- inits1455
- '#f)))
- (extend-env295
- label1474
- (cons
- 'meta-variable
- sym1476)
- mr1459))))
- (generate-id143
- ((lambda (x1478)
- ((lambda (e1479)
- (if (annotation?132
- e1479)
- (annotation-expression
- e1479)
- e1479))
- (if (syntax-object?64
- x1478)
- (syntax-object-expression65
- x1478)
- x1478)))
- id1475)))
- ((lambda (var1480)
- (begin
- (extend-ribcage!410
- ribcage1451
- id1475
- label1474)
- (parse1453
- (cdr body1461)
- (extend-env295
- label1474
- (cons
- 'lexical
- var1480)
- r1460)
- mr1459
- (cons
- id1475
- ids1458)
- (cons
- var1480
- vars1457)
- (cons
- (make-frob476
- (wrap443
- rhs1472
- w1471)
- meta?1464)
- vals1456)
- inits1455
- '#f)))
- (gen-var523
- id1475))))
- (wrap443
- id1473
- w1471)
- (gen-label362))))
- (if (memv
- t1470
- '(define-syntax-form))
- (call-with-values
- (lambda ()
- (parse-define-syntax511
- e1467
- w1466
- ae1465))
- (lambda (id1483
- rhs1482
- w1481)
- ((lambda (id1486
- label1485
- exp1484)
- (begin
- (extend-ribcage!410
- ribcage1451
- id1486
- label1485)
- ((lambda (b1487)
- (parse1453
- (cdr body1461)
- (extend-env295
- label1485
- b1487
- r1460)
- (extend-env295
- label1485
- b1487
- mr1459)
- (cons
- id1486
- ids1458)
- vars1457
- vals1456
- inits1455
- '#f))
- (defer-or-eval-transformer303
- local-eval-hook134
- exp1484))))
- (wrap443
- id1483
- w1481)
- (gen-label362)
- (chi498
- rhs1482
- mr1459
- mr1459
- w1481
- '#t))))
- (if (memv
- t1470
- '($module-form))
- ((lambda (*ribcage1488)
- ((lambda (*w1489)
- ((lambda ()
- (call-with-values
- (lambda ()
- (parse-module508
- e1467
- w1466
- ae1465
- *w1489))
- (lambda (orig1493
- id1492
- exports1491
- forms1490)
- (call-with-values
- (lambda ()
- (chi-internal504
- *ribcage1488
- orig1493
- (map (lambda (d1507)
- (make-frob476
- d1507
- meta?1464))
- forms1490)
- r1460
- mr1459
- m?1446))
- (lambda (r1500
- mr1499
- *body1498
- *ids1497
- *vars1496
- *vals1495
- *inits1494)
- (begin
- (check-module-exports484
- source-exp1450
- (flatten-exports450
- exports1491)
- *ids1497)
- ((lambda (iface1505
- vars1504
- vals1503
- inits1502
- label1501)
- (begin
- (extend-ribcage!410
- ribcage1451
- id1492
- label1501)
- ((lambda (b1506)
- (parse1453
- (cdr body1461)
- (extend-env295
- label1501
- b1506
- r1500)
- (extend-env295
- label1501
- b1506
- mr1499)
- (cons
- id1492
- ids1458)
- vars1504
- vals1503
- inits1502
- '#f))
- (cons
- '$module
- iface1505))))
- (make-resolved-interface460
- id1492
- exports1491
- '#f)
- (append
- *vars1496
- vars1457)
- (append
- *vals1495
- vals1456)
- (append
- inits1455
- *inits1494
- *body1498)
- (gen-label362))))))))))
- (make-wrap315
- (wrap-marks316
- w1466)
- (cons
- *ribcage1488
- (wrap-subst317
- w1466)))))
- (make-ribcage365
- '()
- '()
- '()))
- (if (memv
- t1470
- '($import-form))
- (call-with-values
- (lambda ()
- (parse-import509
- e1467
- w1466
- ae1465))
- (lambda (orig1510
- only?1509
- mid1508)
- ((lambda (mlabel1511)
- ((lambda (binding1512)
- ((lambda (t1513)
- (if (memv
- t1513
- '($module))
- ((lambda (iface1514)
- ((lambda (import-iface1515)
- ((lambda ()
- (begin
- (if only?1509
- (extend-ribcage-barrier!412
- ribcage1451
- mid1508)
- (void))
- (do-import!507
- import-iface1515
- ribcage1451)
- (parse1453
- (cdr body1461)
- r1460
- mr1459
- (cons
- import-iface1515
- ids1458)
- vars1457
- vals1456
- inits1455
- '#f)))))
- (make-import-interface379
- iface1514
- (import-mark-delta505
- mid1508
- iface1514))))
- (binding-value282
- binding1512))
- (if (memv
- t1513
- '(displaced-lexical))
- (displaced-lexical-error299
- mid1508)
- (syntax-error
- mid1508
- '"unknown module"))))
- (binding-type281
- binding1512)))
- (lookup301
- mlabel1511
- r1460)))
- (id-var-name434
- mid1508
- '(())))))
- (if (memv
- t1470
- '(alias-form))
- (call-with-values
- (lambda ()
- (parse-alias514
- e1467
- w1466
- ae1465))
- (lambda (new-id1517
- old-id1516)
- ((lambda (new-id1518)
- (begin
- (extend-ribcage!410
- ribcage1451
- new-id1518
- (id-var-name-loc433
- old-id1516
- w1466))
- (parse1453
- (cdr body1461)
- r1460
- mr1459
- (cons
- new-id1518
- ids1458)
- vars1457
- vals1456
- inits1455
- '#f)))
- (wrap443
- new-id1517
- w1466))))
- (if (memv
- t1470
- '(begin-form))
- (parse1453
- ((letrec ((f1519 (lambda (forms1520)
- (if (null?
- forms1520)
- (cdr body1461)
- (cons
- (make-frob476
- (wrap443
- (car forms1520)
- w1466)
- meta?1464)
- (f1519
- (cdr forms1520)))))))
- f1519)
- (parse-begin515
- e1467
- w1466
- ae1465
- '#t))
- r1460
- mr1459
- ids1458
- vars1457
- vals1456
- inits1455
- '#f)
- (if (memv
- t1470
- '(eval-when-form))
- (call-with-values
- (lambda ()
- (parse-eval-when513
- e1467
- w1466
- ae1465))
- (lambda (when-list1522
- forms1521)
- (parse1453
- (if (memq
- 'eval
- when-list1522)
- ((letrec ((f1523 (lambda (forms1524)
- (if (null?
- forms1524)
- (cdr body1461)
- (cons
- (make-frob476
- (wrap443
- (car forms1524)
- w1466)
- meta?1464)
- (f1523
- (cdr forms1524)))))))
- f1523)
- forms1521)
- (cdr body1461))
- r1460
- mr1459
- ids1458
- vars1457
- vals1456
- inits1455
- '#f)))
- (if (memv
- t1470
- '(meta-form))
- (parse1453
- (cons
- (make-frob476
- (wrap443
- (parse-meta512
- e1467
- w1466
- ae1465)
- w1466)
- '#t)
- (cdr body1461))
- r1460
- mr1459
- ids1458
- vars1457
- vals1456
- inits1455
- '#t)
- (if (memv
- t1470
- '(local-syntax-form))
- (call-with-values
- (lambda ()
- (chi-local-syntax517
- value1468
- e1467
- r1460
- mr1459
- w1466
- ae1465))
- (lambda (forms1529
- r1528
- mr1527
- w1526
- ae1525)
- (parse1453
- ((letrec ((f1530 (lambda (forms1531)
- (if (null?
- forms1531)
- (cdr body1461)
- (cons
- (make-frob476
- (wrap443
- (car forms1531)
- w1526)
- meta?1464)
- (f1530
- (cdr forms1531)))))))
- f1530)
- forms1529)
- r1528
- mr1527
- ids1458
- vars1457
- vals1456
- inits1455
- '#f)))
- (begin
- (if meta-seen?1454
- (syntax-error
- (source-wrap444
- e1467
- w1466
- ae1465)
- '"invalid meta definition")
- (void))
- ((letrec ((f1532 (lambda (body1533)
- (if ((lambda (t1534)
- (if t1534
- t1534
- (not (frob-meta?479
- (car body1533)))))
- (null?
- body1533))
- (return1452
- r1460
- mr1459
- body1533
- ids1458
- vars1457
- vals1456
- inits1455)
- (begin
- (top-level-eval-hook133
- (chi-meta-frob496
- (car body1533)
- mr1459))
- (f1532
- (cdr body1533)))))))
- f1532)
- (cons
- (make-frob476
- (source-wrap444
- e1467
- w1466
- ae1465)
- meta?1464)
- (cdr body1461))))))))))))))
- type1469))))))
- (frob-meta?479
- fr1462)))
- (frob-e478
- fr1462)))
- (car body1461))))))
- parse1453) body1449 r1448 mr1447 '()
- '() '() '() '#f))))
- (import-mark-delta505 (lambda (mid1445 iface1444)
- (diff-marks426
- (id-marks312 mid1445)
- (interface-marks453 iface1444))))
- (lookup-import-label506 (lambda (id1442)
- ((lambda (label1443)
- (begin
- (if (not label1443)
- (syntax-error
- id1442
- '"exported identifier not visible")
- (void))
- label1443))
- (id-var-name-loc433
- id1442
- '(())))))
- (do-import!507 (lambda (import-iface1438 ribcage1437)
- ((lambda (ie1439)
- (if (<= (vector-length ie1439) '20)
- ((lambda (new-marks1440)
- (vfor-each488
- (lambda (id1441)
- (import-extend-ribcage!411
- ribcage1437
- new-marks1440
- id1441
- (lookup-import-label506
- id1441)))
- ie1439))
- (import-interface-new-marks382
- import-iface1438))
- (extend-ribcage-subst!414
- ribcage1437
- import-iface1438)))
- (interface-exports454
- (import-interface-interface381
- import-iface1438)))))
- (parse-module508 (lambda (e1413 w1412 ae1411 *w1410)
- (letrec ((listify1414 (lambda (exports1431)
- (if (null?
- exports1431)
- '()
- (cons
- ((lambda (tmp1432)
- ((lambda (tmp1433)
- (if tmp1433
- (apply
- (lambda (ex1434)
- (listify1414
- ex1434))
- tmp1433)
- ((lambda (x1436)
- (if (id?306
- x1436)
- (wrap443
- x1436
- *w1410)
- (syntax-error
- (source-wrap444
- e1413
- w1412
- ae1411)
- '"invalid exports list in")))
- tmp1432)))
- ($syntax-dispatch
- tmp1432
- 'each-any)))
- (car exports1431))
- (listify1414
- (cdr exports1431)))))))
- ((lambda (tmp1415)
- ((lambda (tmp1416)
- (if (if tmp1416
- (apply
- (lambda (_1421 orig1420
- mid1419 ex1418
- form1417)
- (id?306 mid1419))
- tmp1416)
- '#f)
- (apply
- (lambda (_1426 orig1425
- mid1424 ex1423
- form1422)
- (values
- orig1425
- (wrap443 mid1424 w1412)
- (listify1414 ex1423)
- (map (lambda (x1428)
- (wrap443
- x1428
- *w1410))
- form1422)))
- tmp1416)
- ((lambda (_1430)
- (syntax-error
- (source-wrap444
- e1413
- w1412
- ae1411)))
- tmp1415)))
- ($syntax-dispatch
- tmp1415
- '(any any any each-any .
- each-any))))
- e1413))))
- (parse-import509 (lambda (e1393 w1392 ae1391)
- ((lambda (tmp1394)
- ((lambda (tmp1395)
- (if (if tmp1395
- (apply
- (lambda (_1398 orig1397
- mid1396)
- (id?306 mid1396))
- tmp1395)
- '#f)
- (apply
- (lambda (_1401 orig1400 mid1399)
- (values
- orig1400
- '#t
- (wrap443 mid1399 w1392)))
- tmp1395)
- ((lambda (tmp1402)
- (if (if tmp1402
- (apply
- (lambda (_1405
- orig1404
- mid1403)
- (id?306 mid1403))
- tmp1402)
- '#f)
- (apply
- (lambda (_1408 orig1407
- mid1406)
- (values
- orig1407
- '#f
- (wrap443
- mid1406
- w1392)))
- tmp1402)
- ((lambda (_1409)
- (syntax-error
- (source-wrap444
- e1393
- w1392
- ae1391)))
- tmp1394)))
- ($syntax-dispatch
- tmp1394
- '(any any #(atom #f) any)))))
- ($syntax-dispatch
- tmp1394
- '(any any #(atom #t) any))))
- e1393)))
- (parse-define510 (lambda (e1364 w1363 ae1362)
- ((lambda (tmp1365)
- ((lambda (tmp1366)
- (if (if tmp1366
- (apply
- (lambda (_1369 name1368
- val1367)
- (id?306 name1368))
- tmp1366)
- '#f)
- (apply
- (lambda (_1372 name1371 val1370)
- (values
- name1371
- val1370
- w1363))
- tmp1366)
- ((lambda (tmp1373)
- (if (if tmp1373
- (apply
- (lambda (_1378
- name1377
- args1376
- e11375
- e21374)
- (if (id?306
- name1377)
- (valid-bound-ids?439
- (lambda-var-list524
- args1376))
- '#f))
- tmp1373)
- '#f)
- (apply
- (lambda (_1383 name1382
- args1381 e11380
- e21379)
- (values
- (wrap443
- name1382
- w1363)
- (cons
- '#(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e w ae) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) \ No newline at end of file
- (wrap443
- (cons
- args1381
- (cons
- e11380
- e21379))
- w1363))
- '(())))
- tmp1373)
- ((lambda (tmp1385)
- (if (if tmp1385
- (apply
- (lambda (_1387
- name1386)
- (id?306
- name1386))
- tmp1385)
- '#f)
- (apply
- (lambda (_1389
- name1388)
- (values
- (wrap443
- name1388
- w1363)
- '#(syntax-object (void) ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(e w ae) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) \ No newline at end of file
- '(())))
- tmp1385)
- ((lambda (_1390)
- (syntax-error
- (source-wrap444
- e1364
- w1363
- ae1362)))
- tmp1365)))
- ($syntax-dispatch
- tmp1365
- '(any any)))))
- ($syntax-dispatch
- tmp1365
- '(any (any . any)
- any
- .
- each-any)))))
- ($syntax-dispatch
- tmp1365
- '(any any any))))
- e1364)))
- (parse-define-syntax511 (lambda (e1340 w1339 ae1338)
- ((lambda (tmp1341)
- ((lambda (tmp1342)
- (if (if tmp1342
- (apply
- (lambda (_1347
- name1346
- id1345
- e11344
- e21343)
- (if (id?306
- name1346)
- (id?306 id1345)
- '#f))
- tmp1342)
- '#f)
- (apply
- (lambda (_1352 name1351
- id1350 e11349
- e21348)
- (values
- (wrap443
- name1351
- w1339)
- (cons
- '#(syntax-object lambda ((top) #(ribcage #(_ name id e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e w ae) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (t\ No newline at end of file
- (cons
- (wrap443
- (list id1350)
- w1339)
- (wrap443
- (cons
- e11349
- e21348)
- w1339)))
- '(())))
- tmp1342)
- ((lambda (tmp1354)
- (if (if tmp1354
- (apply
- (lambda (_1357
- name1356
- val1355)
- (id?306
- name1356))
- tmp1354)
- '#f)
- (apply
- (lambda (_1360
- name1359
- val1358)
- (values
- name1359
- val1358
- w1339))
- tmp1354)
- ((lambda (_1361)
- (syntax-error
- (source-wrap444
- e1340
- w1339
- ae1338)))
- tmp1341)))
- ($syntax-dispatch
- tmp1341
- '(any any any)))))
- ($syntax-dispatch
- tmp1341
- '(any (any any)
- any
- .
- each-any))))
- e1340)))
- (parse-meta512 (lambda (e1332 w1331 ae1330)
- ((lambda (tmp1333)
- ((lambda (tmp1334)
- (if tmp1334
- (apply
- (lambda (_1336 form1335) form1335)
- tmp1334)
- ((lambda (_1337)
- (syntax-error
- (source-wrap444
- e1332
- w1331
- ae1330)))
- tmp1333)))
- ($syntax-dispatch tmp1333 '(any . any))))
- e1332)))
- (parse-eval-when513 (lambda (e1320 w1319 ae1318)
- ((lambda (tmp1321)
- ((lambda (tmp1322)
- (if tmp1322
- (apply
- (lambda (_1326 x1325 e11324
- e21323)
- (values
- (chi-when-list445
- x1325
- w1319)
- (cons e11324 e21323)))
- tmp1322)
- ((lambda (_1329)
- (syntax-error
- (source-wrap444
- e1320
- w1319
- ae1318)))
- tmp1321)))
- ($syntax-dispatch
- tmp1321
- '(any each-any any . each-any))))
- e1320)))
- (parse-alias514 (lambda (e1308 w1307 ae1306)
- ((lambda (tmp1309)
- ((lambda (tmp1310)
- (if (if tmp1310
- (apply
- (lambda (_1313 new-id1312
- old-id1311)
- (if (id?306 new-id1312)
- (id?306 old-id1311)
- '#f))
- tmp1310)
- '#f)
- (apply
- (lambda (_1316 new-id1315
- old-id1314)
- (values new-id1315 old-id1314))
- tmp1310)
- ((lambda (_1317)
- (syntax-error
- (source-wrap444
- e1308
- w1307
- ae1306)))
- tmp1309)))
- ($syntax-dispatch
- tmp1309
- '(any any any))))
- e1308)))
- (parse-begin515 (lambda (e1295 w1294 ae1293 empty-okay?1292)
- ((lambda (tmp1296)
- ((lambda (tmp1297)
- (if (if tmp1297
- (apply
- (lambda (_1298)
- empty-okay?1292)
- tmp1297)
- '#f)
- (apply
- (lambda (_1299) '())
- tmp1297)
- ((lambda (tmp1300)
- (if tmp1300
- (apply
- (lambda (_1303 e11302
- e21301)
- (cons e11302 e21301))
- tmp1300)
- ((lambda (_1305)
- (syntax-error
- (source-wrap444
- e1295
- w1294
- ae1293)))
- tmp1296)))
- ($syntax-dispatch
- tmp1296
- '(any any . each-any)))))
- ($syntax-dispatch tmp1296 '(any))))
- e1295)))
- (chi-lambda-clause516 (lambda (e1269 c1268 r1267 mr1266
- w1265 m?1264)
- ((lambda (tmp1270)
- ((lambda (tmp1271)
- (if tmp1271
- (apply
- (lambda (id1274 e11273
- e21272)
- ((lambda (ids1275)
- (if (not (valid-bound-ids?439
- ids1275))
- (syntax-error
- e1269
- '"invalid parameter list in")
- ((lambda (labels1277
- new-vars1276)
- (values
- new-vars1276
- (chi-body503
- (cons
- e11273
- e21272)
- e1269
- (extend-var-env*297
- labels1277
- new-vars1276
- r1267)
- mr1266
- (make-binding-wrap417
- ids1275
- labels1277
- w1265)
- m?1264)))
- (gen-labels364
- ids1275)
- (map gen-var523
- ids1275))))
- id1274))
- tmp1271)
- ((lambda (tmp1280)
- (if tmp1280
- (apply
- (lambda (ids1283
- e11282
- e21281)
- ((lambda (old-ids1284)
- (if (not (valid-bound-ids?439
- old-ids1284))
- (syntax-error
- e1269
- '"invalid parameter list in")
- ((lambda (labels1286
- new-vars1285)
- (values
- ((letrec ((f1288 (lambda (ls11290
- ls21289)
- (if (null?
- ls11290)
- ls21289
- (f1288
- (cdr ls11290)
- (cons
- (car ls11290)
- ls21289))))))
- f1288)
- (cdr new-vars1285)
- (car new-vars1285))
- (chi-body503
- (cons
- e11282
- e21281)
- e1269
- (extend-var-env*297
- labels1286
- new-vars1285
- r1267)
- mr1266
- (make-binding-wrap417
- old-ids1284
- labels1286
- w1265)
- m?1264)))
- (gen-labels364
- old-ids1284)
- (map gen-var523
- old-ids1284))))
- (lambda-var-list524
- ids1283)))
- tmp1280)
- ((lambda (_1291)
- (syntax-error
- e1269))
- tmp1270)))
- ($syntax-dispatch
- tmp1270
- '(any any . each-any)))))
- ($syntax-dispatch
- tmp1270
- '(each-any any . each-any))))
- c1268)))
- (chi-local-syntax517 (lambda (rec?1245 e1244 r1243 mr1242
- w1241 ae1240)
- ((lambda (tmp1246)
- ((lambda (tmp1247)
- (if tmp1247
- (apply
- (lambda (_1252 id1251
- val1250 e11249
- e21248)
- ((lambda (ids1253)
- (if (not (valid-bound-ids?439
- ids1253))
- (invalid-ids-error441
- (map (lambda (x1254)
- (wrap443
- x1254
- w1241))
- ids1253)
- (source-wrap444
- e1244
- w1241
- ae1240)
- '"keyword")
- ((lambda (labels1255)
- ((lambda (new-w1256)
- ((lambda (b*1257)
- (values
- (cons
- e11249
- e21248)
- (extend-env*296
- labels1255
- b*1257
- r1243)
- (extend-env*296
- labels1255
- b*1257
- mr1242)
- new-w1256
- ae1240))
- ((lambda (w1259)
- (map (lambda (x1261)
- (defer-or-eval-transformer303
- local-eval-hook134
- (chi498
- x1261
- mr1242
- mr1242
- w1259
- '#t)))
- val1250))
- (if rec?1245
- new-w1256
- w1241))))
- (make-binding-wrap417
- ids1253
- labels1255
- w1241)))
- (gen-labels364
- ids1253))))
- id1251))
- tmp1247)
- ((lambda (_1263)
- (syntax-error
- (source-wrap444
- e1244
- w1241
- ae1240)))
- tmp1246)))
- ($syntax-dispatch
- tmp1246
- '(any #(each (any any))
- any
- .
- each-any))))
- e1244)))
- (chi-void518 (lambda () (cons 'void '())))
- (ellipsis?519 (lambda (x1239)
- (if (nonsymbol-id?305 x1239)
- (literal-id=?436
- x1239
- '#(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) \ No newline at end of file
- '#f)))
- (strip-annotation520 (lambda (x1238)
- (if (pair? x1238)
- (cons
- (strip-annotation520 (car x1238))
- (strip-annotation520 (cdr x1238)))
- (if (annotation?132 x1238)
- (annotation-stripped x1238)
- x1238))))
- (strip*521 (lambda (x1231 w1230 fn1229)
- (if (memq 'top (wrap-marks316 w1230))
- (fn1229 x1231)
- ((letrec ((f1232 (lambda (x1233)
- (if (syntax-object?64
- x1233)
- (strip*521
- (syntax-object-expression65
- x1233)
- (syntax-object-wrap66
- x1233)
- fn1229)
- (if (pair? x1233)
- ((lambda (a1235
- d1234)
- (if (if (eq? a1235
- (car x1233))
- (eq? d1234
- (cdr x1233))
- '#f)
- x1233
- (cons
- a1235
- d1234)))
- (f1232
- (car x1233))
- (f1232
- (cdr x1233)))
- (if (vector? x1233)
- ((lambda (old1236)
- ((lambda (new1237)
- (if (andmap
- eq?
- old1236
- new1237)
- x1233
- (list->vector
- new1237)))
- (map f1232
- old1236)))
- (vector->list
- x1233))
- x1233))))))
- f1232)
- x1231))))
- (strip522 (lambda (x1226 w1225)
- (strip*521
- x1226
- w1225
- (lambda (x1227)
- (if ((lambda (t1228)
- (if t1228
- t1228
- (if (pair? x1227)
- (annotation?132 (car x1227))
- '#f)))
- (annotation?132 x1227))
- (strip-annotation520 x1227)
- x1227)))))
- (gen-var523 (lambda (id1223)
- ((lambda (id1224)
- (if (annotation?132 id1224)
- (gensym)
- (gensym)))
- (if (syntax-object?64 id1223)
- (syntax-object-expression65 id1223)
- id1223))))
- (lambda-var-list524 (lambda (vars1218)
- ((letrec ((lvl1219 (lambda (vars1222
- ls1221 w1220)
- (if (pair? vars1222)
- (lvl1219
- (cdr vars1222)
- (cons
- (wrap443
- (car vars1222)
- w1220)
- ls1221)
- w1220)
- (if (id?306
- vars1222)
- (cons
- (wrap443
- vars1222
- w1220)
- ls1221)
- (if (null?
- vars1222)
- ls1221
- (if (syntax-object?64
- vars1222)
- (lvl1219
- (syntax-object-expression65
- vars1222)
- ls1221
- (join-wraps422
- w1220
- (syntax-object-wrap66
- vars1222)))
- (if (annotation?132
- vars1222)
- (lvl1219
- (annotation-expression
- vars1222)
- ls1221
- w1220)
- (cons
- vars1222
- ls1221)))))))))
- lvl1219)
- vars1218
- '()
- '(())))))
- (begin
- (set! $sc-put-cte
- (lambda (id1199 b1198 top-token1197)
- (letrec ((sc-put-module1200 (lambda (exports1216 token1215
- new-marks1214)
- (vfor-each488
- (lambda (id1217)
- (store-import-binding416
- id1217
- token1215
- new-marks1214))
- exports1216)))
- (put-cte1201 (lambda (id1212 binding1211 token1210)
- ((lambda (sym1213)
- (begin
- (store-import-binding416
- id1212
- token1210
- '())
- (put-global-definition-hook139
- sym1213
- (if (if (eq? (binding-type281
- binding1211)
- 'global)
- (eq? (binding-value282
- binding1211)
- sym1213)
- '#f)
- '#f
- binding1211))))
- (if (symbol? id1212)
- id1212
- (id-var-name434 id1212 '(())))))))
- ((lambda (binding1202)
- ((lambda (t1203)
- (if (memv t1203 '($module))
- (begin
- ((lambda (iface1204)
- (sc-put-module1200
- (interface-exports454 iface1204)
- (interface-token455 iface1204)
- '()))
- (binding-value282 binding1202))
- (put-cte1201 id1199 binding1202 top-token1197))
- (if (memv t1203 '(do-alias))
- (store-import-binding416
- id1199
- top-token1197
- '())
- (if (memv t1203 '(do-import))
- ((lambda (token1205)
- ((lambda (b1206)
- ((lambda (t1207)
- (if (memv t1207 '($module))
- ((lambda (iface1208)
- ((lambda (exports1209)
- ((lambda ()
- (begin
- (if (not (eq? (interface-token455
- iface1208)
- token1205))
- (syntax-error
- id1199
- '"import mismatch for module")
- (void))
- (sc-put-module1200
- (interface-exports454
- iface1208)
- top-token1197
- (import-mark-delta505
- id1199
- iface1208))))))
- (interface-exports454
- iface1208)))
- (binding-value282 b1206))
- (syntax-error
- id1199
- '"unknown module")))
- (binding-type281 b1206)))
- (lookup301
- (id-var-name434 id1199 '(()))
- '())))
- (binding-value282 b1198))
- (put-cte1201
- id1199
- binding1202
- top-token1197)))))
- (binding-type281 binding1202)))
- (make-transformer-binding302 b1198)))))
- (global-extend304 'local-syntax 'letrec-syntax '#t)
- (global-extend304 'local-syntax 'let-syntax '#f)
- (global-extend304
- 'core
- 'fluid-let-syntax
- (lambda (e1171 r1170 mr1169 w1168 ae1167 m?1166)
- ((lambda (tmp1172)
- ((lambda (tmp1173)
- (if (if tmp1173
- (apply
- (lambda (_1178 var1177 val1176 e11175 e21174)
- (valid-bound-ids?439 var1177))
- tmp1173)
- '#f)
- (apply
- (lambda (_1184 var1183 val1182 e11181 e21180)
- ((lambda (names1185)
- (begin
- (for-each
- (lambda (id1192 n1191)
- ((lambda (t1193)
- (if (memv t1193 '(displaced-lexical))
- (displaced-lexical-error299
- (wrap443 id1192 w1168))
- (void)))
- (binding-type281
- (lookup301 n1191 r1170))))
- var1183
- names1185)
- ((lambda (b*1186)
- (chi-body503 (cons e11181 e21180)
- (source-wrap444 e1171 w1168 ae1167)
- (extend-env*296 names1185 b*1186 r1170)
- (extend-env*296 names1185 b*1186 mr1169)
- w1168 m?1166))
- (map (lambda (x1189)
- (defer-or-eval-transformer303
- local-eval-hook134
- (chi498 x1189 mr1169 mr1169 w1168
- '#t)))
- val1182))))
- (map (lambda (x1195)
- (id-var-name434 x1195 w1168))
- var1183)))
- tmp1173)
- ((lambda (_1196)
- (syntax-error (source-wrap444 e1171 w1168 ae1167)))
- tmp1172)))
- ($syntax-dispatch
- tmp1172
- '(any #(each (any any)) any . each-any))))
- e1171)))
- (global-extend304
- 'core
- 'quote
- (lambda (e1160 r1159 mr1158 w1157 ae1156 m?1155)
- ((lambda (tmp1161)
- ((lambda (tmp1162)
- (if tmp1162
- (apply
- (lambda (_1164 e1163)
- (list 'quote (strip522 e1163 w1157)))
- tmp1162)
- ((lambda (_1165)
- (syntax-error (source-wrap444 e1160 w1157 ae1156)))
- tmp1161)))
- ($syntax-dispatch tmp1161 '(any any))))
- e1160)))
- (global-extend304
- 'core
- 'syntax
- ((lambda ()
- (letrec ((gen-syntax1039 (lambda (src1100 e1099 r1098
- maps1097 ellipsis?1096
- vec?1095)
- (if (id?306 e1099)
- ((lambda (label1101)
- ((lambda (b1102)
- (if (eq? (binding-type281
- b1102)
- 'syntax)
- (call-with-values
- (lambda ()
- ((lambda (var.lev1105)
- (gen-ref1040
- src1100
- (car var.lev1105)
- (cdr var.lev1105)
- maps1097))
- (binding-value282
- b1102)))
- (lambda (var1104
- maps1103)
- (values
- (list
- 'ref
- var1104)
- maps1103)))
- (if (ellipsis?1096
- e1099)
- (syntax-error
- src1100
- '"misplaced ellipsis in syntax form")
- (values
- (list
- 'quote
- e1099)
- maps1097))))
- (lookup301
- label1101
- r1098)))
- (id-var-name434 e1099 '(())))
- ((lambda (tmp1106)
- ((lambda (tmp1107)
- (if (if tmp1107
- (apply
- (lambda (dots1109
- e1108)
- (ellipsis?1096
- dots1109))
- tmp1107)
- '#f)
- (apply
- (lambda (dots1111
- e1110)
- (if vec?1095
- (syntax-error
- src1100
- '"misplaced ellipsis in syntax template")
- (gen-syntax1039
- src1100
- e1110 r1098
- maps1097
- (lambda (x1112)
- '#f)
- '#f)))
- tmp1107)
- ((lambda (tmp1113)
- (if (if tmp1113
- (apply
- (lambda (x1116
- dots1115
- y1114)
- (ellipsis?1096
- dots1115))
- tmp1113)
- '#f)
- (apply
- (lambda (x1119
- dots1118
- y1117)
- ((letrec ((f1120 (lambda (y1122
- k1121)
- ((lambda (tmp1123)
- ((lambda (tmp1124)
- (if (if tmp1124
- (apply
- (lambda (dots1126
- y1125)
- (ellipsis?1096
- dots1126))
- tmp1124)
- '#f)
- (apply
- (lambda (dots1128
- y1127)
- (f1120
- y1127
- (lambda (maps1129)
- (call-with-values
- (lambda ()
- (k1121
- (cons
- '()
- maps1129)))
- (lambda (x1131
- maps1130)
- (if (null?
- (car maps1130))
- (syntax-error
- src1100
- '"extra ellipsis in syntax form")
- (values
- (gen-mappend1042
- x1131
- (car maps1130))
- (cdr maps1130))))))))
- tmp1124)
- ((lambda (_1132)
- (call-with-values
- (lambda ()
- (gen-syntax1039
- src1100
- y1122
- r1098
- maps1097
- ellipsis?1096
- vec?1095))
- (lambda (y1134
- maps1133)
- (call-with-values
- (lambda ()
- (k1121
- maps1133))
- (lambda (x1136
- maps1135)
- (values
- (gen-append1041
- x1136
- y1134)
- maps1135))))))
- tmp1123)))
- ($syntax-dispatch
- tmp1123
- '(any .
- any))))
- y1122))))
- f1120)
- y1117
- (lambda (maps1137)
- (call-with-values
- (lambda ()
- (gen-syntax1039
- src1100
- x1119
- r1098
- (cons
- '()
- maps1137)
- ellipsis?1096
- '#f))
- (lambda (x1139
- maps1138)
- (if (null?
- (car maps1138))
- (syntax-error
- src1100
- '"extra ellipsis in syntax form")
- (values
- (gen-map1043
- x1139
- (car maps1138))
- (cdr maps1138))))))))
- tmp1113)
- ((lambda (tmp1140)
- (if tmp1140
- (apply
- (lambda (x1142
- y1141)
- (call-with-values
- (lambda ()
- (gen-syntax1039
- src1100
- x1142
- r1098
- maps1097
- ellipsis?1096
- '#f))
- (lambda (xnew1144
- maps1143)
- (call-with-values
- (lambda ()
- (gen-syntax1039
- src1100
- y1141
- r1098
- maps1143
- ellipsis?1096
- vec?1095))
- (lambda (ynew1146
- maps1145)
- (values
- (gen-cons1044
- e1099
- x1142
- y1141
- xnew1144
- ynew1146)
- maps1145))))))
- tmp1140)
- ((lambda (tmp1147)
- (if tmp1147
- (apply
- (lambda (x11149
- x21148)
- ((lambda (ls1150)
- (call-with-values
- (lambda ()
- (gen-syntax1039
- src1100
- ls1150
- r1098
- maps1097
- ellipsis?1096
- '#t))
- (lambda (lsnew1152
- maps1151)
- (values
- (gen-vector1045
- e1099
- ls1150
- lsnew1152)
- maps1151))))
- (cons
- x11149
- x21148)))
- tmp1147)
- ((lambda (_1154)
- (values
- (list
- 'quote
- e1099)
- maps1097))
- tmp1106)))
- ($syntax-dispatch
- tmp1106
- '#(vector
- (any .
- each-any))))))
- ($syntax-dispatch
- tmp1106
- '(any .
- any)))))
- ($syntax-dispatch
- tmp1106
- '(any any
- .
- any)))))
- ($syntax-dispatch
- tmp1106
- '(any any))))
- e1099))))
- (gen-ref1040 (lambda (src1090 var1089 level1088
- maps1087)
- (if (= level1088 '0)
- (values var1089 maps1087)
- (if (null? maps1087)
- (syntax-error
- src1090
- '"missing ellipsis in syntax form")
- (call-with-values
- (lambda ()
- (gen-ref1040
- src1090
- var1089
- (- level1088 '1)
- (cdr maps1087)))
- (lambda (outer-var1092
- outer-maps1091)
- ((lambda (b1093)
- (if b1093
- (values
- (cdr b1093)
- maps1087)
- ((lambda (inner-var1094)
- (values
- inner-var1094
- (cons
- (cons
- (cons
- outer-var1092
- inner-var1094)
- (car maps1087))
- outer-maps1091)))
- (gen-var523
- 'tmp))))
- (assq
- outer-var1092
- (car maps1087)))))))))
- (gen-append1041 (lambda (x1086 y1085)
- (if (equal? y1085 ''())
- x1086
- (list 'append x1086 y1085))))
- (gen-mappend1042 (lambda (e1084 map-env1083)
- (list
- 'apply
- '(primitive append)
- (gen-map1043
- e1084
- map-env1083))))
- (gen-map1043 (lambda (e1076 map-env1075)
- ((lambda (formals1078 actuals1077)
- (if (eq? (car e1076) 'ref)
- (car actuals1077)
- (if (andmap
- (lambda (x1079)
- (if (eq? (car x1079)
- 'ref)
- (memq
- (cadr x1079)
- formals1078)
- '#f))
- (cdr e1076))
- (cons
- 'map
- (cons
- (list
- 'primitive
- (car e1076))
- (map ((lambda (r1080)
- (lambda (x1081)
- (cdr (assq
- (cadr
- x1081)
- r1080))))
- (map cons
- formals1078
- actuals1077))
- (cdr e1076))))
- (cons
- 'map
- (cons
- (list
- 'lambda
- formals1078
- e1076)
- actuals1077)))))
- (map cdr map-env1075)
- (map (lambda (x1082)
- (list 'ref (car x1082)))
- map-env1075))))
- (gen-cons1044 (lambda (e1071 x1070 y1069 xnew1068
- ynew1067)
- ((lambda (t1072)
- (if (memv t1072 '(quote))
- (if (eq? (car xnew1068) 'quote)
- ((lambda (xnew1074
- ynew1073)
- (if (if (eq? xnew1074
- x1070)
- (eq? ynew1073
- y1069)
- '#f)
- (list 'quote e1071)
- (list
- 'quote
- (cons
- xnew1074
- ynew1073))))
- (cadr xnew1068)
- (cadr ynew1067))
- (if (eq? (cadr ynew1067)
- '())
- (list 'list xnew1068)
- (list
- 'cons
- xnew1068
- ynew1067)))
- (if (memv t1072 '(list))
- (cons
- 'list
- (cons
- xnew1068
- (cdr ynew1067)))
- (list
- 'cons
- xnew1068
- ynew1067))))
- (car ynew1067))))
- (gen-vector1045 (lambda (e1066 ls1065 lsnew1064)
- (if (eq? (car lsnew1064) 'quote)
- (if (eq? (cadr lsnew1064)
- ls1065)
- (list 'quote e1066)
- (list
- 'quote
- (list->vector
- (cadr lsnew1064))))
- (if (eq? (car lsnew1064) 'list)
- (cons
- 'vector
- (cdr lsnew1064))
- (list
- 'list->vector
- lsnew1064)))))
- (regen1046 (lambda (x1061)
- ((lambda (t1062)
- (if (memv t1062 '(ref))
- (cadr x1061)
- (if (memv t1062 '(primitive))
- (cadr x1061)
- (if (memv t1062 '(quote))
- (list 'quote (cadr x1061))
- (if (memv t1062 '(lambda))
- (list
- 'lambda
- (cadr x1061)
- (regen1046
- (caddr x1061)))
- (if (memv
- t1062
- '(map))
- ((lambda (ls1063)
- (cons
- (if (= (length
- ls1063)
- '2)
- 'map
- 'map)
- ls1063))
- (map regen1046
- (cdr x1061)))
- (cons
- (car x1061)
- (map regen1046
- (cdr x1061)))))))))
- (car x1061)))))
- (lambda (e1052 r1051 mr1050 w1049 ae1048 m?1047)
- ((lambda (e1053)
- ((lambda (tmp1054)
- ((lambda (tmp1055)
- (if tmp1055
- (apply
- (lambda (_1057 x1056)
- (call-with-values
- (lambda ()
- (gen-syntax1039 e1053 x1056 r1051 '()
- ellipsis?519 '#f))
- (lambda (e1059 maps1058)
- (regen1046 e1059))))
- tmp1055)
- ((lambda (_1060) (syntax-error e1053))
- tmp1054)))
- ($syntax-dispatch tmp1054 '(any any))))
- e1053))
- (source-wrap444 e1052 w1049 ae1048)))))))
- (global-extend304
- 'core
- 'lambda
- (lambda (e1032 r1031 mr1030 w1029 ae1028 m?1027)
- ((lambda (tmp1033)
- ((lambda (tmp1034)
- (if tmp1034
- (apply
- (lambda (_1036 c1035)
- (call-with-values
- (lambda ()
- (chi-lambda-clause516
- (source-wrap444 e1032 w1029 ae1028) c1035
- r1031 mr1030 w1029 m?1027))
- (lambda (vars1038 body1037)
- (list 'lambda vars1038 body1037))))
- tmp1034)
- (syntax-error tmp1033)))
- ($syntax-dispatch tmp1033 '(any . any))))
- e1032)))
- (global-extend304
- 'core
- 'letrec
- (lambda (e1008 r1007 mr1006 w1005 ae1004 m?1003)
- ((lambda (tmp1009)
- ((lambda (tmp1010)
- (if tmp1010
- (apply
- (lambda (_1015 id1014 val1013 e11012 e21011)
- ((lambda (ids1016)
- (if (not (valid-bound-ids?439 ids1016))
- (invalid-ids-error441
- (map (lambda (x1017)
- (wrap443 x1017 w1005))
- ids1016)
- (source-wrap444 e1008 w1005 ae1004)
- '"bound variable")
- ((lambda (labels1019 new-vars1018)
- ((lambda (w1021 r1020)
- (build-letrec236
- ae1004
- new-vars1018
- (map (lambda (x1024)
- (chi498 x1024 r1020 mr1006
- w1021 m?1003))
- val1013)
- (chi-body503 (cons e11012 e21011)
- (source-wrap444
- e1008
- w1021
- ae1004)
- r1020 mr1006 w1021 m?1003)))
- (make-binding-wrap417
- ids1016
- labels1019
- w1005)
- (extend-var-env*297
- labels1019
- new-vars1018
- r1007)))
- (gen-labels364 ids1016)
- (map gen-var523 ids1016))))
- id1014))
- tmp1010)
- ((lambda (_1026)
- (syntax-error (source-wrap444 e1008 w1005 ae1004)))
- tmp1009)))
- ($syntax-dispatch
- tmp1009
- '(any #(each (any any)) any . each-any))))
- e1008)))
- (global-extend304
- 'core
- 'if
- (lambda (e991 r990 mr989 w988 ae987 m?986)
- ((lambda (tmp992)
- ((lambda (tmp993)
- (if tmp993
- (apply
- (lambda (_996 test995 then994)
- (list
- 'if
- (chi498 test995 r990 mr989 w988 m?986)
- (chi498 then994 r990 mr989 w988 m?986)
- (chi-void518)))
- tmp993)
- ((lambda (tmp997)
- (if tmp997
- (apply
- (lambda (_1001 test1000 then999 else998)
- (list
- 'if
- (chi498 test1000 r990 mr989 w988 m?986)
- (chi498 then999 r990 mr989 w988 m?986)
- (chi498 else998 r990 mr989 w988 m?986)))
- tmp997)
- ((lambda (_1002)
- (syntax-error
- (source-wrap444 e991 w988 ae987)))
- tmp992)))
- ($syntax-dispatch tmp992 '(any any any any)))))
- ($syntax-dispatch tmp992 '(any any any))))
- e991)))
- (global-extend304 'set! 'set! '())
- (global-extend304 'alias 'alias '())
- (global-extend304 'begin 'begin '())
- (global-extend304 '$module-key '$module '())
- (global-extend304 '$import '$import '())
- (global-extend304 'define 'define '())
- (global-extend304 'define-syntax 'define-syntax '())
- (global-extend304 'eval-when 'eval-when '())
- (global-extend304 'meta 'meta '())
- (global-extend304
- 'core
- 'syntax-case
- ((lambda ()
- (letrec ((convert-pattern858 (lambda (pattern935 keys934)
- (letrec ((cvt*936 (lambda (p*981
- n980
- ids979)
- (if (null?
- p*981)
- (values
- '()
- ids979)
- (call-with-values
- (lambda ()
- (cvt*936
- (cdr p*981)
- n980
- ids979))
- (lambda (y983
- ids982)
- (call-with-values
- (lambda ()
- (cvt937
- (car p*981)
- n980
- ids982))
- (lambda (x985
- ids984)
- (values
- (cons
- x985
- y983)
- ids984))))))))
- (cvt937 (lambda (p940
- n939
- ids938)
- (if (id?306
- p940)
- (if (bound-id-member?442
- p940
- keys934)
- (values
- (vector
- 'free-id
- p940)
- ids938)
- (values
- 'any
- (cons
- (cons
- p940
- n939)
- ids938)))
- ((lambda (tmp941)
- ((lambda (tmp942)
- (if (if tmp942
- (apply
- (lambda (x944
- dots943)
- (ellipsis?519
- dots943))
- tmp942)
- '#f)
- (apply
- (lambda (x946
- dots945)
- (call-with-values
- (lambda ()
- (cvt937
- x946
- (+ n939
- '1)
- ids938))
- (lambda (p948
- ids947)
- (values
- (if (eq? p948
- 'any)
- 'each-any
- (vector
- 'each
- p948))
- ids947))))
- tmp942)
- ((lambda (tmp949)
- (if (if tmp949
- (apply
- (lambda (x953
- dots952
- y951
- z950)
- (ellipsis?519
- dots952))
- tmp949)
- '#f)
- (apply
- (lambda (x957
- dots956
- y955
- z954)
- (call-with-values
- (lambda ()
- (cvt937
- z954
- n939
- ids938))
- (lambda (z959
- ids958)
- (call-with-values
- (lambda ()
- (cvt*936
- y955
- n939
- ids958))
- (lambda (y961
- ids960)
- (call-with-values
- (lambda ()
- (cvt937
- x957
- (+ n939
- '1)
- ids960))
- (lambda (x963
- ids962)
- (values
- (vector
- 'each+
- x963
- (reverse
- y961)
- z959)
- ids962))))))))
- tmp949)
- ((lambda (tmp965)
- (if tmp965
- (apply
- (lambda (x967
- y966)
- (call-with-values
- (lambda ()
- (cvt937
- y966
- n939
- ids938))
- (lambda (y969
- ids968)
- (call-with-values
- (lambda ()
- (cvt937
- x967
- n939
- ids968))
- (lambda (x971
- ids970)
- (values
- (cons
- x971
- y969)
- ids970))))))
- tmp965)
- ((lambda (tmp972)
- (if tmp972
- (apply
- (lambda ()
- (values
- '()
- ids938))
- tmp972)
- ((lambda (tmp973)
- (if tmp973
- (apply
- (lambda (x974)
- (call-with-values
- (lambda ()
- (cvt937
- x974
- n939
- ids938))
- (lambda (p976
- ids975)
- (values
- (vector
- 'vector
- p976)
- ids975))))
- tmp973)
- ((lambda (x978)
- (values
- (vector
- 'atom
- (strip522
- p940
- '(())))
- ids938))
- tmp941)))
- ($syntax-dispatch
- tmp941
- '#(vector
- each-any)))))
- ($syntax-dispatch
- tmp941
- '()))))
- ($syntax-dispatch
- tmp941
- '(any .
- any)))))
- ($syntax-dispatch
- tmp941
- '(any any
- .
- #(each+
- any
- ()
- any))))))
- ($syntax-dispatch
- tmp941
- '(any any))))
- p940)))))
- (cvt937 pattern935 '0 '()))))
- (build-dispatch-call859 (lambda (pvars927 exp926 y925
- r924 mr923 m?922)
- ((lambda (ids929 levels928)
- ((lambda (labels931
- new-vars930)
- (cons
- 'apply
- (list
- (list
- 'lambda
- new-vars930
- (chi498 exp926
- (extend-env*296
- labels931
- (map (lambda (var933
- level932)
- (cons
- 'syntax
- (cons
- var933
- level932)))
- new-vars930
- (map cdr
- pvars927))
- r924)
- mr923
- (make-binding-wrap417
- ids929
- labels931
- '(()))
- m?922))
- y925)))
- (gen-labels364 ids929)
- (map gen-var523
- ids929)))
- (map car pvars927)
- (map cdr pvars927))))
- (gen-clause860 (lambda (x905 keys904 clauses903 r902
- mr901 m?900 pat899 fender898
- exp897)
- (call-with-values
- (lambda ()
- (convert-pattern858
- pat899
- keys904))
- (lambda (p907 pvars906)
- (if (not (distinct-bound-ids?440
- (map car pvars906)))
- (invalid-ids-error441
- (map car pvars906)
- pat899
- '"pattern variable")
- (if (not (andmap
- (lambda (x908)
- (not (ellipsis?519
- (car x908))))
- pvars906))
- (syntax-error
- pat899
- '"misplaced ellipsis in syntax-case pattern")
- ((lambda (y909)
- (cons
- (list
- 'lambda
- (list y909)
- (list
- 'if
- ((lambda (tmp919)
- ((lambda (tmp920)
- (if tmp920
- (apply
- (lambda ()
- y909)
- tmp920)
- ((lambda (_921)
- (list
- 'if
- y909
- (build-dispatch-call859
- pvars906
- fender898
- y909
- r902
- mr901
- m?900)
- (list
- 'quote
- '#f)))
- tmp919)))
- ($syntax-dispatch
- tmp919
- '#(atom
- #t))))
- fender898)
- (build-dispatch-call859
- pvars906
- exp897 y909
- r902 mr901
- m?900)
- (gen-syntax-case861
- x905 keys904
- clauses903
- r902 mr901
- m?900)))
- (list
- (if (eq? p907
- 'any)
- (cons
- 'list
- (list x905))
- (cons
- '$syntax-dispatch
- (list
- x905
- (list
- 'quote
- p907)))))))
- (gen-var523
- 'tmp))))))))
- (gen-syntax-case861 (lambda (x885 keys884 clauses883
- r882 mr881 m?880)
- (if (null? clauses883)
- (cons
- 'syntax-error
- (list x885))
- ((lambda (tmp886)
- ((lambda (tmp887)
- (if tmp887
- (apply
- (lambda (pat889
- exp888)
- (if (if (id?306
- pat889)
- (if (not (bound-id-member?442
- pat889
- keys884))
- (not (ellipsis?519
- pat889))
- '#f)
- '#f)
- ((lambda (label891
- var890)
- (cons
- (list
- 'lambda
- (list
- var890)
- (chi498
- exp888
- (extend-env295
- label891
- (cons
- 'syntax
- (cons
- var890
- '0))
- r882)
- mr881
- (make-binding-wrap417
- (list
- pat889)
- (list
- label891)
- '(()))
- m?880))
- (list
- x885)))
- (gen-label362)
- (gen-var523
- pat889))
- (gen-clause860
- x885
- keys884
- (cdr clauses883)
- r882
- mr881
- m?880
- pat889
- '#t
- exp888)))
- tmp887)
- ((lambda (tmp892)
- (if tmp892
- (apply
- (lambda (pat895
- fender894
- exp893)
- (gen-clause860
- x885
- keys884
- (cdr clauses883)
- r882
- mr881
- m?880
- pat895
- fender894
- exp893))
- tmp892)
- ((lambda (_896)
- (syntax-error
- (car clauses883)
- '"invalid syntax-case clause"))
- tmp886)))
- ($syntax-dispatch
- tmp886
- '(any any
- any)))))
- ($syntax-dispatch
- tmp886
- '(any any))))
- (car clauses883))))))
- (lambda (e867 r866 mr865 w864 ae863 m?862)
- ((lambda (e868)
- ((lambda (tmp869)
- ((lambda (tmp870)
- (if tmp870
- (apply
- (lambda (_874 val873 key872 m871)
- (if (andmap
- (lambda (x876)
- (if (id?306 x876)
- (not (ellipsis?519 x876))
- '#f))
- key872)
- ((lambda (x877)
- (cons
- (list
- 'lambda
- (list x877)
- (gen-syntax-case861 x877 key872
- m871 r866 mr865 m?862))
- (list
- (chi498 val873 r866 mr865 '(())
- m?862))))
- (gen-var523 'tmp))
- (syntax-error
- e868
- '"invalid literals list in")))
- tmp870)
- (syntax-error tmp869)))
- ($syntax-dispatch
- tmp869
- '(any any each-any . each-any))))
- e868))
- (source-wrap444 e867 w864 ae863)))))))
- (put-cte-hook137
- 'module
- (lambda (x827)
- (letrec ((proper-export?828 (lambda (e851)
- ((lambda (tmp852)
- ((lambda (tmp853)
- (if tmp853
- (apply
- (lambda (id855 e854)
- (if (identifier?
- id855)
- (andmap
- proper-export?828
- e854)
- '#f))
- tmp853)
- ((lambda (id857)
- (identifier? id857))
- tmp852)))
- ($syntax-dispatch
- tmp852
- '(any . each-any))))
- e851))))
- ((lambda (tmp829)
- ((lambda (orig830)
- ((lambda (tmp831)
- ((lambda (tmp832)
- (if tmp832
- (apply
- (lambda (_835 e834 d833)
- (if (andmap proper-export?828 e834)
- (list
- '#(syntax-object begin ((top) #(ribcage #(_ e d) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) \ No newline at end of file
- (cons
- '#(syntax-object $module ((top) #(ribcage #(_ e d) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (t\ No newline at end of file
- (cons
- orig830
- (cons
- '#(syntax-object anon ((top) #(ribcage #(_ e d) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (\ No newline at end of file
- (cons e834 d833))))
- (cons
- '#(syntax-object $import ((top) #(ribcage #(_ e d) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (t\ No newline at end of file
- (cons
- orig830
- '#(syntax-object (#f anon) ((top) #(ribcage #(_ e d) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top\ No newline at end of file
- (syntax-error
- x827
- '"invalid exports list in")))
- tmp832)
- ((lambda (tmp839)
- (if (if tmp839
- (apply
- (lambda (_843 m842 e841 d840)
- (identifier? m842))
- tmp839)
- '#f)
- (apply
- (lambda (_847 m846 e845 d844)
- (if (andmap proper-export?828 e845)
- (cons
- '#(syntax-object $module ((top) #(ribcage #(_ m e d) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (to\ No newline at end of file
- (cons
- orig830
- (cons
- m846
- (cons e845 d844))))
- (syntax-error
- x827
- '"invalid exports list in")))
- tmp839)
- (syntax-error tmp831)))
- ($syntax-dispatch
- tmp831
- '(any any each-any . each-any)))))
- ($syntax-dispatch
- tmp831
- '(any each-any . each-any))))
- x827))
- tmp829))
- x827))))
- ((lambda ()
- (letrec (($module-exports628 (lambda (m819 r818)
- ((lambda (b820)
- ((lambda (t821)
- (if (memv t821 '($module))
- ((lambda (interface822)
- ((lambda (new-marks823)
- ((lambda ()
- (vmap487
- (lambda (x824)
- ((lambda (id825)
- (make-syntax-object63
- (syntax-object->datum
- id825)
- ((lambda (marks826)
- (make-wrap315
- marks826
- (if (eq? (car marks826)
- '#f)
- (cons
- 'shift
- (wrap-subst317
- '((top))))
- (wrap-subst317
- '((top))))))
- (join-marks423
- new-marks823
- (wrap-marks316
- (syntax-object-wrap66
- id825))))))
- (if (pair?
- x824)
- (car x824)
- x824)))
- (interface-exports454
- interface822)))))
- (import-mark-delta505
- m819
- interface822)))
- (binding-value282
- b820))
- (if (memv
- t821
- '(displaced-lexical))
- (displaced-lexical-error299
- m819)
- (syntax-error
- m819
- '"unknown module"))))
- (binding-type281 b820)))
- (r818 m819))))
- ($import-help629 (lambda (orig633 import-only?632)
- (lambda (r634)
- (letrec ((difference635 (lambda (ls1817
- ls2816)
- (if (null?
- ls1817)
- ls1817
- (if (bound-id-member?442
- (car ls1817)
- ls2816)
- (difference635
- (cdr ls1817)
- ls2816)
- (cons
- (car ls1817)
- (difference635
- (cdr ls1817)
- ls2816))))))
- (prefix-add636 (lambda (prefix-id813)
- ((lambda (prefix814)
- (lambda (id815)
- (datum->syntax-object
- id815
- (string->symbol
- (string-append
- prefix814
- (symbol->string
- (syntax-object->datum
- id815)))))))
- (symbol->string
- (syntax-object->datum
- prefix-id813)))))
- (prefix-drop637 (lambda (prefix-id807)
- ((lambda (prefix808)
- (lambda (id809)
- ((lambda (s810)
- ((lambda (np812
- ns811)
- (begin
- (if (not (if (>= ns811
- np812)
- (string=?
- (substring
- s810
- '0
- np812)
- prefix808)
- '#f))
- (syntax-error
- id809
- (string-append
- '"missing expected prefix "
- prefix808))
- (void))
- (datum->syntax-object
- id809
- (string->symbol
- (substring
- s810
- np812
- ns811)))))
- (string-length
- prefix808)
- (string-length
- s810)))
- (symbol->string
- (syntax-object->datum
- id809)))))
- (symbol->string
- (syntax-object->datum
- prefix-id807)))))
- (gen-mid638 (lambda (mid804)
- (datum->syntax-object
- mid804
- (generate-id143
- ((lambda (x805)
- ((lambda (e806)
- (if (annotation?132
- e806)
- (annotation-expression
- e806)
- e806))
- (if (syntax-object?64
- x805)
- (syntax-object-expression65
- x805)
- x805)))
- mid804)))))
- (modspec639 (lambda (m655
- exports?654)
- ((lambda (tmp656)
- ((lambda (tmp657)
- (if tmp657
- (apply
- (lambda (orig659
- import-only?658)
- ((lambda (tmp660)
- ((lambda (tmp661)
- (if (if tmp661
- (apply
- (lambda (m663
- id662)
- (andmap
- identifier?
- id662))
- tmp661)
- '#f)
- (apply
- (lambda (m666
- id665)
- (call-with-values
- (lambda ()
- (modspec639
- m666
- '#f))
- (lambda (mid669
- d668
- exports667)
- ((lambda (tmp670)
- ((lambda (tmp671)
- (if tmp671
- (apply
- (lambda (d673
- tmid672)
- (values
- mid669
- (list
- '#(syntax-object begin ((top) #(ribcage #(d tmid) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-bindin\ No newline at end of file
- (list
- '#(syntax-object $module ((top) #(ribcage #(d tmid) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-bi\ No newline at end of file
- orig659
- tmid672
- id665
- d673)
- (list
- '#(syntax-object $import ((top) #(ribcage #(d tmid) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-bi\ No newline at end of file
- orig659
- import-only?658
- tmid672))
- (if exports?654
- id665
- '#f)))
- tmp671)
- (syntax-error
- tmp670)))
- ($syntax-dispatch
- tmp670
- '(any any))))
- (list
- d668
- (gen-mid638
- mid669))))))
- tmp661)
- ((lambda (tmp676)
- (if (if tmp676
- (apply
- (lambda (m678
- id677)
- (andmap
- identifier?
- id677))
- tmp676)
- '#f)
- (apply
- (lambda (m681
- id680)
- (call-with-values
- (lambda ()
- (modspec639
- m681
- '#t))
- (lambda (mid684
- d683
- exports682)
- ((lambda (tmp685)
- ((lambda (tmp687)
- (if tmp687
- (apply
- (lambda (d690
- tmid689
- id688)
- (values
- mid684
- (list
- '#(syntax-object begin ((top) #(ribcage #(d tmid id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-bindin\ No newline at end of file
- (list
- '#(syntax-object $module ((top) #(ribcage #(d tmid id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-bi\ No newline at end of file
- orig659
- tmid689
- id688
- d690)
- (list
- '#(syntax-object $import ((top) #(ribcage #(d tmid id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-bi\ No newline at end of file
- orig659
- import-only?658
- tmid689))
- (if exports?654
- id688
- '#f)))
- tmp687)
- (syntax-error
- tmp685)))
- ($syntax-dispatch
- tmp685
- '(any any
- each-any))))
- (list
- d683
- (gen-mid638
- mid684)
- (difference635
- exports682
- id680))))))
- tmp676)
- ((lambda (tmp693)
- (if (if tmp693
- (apply
- (lambda (m695
- prefix-id694)
- (identifier?
- prefix-id694))
- tmp693)
- '#f)
- (apply
- (lambda (m697
- prefix-id696)
- (call-with-values
- (lambda ()
- (modspec639
- m697
- '#t))
- (lambda (mid700
- d699
- exports698)
- ((lambda (tmp701)
- ((lambda (tmp702)
- (if tmp702
- (apply
- (lambda (d707
- tmid706
- old-id705
- tmp704
- id703)
- (values
- mid700
- (list
- '#(syntax-object begin ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build\ No newline at end of file
- (cons
- '#(syntax-object $module ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional b\ No newline at end of file
- (cons
- orig659
- (cons
- tmid706
- (cons
- (map list
- id703
- tmp704)
- (cons
- (cons
- '#(syntax-object $module ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-con\ No newline at end of file
- (cons
- orig659
- (cons
- tmid706
- (cons
- (map list
- tmp704
- old-id705)
- (cons
- d707
- (map (lambda (tmp714
- tmp713)
- (list
- '#(syntax-object alias ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-refe\ No newline at end of file
- tmp713
- tmp714))
- old-id705
- tmp704))))))
- (cons
- (list
- '#(syntax-object $import ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-c\ No newline at end of file
- orig659
- import-only?658
- tmid706)
- (map (lambda (tmp716
- tmp715)
- (list
- '#(syntax-object alias ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference bu\ No newline at end of file
- tmp715
- tmp716))
- tmp704
- id703)))))))
- (list
- '#(syntax-object $import ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional b\ No newline at end of file
- orig659
- import-only?658
- tmid706))
- (if exports?654
- id703
- '#f)))
- tmp702)
- (syntax-error
- tmp701)))
- ($syntax-dispatch
- tmp701
- '(any any
- each-any
- each-any
- each-any))))
- (list
- d699
- (gen-mid638
- mid700)
- exports698
- (generate-temporaries
- exports698)
- (map (prefix-add636
- prefix-id696)
- exports698))))))
- tmp693)
- ((lambda (tmp717)
- (if (if tmp717
- (apply
- (lambda (m719
- prefix-id718)
- (identifier?
- prefix-id718))
- tmp717)
- '#f)
- (apply
- (lambda (m721
- prefix-id720)
- (call-with-values
- (lambda ()
- (modspec639
- m721
- '#t))
- (lambda (mid724
- d723
- exports722)
- ((lambda (tmp725)
- ((lambda (tmp726)
- (if tmp726
- (apply
- (lambda (d731
- tmid730
- old-id729
- tmp728
- id727)
- (values
- mid724
- (list
- '#(syntax-object begin ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditiona\ No newline at end of file
- (cons
- '#(syntax-object $module ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-condit\ No newline at end of file
- (cons
- orig659
- (cons
- tmid730
- (cons
- (map list
- id727
- tmp728)
- (cons
- (cons
- '#(syntax-object $module ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference bu\ No newline at end of file
- (cons
- orig659
- (cons
- tmid730
- (cons
- (map list
- tmp728
- old-id729)
- (cons
- d731
- (map (lambda (tmp738
- tmp737)
- (list
- '#(syntax-object alias ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexic\ No newline at end of file
- tmp737
- tmp738))
- old-id729
- tmp728))))))
- (cons
- (list
- '#(syntax-object $import ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference \ No newline at end of file
- orig659
- import-only?658
- tmid730)
- (map (lambda (tmp740
- tmp739)
- (list
- '#(syntax-object alias ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-refer\ No newline at end of file
- tmp739
- tmp740))
- tmp728
- id727)))))))
- (list
- '#(syntax-object $import ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-condit\ No newline at end of file
- orig659
- import-only?658
- tmid730))
- (if exports?654
- id727
- '#f)))
- tmp726)
- (syntax-error
- tmp725)))
- ($syntax-dispatch
- tmp725
- '(any any
- each-any
- each-any
- each-any))))
- (list
- d723
- (gen-mid638
- mid724)
- exports722
- (generate-temporaries
- exports722)
- (map (prefix-drop637
- prefix-id720)
- exports722))))))
- tmp717)
- ((lambda (tmp741)
- (if (if tmp741
- (apply
- (lambda (m744
- new-id743
- old-id742)
- (if (andmap
- identifier?
- new-id743)
- (andmap
- identifier?
- old-id742)
- '#f))
- tmp741)
- '#f)
- (apply
- (lambda (m749
- new-id748
- old-id747)
- (call-with-values
- (lambda ()
- (modspec639
- m749
- '#t))
- (lambda (mid752
- d751
- exports750)
- ((lambda (tmp753)
- ((lambda (tmp756)
- (if tmp756
- (apply
- (lambda (d760
- tmid759
- tmp758
- other-id757)
- (values
- mid752
- (list
- '#(syntax-object begin ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-\ No newline at end of file
- (cons
- '#(syntax-object $module ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference bu\ No newline at end of file
- (cons
- orig659
- (cons
- tmid759
- (cons
- (append
- (map list
- new-id748
- tmp758)
- other-id757)
- (cons
- (cons
- '#(syntax-object $module ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-re\ No newline at end of file
- (cons
- orig659
- (cons
- tmid759
- (cons
- (append
- other-id757
- (map list
- tmp758
- old-id747))
- (cons
- d760
- (map (lambda (tmp770
- tmp769)
- (list
- '#(syntax-object alias ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment b\ No newline at end of file
- tmp769
- tmp770))
- old-id747
- tmp758))))))
- (cons
- (list
- '#(syntax-object $import ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-\ No newline at end of file
- orig659
- import-only?658
- tmid759)
- (map (lambda (tmp772
- tmp771)
- (list
- '#(syntax-object alias ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lex\ No newline at end of file
- tmp771
- tmp772))
- tmp758
- new-id748)))))))
- (list
- '#(syntax-object $import ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference bu\ No newline at end of file
- orig659
- import-only?658
- tmid759))
- (if exports?654
- (append
- new-id748
- other-id757)
- '#f)))
- tmp756)
- (syntax-error
- tmp753)))
- ($syntax-dispatch
- tmp753
- '(any any
- each-any
- each-any))))
- (list
- d751
- (gen-mid638
- mid752)
- (generate-temporaries
- old-id747)
- (difference635
- exports750
- old-id747))))))
- tmp741)
- ((lambda (tmp773)
- (if (if tmp773
- (apply
- (lambda (m776
- new-id775
- old-id774)
- (if (andmap
- identifier?
- new-id775)
- (andmap
- identifier?
- old-id774)
- '#f))
- tmp773)
- '#f)
- (apply
- (lambda (m781
- new-id780
- old-id779)
- (call-with-values
- (lambda ()
- (modspec639
- m781
- '#t))
- (lambda (mid784
- d783
- exports782)
- ((lambda (tmp785)
- ((lambda (tmp786)
- (if tmp786
- (apply
- (lambda (d789
- tmid788
- other-id787)
- (values
- mid784
- (list
- '#(syntax-object begin ((top) #(ribcage #(d tmid other-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditi\ No newline at end of file
- (cons
- '#(syntax-object $module ((top) #(ribcage #(d tmid other-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-con\ No newline at end of file
- (cons
- orig659
- (cons
- tmid788
- (cons
- (append
- (map list
- new-id780
- old-id779)
- other-id787)
- (cons
- d789
- (map (lambda (tmp796
- tmp795)
- (list
- '#(syntax-object alias ((top) #(ribcage #(d tmid other-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-refe\ No newline at end of file
- tmp795
- tmp796))
- old-id779
- new-id780))))))
- (list
- '#(syntax-object $import ((top) #(ribcage #(d tmid other-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-con\ No newline at end of file
- orig659
- import-only?658
- tmid788))
- (if exports?654
- (append
- new-id780
- other-id787)
- '#f)))
- tmp786)
- (syntax-error
- tmp785)))
- ($syntax-dispatch
- tmp785
- '(any any
- each-any))))
- (list
- d783
- (gen-mid638
- mid784)
- exports782)))))
- tmp773)
- ((lambda (tmp797)
- (if (if tmp797
- (apply
- (lambda (mid798)
- (identifier?
- mid798))
- tmp797)
- '#f)
- (apply
- (lambda (mid799)
- (values
- mid799
- (list
- '#(syntax-object $import ((top) #(ribcage #(mid) #((top)) #("i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-\ No newline at end of file
- orig659
- import-only?658
- mid799)
- (if exports?654
- ($module-exports628
- mid799
- r634)
- '#f)))
- tmp797)
- ((lambda (tmp800)
- (if (if tmp800
- (apply
- (lambda (mid801)
- (identifier?
- mid801))
- tmp800)
- '#f)
- (apply
- (lambda (mid802)
- (values
- mid802
- (list
- '#(syntax-object $import ((top) #(ribcage #(mid) #((top)) #("i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top\ No newline at end of file
- orig659
- import-only?658
- mid802)
- (if exports?654
- ($module-exports628
- mid802
- r634)
- '#f)))
- tmp800)
- ((lambda (_803)
- (syntax-error
- m655
- '"invalid module specifier"))
- tmp660)))
- ($syntax-dispatch
- tmp660
- '(any)))))
- (list
- tmp660))))
- ($syntax-dispatch
- tmp660
- '(#(free-id
- #(syntax-object alias ((top) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook anno\ No newline at end of file
- any
- .
- #(each
- (any any)))))))
- ($syntax-dispatch
- tmp660
- '(#(free-id
- #(syntax-object rename ((top) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation\ No newline at end of file
- any
- .
- #(each
- (any any)))))))
- ($syntax-dispatch
- tmp660
- '(#(free-id
- #(syntax-object drop-prefix ((top) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? \ No newline at end of file
- any
- any)))))
- ($syntax-dispatch
- tmp660
- '(#(free-id
- #(syntax-object add-prefix ((top) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<\ No newline at end of file
- any
- any)))))
- ($syntax-dispatch
- tmp660
- '(#(free-id
- #(syntax-object except ((top) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< f\ No newline at end of file
- any
- .
- each-any)))))
- ($syntax-dispatch
- tmp660
- '(#(free-id
- #(syntax-object only ((top) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx\ No newline at end of file
- any
- .
- each-any))))
- m655))
- tmp657)
- (syntax-error
- tmp656)))
- ($syntax-dispatch
- tmp656
- '(any any))))
- (list
- orig633
- import-only?632))))
- (modspec*640 (lambda (m650)
- (call-with-values
- (lambda ()
- (modspec639
- m650
- '#f))
- (lambda (mid653
- d652
- exports651)
- d652)))))
- ((lambda (tmp641)
- ((lambda (tmp642)
- (if tmp642
- (apply
- (lambda (_644 m643)
- ((lambda (tmp645)
- ((lambda (tmp647)
- (if tmp647
- (apply
- (lambda (d648)
- (cons
- '#(syntax-object begin ((top) #(ribcage #(d) #((top)) #("i")) #(ribcage #(_ m) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-obje\ No newline at end of file
- d648))
- tmp647)
- (syntax-error
- tmp645)))
- ($syntax-dispatch
- tmp645
- 'each-any)))
- (map modspec*640
- m643)))
- tmp642)
- (syntax-error tmp641)))
- ($syntax-dispatch
- tmp641
- '(any . each-any))))
- orig633))))))
- (begin
- (put-cte-hook137
- 'import
- (lambda (orig631) ($import-help629 orig631 '#f)))
- (put-cte-hook137
- 'import-only
- (lambda (orig630) ($import-help629 orig630 '#t)))))))
- (set! sc-expand
- ((lambda (ctem625 rtem624)
- (lambda (x626)
- ((lambda (env627)
- (if (if (pair? x626) (equal? (car x626) noexpand62) '#f)
- (cadr x626)
- (chi-top*447 x626 '() (env-wrap388 env627) ctem625
- rtem624 '#f (env-top-ribcage387 env627))))
- (interaction-environment))))
- '(e)
- '(e)))
- (set! $make-environment
- (lambda (token622 mutable?621)
- ((lambda (top-ribcage623)
- (make-env385
- top-ribcage623
- (make-wrap315
- (wrap-marks316 '((top)))
- (cons top-ribcage623 (wrap-subst317 '((top)))))))
- (make-top-ribcage373 token622 mutable?621))))
- (set! environment? (lambda (x620) (env?386 x620)))
- (set! interaction-environment
- ((lambda (e619) (lambda () e619))
- ($make-environment '*top* '#t)))
- (set! identifier? (lambda (x618) (nonsymbol-id?305 x618)))
- (set! datum->syntax-object
- (lambda (id616 datum615)
- (begin
- ((lambda (x617)
- (if (not (nonsymbol-id?305 x617))
- (error-hook136
- 'datum->syntax-object
- '"invalid argument"
- x617)
- (void)))
- id616)
- (make-syntax-object63
- datum615
- (syntax-object-wrap66 id616)))))
- (set! syntax->list
- (lambda (orig-ls606)
- ((letrec ((f607 (lambda (ls608)
- ((lambda (tmp609)
- ((lambda (tmp610)
- (if tmp610
- (apply (lambda () '()) tmp610)
- ((lambda (tmp611)
- (if tmp611
- (apply
- (lambda (x613 r612)
- (cons x613 (f607 r612)))
- tmp611)
- ((lambda (_614)
- (error 'syntax->list
- '"invalid argument ~s"
- orig-ls606))
- tmp609)))
- ($syntax-dispatch
- tmp609
- '(any . any)))))
- ($syntax-dispatch tmp609 '())))
- ls608))))
- f607)
- orig-ls606)))
- (set! syntax->vector
- (lambda (v600)
- ((lambda (tmp601)
- ((lambda (tmp602)
- (if tmp602
- (apply
- (lambda (x603) (apply vector (syntax->list x603)))
- tmp602)
- ((lambda (_605)
- (error 'syntax->vector
- '"invalid argument ~s"
- v600))
- tmp601)))
- ($syntax-dispatch tmp601 '#(vector each-any))))
- v600)))
- (set! syntax-object->datum
- (lambda (x599) (strip522 x599 '(()))))
- (set! generate-temporaries
- ((lambda (n595)
- (lambda (ls596)
- (begin
- ((lambda (x598)
- (if (not (list? x598))
- (error-hook136
- 'generate-temporaries
- '"invalid argument"
- x598)
- (void)))
- ls596)
- (map (lambda (x597)
- (begin
- (set! n595 (+ n595 '1))
- (wrap443
- (string->symbol
- (string-append '"t" (number->string n595)))
- '((tmp)))))
- ls596))))
- '0))
- (set! free-identifier=?
- (lambda (x592 y591)
- (begin
- ((lambda (x594)
- (if (not (nonsymbol-id?305 x594))
- (error-hook136
- 'free-identifier=?
- '"invalid argument"
- x594)
- (void)))
- x592)
- ((lambda (x593)
- (if (not (nonsymbol-id?305 x593))
- (error-hook136
- 'free-identifier=?
- '"invalid argument"
- x593)
- (void)))
- y591)
- (free-id=?435 x592 y591))))
- (set! bound-identifier=?
- (lambda (x588 y587)
- (begin
- ((lambda (x590)
- (if (not (nonsymbol-id?305 x590))
- (error-hook136
- 'bound-identifier=?
- '"invalid argument"
- x590)
- (void)))
- x588)
- ((lambda (x589)
- (if (not (nonsymbol-id?305 x589))
- (error-hook136
- 'bound-identifier=?
- '"invalid argument"
- x589)
- (void)))
- y587)
- (bound-id=?438 x588 y587))))
- (set! literal-identifier=?
- (lambda (x584 y583)
- (begin
- ((lambda (x586)
- (if (not (nonsymbol-id?305 x586))
- (error-hook136
- 'literal-identifier=?
- '"invalid argument"
- x586)
- (void)))
- x584)
- ((lambda (x585)
- (if (not (nonsymbol-id?305 x585))
- (error-hook136
- 'literal-identifier=?
- '"invalid argument"
- x585)
- (void)))
- y583)
- (literal-id=?436 x584 y583))))
- (set! syntax-error
- (lambda (object578 . messages579)
- (begin
- (for-each
- (lambda (x581)
- ((lambda (x582)
- (if (not (string? x582))
- (error-hook136
- 'syntax-error
- '"invalid argument"
- x582)
- (void)))
- x581))
- messages579)
- ((lambda (message580)
- (error-hook136 '#f message580 (strip522 object578 '(()))))
- (if (null? messages579)
- '"invalid syntax"
- (apply string-append messages579))))))
- ((lambda ()
- (letrec ((match-each525 (lambda (e575 p574 w573)
- (if (annotation?132 e575)
- (match-each525
- (annotation-expression e575)
- p574
- w573)
- (if (pair? e575)
- ((lambda (first576)
- (if first576
- ((lambda (rest577)
- (if rest577
- (cons
- first576
- rest577)
- '#f))
- (match-each525
- (cdr e575)
- p574
- w573))
- '#f))
- (match531
- (car e575)
- p574
- w573
- '()))
- (if (null? e575)
- '()
- (if (syntax-object?64 e575)
- (match-each525
- (syntax-object-expression65
- e575)
- p574
- (join-wraps422
- w573
- (syntax-object-wrap66
- e575)))
- '#f))))))
- (match-each+526 (lambda (e565 x-pat564 y-pat563 z-pat562
- w561 r560)
- ((letrec ((f566 (lambda (e568 w567)
- (if (pair? e568)
- (call-with-values
- (lambda ()
- (f566
- (cdr e568)
- w567))
- (lambda (xr*571
- y-pat570
- r569)
- (if r569
- (if (null?
- y-pat570)
- ((lambda (xr572)
- (if xr572
- (values
- (cons
- xr572
- xr*571)
- y-pat570
- r569)
- (values
- '#f
- '#f
- '#f)))
- (match531
- (car e568)
- x-pat564
- w567
- '()))
- (values
- '()
- (cdr y-pat570)
- (match531
- (car e568)
- (car y-pat570)
- w567
- r569)))
- (values
- '#f
- '#f
- '#f))))
- (if (annotation?132
- e568)
- (f566
- (annotation-expression
- e568)
- w567)
- (if (syntax-object?64
- e568)
- (f566
- (syntax-object-expression65
- e568)
- (join-wraps422
- w567
- (syntax-object-wrap66
- e568)))
- (values
- '()
- y-pat563
- (match531
- e568
- z-pat562
- w567
- r560))))))))
- f566)
- e565
- w561)))
- (match-each-any527 (lambda (e558 w557)
- (if (annotation?132 e558)
- (match-each-any527
- (annotation-expression e558)
- w557)
- (if (pair? e558)
- ((lambda (l559)
- (if l559
- (cons
- (wrap443
- (car e558)
- w557)
- l559)
- '#f))
- (match-each-any527
- (cdr e558)
- w557))
- (if (null? e558)
- '()
- (if (syntax-object?64
- e558)
- (match-each-any527
- (syntax-object-expression65
- e558)
- (join-wraps422
- w557
- (syntax-object-wrap66
- e558)))
- '#f))))))
- (match-empty528 (lambda (p555 r554)
- (if (null? p555)
- r554
- (if (eq? p555 'any)
- (cons '() r554)
- (if (pair? p555)
- (match-empty528
- (car p555)
- (match-empty528
- (cdr p555)
- r554))
- (if (eq? p555 'each-any)
- (cons '() r554)
- ((lambda (t556)
- (if (memv
- t556
- '(each))
- (match-empty528
- (vector-ref
- p555
- '1)
- r554)
- (if (memv
- t556
- '(each+))
- (match-empty528
- (vector-ref
- p555
- '1)
- (match-empty528
- (reverse
- (vector-ref
- p555
- '2))
- (match-empty528
- (vector-ref
- p555
- '3)
- r554)))
- (if (memv
- t556
- '(free-id
- atom))
- r554
- (if (memv
- t556
- '(vector))
- (match-empty528
- (vector-ref
- p555
- '1)
- r554)
- (void))))))
- (vector-ref
- p555
- '0))))))))
- (combine529 (lambda (r*553 r552)
- (if (null? (car r*553))
- r552
- (cons
- (map car r*553)
- (combine529
- (map cdr r*553)
- r552)))))
- (match*530 (lambda (e545 p544 w543 r542)
- (if (null? p544)
- (if (null? e545) r542 '#f)
- (if (pair? p544)
- (if (pair? e545)
- (match531
- (car e545)
- (car p544)
- w543
- (match531
- (cdr e545)
- (cdr p544)
- w543
- r542))
- '#f)
- (if (eq? p544 'each-any)
- ((lambda (l546)
- (if l546
- (cons l546 r542)
- '#f))
- (match-each-any527
- e545
- w543))
- ((lambda (t547)
- (if (memv t547 '(each))
- (if (null? e545)
- (match-empty528
- (vector-ref
- p544
- '1)
- r542)
- ((lambda (r*548)
- (if r*548
- (combine529
- r*548
- r542)
- '#f))
- (match-each525
- e545
- (vector-ref
- p544
- '1)
- w543)))
- (if (memv
- t547
- '(free-id))
- (if (id?306 e545)
- (if (literal-id=?436
- (wrap443
- e545
- w543)
- (vector-ref
- p544
- '1))
- r542
- '#f)
- '#f)
- (if (memv
- t547
- '(each+))
- (call-with-values
- (lambda ()
- (match-each+526
- e545
- (vector-ref
- p544
- '1)
- (vector-ref
- p544
- '2)
- (vector-ref
- p544
- '3)
- w543
- r542))
- (lambda (xr*551
- y-pat550
- r549)
- (if r549
- (if (null?
- y-pat550)
- (if (null?
- xr*551)
- (match-empty528
- (vector-ref
- p544
- '1)
- r549)
- (combine529
- xr*551
- r549))
- '#f)
- '#f)))
- (if (memv
- t547
- '(atom))
- (if (equal?
- (vector-ref
- p544
- '1)
- (strip522
- e545
- w543))
- r542
- '#f)
- (if (memv
- t547
- '(vector))
- (if (vector?
- e545)
- (match531
- (vector->list
- e545)
- (vector-ref
- p544
- '1)
- w543
- r542)
- '#f)
- (void)))))))
- (vector-ref p544 '0)))))))
- (match531 (lambda (e539 p538 w537 r536)
- (if (not r536)
- '#f
- (if (eq? p538 'any)
- (cons (wrap443 e539 w537) r536)
- (if (syntax-object?64 e539)
- (match*530
- ((lambda (e540)
- (if (annotation?132 e540)
- (annotation-expression
- e540)
- e540))
- (syntax-object-expression65
- e539))
- p538
- (join-wraps422
- w537
- (syntax-object-wrap66 e539))
- r536)
- (match*530
- ((lambda (e541)
- (if (annotation?132 e541)
- (annotation-expression
- e541)
- e541))
- e539)
- p538
- w537
- r536)))))))
- (set! $syntax-dispatch
- (lambda (e533 p532)
- (if (eq? p532 'any)
- (list e533)
- (if (syntax-object?64 e533)
- (match*530
- ((lambda (e534)
- (if (annotation?132 e534)
- (annotation-expression e534)
- e534))
- (syntax-object-expression65 e533))
- p532
- (syntax-object-wrap66 e533)
- '())
- (match*530
- ((lambda (e535)
- (if (annotation?132 e535)
- (annotation-expression e535)
- e535))
- e533)
- p532
- '(())
- '()))))))))))))
-($sc-put-cte
- '#(syntax-object with-syntax ((top) #(ribcage #(with-syntax) #((top)) #(with-syntax))))
- (lambda (x2531)
- ((lambda (tmp2532)
- ((lambda (tmp2533)
- (if tmp2533
- (apply
- (lambda (_2536 e12535 e22534)
- (cons
- '#(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons e12535 e22534)))
- tmp2533)
- ((lambda (tmp2538)
- (if tmp2538
- (apply
- (lambda (_2543 out2542 in2541 e12540 e22539)
- (list
- '#(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")) #(top-ribcage *top* #t)))- in2541
- '()
- (list
- out2542
- (cons
- '#(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons e12540 e22539)))))
- tmp2538)
- ((lambda (tmp2545)
- (if tmp2545
- (apply
- (lambda (_2550 out2549 in2548 e12547 e22546)
- (list
- '#(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")) #(top-ribcage *top* #t)))- (cons
- '#(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- in2548)
- '()
- (list
- out2549
- (cons
- '#(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons e12547 e22546)))))
- tmp2545)
- (syntax-error tmp2532)))
- ($syntax-dispatch
- tmp2532
- '(any #(each (any any)) any . each-any)))))
- ($syntax-dispatch
- tmp2532
- '(any ((any any)) any . each-any)))))
- ($syntax-dispatch tmp2532 '(any () any . each-any))))
- x2531))
- '*top*)
-($sc-put-cte
- '#(syntax-object with-implicit ((top) #(ribcage #(with-implicit) #((top)) #(with-implicit))))
- (lambda (x2554)
- ((lambda (tmp2555)
- ((lambda (tmp2556)
- (if (if tmp2556
- (apply
- (lambda (dummy2561 tid2560 id2559 e12558 e22557)
- (andmap identifier? (cons tid2560 id2559)))
- tmp2556)
- '#f)
- (apply
- (lambda (dummy2567 tid2566 id2565 e12564 e22563)
- (list
- '#(syntax-object begin ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object unless ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object identifier? ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object syntax ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- tid2566))
- (cons
- '#(syntax-object syntax-error ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (cons
- (list
- '#(syntax-object syntax ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- tid2566)
- '#(syntax-object ("non-identifier with-implicit template") ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t))))))- (cons
- '#(syntax-object with-syntax ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (cons
- (map (lambda (tmp2568)
- (list
- tmp2568
- (list
- '#(syntax-object datum->syntax-object ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object syntax ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- tid2566)
- (list
- '#(syntax-object quote ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- tmp2568))))
- id2565)
- (cons e12564 e22563)))))
- tmp2556)
- (syntax-error tmp2555)))
- ($syntax-dispatch
- tmp2555
- '(any (any . each-any) any . each-any))))
- x2554))
- '*top*)
-($sc-put-cte
- '#(syntax-object datum ((top) #(ribcage #(datum) #((top)) #(datum))))
- (lambda (x2570)
- ((lambda (tmp2571)
- ((lambda (tmp2572)
- (if tmp2572
- (apply
- (lambda (dummy2574 x2573)
- (list
- '#(syntax-object syntax-object->datum ((top) #(ribcage #(dummy x) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object syntax ((top) #(ribcage #(dummy x) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- x2573)))
- tmp2572)
- (syntax-error tmp2571)))
- ($syntax-dispatch tmp2571 '(any any))))
- x2570))
- '*top*)
-($sc-put-cte
- '#(syntax-object syntax-rules ((top) #(ribcage #(syntax-rules) #((top)) #(syntax-rules))))
- (lambda (x2575)
- (letrec ((clause2576 (lambda (y2592)
- ((lambda (tmp2593)
- ((lambda (tmp2594)
- (if tmp2594
- (apply
- (lambda (keyword2597 pattern2596
- template2595)
- (list
- (cons
- '#(syntax-object dummy ((top) #(ribcage #(keyword pattern template) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(y) #((top)) #("i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- pattern2596)
- (list
- '#(syntax-object syntax ((top) #(ribcage #(keyword pattern template) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(y) #((top)) #("i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- template2595)))
- tmp2594)
- ((lambda (tmp2598)
- (if tmp2598
- (apply
- (lambda (keyword2602
- pattern2601
- fender2600
- template2599)
- (list
- (cons
- '#(syntax-object dummy ((top) #(ribcage #(keyword pattern fender template) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(y) #((top)) #("i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- pattern2601)
- fender2600
- (list
- '#(syntax-object syntax ((top) #(ribcage #(keyword pattern fender template) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(y) #((top)) #("i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- template2599)))
- tmp2598)
- ((lambda (_2603)
- (syntax-error x2575))
- tmp2593)))
- ($syntax-dispatch
- tmp2593
- '((any . any) any any)))))
- ($syntax-dispatch
- tmp2593
- '((any . any) any))))
- y2592))))
- ((lambda (tmp2577)
- ((lambda (tmp2578)
- (if (if tmp2578
- (apply
- (lambda (_2581 k2580 cl2579)
- (andmap identifier? k2580))
- tmp2578)
- '#f)
- (apply
- (lambda (_2585 k2584 cl2583)
- ((lambda (tmp2586)
- ((lambda (tmp2588)
- (if tmp2588
- (apply
- (lambda (cl2589)
- (list
- '#(syntax-object lambda ((top) #(ribcage #(cl) #((top)) #("i")) #(ribcage #(_ k cl) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object (x) ((top) #(ribcage #(cl) #((top)) #("i")) #(ribcage #(_ k cl) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- '#(syntax-object syntax-case ((top) #(ribcage #(cl) #((top)) #("i")) #(ribcage #(_ k cl) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- '#(syntax-object x ((top) #(ribcage #(cl) #((top)) #("i")) #(ribcage #(_ k cl) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons k2584 cl2589)))))
- tmp2588)
- (syntax-error tmp2586)))
- ($syntax-dispatch tmp2586 'each-any)))
- (map clause2576 cl2583)))
- tmp2578)
- (syntax-error tmp2577)))
- ($syntax-dispatch tmp2577 '(any each-any . each-any))))
- x2575)))
- '*top*)
-($sc-put-cte
- '#(syntax-object or ((top) #(ribcage #(or) #((top)) #(or))))
- (lambda (x2604)
- ((lambda (tmp2605)
- ((lambda (tmp2606)
- (if tmp2606
- (apply
- (lambda (_2607)
- '#(syntax-object #f ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- tmp2606)
- ((lambda (tmp2608)
- (if tmp2608
- (apply (lambda (_2610 e2609) e2609) tmp2608)
- ((lambda (tmp2611)
- (if tmp2611
- (apply
- (lambda (_2615 e12614 e22613 e32612)
- (list
- '#(syntax-object let ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (list
- (list
- '#(syntax-object t ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- e12614))
- (list
- '#(syntax-object if ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object t ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object t ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- '#(syntax-object or ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons e22613 e32612)))))
- tmp2611)
- (syntax-error tmp2605)))
- ($syntax-dispatch
- tmp2605
- '(any any any . each-any)))))
- ($syntax-dispatch tmp2605 '(any any)))))
- ($syntax-dispatch tmp2605 '(any))))
- x2604))
- '*top*)
-($sc-put-cte
- '#(syntax-object and ((top) #(ribcage #(and) #((top)) #(and))))
- (lambda (x2617)
- ((lambda (tmp2618)
- ((lambda (tmp2619)
- (if tmp2619
- (apply
- (lambda (_2623 e12622 e22621 e32620)
- (cons
- '#(syntax-object if ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- e12622
- (cons
- (cons
- '#(syntax-object and ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons e22621 e32620))
- '#(syntax-object (#f) ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))))))- tmp2619)
- ((lambda (tmp2625)
- (if tmp2625
- (apply (lambda (_2627 e2626) e2626) tmp2625)
- ((lambda (tmp2628)
- (if tmp2628
- (apply
- (lambda (_2629)
- '#(syntax-object #t ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- tmp2628)
- (syntax-error tmp2618)))
- ($syntax-dispatch tmp2618 '(any)))))
- ($syntax-dispatch tmp2618 '(any any)))))
- ($syntax-dispatch tmp2618 '(any any any . each-any))))
- x2617))
- '*top*)
-($sc-put-cte
- '#(syntax-object let ((top) #(ribcage #(let) #((top)) #(let))))
- (lambda (x2630)
- ((lambda (tmp2631)
- ((lambda (tmp2632)
- (if (if tmp2632
- (apply
- (lambda (_2637 x2636 v2635 e12634 e22633)
- (andmap identifier? x2636))
- tmp2632)
- '#f)
- (apply
- (lambda (_2643 x2642 v2641 e12640 e22639)
- (cons
- (cons
- '#(syntax-object lambda ((top) #(ribcage #(_ x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons x2642 (cons e12640 e22639)))
- v2641))
- tmp2632)
- ((lambda (tmp2647)
- (if (if tmp2647
- (apply
- (lambda (_2653 f2652 x2651 v2650 e12649 e22648)
- (andmap identifier? (cons f2652 x2651)))
- tmp2647)
- '#f)
- (apply
- (lambda (_2660 f2659 x2658 v2657 e12656 e22655)
- (cons
- (list
- '#(syntax-object letrec ((top) #(ribcage #(_ f x v e1 e2) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (list
- (list
- f2659
- (cons
- '#(syntax-object lambda ((top) #(ribcage #(_ f x v e1 e2) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons x2658 (cons e12656 e22655)))))
- f2659)
- v2657))
- tmp2647)
- (syntax-error tmp2631)))
- ($syntax-dispatch
- tmp2631
- '(any any #(each (any any)) any . each-any)))))
- ($syntax-dispatch
- tmp2631
- '(any #(each (any any)) any . each-any))))
- x2630))
- '*top*)
-($sc-put-cte
- '#(syntax-object let* ((top) #(ribcage #(let*) #((top)) #(let*))))
- (lambda (x2664)
- ((lambda (tmp2665)
- ((lambda (tmp2666)
- (if (if tmp2666
- (apply
- (lambda (let*2671 x2670 v2669 e12668 e22667)
- (andmap identifier? x2670))
- tmp2666)
- '#f)
- (apply
- (lambda (let*2677 x2676 v2675 e12674 e22673)
- ((letrec ((f2678 (lambda (bindings2679)
- (if (null? bindings2679)
- (cons
- '#(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(bindings) #((top)) #("i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons '() (cons e12674 e22673)))
- ((lambda (tmp2681)
- ((lambda (tmp2682)
- (if tmp2682
- (apply
- (lambda (body2684
- binding2683)
- (list
- '#(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(bindings) #((top)) #("i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (list binding2683)
- body2684))
- tmp2682)
- (syntax-error tmp2681)))
- ($syntax-dispatch
- tmp2681
- '(any any))))
- (list
- (f2678 (cdr bindings2679))
- (car bindings2679)))))))
- f2678)
- (map list x2676 v2675)))
- tmp2666)
- (syntax-error tmp2665)))
- ($syntax-dispatch
- tmp2665
- '(any #(each (any any)) any . each-any))))
- x2664))
- '*top*)
-($sc-put-cte
- '#(syntax-object cond ((top) #(ribcage #(cond) #((top)) #(cond))))
- (lambda (x2687)
- ((lambda (tmp2688)
- ((lambda (tmp2689)
- (if tmp2689
- (apply
- (lambda (_2692 m12691 m22690)
- ((letrec ((f2693 (lambda (clause2695 clauses2694)
- (if (null? clauses2694)
- ((lambda (tmp2696)
- ((lambda (tmp2697)
- (if tmp2697
- (apply
- (lambda (e12699
- e22698)
- (cons
- '#(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- e12699
- e22698)))
- tmp2697)
- ((lambda (tmp2701)
- (if tmp2701
- (apply
- (lambda (e02702)
- (cons
- '#(syntax-object let ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- (list
- (list
- '#(syntax-object t ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- e02702))
- '#(syntax-object ((if t t)) ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))))- tmp2701)
- ((lambda (tmp2703)
- (if tmp2703
- (apply
- (lambda (e02705
- e12704)
- (list
- '#(syntax-object let ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (list
- (list
- '#(syntax-object t ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- e02705))
- (list
- '#(syntax-object if ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object t ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- e12704
- '#(syntax-object (t) ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))))))- tmp2703)
- ((lambda (tmp2706)
- (if tmp2706
- (apply
- (lambda (e02709
- e12708
- e22707)
- (list
- '#(syntax-object if ((top) #(ribcage #(e0 e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- e02709
- (cons
- '#(syntax-object begin ((top) #(ribcage #(e0 e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- e12708
- e22707))))
- tmp2706)
- ((lambda (_2711)
- (syntax-error
- x2687))
- tmp2696)))
- ($syntax-dispatch
- tmp2696
- '(any any
- .
- each-any)))))
- ($syntax-dispatch
- tmp2696
- '(any #(free-id
- #(syntax-object => ((top) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- any)))))
- ($syntax-dispatch
- tmp2696
- '(any)))))
- ($syntax-dispatch
- tmp2696
- '(#(free-id
- #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- any
- .
- each-any))))
- clause2695)
- ((lambda (tmp2712)
- ((lambda (rest2713)
- ((lambda (tmp2714)
- ((lambda (tmp2715)
- (if tmp2715
- (apply
- (lambda (e02716)
- (list
- '#(syntax-object let ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (list
- (list
- '#(syntax-object t ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- e02716))
- (list
- '#(syntax-object if ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object t ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object t ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- rest2713)))
- tmp2715)
- ((lambda (tmp2717)
- (if tmp2717
- (apply
- (lambda (e02719
- e12718)
- (list
- '#(syntax-object let ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (list
- (list
- '#(syntax-object t ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- e02719))
- (list
- '#(syntax-object if ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object t ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- e12718
- '#(syntax-object (t) ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- rest2713)))
- tmp2717)
- ((lambda (tmp2720)
- (if tmp2720
- (apply
- (lambda (e02723
- e12722
- e22721)
- (list
- '#(syntax-object if ((top) #(ribcage #(e0 e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- e02723
- (cons
- '#(syntax-object begin ((top) #(ribcage #(e0 e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- e12722
- e22721))
- rest2713))
- tmp2720)
- ((lambda (_2725)
- (syntax-error
- x2687))
- tmp2714)))
- ($syntax-dispatch
- tmp2714
- '(any any
- .
- each-any)))))
- ($syntax-dispatch
- tmp2714
- '(any #(free-id
- #(syntax-object => ((top) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- any)))))
- ($syntax-dispatch
- tmp2714
- '(any))))
- clause2695))
- tmp2712))
- (f2693
- (car clauses2694)
- (cdr clauses2694)))))))
- f2693)
- m12691
- m22690))
- tmp2689)
- (syntax-error tmp2688)))
- ($syntax-dispatch tmp2688 '(any any . each-any))))
- x2687))
- '*top*)
-($sc-put-cte
- '#(syntax-object do ((top) #(ribcage #(do) #((top)) #(do))))
- (lambda (orig-x2727)
- ((lambda (tmp2728)
- ((lambda (tmp2729)
- (if tmp2729
- (apply
- (lambda (_2736 var2735 init2734 step2733 e02732 e12731
- c2730)
- ((lambda (tmp2737)
- ((lambda (tmp2747)
- (if tmp2747
- (apply
- (lambda (step2748)
- ((lambda (tmp2749)
- ((lambda (tmp2751)
- (if tmp2751
- (apply
- (lambda ()
- (list
- '#(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")) #(top-ribcage *top* #t)))- '#(syntax-object do ((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")) #(top-ribcage *top* #t)))- (map list var2735 init2734)
- (list
- '#(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")) #(top-ribcage *top* #t)))- (list
- '#(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")) #(top-ribcage *top* #t)))- e02732)
- (cons
- '#(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")) #(top-ribcage *top* #t)))- (append
- c2730
- (list
- (cons
- '#(syntax-object do ((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")) #(top-ribcage *top* #t)))- step2748)))))))
- tmp2751)
- ((lambda (tmp2756)
- (if tmp2756
- (apply
- (lambda (e12758 e22757)
- (list
- '#(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")) #(top-ribcage *top* #t)))- '#(syntax-object do ((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")) #(top-ribcage *top* #t)))- (map list
- var2735
- init2734)
- (list
- '#(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")) #(top-ribcage *top* #t)))- e02732
- (cons
- '#(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")) #(top-ribcage *top* #t)))- (cons
- e12758
- e22757))
- (cons
- '#(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")) #(top-ribcage *top* #t)))- (append
- c2730
- (list
- (cons
- '#(syntax-object do ((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")) #(top-ribcage *top* #t)))- step2748)))))))
- tmp2756)
- (syntax-error tmp2749)))
- ($syntax-dispatch
- tmp2749
- '(any . each-any)))))
- ($syntax-dispatch tmp2749 '())))
- e12731))
- tmp2747)
- (syntax-error tmp2737)))
- ($syntax-dispatch tmp2737 'each-any)))
- (map (lambda (v2741 s2740)
- ((lambda (tmp2742)
- ((lambda (tmp2743)
- (if tmp2743
- (apply (lambda () v2741) tmp2743)
- ((lambda (tmp2744)
- (if tmp2744
- (apply
- (lambda (e2745) e2745)
- tmp2744)
- ((lambda (_2746)
- (syntax-error orig-x2727))
- tmp2742)))
- ($syntax-dispatch tmp2742 '(any)))))
- ($syntax-dispatch tmp2742 '())))
- s2740))
- var2735
- step2733)))
- tmp2729)
- (syntax-error tmp2728)))
- ($syntax-dispatch
- tmp2728
- '(any #(each (any any . any))
- (any . each-any)
- .
- each-any))))
- orig-x2727))
- '*top*)
-($sc-put-cte
- '#(syntax-object quasiquote ((top) #(ribcage #(quasiquote) #((top)) #(quasiquote))))
- ((lambda ()
- (letrec ((quasi2764 (lambda (p2900 lev2899)
- ((lambda (tmp2901)
- ((lambda (tmp2902)
- (if tmp2902
- (apply
- (lambda (p2903)
- (if (= lev2899 '0)
- (list
- '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- p2903)
- (quasicons2766
- '#(syntax-object ("quote" unquote) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- (quasi2764
- (list p2903)
- (- lev2899 '1)))))
- tmp2902)
- ((lambda (tmp2904)
- (if tmp2904
- (apply
- (lambda (p2905)
- (quasicons2766
- '#(syntax-object ("quote" quasiquote) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- (quasi2764
- (list p2905)
- (+ lev2899 '1))))
- tmp2904)
- ((lambda (tmp2906)
- (if tmp2906
- (apply
- (lambda (p2908 q2907)
- ((lambda (tmp2909)
- ((lambda (tmp2910)
- (if tmp2910
- (apply
- (lambda (p2911)
- (if (= lev2899
- '0)
- (quasilist*2768
- (map (lambda (tmp2912)
- (list
- '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- tmp2912))
- p2911)
- (quasi2764
- q2907
- lev2899))
- (quasicons2766
- (quasicons2766
- '#(syntax-object ("quote" unquote) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- (quasi2764
- p2911
- (- lev2899
- '1)))
- (quasi2764
- q2907
- lev2899))))
- tmp2910)
- ((lambda (tmp2914)
- (if tmp2914
- (apply
- (lambda (p2915)
- (if (= lev2899
- '0)
- (quasiappend2767
- (map (lambda (tmp2916)
- (list
- '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- tmp2916))
- p2915)
- (quasi2764
- q2907
- lev2899))
- (quasicons2766
- (quasicons2766
- '#(syntax-object ("quote" unquote-splicing) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- (quasi2764
- p2915
- (- lev2899
- '1)))
- (quasi2764
- q2907
- lev2899))))
- tmp2914)
- ((lambda (_2918)
- (quasicons2766
- (quasi2764
- p2908
- lev2899)
- (quasi2764
- q2907
- lev2899)))
- tmp2909)))
- ($syntax-dispatch
- tmp2909
- '(#(free-id
- #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))- .
- each-any)))))
- ($syntax-dispatch
- tmp2909
- '(#(free-id
- #(syntax-object unquote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))- .
- each-any))))
- p2908))
- tmp2906)
- ((lambda (tmp2919)
- (if tmp2919
- (apply
- (lambda (x2920)
- (quasivector2769
- (vquasi2765
- x2920
- lev2899)))
- tmp2919)
- ((lambda (p2922)
- (list
- '#(syntax-object "quote" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- p2922))
- tmp2901)))
- ($syntax-dispatch
- tmp2901
- '#(vector
- each-any)))))
- ($syntax-dispatch
- tmp2901
- '(any . any)))))
- ($syntax-dispatch
- tmp2901
- '(#(free-id
- #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))- any)))))
- ($syntax-dispatch
- tmp2901
- '(#(free-id
- #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))- any))))
- p2900)))
- (vquasi2765 (lambda (p2883 lev2882)
- ((lambda (tmp2884)
- ((lambda (tmp2885)
- (if tmp2885
- (apply
- (lambda (p2887 q2886)
- ((lambda (tmp2888)
- ((lambda (tmp2889)
- (if tmp2889
- (apply
- (lambda (p2890)
- (if (= lev2882 '0)
- (quasilist*2768
- (map (lambda (tmp2891)
- (list
- '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- tmp2891))
- p2890)
- (vquasi2765
- q2886
- lev2882))
- (quasicons2766
- (quasicons2766
- '#(syntax-object ("quote" unquote) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- (quasi2764
- p2890
- (- lev2882
- '1)))
- (vquasi2765
- q2886
- lev2882))))
- tmp2889)
- ((lambda (tmp2893)
- (if tmp2893
- (apply
- (lambda (p2894)
- (if (= lev2882
- '0)
- (quasiappend2767
- (map (lambda (tmp2895)
- (list
- '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- tmp2895))
- p2894)
- (vquasi2765
- q2886
- lev2882))
- (quasicons2766
- (quasicons2766
- '#(syntax-object ("quote" unquote-splicing) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- (quasi2764
- p2894
- (- lev2882
- '1)))
- (vquasi2765
- q2886
- lev2882))))
- tmp2893)
- ((lambda (_2897)
- (quasicons2766
- (quasi2764
- p2887
- lev2882)
- (vquasi2765
- q2886
- lev2882)))
- tmp2888)))
- ($syntax-dispatch
- tmp2888
- '(#(free-id
- #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))- .
- each-any)))))
- ($syntax-dispatch
- tmp2888
- '(#(free-id
- #(syntax-object unquote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))- .
- each-any))))
- p2887))
- tmp2885)
- ((lambda (tmp2898)
- (if tmp2898
- (apply
- (lambda ()
- '#(syntax-object ("quote" ()) ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))- tmp2898)
- (syntax-error tmp2884)))
- ($syntax-dispatch tmp2884 '()))))
- ($syntax-dispatch tmp2884 '(any . any))))
- p2883)))
- (quasicons2766 (lambda (x2865 y2864)
- ((lambda (tmp2866)
- ((lambda (tmp2867)
- (if tmp2867
- (apply
- (lambda (x2869 y2868)
- ((lambda (tmp2870)
- ((lambda (tmp2871)
- (if tmp2871
- (apply
- (lambda (dy2872)
- ((lambda (tmp2873)
- ((lambda (tmp2874)
- (if tmp2874
- (apply
- (lambda (dx2875)
- (list
- '#(syntax-object "quote" ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- (cons
- dx2875
- dy2872)))
- tmp2874)
- ((lambda (_2876)
- (if (null?
- dy2872)
- (list
- '#(syntax-object "list" ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- x2869)
- (list
- '#(syntax-object "list*" ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- x2869
- y2868)))
- tmp2873)))
- ($syntax-dispatch
- tmp2873
- '(#(atom
- "quote")
- any))))
- x2869))
- tmp2871)
- ((lambda (tmp2877)
- (if tmp2877
- (apply
- (lambda (stuff2878)
- (cons
- '#(syntax-object "list" ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- (cons
- x2869
- stuff2878)))
- tmp2877)
- ((lambda (tmp2879)
- (if tmp2879
- (apply
- (lambda (stuff2880)
- (cons
- '#(syntax-object "list*" ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- (cons
- x2869
- stuff2880)))
- tmp2879)
- ((lambda (_2881)
- (list
- '#(syntax-object "list*" ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- x2869
- y2868))
- tmp2870)))
- ($syntax-dispatch
- tmp2870
- '(#(atom
- "list*")
- .
- any)))))
- ($syntax-dispatch
- tmp2870
- '(#(atom "list")
- .
- any)))))
- ($syntax-dispatch
- tmp2870
- '(#(atom "quote")
- any))))
- y2868))
- tmp2867)
- (syntax-error tmp2866)))
- ($syntax-dispatch tmp2866 '(any any))))
- (list x2865 y2864))))
- (quasiappend2767 (lambda (x2851 y2850)
- ((lambda (tmp2852)
- ((lambda (tmp2853)
- (if tmp2853
- (apply
- (lambda ()
- (if (null? x2851)
- '#(syntax-object ("quote" ()) ((top) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- (if (null? (cdr x2851))
- (car x2851)
- ((lambda (tmp2854)
- ((lambda (tmp2855)
- (if tmp2855
- (apply
- (lambda (p2856)
- (cons
- '#(syntax-object "append" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- p2856))
- tmp2855)
- (syntax-error
- tmp2854)))
- ($syntax-dispatch
- tmp2854
- 'each-any)))
- x2851))))
- tmp2853)
- ((lambda (_2858)
- (if (null? x2851)
- y2850
- ((lambda (tmp2859)
- ((lambda (tmp2860)
- (if tmp2860
- (apply
- (lambda (p2862
- y2861)
- (cons
- '#(syntax-object "append" ((top) #(ribcage #(p y) #((top) (top)) #("i" "i")) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- (append
- p2862
- (list
- y2861))))
- tmp2860)
- (syntax-error
- tmp2859)))
- ($syntax-dispatch
- tmp2859
- '(each-any any))))
- (list x2851 y2850))))
- tmp2852)))
- ($syntax-dispatch
- tmp2852
- '(#(atom "quote") ()))))
- y2850)))
- (quasilist*2768 (lambda (x2847 y2846)
- ((letrec ((f2848 (lambda (x2849)
- (if (null? x2849)
- y2846
- (quasicons2766
- (car x2849)
- (f2848
- (cdr x2849)))))))
- f2848)
- x2847)))
- (quasivector2769 (lambda (x2817)
- ((lambda (tmp2818)
- ((lambda (tmp2819)
- (if tmp2819
- (apply
- (lambda (x2820)
- (list
- '#(syntax-object "quote" ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- (list->vector x2820)))
- tmp2819)
- ((lambda (_2822)
- ((letrec ((f2823 (lambda (y2825
- k2824)
- ((lambda (tmp2826)
- ((lambda (tmp2827)
- (if tmp2827
- (apply
- (lambda (y2828)
- (k2824
- (map (lambda (tmp2829)
- (list
- '#(syntax-object "quote" ((top) #(ribcage #(y) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(y k) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- tmp2829))
- y2828)))
- tmp2827)
- ((lambda (tmp2830)
- (if tmp2830
- (apply
- (lambda (y2831)
- (k2824
- y2831))
- tmp2830)
- ((lambda (tmp2833)
- (if tmp2833
- (apply
- (lambda (y2835
- z2834)
- (f2823
- z2834
- (lambda (ls2836)
- (k2824
- (append
- y2835
- ls2836)))))
- tmp2833)
- ((lambda (else2838)
- ((lambda (tmp2839)
- ((lambda (t72840)
- (list
- '#(syntax-object "list->vector" ((top) #(ribcage #(t7) #(("m" tmp)) #("i")) #(ribcage #(else) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(y k) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- t72840))
- tmp2839))
- x2817))
- tmp2826)))
- ($syntax-dispatch
- tmp2826
- '(#(atom
- "list*")
- .
- #(each+
- any
- (any)
- ()))))))
- ($syntax-dispatch
- tmp2826
- '(#(atom
- "list")
- .
- each-any)))))
- ($syntax-dispatch
- tmp2826
- '(#(atom
- "quote")
- each-any))))
- y2825))))
- f2823)
- x2817
- (lambda (ls2841)
- ((lambda (tmp2842)
- ((lambda (tmp2843)
- (if tmp2843
- (apply
- (lambda (t82844)
- (cons
- '#(syntax-object "vector" ((top) #(ribcage #(t8) #(("m" tmp)) #("i")) #(ribcage () () ()) #(ribcage #(ls) #((top)) #("i")) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- t82844))
- tmp2843)
- (syntax-error
- tmp2842)))
- ($syntax-dispatch
- tmp2842
- 'each-any)))
- ls2841))))
- tmp2818)))
- ($syntax-dispatch
- tmp2818
- '(#(atom "quote") each-any))))
- x2817)))
- (emit2770 (lambda (x2776)
- ((lambda (tmp2777)
- ((lambda (tmp2778)
- (if tmp2778
- (apply
- (lambda (x2779)
- (list
- '#(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- x2779))
- tmp2778)
- ((lambda (tmp2780)
- (if tmp2780
- (apply
- (lambda (x2781)
- ((lambda (tmp2782)
- ((lambda (tmp2784)
- (if tmp2784
- (apply
- (lambda (t12785)
- (cons
- '#(syntax-object list ((top) #(ribcage #(t1) #(("m" tmp)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- t12785))
- tmp2784)
- (syntax-error
- tmp2782)))
- ($syntax-dispatch
- tmp2782
- 'each-any)))
- (map emit2770 x2781)))
- tmp2780)
- ((lambda (tmp2787)
- (if tmp2787
- (apply
- (lambda (x2789 y2788)
- ((letrec ((f2790 (lambda (x*2791)
- (if (null?
- x*2791)
- (emit2770
- y2788)
- ((lambda (tmp2792)
- ((lambda (tmp2793)
- (if tmp2793
- (apply
- (lambda (t32795
- t22794)
- (list
- '#(syntax-object cons ((top) #(ribcage #(t3 t2) #(("m" tmp) ("m" tmp)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x*) #((top)) #("i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- t32795
- t22794))
- tmp2793)
- (syntax-error
- tmp2792)))
- ($syntax-dispatch
- tmp2792
- '(any any))))
- (list
- (emit2770
- (car x*2791))
- (f2790
- (cdr x*2791))))))))
- f2790)
- x2789))
- tmp2787)
- ((lambda (tmp2797)
- (if tmp2797
- (apply
- (lambda (x2798)
- ((lambda (tmp2799)
- ((lambda (tmp2801)
- (if tmp2801
- (apply
- (lambda (t42802)
- (cons
- '#(syntax-object append ((top) #(ribcage #(t4) #(("m" tmp)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- t42802))
- tmp2801)
- (syntax-error
- tmp2799)))
- ($syntax-dispatch
- tmp2799
- 'each-any)))
- (map emit2770
- x2798)))
- tmp2797)
- ((lambda (tmp2804)
- (if tmp2804
- (apply
- (lambda (x2805)
- ((lambda (tmp2806)
- ((lambda (tmp2808)
- (if tmp2808
- (apply
- (lambda (t52809)
- (cons
- '#(syntax-object vector ((top) #(ribcage #(t5) #(("m" tmp)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- t52809))
- tmp2808)
- (syntax-error
- tmp2806)))
- ($syntax-dispatch
- tmp2806
- 'each-any)))
- (map emit2770
- x2805)))
- tmp2804)
- ((lambda (tmp2811)
- (if tmp2811
- (apply
- (lambda (x2812)
- ((lambda (tmp2813)
- ((lambda (t62814)
- (list
- '#(syntax-object list->vector ((top) #(ribcage #(t6) #(("m" tmp)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))- t62814))
- tmp2813))
- (emit2770
- x2812)))
- tmp2811)
- ((lambda (tmp2815)
- (if tmp2815
- (apply
- (lambda (x2816)
- x2816)
- tmp2815)
- (syntax-error
- tmp2777)))
- ($syntax-dispatch
- tmp2777
- '(#(atom
- "value")
- any)))))
- ($syntax-dispatch
- tmp2777
- '(#(atom
- "list->vector")
- any)))))
- ($syntax-dispatch
- tmp2777
- '(#(atom
- "vector")
- .
- each-any)))))
- ($syntax-dispatch
- tmp2777
- '(#(atom "append")
- .
- each-any)))))
- ($syntax-dispatch
- tmp2777
- '(#(atom "list*")
- .
- #(each+ any (any)
- ()))))))
- ($syntax-dispatch
- tmp2777
- '(#(atom "list") . each-any)))))
- ($syntax-dispatch
- tmp2777
- '(#(atom "quote") any))))
- x2776))))
- (lambda (x2771)
- ((lambda (tmp2772)
- ((lambda (tmp2773)
- (if tmp2773
- (apply
- (lambda (_2775 e2774) (emit2770 (quasi2764 e2774 '0)))
- tmp2773)
- (syntax-error tmp2772)))
- ($syntax-dispatch tmp2772 '(any any))))
- x2771)))))
- '*top*)
-($sc-put-cte
- '#(syntax-object unquote ((top) #(ribcage #(unquote) #((top)) #(unquote))))
- (lambda (x2923) (syntax-error x2923 '"misplaced"))
- '*top*)
-($sc-put-cte
- '#(syntax-object unquote-splicing ((top) #(ribcage #(unquote-splicing) #((top)) #(unquote-splicing))))
- (lambda (x2924) (syntax-error x2924 '"misplaced"))
- '*top*)
-($sc-put-cte
- '#(syntax-object quasisyntax ((top) #(ribcage #(quasisyntax) #((top)) #(quasisyntax))))
- (lambda (x2925)
- (letrec ((qs2926 (lambda (q2977 n2976 b*2975 k2974)
- ((lambda (tmp2978)
- ((lambda (tmp2979)
- (if tmp2979
- (apply
- (lambda (d2980)
- (qs2926
- d2980
- (+ n2976 '1)
- b*2975
- (lambda (b*2982 dnew2981)
- (k2974
- b*2982
- (if (eq? dnew2981 d2980)
- q2977
- ((lambda (tmp2983)
- ((lambda (d2984)
- (cons
- '#(syntax-object quasisyntax ((top) #(ribcage #(d) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* dnew) #((top) (top)) #("i" "i")) #(ribcage #(d) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- d2984))
- tmp2983))
- dnew2981))))))
- tmp2979)
- ((lambda (tmp2985)
- (if (if tmp2985
- (apply
- (lambda (d2986)
- (not (= n2976 '0)))
- tmp2985)
- '#f)
- (apply
- (lambda (d2987)
- (qs2926
- d2987
- (- n2976 '1)
- b*2975
- (lambda (b*2989 dnew2988)
- (k2974
- b*2989
- (if (eq? dnew2988 d2987)
- q2977
- ((lambda (tmp2990)
- ((lambda (d2991)
- (cons
- '#(syntax-object unsyntax ((top) #(ribcage #(d) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* dnew) #((top) (top)) #("i" "i")) #(ribcage #(d) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- d2991))
- tmp2990))
- dnew2988))))))
- tmp2985)
- ((lambda (tmp2992)
- (if (if tmp2992
- (apply
- (lambda (d2993)
- (not (= n2976 '0)))
- tmp2992)
- '#f)
- (apply
- (lambda (d2994)
- (qs2926
- d2994
- (- n2976 '1)
- b*2975
- (lambda (b*2996
- dnew2995)
- (k2974
- b*2996
- (if (eq? dnew2995
- d2994)
- q2977
- ((lambda (tmp2997)
- ((lambda (d2998)
- (cons
- '#(syntax-object unsyntax-splicing ((top) #(ribcage #(d) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* dnew) #((top) (top)) #("i" "i")) #(ribcage #(d) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- d2998))
- tmp2997))
- dnew2995))))))
- tmp2992)
- ((lambda (tmp2999)
- (if (if tmp2999
- (apply
- (lambda (q3000)
- (= n2976 '0))
- tmp2999)
- '#f)
- (apply
- (lambda (q3001)
- ((lambda (tmp3002)
- ((lambda (tmp3003)
- (if tmp3003
- (apply
- (lambda (t3004)
- (k2974
- (cons
- (list
- t3004
- q3001)
- b*2975)
- t3004))
- tmp3003)
- (syntax-error
- tmp3002)))
- ($syntax-dispatch
- tmp3002
- '(any))))
- (generate-temporaries
- (list
- q3001))))
- tmp2999)
- ((lambda (tmp3005)
- (if (if tmp3005
- (apply
- (lambda (q3007
- d3006)
- (= n2976
- '0))
- tmp3005)
- '#f)
- (apply
- (lambda (q3009
- d3008)
- (qs2926
- d3008
- n2976
- b*2975
- (lambda (b*3011
- dnew3010)
- ((lambda (tmp3012)
- ((lambda (tmp3014)
- (if tmp3014
- (apply
- (lambda (t3015)
- (k2974
- (append
- (map list
- t3015
- q3009)
- b*3011)
- ((lambda (tmp3016)
- ((lambda (d3017)
- (append
- t3015
- d3017))
- tmp3016))
- dnew3010)))
- tmp3014)
- (syntax-error
- tmp3012)))
- ($syntax-dispatch
- tmp3012
- 'each-any)))
- (generate-temporaries
- q3009)))))
- tmp3005)
- ((lambda (tmp3021)
- (if (if tmp3021
- (apply
- (lambda (q3023
- d3022)
- (= n2976
- '0))
- tmp3021)
- '#f)
- (apply
- (lambda (q3025
- d3024)
- (qs2926
- d3024
- n2976
- b*2975
- (lambda (b*3027
- dnew3026)
- ((lambda (tmp3028)
- ((lambda (tmp3030)
- (if tmp3030
- (apply
- (lambda (t3031)
- (k2974
- (append
- (map (lambda (tmp3041
- tmp3040)
- (list
- (cons
- tmp3040
- '(#(syntax-object ... ((top) #(ribcage #(t) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* dnew) #((top) (top)) #("i" "i")) #(ribcage #(q d) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))))- tmp3041))
- q3025
- t3031)
- b*3027)
- ((lambda (tmp3032)
- ((lambda (tmp3034)
- (if tmp3034
- (apply
- (lambda (m3035)
- ((lambda (tmp3036)
- ((lambda (d3037)
- (append
- (apply
- append
- m3035)
- d3037))
- tmp3036))
- dnew3026))
- tmp3034)
- (syntax-error
- tmp3032)))
- ($syntax-dispatch
- tmp3032
- '#(each
- each-any))))
- (map (lambda (tmp3033)
- (cons
- tmp3033
- '(#(syntax-object ... ((top) #(ribcage #(t) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* dnew) #((top) (top)) #("i" "i")) #(ribcage #(q d) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))))- t3031))))
- tmp3030)
- (syntax-error
- tmp3028)))
- ($syntax-dispatch
- tmp3028
- 'each-any)))
- (generate-temporaries
- q3025)))))
- tmp3021)
- ((lambda (tmp3042)
- (if tmp3042
- (apply
- (lambda (a3044
- d3043)
- (qs2926
- a3044
- n2976
- b*2975
- (lambda (b*3046
- anew3045)
- (qs2926
- d3043
- n2976
- b*3046
- (lambda (b*3048
- dnew3047)
- (k2974
- b*3048
- (if (if (eq? anew3045
- a3044)
- (eq? dnew3047
- d3043)
- '#f)
- q2977
- ((lambda (tmp3049)
- ((lambda (tmp3050)
- (if tmp3050
- (apply
- (lambda (a3052
- d3051)
- (cons
- a3052
- d3051))
- tmp3050)
- (syntax-error
- tmp3049)))
- ($syntax-dispatch
- tmp3049
- '(any any))))
- (list
- anew3045
- dnew3047)))))))))
- tmp3042)
- ((lambda (tmp3053)
- (if tmp3053
- (apply
- (lambda (x3054)
- (vqs2927
- x3054
- n2976
- b*2975
- (lambda (b*3056
- xnew*3055)
- (k2974
- b*3056
- (if ((letrec ((same?3057 (lambda (x*3059
- xnew*3058)
- (if (null?
- x*3059)
- (null?
- xnew*3058)
- (if (not (null?
- xnew*3058))
- (if (eq? (car x*3059)
- (car xnew*3058))
- (same?3057
- (cdr x*3059)
- (cdr xnew*3058))
- '#f)
- '#f)))))
- same?3057)
- x3054
- xnew*3055)
- q2977
- ((lambda (tmp3061)
- ((lambda (tmp3062)
- (if tmp3062
- (apply
- (lambda (x3063)
- (list->vector
- x3063))
- tmp3062)
- (syntax-error
- tmp3061)))
- ($syntax-dispatch
- tmp3061
- 'each-any)))
- xnew*3055))))))
- tmp3053)
- ((lambda (_3066)
- (k2974
- b*2975
- q2977))
- tmp2978)))
- ($syntax-dispatch
- tmp2978
- '#(vector
- each-any)))))
- ($syntax-dispatch
- tmp2978
- '(any .
- any)))))
- ($syntax-dispatch
- tmp2978
- '((#(free-id
- #(syntax-object unsyntax-splicing ((top) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- .
- each-any)
- .
- any)))))
- ($syntax-dispatch
- tmp2978
- '((#(free-id
- #(syntax-object unsyntax ((top) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- .
- each-any)
- .
- any)))))
- ($syntax-dispatch
- tmp2978
- '(#(free-id
- #(syntax-object unsyntax ((top) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- any)))))
- ($syntax-dispatch
- tmp2978
- '(#(free-id
- #(syntax-object unsyntax-splicing ((top) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- .
- any)))))
- ($syntax-dispatch
- tmp2978
- '(#(free-id
- #(syntax-object unsyntax ((top) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- .
- any)))))
- ($syntax-dispatch
- tmp2978
- '(#(free-id
- #(syntax-object quasisyntax ((top) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- .
- any))))
- q2977)))
- (vqs2927 (lambda (x*2942 n2941 b*2940 k2939)
- (if (null? x*2942)
- (k2939 b*2940 '())
- (vqs2927
- (cdr x*2942)
- n2941
- b*2940
- (lambda (b*2944 xnew*2943)
- ((lambda (tmp2945)
- ((lambda (tmp2946)
- (if (if tmp2946
- (apply
- (lambda (q2947)
- (= n2941 '0))
- tmp2946)
- '#f)
- (apply
- (lambda (q2948)
- ((lambda (tmp2949)
- ((lambda (tmp2951)
- (if tmp2951
- (apply
- (lambda (t2952)
- (k2939
- (append
- (map list
- t2952
- q2948)
- b*2944)
- (append
- t2952
- xnew*2943)))
- tmp2951)
- (syntax-error
- tmp2949)))
- ($syntax-dispatch
- tmp2949
- 'each-any)))
- (generate-temporaries
- q2948)))
- tmp2946)
- ((lambda (tmp2956)
- (if (if tmp2956
- (apply
- (lambda (q2957)
- (= n2941 '0))
- tmp2956)
- '#f)
- (apply
- (lambda (q2958)
- ((lambda (tmp2959)
- ((lambda (tmp2961)
- (if tmp2961
- (apply
- (lambda (t2962)
- (k2939
- (append
- (map (lambda (tmp2970
- tmp2969)
- (list
- (cons
- tmp2969
- '(#(syntax-object ... ((top) #(ribcage #(t) #((top)) #("i")) #(ribcage #(q) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* xnew*) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x* n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))))- tmp2970))
- q2958
- t2962)
- b*2944)
- ((lambda (tmp2963)
- ((lambda (tmp2965)
- (if tmp2965
- (apply
- (lambda (m2966)
- (append
- (apply
- append
- m2966)
- xnew*2943))
- tmp2965)
- (syntax-error
- tmp2963)))
- ($syntax-dispatch
- tmp2963
- '#(each
- each-any))))
- (map (lambda (tmp2964)
- (cons
- tmp2964
- '(#(syntax-object ... ((top) #(ribcage #(t) #((top)) #("i")) #(ribcage #(q) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* xnew*) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x* n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))))- t2962))))
- tmp2961)
- (syntax-error
- tmp2959)))
- ($syntax-dispatch
- tmp2959
- 'each-any)))
- (generate-temporaries
- q2958)))
- tmp2956)
- ((lambda (_2971)
- (qs2926
- (car x*2942)
- n2941
- b*2944
- (lambda (b*2973
- xnew2972)
- (k2939
- b*2973
- (cons
- xnew2972
- xnew*2943)))))
- tmp2945)))
- ($syntax-dispatch
- tmp2945
- '(#(free-id
- #(syntax-object unsyntax-splicing ((top) #(ribcage () () ()) #(ribcage #(b* xnew*) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x* n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- .
- each-any)))))
- ($syntax-dispatch
- tmp2945
- '(#(free-id
- #(syntax-object unsyntax ((top) #(ribcage () () ()) #(ribcage #(b* xnew*) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x* n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- .
- each-any))))
- (car x*2942))))))))
- ((lambda (tmp2928)
- ((lambda (tmp2929)
- (if tmp2929
- (apply
- (lambda (_2931 x2930)
- (qs2926
- x2930
- '0
- '()
- (lambda (b*2933 xnew2932)
- (if (eq? xnew2932 x2930)
- (list
- '#(syntax-object syntax ((top) #(ribcage () () ()) #(ribcage #(b* xnew) #((top) (top)) #("i" "i")) #(ribcage #(_ x) #((top) (top)) #("i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- x2930)
- ((lambda (tmp2934)
- ((lambda (tmp2935)
- (if tmp2935
- (apply
- (lambda (b2937 x2936)
- (list
- '#(syntax-object with-syntax ((top) #(ribcage #(b x) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(b* xnew) #((top) (top)) #("i" "i")) #(ribcage #(_ x) #((top) (top)) #("i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- b2937
- (list
- '#(syntax-object syntax ((top) #(ribcage #(b x) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(b* xnew) #((top) (top)) #("i" "i")) #(ribcage #(_ x) #((top) (top)) #("i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- x2936)))
- tmp2935)
- (syntax-error tmp2934)))
- ($syntax-dispatch
- tmp2934
- '(each-any any))))
- (list b*2933 xnew2932))))))
- tmp2929)
- (syntax-error tmp2928)))
- ($syntax-dispatch tmp2928 '(any any))))
- x2925)))
- '*top*)
-($sc-put-cte
- '#(syntax-object unsyntax ((top) #(ribcage #(unsyntax) #((top)) #(unsyntax))))
- (lambda (x3067) (syntax-error x3067 '"misplaced"))
- '*top*)
-($sc-put-cte
- '#(syntax-object unsyntax-splicing ((top) #(ribcage #(unsyntax-splicing) #((top)) #(unsyntax-splicing))))
- (lambda (x3068) (syntax-error x3068 '"misplaced"))
- '*top*)
-($sc-put-cte
- '#(syntax-object include ((top) #(ribcage #(include) #((top)) #(include))))
- (lambda (x3069)
- (letrec ((read-file3070 (lambda (fn3081 k3080)
- ((lambda (p3082)
- ((letrec ((f3083 (lambda ()
- ((lambda (x3084)
- (if (eof-object?
- x3084)
- (begin
- (close-input-port
- p3082)
- '())
- (cons
- (datum->syntax-object
- k3080
- x3084)
- (f3083))))
- (read p3082)))))
- f3083)))
- (open-input-file fn3081)))))
- ((lambda (tmp3071)
- ((lambda (tmp3072)
- (if tmp3072
- (apply
- (lambda (k3074 filename3073)
- ((lambda (fn3075)
- ((lambda (tmp3076)
- ((lambda (tmp3077)
- (if tmp3077
- (apply
- (lambda (exp3078)
- (cons
- '#(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- exp3078))
- tmp3077)
- (syntax-error tmp3076)))
- ($syntax-dispatch tmp3076 'each-any)))
- (read-file3070 fn3075 k3074)))
- (syntax-object->datum filename3073)))
- tmp3072)
- (syntax-error tmp3071)))
- ($syntax-dispatch tmp3071 '(any any))))
- x3069)))
- '*top*)
-($sc-put-cte
- '#(syntax-object case ((top) #(ribcage #(case) #((top)) #(case))))
- (lambda (x3085)
- ((lambda (tmp3086)
- ((lambda (tmp3087)
- (if tmp3087
- (apply
- (lambda (_3091 e3090 m13089 m23088)
- ((lambda (tmp3092)
- ((lambda (body3119)
- (list
- '#(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")) #(top-ribcage *top* #t)))- (list
- (list
- '#(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")) #(top-ribcage *top* #t)))- e3090))
- body3119))
- tmp3092))
- ((letrec ((f3093 (lambda (clause3095 clauses3094)
- (if (null? clauses3094)
- ((lambda (tmp3096)
- ((lambda (tmp3097)
- (if tmp3097
- (apply
- (lambda (e13099
- e23098)
- (cons
- '#(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- e13099
- e23098)))
- tmp3097)
- ((lambda (tmp3101)
- (if tmp3101
- (apply
- (lambda (k3104
- e13103
- e23102)
- (list
- '#(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- k3104))
- (cons
- '#(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- e13103
- e23102))))
- tmp3101)
- ((lambda (_3107)
- (syntax-error
- x3085))
- tmp3096)))
- ($syntax-dispatch
- tmp3096
- '(each-any
- any
- .
- each-any)))))
- ($syntax-dispatch
- tmp3096
- '(#(free-id
- #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))- any
- .
- each-any))))
- clause3095)
- ((lambda (tmp3108)
- ((lambda (rest3109)
- ((lambda (tmp3110)
- ((lambda (tmp3111)
- (if tmp3111
- (apply
- (lambda (k3114
- e13113
- e23112)
- (list
- '#(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- k3114))
- (cons
- '#(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))- (cons
- e13113
- e23112))
- rest3109))
- tmp3111)
- ((lambda (_3117)
- (syntax-error
- x3085))
- tmp3110)))
- ($syntax-dispatch
- tmp3110
- '(each-any
- any
- .
- each-any))))
- clause3095))
- tmp3108))
- (f3093
- (car clauses3094)
- (cdr clauses3094)))))))
- f3093)
- m13089
- m23088)))
- tmp3087)
- (syntax-error tmp3086)))
- ($syntax-dispatch tmp3086 '(any any any . each-any))))
- x3085))
- '*top*)
-($sc-put-cte
- '#(syntax-object identifier-syntax ((top) #(ribcage #(identifier-syntax) #((top)) #(identifier-syntax))))
- (lambda (x3120)
- ((lambda (tmp3121)
- ((lambda (tmp3122)
- (if tmp3122
- (apply
- (lambda (dummy3124 e3123)
- (list
- '#(syntax-object lambda ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object (x) ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object syntax-case ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object x ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- '()
- (list
- '#(syntax-object id ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object (identifier? (syntax id)) ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object syntax ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- e3123))
- (list
- '(#(syntax-object _ ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- #(syntax-object x ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- #(syntax-object ... ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t))))- (list
- '#(syntax-object syntax ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (cons
- e3123
- '(#(syntax-object x ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- #(syntax-object ... ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t))))))))))- tmp3122)
- ((lambda (tmp3125)
- (if (if tmp3125
- (apply
- (lambda (dummy3131 id3130 exp13129 var3128
- val3127 exp23126)
- (if (identifier? id3130)
- (identifier? var3128)
- '#f))
- tmp3125)
- '#f)
- (apply
- (lambda (dummy3137 id3136 exp13135 var3134 val3133
- exp23132)
- (list
- '#(syntax-object cons ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object (quote macro!) ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object lambda ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object (x) ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object syntax-case ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object x ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- '#(syntax-object (set!) ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (list
- (list
- '#(syntax-object set! ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- var3134
- val3133)
- (list
- '#(syntax-object syntax ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- exp23132))
- (list
- (cons
- id3136
- '(#(syntax-object x ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- #(syntax-object ... ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))))- (list
- '#(syntax-object syntax ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (cons
- exp13135
- '(#(syntax-object x ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- #(syntax-object ... ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))))))- (list
- id3136
- (list
- '#(syntax-object identifier? ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- (list
- '#(syntax-object syntax ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- id3136))
- (list
- '#(syntax-object syntax ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))- exp13135))))))
- tmp3125)
- (syntax-error tmp3121)))
- ($syntax-dispatch
- tmp3121
- '(any (any any)
- ((#(free-id
- #(syntax-object set! ((top) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t))))- any
- any)
- any))))))
- ($syntax-dispatch tmp3121 '(any any))))
- x3120))
- '*top*)
--- a/femtolisp/lib/psyntax.ss
+++ /dev/null
@@ -1,4295 +1,0 @@
-;;; Portable implementation of syntax-case
-;;; Extracted from Chez Scheme Version 7.3 (Feb 26, 2007)
-;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
-
-;;; Copyright (c) 1992-2002 Cadence Research Systems
-;;; Permission to copy this software, in whole or in part, to use this
-;;; software for any lawful purpose, and to redistribute this software
-;;; is granted subject to the restriction that all copies made of this
-;;; software must include this copyright notice in full. This software
-;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
-;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
-;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
-;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
-;;; NATURE WHATSOEVER.
-
-;;; Before attempting to port this code to a new implementation of
-;;; Scheme, please read the notes below carefully.
-
-;;; This file defines the syntax-case expander, sc-expand, and a set
-;;; of associated syntactic forms and procedures. Of these, the
-;;; following are documented in The Scheme Programming Language,
-;;; Third Edition (R. Kent Dybvig, MIT Press, 2003), which can be
-;;; found online at http://www.scheme.com/tspl3/. Most are also documented
-;;; in the R4RS and draft R5RS.
-;;;
-;;; bound-identifier=?
-;;; datum->syntax-object
-;;; define-syntax
-;;; fluid-let-syntax
-;;; free-identifier=?
-;;; generate-temporaries
-;;; identifier?
-;;; identifier-syntax
-;;; let-syntax
-;;; letrec-syntax
-;;; syntax
-;;; syntax-case
-;;; syntax-object->datum
-;;; syntax-rules
-;;; with-syntax
-;;;
-;;; All standard Scheme syntactic forms are supported by the expander
-;;; or syntactic abstractions defined in this file. Only the R4RS
-;;; delay is omitted, since its expansion is implementation-dependent.
-
-;;; Also defined are three forms that support modules: module, import,
-;;; and import-only. These are documented in the Chez Scheme User's
-;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
-;;; also be found online at http://www.scheme.com/csug/. They are
-;;; described briefly here as well.
-
-;;; All are definitions and may appear where and only where other
-;;; definitions may appear. modules may be named:
-;;;
-;;; (module id (ex ...) defn ... init ...)
-;;;
-;;; or anonymous:
-;;;
-;;; (module (ex ...) defn ... init ...)
-;;;
-;;; The latter form is semantically equivalent to:
-;;;
-;;; (module T (ex ...) defn ... init ...)
-;;; (import T)
-;;;
-;;; where T is a fresh identifier.
-;;;
-;;; In either form, each of the exports in (ex ...) is either an
-;;; identifier or of the form (id ex ...). In the former case, the
-;;; single identifier ex is exported. In the latter, the identifier
-;;; id is exported and the exports ex ... are "implicitly" exported.
-;;; This listing of implicit exports is useful only when id is a
-;;; keyword bound to a transformer that expands into references to
-;;; the listed implicit exports. In the present implementation,
-;;; listing of implicit exports is necessary only for top-level
-;;; modules and allows the implementation to avoid placing all
-;;; identifiers into the top-level environment where subsequent passes
-;;; of the compiler will be unable to deal effectively with them.
-;;;
-;;; Named modules may be referenced in import statements, which
-;;; always take one of the forms:
-;;;
-;;; (import id)
-;;; (import-only id)
-;;;
-;;; id must name a module. Each exported identifier becomes visible
-;;; within the scope of the import form. In the case of import-only,
-;;; all other identifiers become invisible in the scope of the
-;;; import-only form, except for those established by definitions
-;;; that appear textually after the import-only form.
-
-;;; import and import-only also support a variety of identifier
-;;; selection and renaming forms: only, except, add-prefix,
-;;; drop-prefix, rename, and alias.
-;;;
-;;; (import (only m x y))
-;;;
-;;; imports x and y (and nothing else) from m.
-;;;
-;;; (import (except m x y))
-;;;
-;;; imports all of m's imports except for x and y.
-;;;
-;;; (import (add-prefix (only m x y) m:))
-;;;
-;;; imports x and y as m:x and m:y.
-;;;
-;;; (import (drop-prefix m foo:))
-;;;
-;;; imports all of m's imports, dropping the common foo: prefix
-;;; (which must appear on all of m's exports).
-;;;
-;;; (import (rename (except m a b) (m-c c) (m-d d)))
-;;;
-;;; imports all of m's imports except for x and y, renaming c
-;;; m-c and d m-d.
-;;;
-;;; (import (alias (except m a b) (m-c c) (m-d d)))
-;;;
-;;; imports all of m's imports except for x and y, with additional
-;;; aliases m-c for c and m-d for d.
-;;;
-;;; multiple imports may be specified with one import form:
-;;;
-;;; (import (except m1 x) (only m2 x))
-;;;
-;;; imports all of m1's exports except for x plus x from m2.
-
-;;; Another form, meta, may be used as a prefix for any definition and
-;;; causes any resulting variable bindings to be created at expansion
-;;; time. Meta variables (variables defined using meta) are available
-;;; only at expansion time. Meta definitions are often used to create
-;;; data and helpers that can be shared by multiple macros, for example:
-
-;;; (module (alpha beta)
-;;; (meta define key-error
-;;; (lambda (key)
-;;; (syntax-error key "invalid key")))
-;;; (meta define parse-keys
-;;; (lambda (keys)
-;;; (let f ((keys keys) (c #'white) (s 10))
-;;; (syntax-case keys (color size)
-;;; (() (list c s))
-;;; (((color c) . keys) (f #'keys #'c s))
-;;; (((size s) . keys) (f #'keys c #'s))
-;;; ((k . keys) (key-error #'k))))))
-;;; (define-syntax alpha
-;;; (lambda (x)
-;;; (syntax-case x ()
-;;; ((_ (k ...) <other stuff>)
-;;; (with-syntax (((c s) (parse-keys (syntax (k ...)))))
-;;; ---)))))
-;;; (define-syntax beta
-;;; (lambda (x)
-;;; (syntax-case x ()
-;;; ((_ (k ...) <other stuff>)
-;;; (with-syntax (((c s) (parse-keys (syntax (k ...)))))
-;;; ---))))))
-
-;;; As with define-syntax rhs expressions, meta expressions can evaluate
-;;; references only to identifiers whose values are (already) available
-;;; in the compile-time environment, e.g., macros and meta variables.
-;;; They can, however, like define-syntax rhs expressions, build syntax
-;;; objects containing occurrences of any identifiers in their scope.
-
-;;; meta definitions propagate through macro expansion, so one can write,
-;;; for example:
-;;;
-;;; (module (a)
-;;; (meta define-structure (foo x))
-;;; (define-syntax a
-;;; (let ((q (make-foo (syntax 'q))))
-;;; (lambda (x)
-;;; (foo-x q)))))
-;;; a -> q
-;;;
-;;; where define-record is a macro that expands into a set of defines.
-;;;
-;;; It is also sometimes convenient to write
-;;;
-;;; (meta begin defn ...)
-;;;
-;;; or
-;;;
-;;; (meta module {exports} defn ...)-;;;
-;;; to create groups of meta bindings.
-
-;;; Another form, alias, is used to create aliases from one identifier
-;;; to another. This is used primarily to support the extended import
-;;; syntaxes (add-prefix, drop-prefix, rename, and alias).
-
-;;; (let ((x 3)) (alias y x) y) -> 3
-
-;;; The remaining exports are listed below. sc-expand, eval-when, and
-;;; syntax-error are described in the Chez Scheme User's Guide.
-;;;
-;;; (sc-expand datum)
-;;; if datum represents a valid expression, sc-expand returns an
-;;; expanded version of datum in a core language that includes no
-;;; syntactic abstractions. The core language includes begin,
-;;; define, if, lambda, letrec, quote, and set!.
-;;; (eval-when situations expr ...)
-;;; conditionally evaluates expr ... at compile-time or run-time
-;;; depending upon situations
-;;; (syntax-error object message)
-;;; used to report errors found during expansion
-;;; ($syntax-dispatch e p)
-;;; used by expanded code to handle syntax-case matching
-;;; ($sc-put-cte symbol val top-token)
-;;; used to establish top-level compile-time (expand-time) bindings.
-
-;;; The following nonstandard procedures must be provided by the
-;;; implementation for this code to run.
-;;;
-;;; (void)
-;;; returns the implementation's cannonical "unspecified value". The
-;;; following usually works:
-;;;
-;;; (define void (lambda () (if #f #f))).
-;;;
-;;; (andmap proc list1 list2 ...)
-;;; returns true if proc returns true when applied to each element of list1
-;;; along with the corresponding elements of list2 .... The following
-;;; definition works but does no error checking:
-;;;
-;;; (define andmap
-;;; (lambda (f first . rest)
-;;; (or (null? first)
-;;; (if (null? rest)
-;;; (let andmap ((first first))
-;;; (let ((x (car first)) (first (cdr first)))
-;;; (if (null? first)
-;;; (f x)
-;;; (and (f x) (andmap first)))))
-;;; (let andmap ((first first) (rest rest))
-;;; (let ((x (car first))
-;;; (xr (map car rest))
-;;; (first (cdr first))
-;;; (rest (map cdr rest)))
-;;; (if (null? first)
-;;; (apply f (cons x xr))
-;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
-;;;
-;;; (ormap proc list1)
-;;; returns the first non-false return result of proc applied to
-;;; the elements of list1 or false if none. The following definition
-;;; works but does no error checking:
-;;;
-;;; (define ormap
-;;; (lambda (proc list1)
-;;; (and (not (null? list1))
-;;; (or (proc (car list1)) (ormap proc (cdr list1))))))
-;;;
-;;; The following nonstandard procedures must also be provided by the
-;;; implementation for this code to run using the standard portable
-;;; hooks and output constructors. They are not used by expanded code,
-;;; and so need be present only at expansion time.
-;;;
-;;; (eval x)
-;;; where x is always in the form ("noexpand" expr).-;;; returns the value of expr. the "noexpand" flag is used to tell the
-;;; evaluator/expander that no expansion is necessary, since expr has
-;;; already been fully expanded to core forms.
-;;;
-;;; eval will not be invoked during the loading of psyntax.pp. After
-;;; psyntax.pp has been loaded, the expansion of any macro definition,
-;;; whether local or global, results in a call to eval. If, however,
-;;; sc-expand has already been registered as the expander to be used
-;;; by eval, and eval accepts one argument, nothing special must be done
-;;; to support the "noexpand" flag, since it is handled by sc-expand.
-;;;
-;;; (error who format-string why what)
-;;; where who is either a symbol or #f, format-string is always "~a ~s",
-;;; why is always a string, and what may be any object. error should
-;;; signal an error with a message something like
-;;;
-;;; "error in <who>: <why> <what>"
-;;;
-;;; (gensym)
-;;; returns a unique symbol each time it's called. In Chez Scheme, gensym
-;;; returns a symbol with a "globally" unique name so that gensyms that
-;;; end up in the object code of separately compiled files cannot conflict.
-;;; This is necessary only if you intend to support compiled files.
-;;;
-;;; (gensym? x)
-;;; returns #t if x is a gensym, otherwise false.
-;;;
-;;; (putprop symbol key value)
-;;; (getprop symbol key)
-;;; (remprop symbol key)
-;;; key is always a symbol; value may be any object. putprop should
-;;; associate the given value with the given symbol and key in some way
-;;; that it can be retrieved later with getprop. getprop should return
-;;; #f if no value is associated with the given symbol and key. remprop
-;;; should remove the association between the given symbol and key.
-
-;;; When porting to a new Scheme implementation, you should define the
-;;; procedures listed above, load the expanded version of psyntax.ss
-;;; (psyntax.pp, which should be available whereever you found
-;;; psyntax.ss), and register sc-expand as the current expander (how
-;;; you do this depends upon your implementation of Scheme). You may
-;;; change the hooks and constructors defined toward the beginning of
-;;; the code below, but to avoid bootstrapping problems, do so only
-;;; after you have a working version of the expander.
-
-;;; Chez Scheme allows the syntactic form (syntax <template>) to be
-;;; abbreviated to #'<template>, just as (quote <datum>) may be
-;;; abbreviated to '<datum>. The #' syntax makes programs written
-;;; using syntax-case shorter and more readable and draws out the
-;;; intuitive connection between syntax and quote. If you have access
-;;; to the source code of your Scheme system's reader, you might want
-;;; to implement this extension.
-
-;;; If you find that this code loads or runs slowly, consider
-;;; switching to faster hardware or a faster implementation of
-;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
-;;; compiling (with full optimization), and loading this file takes
-;;; between one and two seconds.
-
-;;; In the expander implementation, we sometimes use syntactic abstractions
-;;; when procedural abstractions would suffice. For example, we define
-;;; top-wrap and top-marked? as
-;;; (define-syntax top-wrap (identifier-syntax '((top))))
-;;; (define-syntax top-marked?
-;;; (syntax-rules ()
-;;; ((_ w) (memq 'top (wrap-marks w)))))
-;;; rather than
-;;; (define top-wrap '((top)))
-;;; (define top-marked?
-;;; (lambda (w) (memq 'top (wrap-marks w))))
-;;; On ther other hand, we don't do this consistently; we define make-wrap,
-;;; wrap-marks, and wrap-subst simply as
-;;; (define make-wrap cons)
-;;; (define wrap-marks car)
-;;; (define wrap-subst cdr)
-;;; In Chez Scheme, the syntactic and procedural forms of these
-;;; abstractions are equivalent, since the optimizer consistently
-;;; integrates constants and small procedures. Some Scheme
-;;; implementations, however, may benefit from more consistent use
-;;; of one form or the other.
-
-
-;;; Implementation notes:
-
-;;; "begin" is treated as a splicing construct at top level and at
-;;; the beginning of bodies. Any sequence of expressions that would
-;;; be allowed where the "begin" occurs is allowed.
-
-;;; "let-syntax" and "letrec-syntax" are also treated as splicing
-;;; constructs, in violation of the R5RS. A consequence is that let-syntax
-;;; and letrec-syntax do not create local contours, as do let and letrec.
-;;; Although the functionality is greater as it is presently implemented,
-;;; we will probably change it to conform to the R5RS. modules provide
-;;; similar functionality to nonsplicing letrec-syntax when the latter is
-;;; used as a definition.
-
-;;; Objects with no standard print syntax, including objects containing
-;;; cycles and syntax objects, are allowed in quoted data as long as they
-;;; are contained within a syntax form or produced by datum->syntax-object.
-;;; Such objects are never copied.
-
-;;; When the expander encounters a reference to an identifier that has
-;;; no global or lexical binding, it treats it as a global-variable
-;;; reference. This allows one to write mutually recursive top-level
-;;; definitions, e.g.:
-;;;
-;;; (define f (lambda (x) (g x)))
-;;; (define g (lambda (x) (f x)))
-;;;
-;;; but may not always yield the intended when the variable in question
-;;; is later defined as a keyword.
-
-;;; Top-level variable definitions of syntax keywords are permitted.
-;;; In order to make this work, top-level define not only produces a
-;;; top-level definition in the core language, but also modifies the
-;;; compile-time environment (using $sc-put-cte) to record the fact
-;;; that the identifier is a variable.
-
-;;; Top-level definitions of macro-introduced identifiers are visible
-;;; only in code produced by the macro. That is, a binding for a
-;;; hidden (generated) identifier is created instead, and subsequent
-;;; references within the macro output are renamed accordingly. For
-;;; example:
-;;;
-;;; (define-syntax a
-;;; (syntax-rules ()
-;;; ((_ var exp)
-;;; (begin
-;;; (define secret exp)
-;;; (define var
-;;; (lambda ()
-;;; (set! secret (+ secret 17))
-;;; secret))))))
-;;; (a x 0)
-;;; (x) => 17
-;;; (x) => 34
-;;; secret => Error: variable secret is not bound
-;;;
-;;; The definition above would fail if the definition for secret
-;;; were placed after the definition for var, since the expander would
-;;; encounter the references to secret before the definition that
-;;; establishes the compile-time map from the identifier secret to
-;;; the generated identifier.
-
-;;; Identifiers and syntax objects are implemented as vectors for
-;;; portability. As a result, it is possible to "forge" syntax
-;;; objects.
-
-;;; The input to sc-expand may contain "annotations" describing, e.g., the
-;;; source file and character position from where each object was read if
-;;; it was read from a file. These annotations are handled properly by
-;;; sc-expand only if the annotation? hook (see hooks below) is implemented
-;;; properly and the operators annotation-expression and annotation-stripped
-;;; are supplied. If annotations are supplied, the proper annotated
-;;; expression is passed to the various output constructors, allowing
-;;; implementations to accurately correlate source and expanded code.
-;;; Contact one of the authors for details if you wish to make use of
-;;; this feature.
-
-;;; Implementation of modules:
-;;;
-;;; The implementation of modules requires that implicit top-level exports
-;;; be listed with the exported macro at some level where both are visible,
-;;; e.g.,
-;;;
-;;; (module M (alpha (beta b))
-;;; (module ((alpha a) b)
-;;; (define-syntax alpha (identifier-syntax a))
-;;; (define a 'a)
-;;; (define b 'b))
-;;; (define-syntax beta (identifier-syntax b)))
-;;;
-;;; Listing of implicit imports is not needed for macros that do not make
-;;; it out to top level, including all macros that are local to a "body".
-;;; (They may be listed in this case, however.) We need this information
-;;; for top-level modules since a top-level module expands into a letrec
-;;; for non-top-level variables and top-level definitions (assignments) for
-;;; top-level variables. Because of the general nature of macro
-;;; transformers, we cannot determine the set of implicit exports from the
-;;; transformer code, so without the user's help, we'd have to put all
-;;; variables at top level.
-;;;
-;;; Each such top-level identifier is given a generated name (gensym).
-;;; When a top-level module is imported at top level, a compile-time
-;;; alias is established from the top-level name to the generated name.
-;;; The expander follows these aliases transparently. When any module is
-;;; imported anywhere other than at top level, the id-var-name of the
-;;; import identifier is set to the id-var-name of the export identifier.
-;;; Since we can't determine the actual labels for identifiers defined in
-;;; top-level modules until we determine which are placed in the letrec
-;;; and which make it to top level, we give each an "indirect" label---a
-;;; pair whose car will eventually contain the actual label. Import does
-;;; not follow the indirect, but id-var-name does.
-;;;
-;;; All identifiers defined within a local module are folded into the
-;;; letrec created for the enclosing body. Visibility is controlled in
-;;; this case and for nested top-level modules by introducing a new wrap
-;;; for each module.
-
-
-;;; Bootstrapping:
-
-;;; When changing syntax-object representations, it is necessary to support
-;;; both old and new syntax-object representations in id-var-name. It
-;;; should be sufficient to redefine syntax-object-expression to work for
-;;; both old and new representations and syntax-object-wrap to return the
-;;; empty-wrap for old representations.
-
-
-;;; The following set of definitions establishes bindings for the
-;;; top-level variables assigned values in the let expression below.
-;;; Uncomment them here and copy them to the front of psyntax.pp if
-;;; required by your system.
-
-; (define $sc-put-cte #f)
-; (define sc-expand #f)
-; (define $make-environment #f)
-; (define environment? #f)
-; (define interaction-environment #f)
-; (define identifier? #f)
-; (define syntax->list #f)
-; (define syntax-object->datum #f)
-; (define datum->syntax-object #f)
-; (define generate-temporaries #f)
-; (define free-identifier=? #f)
-; (define bound-identifier=? #f)
-; (define literal-identifier=? #f)
-; (define syntax-error #f)
-; (define $syntax-dispatch #f)
-
-(let ()
-
-(define-syntax when
- (syntax-rules ()
- ((_ test e1 e2 ...) (if test (begin e1 e2 ...)))))
-(define-syntax unless
- (syntax-rules ()
- ((_ test e1 e2 ...) (when (not test) (begin e1 e2 ...)))))
-(define-syntax define-structure
- (lambda (x)
- (define construct-name
- (lambda (template-identifier . args)
- (datum->syntax-object
- template-identifier
- (string->symbol
- (apply string-append
- (map (lambda (x)
- (if (string? x)
- x
- (symbol->string (syntax-object->datum x))))
- args))))))
- (syntax-case x ()
- ((_ (name id1 ...))
- (andmap identifier? (syntax (name id1 ...)))
- (with-syntax
- ((constructor (construct-name (syntax name) "make-" (syntax name)))
- (predicate (construct-name (syntax name) (syntax name) "?"))
- ((access ...)
- (map (lambda (x) (construct-name x (syntax name) "-" x))
- (syntax (id1 ...))))
- ((assign ...)
- (map (lambda (x)
- (construct-name x "set-" (syntax name) "-" x "!"))
- (syntax (id1 ...))))
- (structure-length
- (+ (length (syntax (id1 ...))) 1))
- ((index ...)
- (let f ((i 1) (ids (syntax (id1 ...))))
- (if (null? ids)
- '()
- (cons i (f (+ i 1) (cdr ids)))))))
- (syntax (begin
- (define constructor
- (lambda (id1 ...)
- (vector 'name id1 ... )))
- (define predicate
- (lambda (x)
- (and (vector? x)
- (= (vector-length x) structure-length)
- (eq? (vector-ref x 0) 'name))))
- (define access
- (lambda (x)
- (vector-ref x index)))
- ...
- (define assign
- (lambda (x update)
- (vector-set! x index update)))
- ...)))))))
-
-(define-syntax let-values ; impoverished one-clause version
- (syntax-rules ()
- ((_ ((formals expr)) form1 form2 ...)
- (call-with-values (lambda () expr) (lambda formals form1 form2 ...)))))
-
-(define noexpand "noexpand")
-
-(define-structure (syntax-object expression wrap))
-
-;;; hooks to nonportable run-time helpers
-(begin
-(define-syntax fx+ (identifier-syntax +))
-(define-syntax fx- (identifier-syntax -))
-(define-syntax fx= (identifier-syntax =))
-(define-syntax fx< (identifier-syntax <))
-(define-syntax fx> (identifier-syntax >))
-(define-syntax fx<= (identifier-syntax <=))
-(define-syntax fx>= (identifier-syntax >=))
-
-(define annotation? (lambda (x) #f))
-
-; top-level-eval-hook is used to create "permanent" code (e.g., top-level
-; transformers), so it might be a good idea to compile it
-(define top-level-eval-hook
- (lambda (x)
- (eval `(,noexpand ,x))))
-
-; local-eval-hook is used to create "temporary" code (e.g., local
-; transformers), so it might be a good idea to interpret it
-(define local-eval-hook
- (lambda (x)
- (eval `(,noexpand ,x))))
-
-(define define-top-level-value-hook
- (lambda (sym val)
- (top-level-eval-hook
- (build-global-definition no-source sym
- (build-data no-source val)))))
-
-(define error-hook
- (lambda (who why what)
- (error who "~a ~s" why what)))
-
-(define put-cte-hook
- (lambda (symbol val)
- ($sc-put-cte symbol val '*top*)))
-
-(define get-global-definition-hook
- (lambda (symbol)
- (getprop symbol '*sc-expander*)))
-
-(define put-global-definition-hook
- (lambda (symbol x)
- (if (not x)
- (remprop symbol '*sc-expander*)
- (putprop symbol '*sc-expander* x))))
-
-; if you treat certain bindings (say from environments like ieee or r5rs)
-; read-only, this should return #t for those bindings
-(define read-only-binding?
- (lambda (symbol)
- #f))
-
-; should return #f if symbol has no binding for token
-(define get-import-binding
- (lambda (symbol token)
- (getprop symbol token)))
-
-; remove binding if x is false
-(define update-import-binding!
- (lambda (symbol token p)
- (let ((x (p (get-import-binding symbol token))))
- (if (not x)
- (remprop symbol token)
- (putprop symbol token x)))))
-
-;;; generate-id ideally produces globally unique symbols, i.e., symbols
-;;; unique across system runs, to support separate compilation/expansion.
-;;; Use gensyms if you do not need to support separate compilation/
-;;; expansion or if your system's gensym creates globally unique
-;;; symbols (as in Chez Scheme). Otherwise, use the following code
-;;; as a starting point. session-key should be a unique string for each
-;;; system run to support separate compilation; the default value given
-;;; is satisfactory during initial development only.
-(define generate-id
- (let ((digits "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?~_^.+-"))
- (let ((base (string-length digits)) (session-key "_"))
- (define make-digit (lambda (x) (string-ref digits x)))
- (define fmt
- (lambda (n)
- (let fmt ((n n) (a '()))
- (if (< n base)
- (list->string (cons (make-digit n) a))
- (let ((r (modulo n base)) (rest (quotient n base)))
- (fmt rest (cons (make-digit r) a)))))))
- (let ((n -1))
- (lambda (name) ; name is #f or a symbol
- (set! n (+ n 1))
- (string->symbol (string-append session-key (fmt n))))))))
-)
-
-
-
-;;; output constructors
-(begin
-(define-syntax build-application
- (syntax-rules ()
- ((_ ae fun-exp arg-exps)
- `(,fun-exp . ,arg-exps))))
-
-(define-syntax build-conditional
- (syntax-rules ()
- ((_ ae test-exp then-exp else-exp)
- `(if ,test-exp ,then-exp ,else-exp))))
-
-(define-syntax build-lexical-reference
- (syntax-rules ()
- ((_ type ae var)
- var)))
-
-(define-syntax build-lexical-assignment
- (syntax-rules ()
- ((_ ae var exp)
- `(set! ,var ,exp))))
-
-(define-syntax build-global-reference
- (syntax-rules ()
- ((_ ae var)
- var)))
-
-(define-syntax build-global-assignment
- (syntax-rules ()
- ((_ ae var exp)
- `(set! ,var ,exp))))
-
-(define-syntax build-global-definition
- (syntax-rules ()
- ((_ ae var exp)
- `(define ,var ,exp))))
-
-(define-syntax build-cte-install
- ; should build a call that has the same effect as calling put-cte-hook
- (syntax-rules ()
- ((_ sym exp token) `($sc-put-cte ',sym ,exp ',token))))
-
-(define-syntax build-visit-only
- ; should mark the result as "visit only" for compile-file
- ; in implementations that support visit/revisit
- (syntax-rules ()
- ((_ exp) exp)))
-
-(define-syntax build-revisit-only
- ; should mark the result as "revisit only" for compile-file,
- ; in implementations that support visit/revisit
- (syntax-rules ()
- ((_ exp) exp)))
-
-(define-syntax build-lambda
- (syntax-rules ()
- ((_ ae vars exp)
- `(lambda ,vars ,exp))))
-
-(define built-lambda?
- (lambda (x)
- (and (pair? x) (eq? (car x) 'lambda))))
-
-(define-syntax build-primref
- (syntax-rules ()
- ((_ ae name) name)
- ((_ ae level name) name)))
-
-(define-syntax build-data
- (syntax-rules ()
- ((_ ae exp) `',exp)))
-
-(define build-sequence
- (lambda (ae exps)
- (let loop ((exps exps))
- (if (null? (cdr exps))
- (car exps)
- ; weed out leading void calls, assuming ordinary list representation
- (if (equal? (car exps) '(void))
- (loop (cdr exps))
- `(begin ,@exps))))))
-
-(define build-letrec
- (lambda (ae vars val-exps body-exp)
- (if (null? vars)
- body-exp
- `(letrec ,(map list vars val-exps) ,body-exp))))
-
-(define build-body
- (lambda (ae vars val-exps body-exp)
- (build-letrec ae vars val-exps body-exp)))
-
-(define build-top-module
- ; each type is either global (exported) or local (not exported)
- ; we produce global definitions and assignments for globals and
- ; letrec bindings for locals. if you don't need the definitions,
- ; (just assignments) you can eliminate them. if you wish to
- ; have your module definitions ordered from left-to-right (ala
- ; letrec*), you can replace the global var-exps with dummy vars
- ; and global val-exps with global assignments, and produce a letrec*
- ; in place of a letrec.
- (lambda (ae types vars val-exps body-exp)
- (let-values (((vars defns sets)
- (let f ((types types) (vars vars))
- (if (null? types)
- (values '() '() '())
- (let ((var (car vars)))
- (let-values (((vars defns sets) (f (cdr types) (cdr vars))))
- (if (eq? (car types) 'global)
- (let ((x (build-lexical-var no-source var)))
- (values
- (cons x vars)
- (cons (build-global-definition no-source var (chi-void)) defns)
- (cons (build-global-assignment no-source var (build-lexical-reference 'value no-source x)) sets)))
- (values (cons var vars) defns sets))))))))
- (if (null? defns)
- (build-letrec ae vars val-exps body-exp)
- (build-sequence no-source
- (append defns
- (list
- (build-letrec ae vars val-exps
- (build-sequence no-source (append sets (list body-exp)))))))))))
-
-(define-syntax build-lexical-var
- (syntax-rules ()
- ((_ ae id) (gensym))))
-
-(define-syntax lexical-var? gensym?)
-
-(define-syntax self-evaluating?
- (syntax-rules ()
- ((_ e)
- (let ((x e))
- (or (boolean? x) (number? x) (string? x) (char? x) (null? x))))))
-)
-
-(define-syntax unannotate
- (syntax-rules ()
- ((_ x)
- (let ((e x))
- (if (annotation? e)
- (annotation-expression e)
- e)))))
-
-(define-syntax no-source (identifier-syntax #f))
-
-(define-syntax arg-check
- (syntax-rules ()
- ((_ pred? e who)
- (let ((x e))
- (if (not (pred? x)) (error-hook who "invalid argument" x))))))
-
-;;; compile-time environments
-
-;;; wrap and environment comprise two level mapping.
-;;; wrap : id --> label
-;;; env : label --> <element>
-
-;;; environments are represented in two parts: a lexical part and a global
-;;; part. The lexical part is a simple list of associations from labels
-;;; to bindings. The global part is implemented by
-;;; {put,get}-global-definition-hook and associates symbols with-;;; bindings.
-
-;;; global (assumed global variable) and displaced-lexical (see below)
-;;; do not show up in any environment; instead, they are fabricated by
-;;; lookup when it finds no other bindings.
-
-;;; <environment> ::= ((<label> . <binding>)*)
-
-;;; identifier bindings include a type and a value
-
-;;; <binding> ::= <procedure> macro keyword
-;;; (macro . <procedure>) macro keyword
-;;; (deferred . <thunk>) macro keyword w/lazily evaluated transformer
-;;; (macro! . <procedure>) extended identifier macro keyword
-;;; (core . <procedure>) core keyword
-;;; (begin) begin keyword
-;;; (define) define keyword
-;;; (define-syntax) define-syntax keyword
-;;; (local-syntax . <boolean>) let-syntax (#f)/letrec-syntax (#t) keyword
-;;; (eval-when) eval-when keyword
-;;; (set!) set! keyword
-;;; (meta) meta keyword
-;;; ($module-key) $module keyword
-;;; ($import) $import keyword
-;;; ($module . <interface>) modules
-;;; (syntax . (<var> . <level>)) pattern variables
-;;; (global . <symbol>) assumed global variable
-;;; (meta-variable . <symbol>) meta variable
-;;; (lexical . <var>) lexical variables
-;;; (displaced-lexical . #f) id-var-name not found in store
-;;; <level> ::= <nonnegative integer>
-;;; <var> ::= variable returned by build-lexical-var
-
-;;; a macro is a user-defined syntactic-form. a core is a system-defined
-;;; syntactic form. begin, define, define-syntax, let-syntax, letrec-syntax,
-;;; eval-when, and meta are treated specially since they are sensitive to
-;;; whether the form is at top-level and can denote valid internal
-;;; definitions.
-
-;;; a pattern variable is a variable introduced by syntax-case and can
-;;; be referenced only within a syntax form.
-
-;;; any identifier for which no top-level syntax definition or local
-;;; binding of any kind has been seen is assumed to be a global
-;;; variable.
-
-;;; a lexical variable is a lambda- or letrec-bound variable.
-
-;;; a displaced-lexical identifier is a lexical identifier removed from
-;;; it's scope by the return of a syntax object containing the identifier.
-;;; a displaced lexical can also appear when a letrec-syntax-bound
-;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
-;;; a displaced lexical should never occur with properly written macros.
-
-(define sanitize-binding
- (lambda (b)
- (cond
- ((procedure? b) (make-binding 'macro b))
- ((binding? b)
- (and (case (binding-type b)
- ((core macro macro! deferred) (and (procedure? (binding-value b))))
- (($module) (interface? (binding-value b)))
- ((lexical) (lexical-var? (binding-value b)))
- ((global meta-variable) (symbol? (binding-value b)))
- ((syntax) (let ((x (binding-value b)))
- (and (pair? x)
- (lexical-var? (car x))
- (let ((n (cdr x)))
- (and (integer? n) (exact? n) (>= n 0))))))
- ((begin define define-syntax set! $module-key $import eval-when meta) (null? (binding-value b)))
- ((local-syntax) (boolean? (binding-value b)))
- ((displaced-lexical) (eq? (binding-value b) #f))
- (else #t))
- b))
- (else #f))))
-
-(define-syntax make-binding
- (syntax-rules (quote)
- ((_ 'type #f) '(type . #f))
- ((_ type value) (cons type value))))
-(define binding-type car)
-(define binding-value cdr)
-(define set-binding-type! set-car!)
-(define set-binding-value! set-cdr!)
-(define binding? (lambda (x) (and (pair? x) (symbol? (car x)))))
-
-(define-syntax null-env (identifier-syntax '()))
-
-(define extend-env
- (lambda (label binding r)
- (cons (cons label binding) r)))
-
-(define extend-env*
- (lambda (labels bindings r)
- (if (null? labels)
- r
- (extend-env* (cdr labels) (cdr bindings)
- (extend-env (car labels) (car bindings) r)))))
-
-(define extend-var-env*
- ; variant of extend-env* that forms "lexical" binding
- (lambda (labels vars r)
- (if (null? labels)
- r
- (extend-var-env* (cdr labels) (cdr vars)
- (extend-env (car labels) (make-binding 'lexical (car vars)) r)))))
-
-(define (displaced-lexical? id r)
- (let ((n (id-var-name id empty-wrap)))
- (and n
- (let ((b (lookup n r)))
- (eq? (binding-type b) 'displaced-lexical)))))
-
-(define displaced-lexical-error
- (lambda (id)
- (syntax-error id
- (if (id-var-name id empty-wrap)
- "identifier out of context"
- "identifier not visible"))))
-
-(define lookup*
- ; x may be a label or a symbol
- ; although symbols are usually global, we check the environment first
- ; anyway because a temporary binding may have been established by
- ; fluid-let-syntax
- (lambda (x r)
- (cond
- ((assq x r) => cdr)
- ((symbol? x)
- (or (get-global-definition-hook x) (make-binding 'global x)))
- (else (make-binding 'displaced-lexical #f)))))
-
-(define lookup
- (lambda (x r)
- (define whack-binding!
- (lambda (b *b)
- (set-binding-type! b (binding-type *b))
- (set-binding-value! b (binding-value *b))))
- (let ((b (lookup* x r)))
- (when (eq? (binding-type b) 'deferred)
- (whack-binding! b (make-transformer-binding ((binding-value b)))))
- b)))
-
-(define make-transformer-binding
- (lambda (b)
- (or (sanitize-binding b)
- (syntax-error b "invalid transformer"))))
-
-(define defer-or-eval-transformer
- (lambda (eval x)
- (if (built-lambda? x)
- (make-binding 'deferred (lambda () (eval x)))
- (make-transformer-binding (eval x)))))
-
-(define global-extend
- (lambda (type sym val)
- (put-cte-hook sym (make-binding type val))))
-
-
-;;; Conceptually, identifiers are always syntax objects. Internally,
-;;; however, the wrap is sometimes maintained separately (a source of
-;;; efficiency and confusion), so that symbols are also considered
-;;; identifiers by id?. Externally, they are always wrapped.
-
-(define nonsymbol-id?
- (lambda (x)
- (and (syntax-object? x)
- (symbol? (unannotate (syntax-object-expression x))))))
-
-(define id?
- (lambda (x)
- (cond
- ((symbol? x) #t)
- ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
- ((annotation? x) (symbol? (annotation-expression x)))
- (else #f))))
-
-(define-syntax id-sym-name
- (syntax-rules ()
- ((_ e)
- (let ((x e))
- (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
-
-(define id-marks
- (lambda (id)
- (if (syntax-object? id)
- (wrap-marks (syntax-object-wrap id))
- (wrap-marks top-wrap))))
-
-(define id-subst
- (lambda (id)
- (if (syntax-object? id)
- (wrap-subst (syntax-object-wrap id))
- (wrap-marks top-wrap))))
-
-(define id-sym-name&marks
- (lambda (x w)
- (if (syntax-object? x)
- (values
- (unannotate (syntax-object-expression x))
- (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
- (values (unannotate x) (wrap-marks w)))))
-
-;;; syntax object wraps
-
-;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
-;;; <subst> ::= <ribcage> | <shift>
-;;; <ribcage> ::= #((<ex-symname> ...) (<mark> ...) (<label> ...)) ; extensible, for chi-internal/external
-;;; | #(#(<symname> ...) #(<mark> ...) #(<label> ...)) ; nonextensible
-;;; <ex-symname> ::= <symname> | <import token> | <barrier>
-;;; <shift> ::= shift
-;;; <barrier> ::= #f ; inserted by import-only
-;;; <import interface> ::= #<import-interface interface new-marks>
-;;; <token> ::= <generated id>
-
-(define make-wrap cons)
-(define wrap-marks car)
-(define wrap-subst cdr)
-
-
-(define-syntax empty-wrap (identifier-syntax '(())))
-
-(define-syntax top-wrap (identifier-syntax '((top))))
-
-(define-syntax tmp-wrap (identifier-syntax '((tmp)))) ; for generate-temporaries
-
-(define-syntax top-marked?
- (syntax-rules ()
- ((_ w) (memq 'top (wrap-marks w)))))
-
-(define-syntax only-top-marked?
- (syntax-rules ()
- ((_ id) (same-marks? (wrap-marks (syntax-object-wrap id)) (wrap-marks top-wrap)))))
-
-;;; labels
-
-;;; simple labels must be comparable with "eq?" and distinct from symbols
-;;; and pairs.
-
-;;; indirect labels, which are implemented as pairs, are used to support
-;;; import aliasing for identifiers exported (explictly or implicitly) from
-;;; top-level modules. chi-external creates an indirect label for each
-;;; defined identifier, import causes the pair to be shared with aliases it
-;;; establishes, and chi-top-module whacks the pair to hold the top-level
-;;; identifier name (symbol) if the id is to be placed at top level, before
-;;; expanding the right-hand sides of the definitions in the module.
-
-(module (gen-indirect-label indirect-label? get-indirect-label set-indirect-label!)
- (define-structure (indirect-label label))
- (define gen-indirect-label
- (lambda ()
- (make-indirect-label (gen-label))))
- (define get-indirect-label (lambda (x) (indirect-label-label x)))
- (define set-indirect-label! (lambda (x v) (set-indirect-label-label! x v))))
-
-(define gen-label
- (lambda () (string #\i)))
-(define label?
- (lambda (x)
- (or (string? x) ; normal lexical labels
- (symbol? x) ; global labels (symbolic names)
- (indirect-label? x))))
-
-(define gen-labels
- (lambda (ls)
- (if (null? ls)
- '()
- (cons (gen-label) (gen-labels (cdr ls))))))
-
-(define-structure (ribcage symnames marks labels))
-(define-structure (top-ribcage key mutable?))
-(define-structure (import-interface interface new-marks))
-(define-structure (env top-ribcage wrap))
-
-;;; Marks must be comparable with "eq?" and distinct from pairs and
-;;; the symbol top. We do not use integers so that marks will remain
-;;; unique even across file compiles.
-
-(define-syntax the-anti-mark (identifier-syntax #f))
-
-(define anti-mark
- (lambda (w)
- (make-wrap (cons the-anti-mark (wrap-marks w))
- (cons 'shift (wrap-subst w)))))
-
-(define-syntax new-mark
- (syntax-rules ()
- ((_) (string #\m))))
-
-(define barrier-marker #f)
-
-;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
-;;; internal definitions, in which the ribcages are built incrementally
-(define-syntax make-empty-ribcage
- (syntax-rules ()
- ((_) (make-ribcage '() '() '()))))
-
-(define extend-ribcage!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
- (lambda (ribcage id label)
- (set-ribcage-symnames! ribcage
- (cons (unannotate (syntax-object-expression id))
- (ribcage-symnames ribcage)))
- (set-ribcage-marks! ribcage
- (cons (wrap-marks (syntax-object-wrap id))
- (ribcage-marks ribcage)))
- (set-ribcage-labels! ribcage
- (cons label (ribcage-labels ribcage)))))
-
-(define import-extend-ribcage!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
- (lambda (ribcage new-marks id label)
- (set-ribcage-symnames! ribcage
- (cons (unannotate (syntax-object-expression id))
- (ribcage-symnames ribcage)))
- (set-ribcage-marks! ribcage
- (cons (join-marks new-marks (wrap-marks (syntax-object-wrap id)))
- (ribcage-marks ribcage)))
- (set-ribcage-labels! ribcage
- (cons label (ribcage-labels ribcage)))))
-
-(define extend-ribcage-barrier!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
- (lambda (ribcage killer-id)
- (extend-ribcage-barrier-help! ribcage (syntax-object-wrap killer-id))))
-
-(define extend-ribcage-barrier-help!
- (lambda (ribcage wrap)
- (set-ribcage-symnames! ribcage
- (cons barrier-marker (ribcage-symnames ribcage)))
- (set-ribcage-marks! ribcage
- (cons (wrap-marks wrap) (ribcage-marks ribcage)))))
-
-(define extend-ribcage-subst!
- ; ribcage guaranteed to be list-based
- (lambda (ribcage import-iface)
- (set-ribcage-symnames! ribcage
- (cons import-iface (ribcage-symnames ribcage)))))
-
-(define lookup-import-binding-name
- (lambda (sym marks token new-marks)
- (let ((new (get-import-binding sym token)))
- (and new
- (let f ((new new))
- (cond
- ((pair? new) (or (f (car new)) (f (cdr new))))
- ((symbol? new)
- (and (same-marks? marks (join-marks new-marks (wrap-marks top-wrap))) new))
- ((same-marks? marks (join-marks new-marks (wrap-marks (syntax-object-wrap new)))) new)
- (else #f)))))))
-
-(define store-import-binding
- (lambda (id token new-marks)
- (define cons-id
- (lambda (id x)
- (if (not x) id (cons id x))))
- (define weed ; remove existing binding for id, if any
- (lambda (marks x)
- (if (pair? x)
- (if (same-marks? (id-marks (car x)) marks)
- (weed marks (cdr x))
- (cons-id (car x) (weed marks (cdr x))))
- (and x (not (same-marks? (id-marks x) marks)) x))))
- (let ((id (if (null? new-marks)
- id
- (make-syntax-object (id-sym-name id)
- (make-wrap
- (join-marks new-marks (id-marks id))
- (id-subst id))))))
- (let ((sym (id-sym-name id)))
- ; no need to record bindings mapping symbol to self, since this
- ; assumed by default.
- (unless (eq? id sym)
- (let ((marks (id-marks id)))
- (update-import-binding! sym token
- (lambda (old-binding)
- (let ((x (weed marks old-binding)))
- (cons-id
- (if (same-marks? marks (wrap-marks top-wrap))
- ; need full id only if more than top-marked.
- (resolved-id-var-name id)
- id)
- x))))))))))
-
-;;; make-binding-wrap creates vector-based ribcages
-(define make-binding-wrap
- (lambda (ids labels w)
- (if (null? ids)
- w
- (make-wrap
- (wrap-marks w)
- (cons
- (let ((labelvec (list->vector labels)))
- (let ((n (vector-length labelvec)))
- (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
- (let f ((ids ids) (i 0))
- (unless (null? ids)
- (let-values (((symname marks) (id-sym-name&marks (car ids) w)))
- (vector-set! symnamevec i symname)
- (vector-set! marksvec i marks)
- (f (cdr ids) (fx+ i 1)))))
- (make-ribcage symnamevec marksvec labelvec))))
- (wrap-subst w))))))
-
-;;; resolved ids contain no unnecessary substitutions or marks. they are
-;;; used essentially as indirects or aliases in modules interfaces.
-(define make-resolved-id
- (lambda (fromsym marks tosym)
- (make-syntax-object fromsym
- (make-wrap marks
- (list (make-ribcage (vector fromsym) (vector marks) (vector tosym)))))))
-
-(define id->resolved-id
- (lambda (id)
- (let-values (((tosym marks) (id-var-name&marks id empty-wrap)))
- (unless tosym
- (syntax-error id "identifier not visible for export"))
- (make-resolved-id (id-sym-name id) marks tosym))))
-
-(define resolved-id-var-name
- (lambda (id)
- (vector-ref
- (ribcage-labels (car (wrap-subst (syntax-object-wrap id))))
- 0)))
-
-;;; Scheme's append should not copy the first argument if the second is
-;;; nil, but it does, so we define a smart version here.
-(define smart-append
- (lambda (m1 m2)
- (if (null? m2)
- m1
- (append m1 m2))))
-
-(define join-wraps
- (lambda (w1 w2)
- (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
- (if (null? m1)
- (if (null? s1)
- w2
- (make-wrap
- (wrap-marks w2)
- (join-subst s1 (wrap-subst w2))))
- (make-wrap
- (join-marks m1 (wrap-marks w2))
- (join-subst s1 (wrap-subst w2)))))))
-
-(define join-marks
- (lambda (m1 m2)
- (smart-append m1 m2)))
-
-(define join-subst
- (lambda (s1 s2)
- (smart-append s1 s2)))
-
-(define same-marks?
- (lambda (x y)
- (or (eq? x y)
- (and (not (null? x))
- (not (null? y))
- (eq? (car x) (car y))
- (same-marks? (cdr x) (cdr y))))))
-
-(define diff-marks
- (lambda (m1 m2)
- (let ((n1 (length m1)) (n2 (length m2)))
- (let f ((n1 n1) (m1 m1))
- (cond
- ((> n1 n2) (cons (car m1) (f (- n1 1) (cdr m1))))
- ((equal? m1 m2) '())
- (else (error 'sc-expand
- "internal error in diff-marks: ~s is not a tail of ~s"
- m1 m2)))))))
-
-(module (top-id-bound-var-name top-id-free-var-name)
- ;; top-id-bound-var-name is used to look up or establish new top-level
- ;; substitutions, while top-id-free-var-name is used to look up existing
- ;; (possibly implicit) substitutions. Implicit substitutions exist
- ;; for top-marked names in all environments, but we represent them
- ;; explicitly only on demand.
- ;;
- ;; In both cases, we first look for an existing substitution for sym
- ;; and the given marks. If we find one, we return it. Otherwise, we
- ;; extend the appropriate top-level environment
- ;;
- ;; For top-id-bound-var-name, we extend the environment with a substition
- ;; keyed by the given marks, so that top-level definitions introduced by
- ;; a macro are distinct from other top-level definitions for the same
- ;; name. For example, if macros a and b both introduce definitions and
- ;; bound references to identifier x, the two x's should be different,
- ;; i.e., keyed by their own marks.
- ;;
- ;; For top-id-free-var-name, we extend the environment with a substition
- ;; keyed by the top marks, since top-level free identifier references
- ;; should refer to the existing implicit (top-marked) substitution. For
- ;; example, if macros a and b both introduce free references to identifier
- ;; x, they should both refer to the same (global, unmarked) x.
- ;;
- ;; If the environment is *top*, we map a symbol to itself
-
- (define leave-implicit? (lambda (token) (eq? token '*top*)))
-
- (define new-binding
- (lambda (sym marks token)
- (let ((loc (if (and (leave-implicit? token)
- (same-marks? marks (wrap-marks top-wrap)))
- sym
- (generate-id sym))))
- (let ((id (make-resolved-id sym marks loc)))
- (store-import-binding id token '())
- (values loc id)))))
-
- (define top-id-bound-var-name
- ; should be called only when top-ribcage is mutable
- (lambda (sym marks top-ribcage)
- (let ((token (top-ribcage-key top-ribcage)))
- (cond
- ((lookup-import-binding-name sym marks token '()) =>
- (lambda (id)
- (if (symbol? id) ; symbol iff marks == (wrap-marks top-wrap)
- (if (read-only-binding? id)
- (new-binding sym marks token)
- (values id (make-resolved-id sym marks id)))
- (values (resolved-id-var-name id) id))))
- (else (new-binding sym marks token))))))
-
- (define top-id-free-var-name
- (lambda (sym marks top-ribcage)
- (let ((token (top-ribcage-key top-ribcage)))
- (cond
- ((lookup-import-binding-name sym marks token '()) =>
- (lambda (id) (if (symbol? id) id (resolved-id-var-name id))))
- ((and (top-ribcage-mutable? top-ribcage)
- (same-marks? marks (wrap-marks top-wrap)))
- (let-values (((sym id) (new-binding sym (wrap-marks top-wrap) token)))
- sym))
- (else #f))))))
-
-(define id-var-name-loc&marks
- (lambda (id w)
- (define search
- (lambda (sym subst marks)
- (if (null? subst)
- (values #f marks)
- (let ((fst (car subst)))
- (cond
- ((eq? fst 'shift) (search sym (cdr subst) (cdr marks)))
- ((ribcage? fst)
- (let ((symnames (ribcage-symnames fst)))
- (if (vector? symnames)
- (search-vector-rib sym subst marks symnames fst)
- (search-list-rib sym subst marks symnames fst))))
- ((top-ribcage? fst)
- (cond
- ((top-id-free-var-name sym marks fst) =>
- (lambda (var-name) (values var-name marks)))
- (else (search sym (cdr subst) marks))))
- (else
- (error 'sc-expand
- "internal error in id-var-name-loc&marks: improper subst ~s"
- subst)))))))
- (define search-list-rib
- (lambda (sym subst marks symnames ribcage)
- (let f ((symnames symnames) (i 0))
- (if (null? symnames)
- (search sym (cdr subst) marks)
- (let ((x (car symnames)))
- (cond
- ((and (eq? x sym)
- (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values (list-ref (ribcage-labels ribcage) i) marks))
- ((import-interface? x)
- (let ((iface (import-interface-interface x))
- (new-marks (import-interface-new-marks x)))
- (cond
- ((interface-token iface) =>
- (lambda (token)
- (cond
- ((lookup-import-binding-name sym marks token new-marks) =>
- (lambda (id)
- (values
- (if (symbol? id) id (resolved-id-var-name id))
- marks)))
- (else (f (cdr symnames) i)))))
- (else
- (let* ((ie (interface-exports iface))
- (n (vector-length ie)))
- (let g ((j 0))
- (if (fx= j n)
- (f (cdr symnames) i)
- (let ((id (vector-ref ie j)))
- (let ((id.sym (id-sym-name id))
- (id.marks (join-marks new-marks (id-marks id))))
- (if (help-bound-id=? id.sym id.marks sym marks)
- (values (lookup-import-label id) marks)
- (g (fx+ j 1))))))))))))
- ((and (eq? x barrier-marker)
- (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values #f marks))
- (else (f (cdr symnames) (fx+ i 1)))))))))
- (define search-vector-rib
- (lambda (sym subst marks symnames ribcage)
- (let ((n (vector-length symnames)))
- (let f ((i 0))
- (cond
- ((fx= i n) (search sym (cdr subst) marks))
- ((and (eq? (vector-ref symnames i) sym)
- (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
- (values (vector-ref (ribcage-labels ribcage) i) marks))
- (else (f (fx+ i 1))))))))
- (cond
- ((symbol? id) (search id (wrap-subst w) (wrap-marks w)))
- ((syntax-object? id)
- (let ((sym (unannotate (syntax-object-expression id)))
- (w1 (syntax-object-wrap id)))
- (let-values (((name marks) (search sym (wrap-subst w)
- (join-marks
- (wrap-marks w)
- (wrap-marks w1)))))
- (if name
- (values name marks)
- (search sym (wrap-subst w1) marks)))))
- ((annotation? id) (search (unannotate id) (wrap-subst w) (wrap-marks w)))
- (else (error-hook 'id-var-name "invalid id" id)))))
-
-(define id-var-name&marks
- ; this version follows indirect labels
- (lambda (id w)
- (let-values (((label marks) (id-var-name-loc&marks id w)))
- (values (if (indirect-label? label) (get-indirect-label label) label) marks))))
-
-(define id-var-name-loc
- ; this version doesn't follow indirect labels
- (lambda (id w)
- (let-values (((label marks) (id-var-name-loc&marks id w)))
- label)))
-
-(define id-var-name
- ; this version follows indirect labels
- (lambda (id w)
- (let-values (((label marks) (id-var-name-loc&marks id w)))
- (if (indirect-label? label) (get-indirect-label label) label))))
-
-;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
-;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
-
-(define free-id=?
- (lambda (i j)
- (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
- (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
-
-(define literal-id=?
- (lambda (id literal)
- (and (eq? (id-sym-name id) (id-sym-name literal))
- (let ((n-id (id-var-name id empty-wrap))
- (n-literal (id-var-name literal empty-wrap)))
- (or (eq? n-id n-literal)
- (and (or (not n-id) (symbol? n-id))
- (or (not n-literal) (symbol? n-literal))))))))
-
-;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
-;;; long as the missing portion of the wrap is common to both of the ids
-;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
-
-(define help-bound-id=?
- (lambda (i.sym i.marks j.sym j.marks)
- (and (eq? i.sym j.sym)
- (same-marks? i.marks j.marks))))
-
-(define bound-id=?
- (lambda (i j)
- (help-bound-id=? (id-sym-name i) (id-marks i) (id-sym-name j) (id-marks j))))
-
-;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
-;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
-;;; as long as the missing portion of the wrap is common to all of the
-;;; ids.
-
-(define valid-bound-ids?
- (lambda (ids)
- (and (let all-ids? ((ids ids))
- (or (null? ids)
- (and (id? (car ids))
- (all-ids? (cdr ids)))))
- (distinct-bound-ids? ids))))
-
-;;; distinct-bound-ids? expects a list of ids and returns #t if there are
-;;; no duplicates. It is quadratic on the length of the id list; long
-;;; lists could be sorted to make it more efficient. distinct-bound-ids?
-;;; may be passed unwrapped (or partially wrapped) ids as long as the
-;;; missing portion of the wrap is common to all of the ids.
-
-(define distinct-bound-ids?
- (lambda (ids)
- (let distinct? ((ids ids))
- (or (null? ids)
- (and (not (bound-id-member? (car ids) (cdr ids)))
- (distinct? (cdr ids)))))))
-
-(define invalid-ids-error
- ; find first bad one and complain about it
- (lambda (ids exp class)
- (let find ((ids ids) (gooduns '()))
- (if (null? ids)
- (syntax-error exp) ; shouldn't happen
- (if (id? (car ids))
- (if (bound-id-member? (car ids) gooduns)
- (syntax-error (car ids) "duplicate " class)
- (find (cdr ids) (cons (car ids) gooduns)))
- (syntax-error (car ids) "invalid " class))))))
-
-(define bound-id-member?
- (lambda (x list)
- (and (not (null? list))
- (or (bound-id=? x (car list))
- (bound-id-member? x (cdr list))))))
-
-;;; wrapping expressions and identifiers
-
-(define wrap
- (lambda (x w)
- (cond
- ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
- ((syntax-object? x)
- (make-syntax-object
- (syntax-object-expression x)
- (join-wraps w (syntax-object-wrap x))))
- ((null? x) x)
- (else (make-syntax-object x w)))))
-
-(define source-wrap
- (lambda (x w ae)
- (wrap (if (annotation? ae)
- (begin
- (unless (eq? (annotation-expression ae) x)
- (error 'sc-expand "internal error in source-wrap: ae/x mismatch"))
- ae)
- x)
- w)))
-
-;;; expanding
-
-(define chi-when-list
- (lambda (when-list w)
- ; when-list is syntax'd version of list of situations
- (map (lambda (x)
- (cond
- ((literal-id=? x (syntax compile)) 'compile)
- ((literal-id=? x (syntax load)) 'load)
- ((literal-id=? x (syntax visit)) 'visit)
- ((literal-id=? x (syntax revisit)) 'revisit)
- ((literal-id=? x (syntax eval)) 'eval)
- (else (syntax-error (wrap x w) "invalid eval-when situation"))))
- when-list)))
-
-;;; syntax-type returns five values: type, value, e, w, and ae. The first
-;;; two are described in the table below.
-;;;
-;;; type value explanation
-;;; -------------------------------------------------------------------
-;;; alias none alias keyword
-;;; alias-form none alias expression
-;;; begin none begin keyword
-;;; begin-form none begin expression
-;;; call none any other call
-;;; constant none self-evaluating datum
-;;; core procedure core form (including singleton)
-;;; define none define keyword
-;;; define-form none variable definition
-;;; define-syntax none define-syntax keyword
-;;; define-syntax-form none syntax definition
-;;; displaced-lexical none displaced lexical identifier
-;;; eval-when none eval-when keyword
-;;; eval-when-form none eval-when form
-;;; global name global variable reference
-;;; $import none $import keyword
-;;; $import-form none $import form
-;;; lexical name lexical variable reference
-;;; lexical-call name call to lexical variable
-;;; local-syntax rec? letrec-syntax/let-syntax keyword
-;;; local-syntax-form rec? syntax definition
-;;; meta none meta keyword
-;;; meta-form none meta form
-;;; meta-variable name meta variable
-;;; $module none $module keyword
-;;; $module-form none $module definition
-;;; syntax level pattern variable
-;;; other none anything else
-;;;
-;;; For all forms, e is the form, w is the wrap for e. and ae is the
-;;; (possibly) source-annotated form.
-;;;
-;;; syntax-type expands macros and unwraps as necessary to get to
-;;; one of the forms above.
-
-(define syntax-type
- (lambda (e r w ae rib)
- (cond
- ((symbol? e)
- (let* ((n (id-var-name e w))
- (b (lookup n r))
- (type (binding-type b)))
- (case type
- ((macro macro!) (syntax-type (chi-macro (binding-value b) e r w ae rib) r empty-wrap #f rib))
- (else (values type (binding-value b) e w ae)))))
- ((pair? e)
- (let ((first (car e)))
- (if (id? first)
- (let* ((n (id-var-name first w))
- (b (lookup n r))
- (type (binding-type b)))
- (case type
- ((lexical) (values 'lexical-call (binding-value b) e w ae))
- ((macro macro!)
- (syntax-type (chi-macro (binding-value b) e r w ae rib)
- r empty-wrap #f rib))
- ((core) (values type (binding-value b) e w ae))
- ((begin) (values 'begin-form #f e w ae))
- ((alias) (values 'alias-form #f e w ae))
- ((define) (values 'define-form #f e w ae))
- ((define-syntax) (values 'define-syntax-form #f e w ae))
- ((set!) (chi-set! e r w ae rib))
- (($module-key) (values '$module-form #f e w ae))
- (($import) (values '$import-form #f e w ae))
- ((eval-when) (values 'eval-when-form #f e w ae))
- ((meta) (values 'meta-form #f e w ae))
- ((local-syntax)
- (values 'local-syntax-form (binding-value b) e w ae))
- (else (values 'call #f e w ae))))
- (values 'call #f e w ae))))
- ((syntax-object? e)
- (syntax-type (syntax-object-expression e)
- r
- (join-wraps w (syntax-object-wrap e))
- #f rib))
- ((annotation? e)
- (syntax-type (annotation-expression e) r w e rib))
- ((self-evaluating? e) (values 'constant #f e w ae))
- (else (values 'other #f e w ae)))))
-
-(define chi-top*
- (lambda (e r w ctem rtem meta? top-ribcage)
- (let ((meta-residuals '()))
- (define meta-residualize!
- (lambda (x)
- (set! meta-residuals
- (cons x meta-residuals))))
- (let ((e (chi-top e r w ctem rtem meta? top-ribcage meta-residualize! #f)))
- (build-sequence no-source
- (reverse (cons e meta-residuals)))))))
-
-(define chi-top-sequence
- (lambda (body r w ae ctem rtem meta? ribcage meta-residualize!)
- (build-sequence ae
- (let dobody ((body body))
- (if (null? body)
- '()
- (let ((first (chi-top (car body) r w ctem rtem meta? ribcage meta-residualize! #f)))
- (cons first (dobody (cdr body)))))))))
-
-(define chi-top
- (lambda (e r w ctem rtem meta? top-ribcage meta-residualize! meta-seen?)
- (let-values (((type value e w ae) (syntax-type e r w no-source top-ribcage)))
- (case type
- ((begin-form)
- (let ((forms (parse-begin e w ae #t)))
- (if (null? forms)
- (chi-void)
- (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!))))
- ((local-syntax-form)
- (let-values (((forms r mr w ae) (chi-local-syntax value e r r w ae)))
- ; mr should be same as r here
- (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!)))
- ((eval-when-form)
- (let-values (((when-list forms) (parse-eval-when e w ae)))
- (let ((ctem (update-mode-set when-list ctem))
- (rtem (update-mode-set when-list rtem)))
- (if (and (null? ctem) (null? rtem))
- (chi-void)
- (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!)))))
- ((meta-form) (chi-top (parse-meta e w ae) r w ctem rtem #t top-ribcage meta-residualize! #t))
- ((define-syntax-form)
- (let-values (((id rhs w) (parse-define-syntax e w ae)))
- (let ((id (wrap id w)))
- (when (displaced-lexical? id r) (displaced-lexical-error id))
- (unless (top-ribcage-mutable? top-ribcage)
- (syntax-error (source-wrap e w ae)
- "invalid definition in read-only environment"))
- (let ((sym (id-sym-name id)))
- (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap id)) top-ribcage)))
- (unless (eq? (id-var-name id empty-wrap) valsym)
- (syntax-error (source-wrap e w ae)
- "definition not permitted"))
- (when (read-only-binding? valsym)
- (syntax-error (source-wrap e w ae)
- "invalid definition of read-only identifier"))
- (ct-eval/residualize2 ctem
- (lambda ()
- (build-cte-install
- bound-id
- (chi rhs r r w #t)
- (top-ribcage-key top-ribcage)))))))))
- ((define-form)
- (let-values (((id rhs w) (parse-define e w ae)))
- (let ((id (wrap id w)))
- (when (displaced-lexical? id r) (displaced-lexical-error id))
- (unless (top-ribcage-mutable? top-ribcage)
- (syntax-error (source-wrap e w ae)
- "invalid definition in read-only environment"))
- (let ((sym (id-sym-name id)))
- (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap id)) top-ribcage)))
- (unless (eq? (id-var-name id empty-wrap) valsym)
- (syntax-error (source-wrap e w ae)
- "definition not permitted"))
- (when (read-only-binding? valsym)
- (syntax-error (source-wrap e w ae)
- "invalid definition of read-only identifier"))
- (if meta?
- (ct-eval/residualize2 ctem
- (lambda ()
- (build-sequence no-source
- (list
- (build-cte-install bound-id
- (build-data no-source (make-binding 'meta-variable valsym))
- (top-ribcage-key top-ribcage))
- (build-global-definition ae valsym (chi rhs r r w #t))))))
- ; make sure compile-time definitions occur before we
- ; expand the run-time code
- (let ((x (ct-eval/residualize2 ctem
- (lambda ()
- (build-cte-install
- bound-id
- (build-data no-source (make-binding 'global valsym))
- (top-ribcage-key top-ribcage))))))
- (build-sequence no-source
- (list
- x
- (rt-eval/residualize rtem
- (lambda ()
- (build-global-definition ae valsym (chi rhs r r w #f)))))))))
- ))))
- (($module-form)
- (let ((ribcage (make-empty-ribcage)))
- (let-values (((orig id exports forms)
- (parse-module e w ae
- (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))))
- (when (displaced-lexical? id r) (displaced-lexical-error (wrap id w)))
- (unless (top-ribcage-mutable? top-ribcage)
- (syntax-error orig
- "invalid definition in read-only environment"))
- (chi-top-module orig r r top-ribcage ribcage ctem rtem meta? id exports forms meta-residualize!))))
- (($import-form)
- (let-values (((orig only? mid) (parse-import e w ae)))
- (unless (top-ribcage-mutable? top-ribcage)
- (syntax-error orig
- "invalid definition in read-only environment"))
- (ct-eval/residualize2 ctem
- (lambda ()
- (let ((binding (lookup (id-var-name mid empty-wrap) null-env)))
- (case (binding-type binding)
- (($module) (do-top-import only? top-ribcage mid (interface-token (binding-value binding))))
- ((displaced-lexical) (displaced-lexical-error mid))
- (else (syntax-error mid "unknown module"))))))))
- ((alias-form)
- (let-values (((new-id old-id) (parse-alias e w ae)))
- (let ((new-id (wrap new-id w)))
- (when (displaced-lexical? new-id r) (displaced-lexical-error new-id))
- (unless (top-ribcage-mutable? top-ribcage)
- (syntax-error (source-wrap e w ae)
- "invalid definition in read-only environment"))
- (let ((sym (id-sym-name new-id)))
- (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap new-id)) top-ribcage)))
- (unless (eq? (id-var-name new-id empty-wrap) valsym)
- (syntax-error (source-wrap e w ae)
- "definition not permitted"))
- (when (read-only-binding? valsym)
- (syntax-error (source-wrap e w ae)
- "invalid definition of read-only identifier"))
- (ct-eval/residualize2 ctem
- (lambda ()
- (build-cte-install
- (make-resolved-id sym (wrap-marks (syntax-object-wrap new-id)) (id-var-name old-id w))
- (build-data no-source (make-binding 'do-alias #f))
- (top-ribcage-key top-ribcage)))))))))
- (else
- (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
- (if meta?
- (let ((x (chi-expr type value e r r w ae #t)))
- (top-level-eval-hook x)
- (ct-eval/residualize3 ctem void (lambda () x)))
- (rt-eval/residualize rtem
- (lambda ()
- (chi-expr type value e r r w ae #f)))))))))
-
-(define flatten-exports
- (lambda (exports)
- (let loop ((exports exports) (ls '()))
- (if (null? exports)
- ls
- (loop (cdr exports)
- (if (pair? (car exports))
- (loop (car exports) ls)
- (cons (car exports) ls)))))))
-
-
-(define-structure (interface marks exports token))
-
-;; leaves interfaces unresolved so that indirect labels can be followed.
-;; (can't resolve until indirect labels have their final value)
-(define make-unresolved-interface
- ; trim out implicit exports
- (lambda (mid exports)
- (make-interface
- (wrap-marks (syntax-object-wrap mid))
- (list->vector (map (lambda (x) (if (pair? x) (car x) x)) exports))
- #f)))
-
-(define make-resolved-interface
- ; trim out implicit exports & resolve others to actual top-level symbol
- (lambda (mid exports token)
- (make-interface
- (wrap-marks (syntax-object-wrap mid))
- (list->vector (map (lambda (x) (id->resolved-id (if (pair? x) (car x) x))) exports))
- token)))
-
-(define-structure (module-binding type id label imps val exported))
-(define create-module-binding
- (lambda (type id label imps val)
- (make-module-binding type id label imps val #f)))
-
-;;; frobs represent body forms
-(define-structure (frob e meta?))
-
-(define chi-top-module
- (lambda (orig r mr top-ribcage ribcage ctem rtem meta? id exports forms meta-residualize!)
- (let ((fexports (flatten-exports exports)))
- (let-values (((r mr bindings inits)
- (chi-external ribcage orig
- (map (lambda (d) (make-frob d meta?)) forms) r mr ctem exports fexports
- meta-residualize!)))
- ; identify exported identifiers, create ctdefs
- (let process-exports ((fexports fexports) (ctdefs (lambda () '())))
- (if (null? fexports)
- ; remaining bindings are either identified global vars,
- ; local vars, or local compile-time entities
- ; dts: type (local/global)
- ; dvs & des: define lhs & rhs
- (let process-locals ((bs bindings) (r r) (dts '()) (dvs '()) (des '()))
- (if (null? bs)
- (let ((des (chi-frobs des r mr #f))
- (inits (chi-frobs inits r mr #f)))
- (build-sequence no-source
- (append
- ; we wait to establish global compile-time definitions so that
- ; expansion of des use local versions of modules and macros
- ; in case ctem tells us not to eval ctdefs now. this means that
- ; local code can use exported compile-time values (modules, macros,
- ; meta variables) just as it can unexported ones.
- (ctdefs)
- (list
- (ct-eval/residualize2 ctem
- (lambda ()
- (let ((sym (id-sym-name id)))
- (let* ((token (generate-id sym))
- (b (build-data no-source
- (make-binding '$module
- (make-resolved-interface id exports token)))))
- (let-values (((valsym bound-id)
- (top-id-bound-var-name sym
- (wrap-marks (syntax-object-wrap id))
- top-ribcage)))
- (unless (eq? (id-var-name id empty-wrap) valsym)
- (syntax-error orig
- "definition not permitted"))
- (when (read-only-binding? valsym)
- (syntax-error orig
- "invalid definition of read-only identifier"))
- (build-cte-install bound-id b
- (top-ribcage-key top-ribcage)))))))
- (rt-eval/residualize rtem
- (lambda ()
- (build-top-module no-source dts dvs des
- (if (null? inits)
- (chi-void)
- (build-sequence no-source
- (append inits (list (chi-void))))))))))))
- (let ((b (car bs)) (bs (cdr bs)))
- (let ((t (module-binding-type b)))
- (case (module-binding-type b)
- ((define-form)
- (let ((label (get-indirect-label (module-binding-label b))))
- (if (module-binding-exported b)
- (let ((var (module-binding-id b)))
- (process-locals bs r (cons 'global dts) (cons label dvs)
- (cons (module-binding-val b) des)))
- (let ((var (gen-var (module-binding-id b))))
- (process-locals bs
- ; add lexical bindings only to run-time environment
- (extend-env label (make-binding 'lexical var) r)
- (cons 'local dts) (cons var dvs)
- (cons (module-binding-val b) des))))))
- ((ctdefine-form define-syntax-form $module-form alias-form) (process-locals bs r dts dvs des))
- (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))))
- (let ((id (car fexports)) (fexports (cdr fexports)))
- (let loop ((bs bindings))
- (if (null? bs)
- ; must be rexport from an imported module
- (process-exports fexports ctdefs)
- (let ((b (car bs)) (bs (cdr bs)))
- ; following formerly used bound-id=?, but free-id=? can prevent false positives
- ; and is okay since the substitutions have already been applied
- (if (free-id=? (module-binding-id b) id)
- (if (module-binding-exported b)
- (process-exports fexports ctdefs)
- (let* ((t (module-binding-type b))
- (label (module-binding-label b))
- (imps (module-binding-imps b))
- (fexports (append imps fexports)))
- (set-module-binding-exported! b #t)
- (case t
- ((define-form)
- (let ((sym (generate-id (id-sym-name id))))
- (set-indirect-label! label sym)
- (process-exports fexports ctdefs)))
- ((ctdefine-form)
- (let ((b (module-binding-val b)))
- (process-exports fexports
- (lambda ()
- (let ((sym (binding-value b)))
- (set-indirect-label! label sym)
- (cons (ct-eval/residualize3 ctem
- (lambda () (put-cte-hook sym b))
- (lambda () (build-cte-install sym (build-data no-source b) #f)))
- (ctdefs)))))))
- ((define-syntax-form)
- (let ((sym (generate-id (id-sym-name id))))
- (process-exports fexports
- (lambda ()
- (let ((local-label (get-indirect-label label)))
- (set-indirect-label! label sym)
- (cons
- (ct-eval/residualize3 ctem
- (lambda () (put-cte-hook sym (car (module-binding-val b))))
- (lambda () (build-cte-install sym (cdr (module-binding-val b)) #f)))
- (ctdefs)))))))
- (($module-form)
- (let ((sym (generate-id (id-sym-name id)))
- (exports (module-binding-val b)))
- (process-exports (append (flatten-exports exports) fexports)
- (lambda ()
- (set-indirect-label! label sym)
- (let ((rest (ctdefs))) ; set indirect labels before resolving
- (let ((x (make-binding '$module (make-resolved-interface id exports sym))))
- (cons (ct-eval/residualize3 ctem
- (lambda () (put-cte-hook sym x))
- (lambda () (build-cte-install sym (build-data no-source x) #f)))
- rest)))))))
- ((alias-form)
- (process-exports
- fexports
- (lambda ()
- (let ((rest (ctdefs))) ; set indirect labels before resolving
- (when (indirect-label? label)
- (unless (symbol? (get-indirect-label label))
- (syntax-error (module-binding-id b) "unexported target of alias")))
- rest))))
- (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))
- (loop bs))))))))))))
-
-(define id-set-diff
- (lambda (exports defs)
- (cond
- ((null? exports) '())
- ((bound-id-member? (car exports) defs) (id-set-diff (cdr exports) defs))
- (else (cons (car exports) (id-set-diff (cdr exports) defs))))))
-
-(define check-module-exports
- ; After processing the definitions of a module this is called to verify that the
- ; module has defined or imported each exported identifier. Because ids in fexports are
- ; wrapped with the given ribcage, they will contain substitutions for anything defined
- ; or imported here. These subsitutions can be used by do-import! and do-import-top! to
- ; provide access to reexported bindings, for example.
- (lambda (source-exp fexports ids)
- (define defined?
- (lambda (e ids)
- (ormap (lambda (x)
- (if (import-interface? x)
- (let ((x.iface (import-interface-interface x))
- (x.new-marks (import-interface-new-marks x)))
- (cond
- ((interface-token x.iface) =>
- (lambda (token)
- (lookup-import-binding-name (id-sym-name e) (id-marks e) token x.new-marks)))
- (else
- (let ((v (interface-exports x.iface)))
- (let lp ((i (fx- (vector-length v) 1)))
- (and (fx>= i 0)
- (or (let ((id (vector-ref v i)))
- (help-bound-id=?
- (id-sym-name id)
- (join-marks x.new-marks (id-marks id))
- (id-sym-name e) (id-marks e)))
- (lp (fx- i 1)))))))))
- (bound-id=? e x)))
- ids)))
- (let loop ((fexports fexports) (missing '()))
- (if (null? fexports)
- (unless (null? missing)
- (syntax-error (car missing)
- (if (= (length missing) 1)
- "missing definition for export"
- "missing definition for multiple exports, including")))
- (let ((e (car fexports)) (fexports (cdr fexports)))
- (if (defined? e ids)
- (loop fexports missing)
- (loop fexports (cons e missing))))))))
-
-(define check-defined-ids
- (lambda (source-exp ls)
- (define vfold
- (lambda (v p cls)
- (let ((len (vector-length v)))
- (let lp ((i 0) (cls cls))
- (if (fx= i len)
- cls
- (lp (fx+ i 1) (p (vector-ref v i) cls)))))))
- (define conflicts
- (lambda (x y cls)
- (if (import-interface? x)
- (let ((x.iface (import-interface-interface x))
- (x.new-marks (import-interface-new-marks x)))
- (if (import-interface? y)
- (let ((y.iface (import-interface-interface y))
- (y.new-marks (import-interface-new-marks y)))
- (let ((xe (interface-exports x.iface)) (ye (interface-exports y.iface)))
- (if (fx> (vector-length xe) (vector-length ye))
- (vfold ye
- (lambda (id cls)
- (id-iface-conflicts id y.new-marks x.iface x.new-marks cls)) cls)
- (vfold xe
- (lambda (id cls)
- (id-iface-conflicts id x.new-marks y.iface y.new-marks cls)) cls))))
- (id-iface-conflicts y '() x.iface x.new-marks cls)))
- (if (import-interface? y)
- (let ((y.iface (import-interface-interface y))
- (y.new-marks (import-interface-new-marks y)))
- (id-iface-conflicts x '() y.iface y.new-marks cls))
- (if (bound-id=? x y) (cons x cls) cls)))))
- (define id-iface-conflicts
- (lambda (id id.new-marks iface iface.new-marks cls)
- (let ((id.sym (id-sym-name id))
- (id.marks (join-marks id.new-marks (id-marks id))))
- (cond
- ((interface-token iface) =>
- (lambda (token)
- (if (lookup-import-binding-name id.sym id.marks token iface.new-marks)
- (cons id cls)
- cls)))
- (else
- (vfold (interface-exports iface)
- (lambda (*id cls)
- (let ((*id.sym (id-sym-name *id))
- (*id.marks (join-marks iface.new-marks (id-marks *id))))
- (if (help-bound-id=? *id.sym *id.marks id.sym id.marks)
- (cons *id cls)
- cls)))
- cls))))))
- (unless (null? ls)
- (let lp ((x (car ls)) (ls (cdr ls)) (cls '()))
- (if (null? ls)
- (unless (null? cls)
- (let ((cls (syntax-object->datum cls)))
- (syntax-error source-exp "duplicate definition for "
- (symbol->string (car cls))
- " in")))
- (let lp2 ((ls2 ls) (cls cls))
- (if (null? ls2)
- (lp (car ls) (cdr ls) cls)
- (lp2 (cdr ls2) (conflicts x (car ls2) cls)))))))))
-
-(define chi-external
- (lambda (ribcage source-exp body r mr ctem exports fexports meta-residualize!)
- (define return
- (lambda (r mr bindings ids inits)
- (check-defined-ids source-exp ids)
- (check-module-exports source-exp fexports ids)
- (values r mr bindings inits)))
- (define get-implicit-exports
- (lambda (id)
- (let f ((exports exports))
- (if (null? exports)
- '()
- (if (and (pair? (car exports)) (bound-id=? id (caar exports)))
- (flatten-exports (cdar exports))
- (f (cdr exports)))))))
- (define update-imp-exports
- (lambda (bindings exports)
- (let ((exports (map (lambda (x) (if (pair? x) (car x) x)) exports)))
- (map (lambda (b)
- (let ((id (module-binding-id b)))
- (if (not (bound-id-member? id exports))
- b
- (create-module-binding
- (module-binding-type b)
- id
- (module-binding-label b)
- (append (get-implicit-exports id) (module-binding-imps b))
- (module-binding-val b)))))
- bindings))))
- (let parse ((body body) (r r) (mr mr) (ids '()) (bindings '()) (inits '()) (meta-seen? #f))
- (if (null? body)
- (return r mr bindings ids inits)
- (let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
- (let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
- (case type
- ((define-form)
- (let-values (((id rhs w) (parse-define e w ae)))
- (let* ((id (wrap id w))
- (label (gen-indirect-label))
- (imps (get-implicit-exports id)))
- (extend-ribcage! ribcage id label)
- (cond
- (meta?
- (let* ((sym (generate-id (id-sym-name id)))
- (b (make-binding 'meta-variable sym)))
- ; add meta bindings only to meta environment
- (let ((mr (extend-env (get-indirect-label label) b mr)))
- (let ((exp (chi rhs mr mr w #t)))
- (define-top-level-value-hook sym (top-level-eval-hook exp))
- (meta-residualize!
- (ct-eval/residualize3 ctem
- void
- (lambda () (build-global-definition no-source sym exp))))
- (parse (cdr body) r mr
- (cons id ids)
- (cons (create-module-binding 'ctdefine-form id label imps b) bindings)
- inits
- #f)))))
- (else
- (parse (cdr body) r mr
- (cons id ids)
- (cons (create-module-binding type id label
- imps (make-frob (wrap rhs w) meta?))
- bindings)
- inits
- #f))))))
- ((define-syntax-form)
- (let-values (((id rhs w) (parse-define-syntax e w ae)))
- (let* ((id (wrap id w))
- (label (gen-indirect-label))
- (imps (get-implicit-exports id))
- (exp (chi rhs mr mr w #t)))
- (extend-ribcage! ribcage id label)
- (let ((l (get-indirect-label label)) (b (defer-or-eval-transformer top-level-eval-hook exp)))
- (parse (cdr body)
- (extend-env l b r)
- (extend-env l b mr)
- (cons id ids)
- (cons (create-module-binding type id label imps (cons b exp))
- bindings)
- inits
- #f)))))
- (($module-form)
- (let* ((*ribcage (make-empty-ribcage))
- (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
- (let-values (((orig id *exports forms) (parse-module e w ae *w)))
- (let-values (((r mr *bindings *inits)
- (chi-external *ribcage orig
- (map (lambda (d) (make-frob d meta?)) forms)
- r mr ctem *exports (flatten-exports *exports) meta-residualize!)))
- (let ((iface (make-unresolved-interface id *exports))
- (bindings (append *bindings bindings))
- (inits (append inits *inits))
- (label (gen-indirect-label))
- (imps (get-implicit-exports id)))
- (extend-ribcage! ribcage id label)
- (let ((l (get-indirect-label label)) (b (make-binding '$module iface)))
- (parse (cdr body)
- (extend-env l b r)
- (extend-env l b mr)
- (cons id ids)
- (cons (create-module-binding type id label imps *exports) bindings)
- inits
- #f)))))))
- (($import-form)
- (let-values (((orig only? mid) (parse-import e w ae)))
- (let ((mlabel (id-var-name mid empty-wrap)))
- (let ((binding (lookup mlabel r)))
- (case (binding-type binding)
- (($module)
- (let* ((iface (binding-value binding))
- (import-iface (make-import-interface iface (import-mark-delta mid iface))))
- (when only? (extend-ribcage-barrier! ribcage mid))
- (do-import! import-iface ribcage)
- (parse (cdr body) r mr
- (cons import-iface ids)
- (update-imp-exports bindings (vector->list (interface-exports iface)))
- inits
- #f)))
- ((displaced-lexical) (displaced-lexical-error mid))
- (else (syntax-error mid "unknown module")))))))
- ((alias-form)
- (let-values (((new-id old-id) (parse-alias e w ae)))
- (let* ((new-id (wrap new-id w))
- (label (id-var-name-loc old-id w))
- (imps (get-implicit-exports new-id)))
- (extend-ribcage! ribcage new-id label)
- (parse (cdr body) r mr
- (cons new-id ids)
- (cons (create-module-binding type new-id label imps #f)
- bindings)
- inits
- #f))))
- ((begin-form)
- (parse (let f ((forms (parse-begin e w ae #t)))
- (if (null? forms)
- (cdr body)
- (cons (make-frob (wrap (car forms) w) meta?)
- (f (cdr forms)))))
- r mr ids bindings inits #f))
- ((eval-when-form)
- (let-values (((when-list forms) (parse-eval-when e w ae)))
- (parse (if (memq 'eval when-list) ; mode set is implicitly (E)
- (let f ((forms forms))
- (if (null? forms)
- (cdr body)
- (cons (make-frob (wrap (car forms) w) meta?)
- (f (cdr forms)))))
- (cdr body))
- r mr ids bindings inits #f)))
- ((meta-form)
- (parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
- (cdr body))
- r mr ids bindings inits #t))
- ((local-syntax-form)
- (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
- (parse (let f ((forms forms))
- (if (null? forms)
- (cdr body)
- (cons (make-frob (wrap (car forms) w) meta?)
- (f (cdr forms)))))
- r mr ids bindings inits #f)))
- (else ; found an init expression
- (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
- (let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
- (if (or (null? body) (not (frob-meta? (car body))))
- (return r mr bindings ids (append inits body))
- (begin
- ; expand and eval meta inits for effect only
- (let ((x (chi-meta-frob (car body) mr)))
- (top-level-eval-hook x)
- (meta-residualize! (ct-eval/residualize3 ctem void (lambda () x))))
- (f (cdr body)))))))))))))
-
-(define vmap
- (lambda (fn v)
- (do ((i (fx- (vector-length v) 1) (fx- i 1))
- (ls '() (cons (fn (vector-ref v i)) ls)))
- ((fx< i 0) ls))))
-
-(define vfor-each
- (lambda (fn v)
- (let ((len (vector-length v)))
- (do ((i 0 (fx+ i 1)))
- ((fx= i len))
- (fn (vector-ref v i))))))
-
-(define do-top-import
- (lambda (import-only? top-ribcage mid token)
- ; silently treat import-only like regular import at top level
- (build-cte-install mid
- (build-data no-source
- (make-binding 'do-import token))
- (top-ribcage-key top-ribcage))))
-
-(define update-mode-set
- (let ((table
- '((L (load . L) (compile . C) (visit . V) (revisit . R) (eval . -))
- (C (load . -) (compile . -) (visit . -) (revisit . -) (eval . C))
- (V (load . V) (compile . C) (visit . V) (revisit . -) (eval . -))
- (R (load . R) (compile . C) (visit . -) (revisit . R) (eval . -))
- (E (load . -) (compile . -) (visit . -) (revisit . -) (eval . E)))))
- (lambda (when-list mode-set)
- (define remq
- (lambda (x ls)
- (if (null? ls)
- '()
- (if (eq? (car ls) x)
- (remq x (cdr ls))
- (cons (car ls) (remq x (cdr ls)))))))
- (remq '-
- (apply append
- (map (lambda (m)
- (let ((row (cdr (assq m table))))
- (map (lambda (s) (cdr (assq s row)))
- when-list)))
- mode-set))))))
-
-(define initial-mode-set
- (lambda (when-list compiling-a-file)
- (apply append
- (map (lambda (s)
- (if compiling-a-file
- (case s
- ((compile) '(C))
- ((load) '(L))
- ((visit) '(V))
- ((revisit) '(R))
- (else '()))
- (case s
- ((eval) '(E))
- (else '()))))
- when-list))))
-
-(define rt-eval/residualize
- (lambda (rtem thunk)
- (if (memq 'E rtem)
- (thunk)
- (let ((thunk (if (memq 'C rtem)
- (let ((x (thunk)))
- (top-level-eval-hook x)
- (lambda () x))
- thunk)))
- (if (memq 'V rtem)
- (if (or (memq 'L rtem) (memq 'R rtem))
- (thunk) ; visit-revisit
- (build-visit-only (thunk)))
- (if (or (memq 'L rtem) (memq 'R rtem))
- (build-revisit-only (thunk))
- (chi-void)))))))
-
-(define ct-eval/residualize2
- (lambda (ctem thunk)
- (let ((t #f))
- (ct-eval/residualize3 ctem
- (lambda ()
- (unless t (set! t (thunk)))
- (top-level-eval-hook t))
- (lambda () (or t (thunk)))))))
-(define ct-eval/residualize3
- (lambda (ctem eval-thunk residualize-thunk)
- (if (memq 'E ctem)
- (begin (eval-thunk) (chi-void))
- (begin
- (when (memq 'C ctem) (eval-thunk))
- (if (memq 'R ctem)
- (if (or (memq 'L ctem) (memq 'V ctem))
- (residualize-thunk) ; visit-revisit
- (build-revisit-only (residualize-thunk)))
- (if (or (memq 'L ctem) (memq 'V ctem))
- (build-visit-only (residualize-thunk))
- (chi-void)))))))
-
-(define chi-frobs
- (lambda (frob* r mr m?)
- (map (lambda (x) (chi (frob-e x) r mr empty-wrap m?)) frob*)))
-
-(define chi-meta-frob
- (lambda (x mr)
- (chi (frob-e x) mr mr empty-wrap #t)))
-
-(define chi-sequence
- (lambda (body r mr w ae m?)
- (build-sequence ae
- (let dobody ((body body))
- (if (null? body)
- '()
- (let ((first (chi (car body) r mr w m?)))
- (cons first (dobody (cdr body)))))))))
-
-(define chi
- (lambda (e r mr w m?)
- (let-values (((type value e w ae) (syntax-type e r w no-source #f)))
- (chi-expr type value e r mr w ae m?))))
-
-(define chi-expr
- (lambda (type value e r mr w ae m?)
- (case type
- ((lexical)
- (build-lexical-reference 'value ae value))
- ((core) (value e r mr w ae m?))
- ((lexical-call)
- (chi-application
- (build-lexical-reference 'fun
- (let ((x (car e)))
- (if (syntax-object? x) (syntax-object-expression x) x))
- value)
- e r mr w ae m?))
- ((constant) (build-data ae (strip (source-wrap e w ae) empty-wrap)))
- ((global) (build-global-reference ae value))
- ((meta-variable)
- (if m?
- (build-global-reference ae value)
- (displaced-lexical-error (source-wrap e w ae))))
- ((call) (chi-application (chi (car e) r mr w m?) e r mr w ae m?))
- ((begin-form) (chi-sequence (parse-begin e w ae #f) r mr w ae m?))
- ((local-syntax-form)
- (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
- (chi-sequence forms r mr w ae m?)))
- ((eval-when-form)
- (let-values (((when-list forms) (parse-eval-when e w ae)))
- (if (memq 'eval when-list) ; mode set is implicitly (E)
- (chi-sequence forms r mr w ae m?)
- (chi-void))))
- ((meta-form)
- (syntax-error (source-wrap e w ae) "invalid context for meta definition"))
- ((define-form)
- (parse-define e w ae)
- (syntax-error (source-wrap e w ae) "invalid context for definition"))
- ((define-syntax-form)
- (parse-define-syntax e w ae)
- (syntax-error (source-wrap e w ae) "invalid context for definition"))
- (($module-form)
- (let-values (((orig id exports forms) (parse-module e w ae w)))
- (syntax-error orig "invalid context for definition")))
- (($import-form)
- (let-values (((orig only? mid) (parse-import e w ae)))
- (syntax-error orig "invalid context for definition")))
- ((alias-form)
- (parse-alias e w ae)
- (syntax-error (source-wrap e w ae) "invalid context for definition"))
- ((syntax)
- (syntax-error (source-wrap e w ae)
- "reference to pattern variable outside syntax form"))
- ((displaced-lexical) (displaced-lexical-error (source-wrap e w ae)))
- (else (syntax-error (source-wrap e w ae))))))
-
-(define chi-application
- (lambda (x e r mr w ae m?)
- (syntax-case e ()
- ((e0 e1 ...)
- (build-application ae x
- (map (lambda (e) (chi e r mr w m?)) (syntax (e1 ...)))))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(define chi-set!
- (lambda (e r w ae rib)
- (syntax-case e ()
- ((_ id val)
- (id? (syntax id))
- (let ((n (id-var-name (syntax id) w)))
- (let ((b (lookup n r)))
- (case (binding-type b)
- ((macro!)
- (let ((id (wrap (syntax id) w)) (val (wrap (syntax val) w)))
- (syntax-type (chi-macro (binding-value b)
- `(,(syntax set!) ,id ,val)
- r empty-wrap #f rib) r empty-wrap #f rib)))
- (else
- (values 'core
- (lambda (e r mr w ae m?)
- ; repeat lookup in case we were first expression (init) in
- ; module or lambda body. we repeat id-var-name as well,
- ; although this is only necessary if we allow inits to
- ; preced definitions
- (let ((val (chi (syntax val) r mr w m?))
- (n (id-var-name (syntax id) w)))
- (let ((b (lookup n r)))
- (case (binding-type b)
- ((lexical) (build-lexical-assignment ae (binding-value b) val))
- ((global)
- (let ((sym (binding-value b)))
- (when (read-only-binding? n)
- (syntax-error (source-wrap e w ae)
- "invalid assignment to read-only variable"))
- (build-global-assignment ae sym val)))
- ((meta-variable)
- (if m?
- (build-global-assignment ae (binding-value b) val)
- (displaced-lexical-error (wrap (syntax id) w))))
- ((displaced-lexical)
- (displaced-lexical-error (wrap (syntax id) w)))
- (else (syntax-error (source-wrap e w ae)))))))
- e w ae))))))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(define chi-macro
- (lambda (p e r w ae rib)
- (define rebuild-macro-output
- (lambda (x m)
- (cond ((pair? x)
- (cons (rebuild-macro-output (car x) m)
- (rebuild-macro-output (cdr x) m)))
- ((syntax-object? x)
- (let ((w (syntax-object-wrap x)))
- (let ((ms (wrap-marks w)) (s (wrap-subst w)))
- (make-syntax-object (syntax-object-expression x)
- (if (and (pair? ms) (eq? (car ms) the-anti-mark))
- (make-wrap (cdr ms) (cdr s))
- (make-wrap (cons m ms)
- (if rib
- (cons rib (cons 'shift s))
- (cons 'shift s))))))))
- ((vector? x)
- (let* ((n (vector-length x)) (v (make-vector n)))
- (do ((i 0 (fx+ i 1)))
- ((fx= i n) v)
- (vector-set! v i
- (rebuild-macro-output (vector-ref x i) m)))))
- ((symbol? x)
- (syntax-error (source-wrap e w ae)
- "encountered raw symbol "
- (symbol->string x)
- " in output of macro"))
- (else x))))
- (rebuild-macro-output
- (let ((out (p (source-wrap e (anti-mark w) ae))))
- (if (procedure? out)
- (out (lambda (id)
- (unless (identifier? id)
- (syntax-error id
- "environment argument is not an identifier"))
- (lookup (id-var-name id empty-wrap) r)))
- out))
- (new-mark))))
-
-(define chi-body
- (lambda (body outer-form r mr w m?)
- (let* ((ribcage (make-empty-ribcage))
- (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))
- (body (map (lambda (x) (make-frob (wrap x w) #f)) body)))
- (let-values (((r mr exprs ids vars vals inits)
- (chi-internal ribcage outer-form body r mr m?)))
- (when (null? exprs) (syntax-error outer-form "no expressions in body"))
- (build-body no-source
- (reverse vars) (chi-frobs (reverse vals) r mr m?)
- (build-sequence no-source
- (chi-frobs (append inits exprs) r mr m?)))))))
-
-(define chi-internal
- ;; In processing the forms of the body, we create a new, empty wrap.
- ;; This wrap is augmented (destructively) each time we discover that
- ;; the next form is a definition. This is done:
- ;;
- ;; (1) to allow the first nondefinition form to be a call to
- ;; one of the defined ids even if the id previously denoted a
- ;; definition keyword or keyword for a macro expanding into a
- ;; definition;
- ;; (2) to prevent subsequent definition forms (but unfortunately
- ;; not earlier ones) and the first nondefinition form from
- ;; confusing one of the bound identifiers for an auxiliary
- ;; keyword; and
- ;; (3) so that we do not need to restart the expansion of the
- ;; first nondefinition form, which is problematic anyway
- ;; since it might be the first element of a begin that we
- ;; have just spliced into the body (meaning if we restarted,
- ;; we'd really need to restart with the begin or the macro
- ;; call that expanded into the begin, and we'd have to give
- ;; up allowing (begin <defn>+ <expr>+), which is itself
- ;; problematic since we don't know if a begin contains only
- ;; definitions until we've expanded it).
- ;;
- ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
- ;; into the body.
- ;;
- ;; outer-form is fully wrapped w/source
- (lambda (ribcage source-exp body r mr m?)
- (define return
- (lambda (r mr exprs ids vars vals inits)
- (check-defined-ids source-exp ids)
- (values r mr exprs ids vars vals inits)))
- (let parse ((body body) (r r) (mr mr) (ids '()) (vars '()) (vals '()) (inits '()) (meta-seen? #f))
- (if (null? body)
- (return r mr body ids vars vals inits)
- (let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
- (let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
- (case type
- ((define-form)
- (let-values (((id rhs w) (parse-define e w ae)))
- (let ((id (wrap id w)) (label (gen-label)))
- (cond
- (meta?
- (let ((sym (generate-id (id-sym-name id))))
- (extend-ribcage! ribcage id label)
- ; add meta bindings only to meta environment
- ; so visible only to next higher level and beyond
- (let ((mr (extend-env label (make-binding 'meta-variable sym) mr)))
- (define-top-level-value-hook sym
- (top-level-eval-hook (chi rhs mr mr w #t)))
- (parse (cdr body) r mr (cons id ids) vars vals inits #f))))
- (else
- (let ((var (gen-var id)))
- (extend-ribcage! ribcage id label)
- ; add lexical bindings only to run-time environment
- (parse (cdr body)
- (extend-env label (make-binding 'lexical var) r)
- mr
- (cons id ids)
- (cons var vars)
- (cons (make-frob (wrap rhs w) meta?) vals)
- inits
- #f)))))))
- ((define-syntax-form)
- (let-values (((id rhs w) (parse-define-syntax e w ae)))
- (let ((id (wrap id w))
- (label (gen-label))
- (exp (chi rhs mr mr w #t)))
- (extend-ribcage! ribcage id label)
- (let ((b (defer-or-eval-transformer local-eval-hook exp)))
- (parse (cdr body)
- (extend-env label b r) (extend-env label b mr)
- (cons id ids) vars vals inits #f)))))
- (($module-form)
- (let* ((*ribcage (make-empty-ribcage))
- (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
- (let-values (((orig id exports forms) (parse-module e w ae *w)))
- (let-values (((r mr *body *ids *vars *vals *inits)
- (chi-internal *ribcage orig
- (map (lambda (d) (make-frob d meta?)) forms)
- r mr m?)))
- ; valid bound ids checked already by chi-internal
- (check-module-exports source-exp (flatten-exports exports) *ids)
- (let ((iface (make-resolved-interface id exports #f))
- (vars (append *vars vars))
- (vals (append *vals vals))
- (inits (append inits *inits *body))
- (label (gen-label)))
- (extend-ribcage! ribcage id label)
- (let ((b (make-binding '$module iface)))
- (parse (cdr body)
- (extend-env label b r) (extend-env label b mr)
- (cons id ids) vars vals inits #f)))))))
- (($import-form)
- (let-values (((orig only? mid) (parse-import e w ae)))
- (let ((mlabel (id-var-name mid empty-wrap)))
- (let ((binding (lookup mlabel r)))
- (case (binding-type binding)
- (($module)
- (let* ((iface (binding-value binding))
- (import-iface (make-import-interface iface (import-mark-delta mid iface))))
- (when only? (extend-ribcage-barrier! ribcage mid))
- (do-import! import-iface ribcage)
- (parse (cdr body) r mr (cons import-iface ids) vars vals inits #f)))
- ((displaced-lexical) (displaced-lexical-error mid))
- (else (syntax-error mid "unknown module")))))))
- ((alias-form)
- (let-values (((new-id old-id) (parse-alias e w ae)))
- (let ((new-id (wrap new-id w)))
- (extend-ribcage! ribcage new-id (id-var-name-loc old-id w))
- (parse (cdr body) r mr
- (cons new-id ids)
- vars
- vals
- inits
- #f))))
- ((begin-form)
- (parse (let f ((forms (parse-begin e w ae #t)))
- (if (null? forms)
- (cdr body)
- (cons (make-frob (wrap (car forms) w) meta?)
- (f (cdr forms)))))
- r mr ids vars vals inits #f))
- ((eval-when-form)
- (let-values (((when-list forms) (parse-eval-when e w ae)))
- (parse (if (memq 'eval when-list) ; mode set is implicitly (E)
- (let f ((forms forms))
- (if (null? forms)
- (cdr body)
- (cons (make-frob (wrap (car forms) w) meta?)
- (f (cdr forms)))))
- (cdr body))
- r mr ids vars vals inits #f)))
- ((meta-form)
- (parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
- (cdr body))
- r mr ids vars vals inits #t))
- ((local-syntax-form)
- (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
- (parse (let f ((forms forms))
- (if (null? forms)
- (cdr body)
- (cons (make-frob (wrap (car forms) w) meta?)
- (f (cdr forms)))))
- r mr ids vars vals inits #f)))
- (else ; found a non-definition
- (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
- (let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
- (if (or (null? body) (not (frob-meta? (car body))))
- (return r mr body ids vars vals inits)
- (begin
- ; expand meta inits for effect only
- (top-level-eval-hook (chi-meta-frob (car body) mr))
- (f (cdr body)))))))))))))
-
-(define import-mark-delta
- ; returns list of marks layered on top of module id beyond those
- ; cached in the interface
- (lambda (mid iface)
- (diff-marks (id-marks mid) (interface-marks iface))))
-
-(define lookup-import-label
- (lambda (id)
- (let ((label (id-var-name-loc id empty-wrap)))
- (unless label
- (syntax-error id "exported identifier not visible"))
- label)))
-
-(define do-import!
- (lambda (import-iface ribcage)
- (let ((ie (interface-exports (import-interface-interface import-iface))))
- (if (<= (vector-length ie) 20)
- (let ((new-marks (import-interface-new-marks import-iface)))
- (vfor-each
- (lambda (id)
- (import-extend-ribcage! ribcage new-marks id
- (lookup-import-label id)))
- ie))
- (extend-ribcage-subst! ribcage import-iface)))))
-
-(define parse-module
- (lambda (e w ae *w)
- (define listify
- (lambda (exports)
- (if (null? exports)
- '()
- (cons (syntax-case (car exports) ()
- ((ex ...) (listify (syntax (ex ...))))
- (x (if (id? (syntax x))
- (wrap (syntax x) *w)
- (syntax-error (source-wrap e w ae)
- "invalid exports list in"))))
- (listify (cdr exports))))))
- (syntax-case e ()
- ((_ orig mid (ex ...) form ...)
- (id? (syntax mid))
- ; id receives old wrap so it won't be confused with id of same name
- ; defined within the module
- (values (syntax orig) (wrap (syntax mid) w) (listify (syntax (ex ...))) (map (lambda (x) (wrap x *w)) (syntax (form ...)))))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-import
- (lambda (e w ae)
- (syntax-case e ()
- ((_ orig #t mid)
- (id? (syntax mid))
- (values (syntax orig) #t (wrap (syntax mid) w)))
- ((_ orig #f mid)
- (id? (syntax mid))
- (values (syntax orig) #f (wrap (syntax mid) w)))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-define
- (lambda (e w ae)
- (syntax-case e ()
- ((_ name val)
- (id? (syntax name))
- (values (syntax name) (syntax val) w))
- ((_ (name . args) e1 e2 ...)
- (and (id? (syntax name))
- (valid-bound-ids? (lambda-var-list (syntax args))))
- (values (wrap (syntax name) w)
- (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
- empty-wrap))
- ((_ name)
- (id? (syntax name))
- (values (wrap (syntax name) w) (syntax (void)) empty-wrap))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-define-syntax
- (lambda (e w ae)
- (syntax-case e ()
- ((_ (name id) e1 e2 ...)
- (and (id? (syntax name)) (id? (syntax id)))
- (values (wrap (syntax name) w)
- `(,(syntax lambda) ,(wrap (syntax (id)) w)
- ,@(wrap (syntax (e1 e2 ...)) w))
- empty-wrap))
- ((_ name val)
- (id? (syntax name))
- (values (syntax name) (syntax val) w))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-meta
- (lambda (e w ae)
- (syntax-case e ()
- ((_ . form) (syntax form))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-eval-when
- (lambda (e w ae)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (values (chi-when-list (syntax (x ...)) w) (syntax (e1 e2 ...))))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-alias
- (lambda (e w ae)
- (syntax-case e ()
- ((_ new-id old-id)
- (and (id? (syntax new-id)) (id? (syntax old-id)))
- (values (syntax new-id) (syntax old-id)))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(define parse-begin
- (lambda (e w ae empty-okay?)
- (syntax-case e ()
- ((_) empty-okay? '())
- ((_ e1 e2 ...) (syntax (e1 e2 ...)))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(define chi-lambda-clause
- (lambda (e c r mr w m?)
- (syntax-case c ()
- (((id ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (syntax-error e "invalid parameter list in")
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (values
- new-vars
- (chi-body (syntax (e1 e2 ...))
- e
- (extend-var-env* labels new-vars r)
- mr
- (make-binding-wrap ids labels w)
- m?))))))
- ((ids e1 e2 ...)
- (let ((old-ids (lambda-var-list (syntax ids))))
- (if (not (valid-bound-ids? old-ids))
- (syntax-error e "invalid parameter list in")
- (let ((labels (gen-labels old-ids))
- (new-vars (map gen-var old-ids)))
- (values
- (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
- (if (null? ls1)
- ls2
- (f (cdr ls1) (cons (car ls1) ls2))))
- (chi-body (syntax (e1 e2 ...))
- e
- (extend-var-env* labels new-vars r)
- mr
- (make-binding-wrap old-ids labels w)
- m?))))))
- (_ (syntax-error e)))))
-
-(define chi-local-syntax
- (lambda (rec? e r mr w ae)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
- (source-wrap e w ae)
- "keyword")
- (let ((labels (gen-labels ids)))
- (let ((new-w (make-binding-wrap ids labels w)))
- (let ((b* (let ((w (if rec? new-w w)))
- (map (lambda (x)
- (defer-or-eval-transformer
- local-eval-hook
- (chi x mr mr w #t)))
- (syntax (val ...))))))
- (values
- (syntax (e1 e2 ...))
- (extend-env* labels b* r)
- (extend-env* labels b* mr)
- new-w
- ae)))))))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(define chi-void
- (lambda ()
- (build-application no-source (build-primref no-source 'void) '())))
-
-(define ellipsis?
- (lambda (x)
- (and (nonsymbol-id? x)
- (literal-id=? x (syntax (... ...))))))
-
-;;; data
-
-;;; strips all annotations from potentially circular reader output.
-
-(define strip-annotation
- (lambda (x)
- (cond
- ((pair? x)
- (cons (strip-annotation (car x))
- (strip-annotation (cdr x))))
- ((annotation? x) (annotation-stripped x))
- (else x))))
-
-;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
-;;; on an annotation, strips the annotation as well.
-;;; since only the head of a list is annotated by the reader, not each pair
-;;; in the spine, we also check for pairs whose cars are annotated in case
-;;; we've been passed the cdr of an annotated list
-
-(define strip*
- (lambda (x w fn)
- (if (top-marked? w)
- (fn x)
- (let f ((x x))
- (cond
- ((syntax-object? x)
- (strip* (syntax-object-expression x) (syntax-object-wrap x) fn))
- ((pair? x)
- (let ((a (f (car x))) (d (f (cdr x))))
- (if (and (eq? a (car x)) (eq? d (cdr x)))
- x
- (cons a d))))
- ((vector? x)
- (let ((old (vector->list x)))
- (let ((new (map f old)))
- (if (andmap eq? old new) x (list->vector new)))))
- (else x))))))
-
-(define strip
- (lambda (x w)
- (strip* x w
- (lambda (x)
- (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
- (strip-annotation x)
- x)))))
-
-;;; lexical variables
-
-(define gen-var
- (lambda (id)
- (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
- (if (annotation? id)
- (build-lexical-var id (annotation-expression id))
- (build-lexical-var id id)))))
-
-(define lambda-var-list
- (lambda (vars)
- (let lvl ((vars vars) (ls '()) (w empty-wrap))
- (cond
- ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
- ((id? vars) (cons (wrap vars w) ls))
- ((null? vars) ls)
- ((syntax-object? vars)
- (lvl (syntax-object-expression vars)
- ls
- (join-wraps w (syntax-object-wrap vars))))
- ((annotation? vars)
- (lvl (annotation-expression vars) ls w))
- ; include anything else to be caught by subsequent error
- ; checking
- (else (cons vars ls))))))
-
-
-; must precede global-extends
-
-(set! $sc-put-cte
- (lambda (id b top-token)
- (define sc-put-module
- (lambda (exports token new-marks)
- (vfor-each
- (lambda (id) (store-import-binding id token new-marks))
- exports)))
- (define (put-cte id binding token)
- (let ((sym (if (symbol? id) id (id-var-name id empty-wrap))))
- (store-import-binding id token '())
- (put-global-definition-hook sym
- ; global binding is assumed; if global pass #f to remove existing binding, if any
- (if (and (eq? (binding-type binding) 'global)
- (eq? (binding-value binding) sym))
- #f
- binding))))
- (let ((binding (make-transformer-binding b)))
- (case (binding-type binding)
- (($module)
- (let ((iface (binding-value binding)))
- (sc-put-module (interface-exports iface) (interface-token iface) '()))
- (put-cte id binding top-token))
- ((do-alias) (store-import-binding id top-token '()))
- ((do-import)
- ; fake binding: id is module id binding-value is token
- (let ((token (binding-value b)))
- (let ((b (lookup (id-var-name id empty-wrap) null-env)))
- (case (binding-type b)
- (($module)
- (let* ((iface (binding-value b))
- (exports (interface-exports iface)))
- (unless (eq? (interface-token iface) token)
- (syntax-error id "import mismatch for module"))
- (sc-put-module (interface-exports iface) top-token
- (import-mark-delta id iface))))
- (else (syntax-error id "unknown module"))))))
- (else (put-cte id binding top-token))))
- ))
-
-
-;;; core transformers
-
-(global-extend 'local-syntax 'letrec-syntax #t)
-(global-extend 'local-syntax 'let-syntax #f)
-
-
-(global-extend 'core 'fluid-let-syntax
- (lambda (e r mr w ae m?)
- (syntax-case e ()
- ((_ ((var val) ...) e1 e2 ...)
- (valid-bound-ids? (syntax (var ...)))
- (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
- (for-each
- (lambda (id n)
- (case (binding-type (lookup n r))
- ((displaced-lexical) (displaced-lexical-error (wrap id w)))))
- (syntax (var ...))
- names)
- (let ((b* (map (lambda (x)
- (defer-or-eval-transformer
- local-eval-hook
- (chi x mr mr w #t)))
- (syntax (val ...)))))
- (chi-body
- (syntax (e1 e2 ...))
- (source-wrap e w ae)
- (extend-env* names b* r)
- (extend-env* names b* mr)
- w
- m?))))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(global-extend 'core 'quote
- (lambda (e r mr w ae m?)
- (syntax-case e ()
- ((_ e) (build-data ae (strip (syntax e) w)))
- (_ (syntax-error (source-wrap e w ae))))))
-
-(global-extend 'core 'syntax
- (let ()
- (define gen-syntax
- (lambda (src e r maps ellipsis? vec?)
- (if (id? e)
- (let ((label (id-var-name e empty-wrap)))
- (let ((b (lookup label r)))
- (if (eq? (binding-type b) 'syntax)
- (let-values (((var maps)
- (let ((var.lev (binding-value b)))
- (gen-ref src (car var.lev) (cdr var.lev) maps))))
- (values `(ref ,var) maps))
- (if (ellipsis? e)
- (syntax-error src "misplaced ellipsis in syntax form")
- (values `(quote ,e) maps)))))
- (syntax-case e ()
- ((dots e)
- (ellipsis? (syntax dots))
- (if vec?
- (syntax-error src "misplaced ellipsis in syntax template")
- (gen-syntax src (syntax e) r maps (lambda (x) #f) #f)))
- ((x dots . y)
- ; this could be about a dozen lines of code, except that we
- ; choose to handle (syntax (x ... ...)) forms
- (ellipsis? (syntax dots))
- (let f ((y (syntax y))
- (k (lambda (maps)
- (let-values (((x maps)
- (gen-syntax src (syntax x) r
- (cons '() maps) ellipsis? #f)))
- (if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
- (values (gen-map x (car maps))
- (cdr maps)))))))
- (syntax-case y ()
- ((dots . y)
- (ellipsis? (syntax dots))
- (f (syntax y)
- (lambda (maps)
- (let-values (((x maps) (k (cons '() maps))))
- (if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
- (values (gen-mappend x (car maps))
- (cdr maps)))))))
- (_ (let-values (((y maps) (gen-syntax src y r maps ellipsis? vec?)))
- (let-values (((x maps) (k maps)))
- (values (gen-append x y) maps)))))))
- ((x . y)
- (let-values (((xnew maps) (gen-syntax src (syntax x) r maps ellipsis? #f)))
- (let-values (((ynew maps) (gen-syntax src (syntax y) r maps ellipsis? vec?)))
- (values (gen-cons e (syntax x) (syntax y) xnew ynew)
- maps))))
- (#(x1 x2 ...)
- (let ((ls (syntax (x1 x2 ...))))
- (let-values (((lsnew maps) (gen-syntax src ls r maps ellipsis? #t)))
- (values (gen-vector e ls lsnew) maps))))
- (_ (values `(quote ,e) maps))))))
-
- (define gen-ref
- (lambda (src var level maps)
- (if (fx= level 0)
- (values var maps)
- (if (null? maps)
- (syntax-error src "missing ellipsis in syntax form")
- (let-values (((outer-var outer-maps) (gen-ref src var (fx- level 1) (cdr maps))))
- (let ((b (assq outer-var (car maps))))
- (if b
- (values (cdr b) maps)
- (let ((inner-var (gen-var 'tmp)))
- (values inner-var
- (cons (cons (cons outer-var inner-var)
- (car maps))
- outer-maps))))))))))
-
- (define gen-append
- (lambda (x y)
- (if (equal? y '(quote ()))
- x
- `(append ,x ,y))))
-
- (define gen-mappend
- (lambda (e map-env)
- `(apply (primitive append) ,(gen-map e map-env))))
-
- (define gen-map
- (lambda (e map-env)
- (let ((formals (map cdr map-env))
- (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
- (cond
- ((eq? (car e) 'ref)
- ; identity map equivalence:
- ; (map (lambda (x) x) y) == y
- (car actuals))
- ((andmap
- (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
- (cdr e))
- ; eta map equivalence:
- ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
- `(map (primitive ,(car e))
- ,@(map (let ((r (map cons formals actuals)))
- (lambda (x) (cdr (assq (cadr x) r))))
- (cdr e))))
- (else `(map (lambda ,formals ,e) ,@actuals))))))
-
- ; 12/12/00: semantic change: we now return original syntax object (e)
- ; if no pattern variables were found within, to avoid dropping
- ; source annotations prematurely. the "syntax returns lists" for
- ; lists in its input guarantee counts only for substructure that
- ; contains pattern variables
- (define gen-cons
- (lambda (e x y xnew ynew)
- (case (car ynew)
- ((quote)
- (if (eq? (car xnew) 'quote)
- (let ((xnew (cadr xnew)) (ynew (cadr ynew)))
- (if (and (eq? xnew x) (eq? ynew y))
- `',e
- `'(,xnew . ,ynew)))
- (if (eq? (cadr ynew) '()) `(list ,xnew) `(cons ,xnew ,ynew))))
- ((list) `(list ,xnew ,@(cdr ynew)))
- (else `(cons ,xnew ,ynew)))))
-
- (define gen-vector
- (lambda (e ls lsnew)
- (cond
- ((eq? (car lsnew) 'quote)
- (if (eq? (cadr lsnew) ls)
- `',e
- `(quote #(,@(cadr lsnew)))))
- ((eq? (car lsnew) 'list) `(vector ,@(cdr lsnew)))
- (else `(list->vector ,lsnew)))))
-
-
- (define regen
- (lambda (x)
- (case (car x)
- ((ref) (build-lexical-reference 'value no-source (cadr x)))
- ((primitive) (build-primref no-source (cadr x)))
- ((quote) (build-data no-source (cadr x)))
- ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
- ((map) (let ((ls (map regen (cdr x))))
- (build-application no-source
- (if (fx= (length ls) 2)
- (build-primref no-source 'map)
- ; really need to do our own checking here
- (build-primref no-source 2 'map)) ; require error check
- ls)))
- (else (build-application no-source
- (build-primref no-source (car x))
- (map regen (cdr x)))))))
-
- (lambda (e r mr w ae m?)
- (let ((e (source-wrap e w ae)))
- (syntax-case e ()
- ((_ x)
- (let-values (((e maps) (gen-syntax e (syntax x) r '() ellipsis? #f)))
- (regen e)))
- (_ (syntax-error e)))))))
-
-
-(global-extend 'core 'lambda
- (lambda (e r mr w ae m?)
- (syntax-case e ()
- ((_ . c)
- (let-values (((vars body) (chi-lambda-clause (source-wrap e w ae) (syntax c) r mr w m?)))
- (build-lambda ae vars body))))))
-
-
-(global-extend 'core 'letrec
- (lambda (e r mr w ae m?)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
- (source-wrap e w ae) "bound variable")
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (let ((w (make-binding-wrap ids labels w))
- (r (extend-var-env* labels new-vars r)))
- (build-letrec ae
- new-vars
- (map (lambda (x) (chi x r mr w m?)) (syntax (val ...)))
- (chi-body (syntax (e1 e2 ...)) (source-wrap e w ae) r mr w m?)))))))
- (_ (syntax-error (source-wrap e w ae))))))
-
-
-(global-extend 'core 'if
- (lambda (e r mr w ae m?)
- (syntax-case e ()
- ((_ test then)
- (build-conditional ae
- (chi (syntax test) r mr w m?)
- (chi (syntax then) r mr w m?)
- (chi-void)))
- ((_ test then else)
- (build-conditional ae
- (chi (syntax test) r mr w m?)
- (chi (syntax then) r mr w m?)
- (chi (syntax else) r mr w m?)))
- (_ (syntax-error (source-wrap e w ae))))))
-
-
-
-(global-extend 'set! 'set! '())
-
-(global-extend 'alias 'alias '())
-(global-extend 'begin 'begin '())
-
-(global-extend '$module-key '$module '())
-(global-extend '$import '$import '())
-
-(global-extend 'define 'define '())
-
-(global-extend 'define-syntax 'define-syntax '())
-
-(global-extend 'eval-when 'eval-when '())
-
-(global-extend 'meta 'meta '())
-
-(global-extend 'core 'syntax-case
- (let ()
- (define convert-pattern
- ; accepts pattern & keys
- ; returns syntax-dispatch pattern & ids
- (lambda (pattern keys)
- (define cvt*
- (lambda (p* n ids)
- (if (null? p*)
- (values '() ids)
- (let-values (((y ids) (cvt* (cdr p*) n ids)))
- (let-values (((x ids) (cvt (car p*) n ids)))
- (values (cons x y) ids))))))
- (define cvt
- (lambda (p n ids)
- (if (id? p)
- (if (bound-id-member? p keys)
- (values (vector 'free-id p) ids)
- (values 'any (cons (cons p n) ids)))
- (syntax-case p ()
- ((x dots)
- (ellipsis? (syntax dots))
- (let-values (((p ids) (cvt (syntax x) (fx+ n 1) ids)))
- (values (if (eq? p 'any) 'each-any (vector 'each p))
- ids)))
- ((x dots y ... . z)
- (ellipsis? (syntax dots))
- (let-values (((z ids) (cvt (syntax z) n ids)))
- (let-values (((y ids) (cvt* (syntax (y ...)) n ids)))
- (let-values (((x ids) (cvt (syntax x) (fx+ n 1) ids)))
- (values `#(each+ ,x ,(reverse y) ,z) ids)))))
- ((x . y)
- (let-values (((y ids) (cvt (syntax y) n ids)))
- (let-values (((x ids) (cvt (syntax x) n ids)))
- (values (cons x y) ids))))
- (() (values '() ids))
- (#(x ...)
- (let-values (((p ids) (cvt (syntax (x ...)) n ids)))
- (values (vector 'vector p) ids)))
- (x (values (vector 'atom (strip p empty-wrap)) ids))))))
- (cvt pattern 0 '())))
-
- (define build-dispatch-call
- (lambda (pvars exp y r mr m?)
- (let ((ids (map car pvars)) (levels (map cdr pvars)))
- (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
- (build-application no-source
- (build-primref no-source 'apply)
- (list (build-lambda no-source new-vars
- (chi exp
- (extend-env*
- labels
- (map (lambda (var level)
- (make-binding 'syntax `(,var . ,level)))
- new-vars
- (map cdr pvars))
- r)
- mr
- (make-binding-wrap ids labels empty-wrap)
- m?))
- y))))))
-
- (define gen-clause
- (lambda (x keys clauses r mr m? pat fender exp)
- (let-values (((p pvars) (convert-pattern pat keys)))
- (cond
- ((not (distinct-bound-ids? (map car pvars)))
- (invalid-ids-error (map car pvars) pat "pattern variable"))
- ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
- (syntax-error pat
- "misplaced ellipsis in syntax-case pattern"))
- (else
- (let ((y (gen-var 'tmp)))
- ; fat finger binding and references to temp variable y
- (build-application no-source
- (build-lambda no-source (list y)
- (let-syntax ((y (identifier-syntax
- (build-lexical-reference 'value no-source y))))
- (build-conditional no-source
- (syntax-case fender ()
- (#t y)
- (_ (build-conditional no-source
- y
- (build-dispatch-call pvars fender y r mr m?)
- (build-data no-source #f))))
- (build-dispatch-call pvars exp y r mr m?)
- (gen-syntax-case x keys clauses r mr m?))))
- (list (if (eq? p 'any)
- (build-application no-source
- (build-primref no-source 'list)
- (list (build-lexical-reference no-source 'value x)))
- (build-application no-source
- (build-primref no-source '$syntax-dispatch)
- (list (build-lexical-reference no-source 'value x)
- (build-data no-source p))))))))))))
-
- (define gen-syntax-case
- (lambda (x keys clauses r mr m?)
- (if (null? clauses)
- (build-application no-source
- (build-primref no-source 'syntax-error)
- (list (build-lexical-reference 'value no-source x)))
- (syntax-case (car clauses) ()
- ((pat exp)
- (if (and (id? (syntax pat))
- (not (bound-id-member? (syntax pat) keys))
- (not (ellipsis? (syntax pat))))
- (let ((label (gen-label))
- (var (gen-var (syntax pat))))
- (build-application no-source
- (build-lambda no-source (list var)
- (chi (syntax exp)
- (extend-env label (make-binding 'syntax `(,var . 0)) r)
- mr
- (make-binding-wrap (syntax (pat))
- (list label) empty-wrap)
- m?))
- (list (build-lexical-reference 'value no-source x))))
- (gen-clause x keys (cdr clauses) r mr m?
- (syntax pat) #t (syntax exp))))
- ((pat fender exp)
- (gen-clause x keys (cdr clauses) r mr m?
- (syntax pat) (syntax fender) (syntax exp)))
- (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
-
- (lambda (e r mr w ae m?)
- (let ((e (source-wrap e w ae)))
- (syntax-case e ()
- ((_ val (key ...) m ...)
- (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
- (syntax (key ...)))
- (let ((x (gen-var 'tmp)))
- ; fat finger binding and references to temp variable x
- (build-application ae
- (build-lambda no-source (list x)
- (gen-syntax-case x
- (syntax (key ...)) (syntax (m ...))
- r mr m?))
- (list (chi (syntax val) r mr empty-wrap m?))))
- (syntax-error e "invalid literals list in"))))))))
-
-(put-cte-hook 'module
- (lambda (x)
- (define proper-export?
- (lambda (e)
- (syntax-case e ()
- ((id e ...)
- (and (identifier? (syntax id))
- (andmap proper-export? (syntax (e ...)))))
- (id (identifier? (syntax id))))))
- (with-syntax ((orig x))
- (syntax-case x ()
- ((_ (e ...) d ...)
- (if (andmap proper-export? (syntax (e ...)))
- (syntax (begin ($module orig anon (e ...) d ...) ($import orig #f anon)))
- (syntax-error x "invalid exports list in")))
- ((_ m (e ...) d ...)
- (identifier? (syntax m))
- (if (andmap proper-export? (syntax (e ...)))
- (syntax ($module orig m (e ...) d ...))
- (syntax-error x "invalid exports list in")))))))
-
-(let ()
- (define $module-exports
- (lambda (m r)
- (let ((b (r m)))
- (case (binding-type b)
- (($module)
- (let* ((interface (binding-value b))
- (new-marks (import-mark-delta m interface)))
- (vmap (lambda (x)
- (let ((id (if (pair? x) (car x) x)))
- (make-syntax-object
- (syntax-object->datum id)
- (let ((marks (join-marks new-marks (wrap-marks (syntax-object-wrap id)))))
- (make-wrap marks
- ; the anti mark should always be present at the head
- ; of new-marks, but we paranoically check anyway
- (if (eq? (car marks) the-anti-mark)
- (cons 'shift (wrap-subst top-wrap))
- (wrap-subst top-wrap)))))))
- (interface-exports interface))))
- ((displaced-lexical) (displaced-lexical-error m))
- (else (syntax-error m "unknown module"))))))
- (define $import-help
- (lambda (orig import-only?)
- (lambda (r)
- (define difference
- (lambda (ls1 ls2)
- (if (null? ls1)
- ls1
- (if (bound-id-member? (car ls1) ls2)
- (difference (cdr ls1) ls2)
- (cons (car ls1) (difference (cdr ls1) ls2))))))
- (define prefix-add
- (lambda (prefix-id)
- (let ((prefix (symbol->string (syntax-object->datum prefix-id))))
- (lambda (id)
- (datum->syntax-object id
- (string->symbol
- (string-append prefix
- (symbol->string (syntax-object->datum id)))))))))
- (define prefix-drop
- (lambda (prefix-id)
- (let ((prefix (symbol->string (syntax-object->datum prefix-id))))
- (lambda (id)
- (let ((s (symbol->string (syntax-object->datum id))))
- (let ((np (string-length prefix)) (ns (string-length s)))
- (unless (and (>= ns np) (string=? (substring s 0 np) prefix))
- (syntax-error id (string-append "missing expected prefix " prefix)))
- (datum->syntax-object id
- (string->symbol (substring s np ns)))))))))
- (define gen-mid
- (lambda (mid)
- ; introduced module ids must have same marks as original
- ; for import-only, since the barrier carries the marks of
- ; the module id
- (datum->syntax-object mid (generate-id (id-sym-name mid)))))
- (define (modspec m exports?)
- (with-syntax ((orig orig) (import-only? import-only?))
- (syntax-case m (only-for-syntax also-for-syntax
- only except
- add-prefix drop-prefix rename alias)
- ((only m id ...)
- (andmap identifier? (syntax (id ...)))
- (let-values (((mid d exports) (modspec (syntax m) #f)))
- (with-syntax ((d d) (tmid (gen-mid mid)))
- (values mid
- (syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
- (and exports? (syntax (id ...)))))))
- ((except m id ...)
- (andmap identifier? (syntax (id ...)))
- (let-values (((mid d exports) (modspec (syntax m) #t)))
- (with-syntax ((d d)
- (tmid (gen-mid mid))
- ((id ...) (difference exports (syntax (id ...)))))
- (values mid
- (syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
- (and exports? (syntax (id ...)))))))
- ((add-prefix m prefix-id)
- (identifier? (syntax prefix-id))
- (let-values (((mid d exports) (modspec (syntax m) #t)))
- (with-syntax ((d d)
- (tmid (gen-mid mid))
- ((old-id ...) exports)
- ((tmp ...) (generate-temporaries exports))
- ((id ...) (map (prefix-add (syntax prefix-id)) exports)))
- (values mid
- (syntax (begin ($module orig tmid ((id tmp) ...)
- ($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
- ($import orig import-only? tmid)
- (alias id tmp) ...)
- ($import orig import-only? tmid)))
- (and exports? (syntax (id ...)))))))
- ((drop-prefix m prefix-id)
- (identifier? (syntax prefix-id))
- (let-values (((mid d exports) (modspec (syntax m) #t)))
- (with-syntax ((d d)
- (tmid (gen-mid mid))
- ((old-id ...) exports)
- ((tmp ...) (generate-temporaries exports))
- ((id ...) (map (prefix-drop (syntax prefix-id)) exports)))
- (values mid
- (syntax (begin ($module orig tmid ((id tmp) ...)
- ($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
- ($import orig import-only? tmid)
- (alias id tmp) ...)
- ($import orig import-only? tmid)))
- (and exports? (syntax (id ...)))))))
- ((rename m (new-id old-id) ...)
- (and (andmap identifier? (syntax (new-id ...)))
- (andmap identifier? (syntax (old-id ...))))
- (let-values (((mid d exports) (modspec (syntax m) #t)))
- (with-syntax ((d d)
- (tmid (gen-mid mid))
- ((tmp ...) (generate-temporaries (syntax (old-id ...))))
- ((other-id ...) (difference exports (syntax (old-id ...)))))
- (values mid
- (syntax (begin ($module orig tmid ((new-id tmp) ... other-id ...)
- ($module orig tmid (other-id ... (tmp old-id) ...) d (alias tmp old-id) ...)
- ($import orig import-only? tmid)
- (alias new-id tmp) ...)
- ($import orig import-only? tmid)))
- (and exports? (syntax (new-id ... other-id ...)))))))
- ((alias m (new-id old-id) ...)
- (and (andmap identifier? (syntax (new-id ...)))
- (andmap identifier? (syntax (old-id ...))))
- (let-values (((mid d exports) (modspec (syntax m) #t)))
- (with-syntax ((d d)
- (tmid (gen-mid mid))
- ((other-id ...) exports))
- (values mid
- (syntax (begin ($module orig tmid ((new-id old-id) ... other-id ...) d (alias new-id old-id) ...)
- ($import orig import-only? tmid)))
- (and exports? (syntax (new-id ... other-id ...)))))))
- ; base cases
- (mid
- (identifier? (syntax mid))
- (values (syntax mid)
- (syntax ($import orig import-only? mid))
- (and exports? ($module-exports (syntax mid) r))))
- ((mid)
- (identifier? (syntax mid))
- (values (syntax mid)
- (syntax ($import orig import-only? mid))
- (and exports? ($module-exports (syntax mid) r))))
- (_ (syntax-error m "invalid module specifier")))))
- (define modspec*
- (lambda (m)
- (let-values (((mid d exports) (modspec m #f))) d)))
- (syntax-case orig ()
- ((_ m ...)
- (with-syntax (((d ...) (map modspec* (syntax (m ...)))))
- (syntax (begin d ...))))))))
-
- (put-cte-hook 'import
- (lambda (orig)
- ($import-help orig #f)))
-
- (put-cte-hook 'import-only
- (lambda (orig)
- ($import-help orig #t)))
-)
-
-;;; To support eval-when, we maintain two mode sets:
-;;;
-;;; ctem (compile-time-expression mode)
-;;; determines whether/when to evaluate compile-time expressions such
-;;; as macro definitions, module definitions, and compile-time
-;;; registration of variable definitions
-;;;
-;;; rtem (run-time-expression mode)
-;;; determines whether/when to evaluate run-time expressions such
-;;; as the actual assignment performed by a variable definition or
-;;; arbitrary top-level expressions
-
-;;; Possible modes in the mode set are:
-;;;
-;;; L (load): evaluate at load time. implies V for compile-time
-;;; expressions and R for run-time expressions.
-;;;
-;;; C (compile): evaluate at compile (file) time
-;;;
-;;; E (eval): evaluate at evaluation (compile or interpret) time
-;;;
-;;; V (visit): evaluate at visit time
-;;;
-;;; R (revisit): evaluate at revisit time
-
-;;; The mode set for the body of an eval-when is determined by
-;;; translating each mode in the old mode set based on the situations
-;;; present in the eval-when form and combining these into a set,
-;;; using the following table. See also update-mode-set.
-
-;;; load compile visit revisit eval
-;;;
-;;; L L C V R -
-;;;
-;;; C - - - - C
-;;;
-;;; V V C V - -
-;;;
-;;; R R C - R -
-;;;
-;;; E - - - - E
-
-;;; When we complete the expansion of a compile or run-time expression,
-;;; the current ctem or rtem determines how the expression will be
-;;; treated. See ct-eval/residualize and rt-eval/residualize.
-
-;;; Initial mode sets
-;;;
-;;; when compiling a file:
-;;;
-;;; initial ctem: (L C)
-;;;
-;;; initial rtem: (L)
-;;;
-;;; when not compiling a file:
-;;;
-;;; initial ctem: (E)
-;;;
-;;; initial rtem: (E)
-;;;
-;;;
-;;; This means that top-level syntactic definitions are evaluated
-;;; immediately after they are expanded, and the expanded definitions
-;;; are also residualized into the object file if we are compiling
-;;; a file.
-
-(set! sc-expand
- (let ((ctem '(E)) (rtem '(E)))
- (lambda (x)
- (let ((env (interaction-environment)))
- (if (and (pair? x) (equal? (car x) noexpand))
- (cadr x)
- (chi-top* x null-env
- (env-wrap env)
- ctem rtem #f
- (env-top-ribcage env)))))))
-
-
-
-(set! $make-environment
- (lambda (token mutable?)
- (let ((top-ribcage (make-top-ribcage token mutable?)))
- (make-env
- top-ribcage
- (make-wrap
- (wrap-marks top-wrap)
- (cons top-ribcage (wrap-subst top-wrap)))))))
-
-(set! environment?
- (lambda (x)
- (env? x)))
-
-
-
-(set! interaction-environment
- (let ((e ($make-environment '*top* #t)))
- (lambda () e)))
-
-(set! identifier?
- (lambda (x)
- (nonsymbol-id? x)))
-
-(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->list
- (lambda (orig-ls)
- (let f ((ls orig-ls))
- (syntax-case ls ()
- (() '())
- ((x . r) (cons #'x (f #'r)))
- (_ (error 'syntax->list "invalid argument ~s" orig-ls))))))
-
-(set! syntax->vector
- (lambda (v)
- (syntax-case v ()
- (#(x ...) (apply vector (syntax->list #'(x ...))))
- (_ (error 'syntax->vector "invalid argument ~s" v)))))
-
-(set! syntax-object->datum
- ; accepts any object, since syntax objects may consist partially
- ; or entirely of unwrapped, nonsymbolic data
- (lambda (x)
- (strip x empty-wrap)))
-
-(set! generate-temporaries
- (let ((n 0))
- (lambda (ls)
- (arg-check list? ls 'generate-temporaries)
- (map (lambda (x)
- (set! n (+ n 1))
- (wrap
- ; unique name to distinguish from other temporaries
- (string->symbol (string-append "t" (number->string n)))
- ; unique mark (in tmp-wrap) to distinguish from non-temporaries
- tmp-wrap))
- ls))))
-
-(set! free-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'free-identifier=?)
- (arg-check nonsymbol-id? y 'free-identifier=?)
- (free-id=? x y)))
-
-(set! bound-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'bound-identifier=?)
- (arg-check nonsymbol-id? y 'bound-identifier=?)
- (bound-id=? x y)))
-
-(set! literal-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'literal-identifier=?)
- (arg-check nonsymbol-id? y 'literal-identifier=?)
- (literal-id=? x y)))
-
-(set! syntax-error
- (lambda (object . messages)
- (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
- (let ((message (if (null? messages)
- "invalid syntax"
- (apply string-append messages))))
- (error-hook #f message (strip object empty-wrap)))))
-
-;;; syntax-dispatch expects an expression and a pattern. If the expression
-;;; matches the pattern a list of the matching expressions for each
-;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
-;;; not work on r4rs implementations that violate the ieee requirement
-;;; that #f and () be distinct.)
-
-;;; The expression is matched with the pattern as follows:
-
-;;; p in pattern: matches:
-;;; () empty list
-;;; any anything
-;;; (p1 . p2) pair (list)
-;;; #(free-id <key>) <key> with literal-identifier=?
-;;; each-any any proper list
-;;; #(each p) (p*)
-;;; #(each+ p1 (p2_1 ...p2_n) p3) (p1* (p2_n ... p2_1) . p3)
-;;; #(vector p) (list->vector p)
-;;; #(atom <object>) <object> with "equal?"
-
-;;; Vector cops out to pair under assumption that vectors are rare. If
-;;; not, should convert to:
-;;; #(vector p) #(p*)
-
-(let ()
-
-(define match-each
- (lambda (e p w)
- (cond
- ((annotation? e)
- (match-each (annotation-expression e) p w))
- ((pair? e)
- (let ((first (match (car e) p w '())))
- (and first
- (let ((rest (match-each (cdr e) p w)))
- (and rest (cons first rest))))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each (syntax-object-expression e)
- p
- (join-wraps w (syntax-object-wrap e))))
- (else #f))))
-
-(define match-each+
- (lambda (e x-pat y-pat z-pat w r)
- (let f ((e e) (w w))
- (cond
- ((pair? e)
- (let-values (((xr* y-pat r) (f (cdr e) w)))
- (if r
- (if (null? y-pat)
- (let ((xr (match (car e) x-pat w '())))
- (if xr
- (values (cons xr xr*) y-pat r)
- (values #f #f #f)))
- (values '() (cdr y-pat) (match (car e) (car y-pat) w r)))
- (values #f #f #f))))
- ((annotation? e) (f (annotation-expression e) w))
- ((syntax-object? e) (f (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))))
- (else (values '() y-pat (match e z-pat w r)))))))
-
-(define match-each-any
- (lambda (e w)
- (cond
- ((annotation? e)
- (match-each-any (annotation-expression e) w))
- ((pair? e)
- (let ((l (match-each-any (cdr e) w)))
- (and l (cons (wrap (car e) w) l))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each-any (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))))
- (else #f))))
-
-(define match-empty
- (lambda (p r)
- (cond
- ((null? p) r)
- ((eq? p 'any) (cons '() r))
- ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
- ((eq? p 'each-any) (cons '() r))
- (else
- (case (vector-ref p 0)
- ((each) (match-empty (vector-ref p 1) r))
- ((each+) (match-empty (vector-ref p 1)
- (match-empty (reverse (vector-ref p 2))
- (match-empty (vector-ref p 3) r))))
- ((free-id atom) r)
- ((vector) (match-empty (vector-ref p 1) r)))))))
-
-(define combine
- (lambda (r* r)
- (if (null? (car r*))
- r
- (cons (map car r*) (combine (map cdr r*) r)))))
-
-(define match*
- (lambda (e p w r)
- (cond
- ((null? p) (and (null? e) r))
- ((pair? p)
- (and (pair? e) (match (car e) (car p) w
- (match (cdr e) (cdr p) w r))))
- ((eq? p 'each-any)
- (let ((l (match-each-any e w))) (and l (cons l r))))
- (else
- (case (vector-ref p 0)
- ((each)
- (if (null? e)
- (match-empty (vector-ref p 1) r)
- (let ((r* (match-each e (vector-ref p 1) w)))
- (and r* (combine r* r)))))
- ((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r))
- ((each+)
- (let-values (((xr* y-pat r)
- (match-each+ e (vector-ref p 1) (vector-ref p 2)
- (vector-ref p 3) w r)))
- (and r (null? y-pat)
- (if (null? xr*)
- (match-empty (vector-ref p 1) r)
- (combine xr* r)))))
- ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
- ((vector)
- (and (vector? e)
- (match (vector->list e) (vector-ref p 1) w r))))))))
-
-(define match
- (lambda (e p w r)
- (cond
- ((not r) #f)
- ((eq? p 'any) (cons (wrap e w) r))
- ((syntax-object? e)
- (match*
- (unannotate (syntax-object-expression e))
- p
- (join-wraps w (syntax-object-wrap e))
- r))
- (else (match* (unannotate e) p w r)))))
-
-(set! $syntax-dispatch
- (lambda (e p)
- (cond
- ((eq? p 'any) (list e))
- ((syntax-object? e)
- (match* (unannotate (syntax-object-expression e))
- p (syntax-object-wrap e) '()))
- (else (match* (unannotate e) p empty-wrap '())))))
-))
-
-
-(define-syntax with-syntax
- (lambda (x)
- (syntax-case x ()
- ((_ () e1 e2 ...)
- (syntax (begin e1 e2 ...)))
- ((_ ((out in)) e1 e2 ...)
- (syntax (syntax-case in () (out (begin e1 e2 ...)))))
- ((_ ((out in) ...) e1 e2 ...)
- (syntax (syntax-case (list in ...) ()
- ((out ...) (begin e1 e2 ...))))))))
-
-(define-syntax with-implicit
- (syntax-rules ()
- ((_ (tid id ...) e1 e2 ...)
- (andmap identifier? (syntax (tid id ...)))
- (begin
- (unless (identifier? (syntax tid))
- (syntax-error (syntax tid) "non-identifier with-implicit template"))
- (with-syntax ((id (datum->syntax-object (syntax tid) 'id)) ...)
- e1 e2 ...)))))
-
-(define-syntax datum
- (syntax-rules ()
- ((_ x) (syntax-object->datum (syntax x)))))
-
-(define-syntax syntax-rules
- (lambda (x)
- (define clause
- (lambda (y)
- (syntax-case y ()
- (((keyword . pattern) template)
- (syntax ((dummy . pattern) (syntax template))))
- (((keyword . pattern) fender template)
- (syntax ((dummy . pattern) fender (syntax template))))
- (_ (syntax-error x)))))
- (syntax-case x ()
- ((_ (k ...) cl ...)
- (andmap identifier? (syntax (k ...)))
- (with-syntax (((cl ...) (map clause (syntax (cl ...)))))
- (syntax (lambda (x) (syntax-case x (k ...) cl ...))))))))
-
-(define-syntax or
- (lambda (x)
- (syntax-case x ()
- ((_) (syntax #f))
- ((_ e) (syntax e))
- ((_ e1 e2 e3 ...)
- (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
-
-(define-syntax and
- (lambda (x)
- (syntax-case x ()
- ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
- ((_ e) (syntax e))
- ((_) (syntax #t)))))
-
-(define-syntax let
- (lambda (x)
- (syntax-case x ()
- ((_ ((x v) ...) e1 e2 ...)
- (andmap identifier? (syntax (x ...)))
- (syntax ((lambda (x ...) e1 e2 ...) v ...)))
- ((_ f ((x v) ...) e1 e2 ...)
- (andmap identifier? (syntax (f x ...)))
- (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
- v ...))))))
-
-(define-syntax let*
- (lambda (x)
- (syntax-case x ()
- ((let* ((x v) ...) e1 e2 ...)
- (andmap identifier? (syntax (x ...)))
- (let f ((bindings (syntax ((x v) ...))))
- (if (null? bindings)
- (syntax (let () e1 e2 ...))
- (with-syntax ((body (f (cdr bindings)))
- (binding (car bindings)))
- (syntax (let (binding) body)))))))))
-
-(define-syntax cond
- (lambda (x)
- (syntax-case x ()
- ((_ m1 m2 ...)
- (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
- (if (null? clauses)
- (syntax-case clause (else =>)
- ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
- ((e0) (syntax (let ((t e0)) (if t t))))
- ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
- ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
- (_ (syntax-error x)))
- (with-syntax ((rest (f (car clauses) (cdr clauses))))
- (syntax-case clause (else =>)
- ((e0) (syntax (let ((t e0)) (if t t rest))))
- ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
- ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
- (_ (syntax-error x))))))))))
-
-(define-syntax do
- (lambda (orig-x)
- (syntax-case orig-x ()
- ((_ ((var init . step) ...) (e0 e1 ...) c ...)
- (with-syntax (((step ...)
- (map (lambda (v s)
- (syntax-case s ()
- (() v)
- ((e) (syntax e))
- (_ (syntax-error orig-x))))
- (syntax (var ...))
- (syntax (step ...)))))
- (syntax-case (syntax (e1 ...)) ()
- (() (syntax (let do ((var init) ...)
- (if (not e0)
- (begin c ... (do step ...))))))
- ((e1 e2 ...)
- (syntax (let do ((var init) ...)
- (if e0
- (begin e1 e2 ...)
- (begin c ... (do step ...))))))))))))
-
-(define-syntax quasiquote
- (let ()
- (define (quasi p lev)
- (syntax-case p (unquote quasiquote)
- ((unquote p)
- (if (= lev 0)
- #'("value" p)- (quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))- ((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))- ((p . q)
- (syntax-case #'p (unquote unquote-splicing)
- ((unquote p ...)
- (if (= lev 0)
- (quasilist* #'(("value" p) ...) (quasi #'q lev))- (quasicons
- (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))- (quasi #'q lev))))
- ((unquote-splicing p ...)
- (if (= lev 0)
- (quasiappend #'(("value" p) ...) (quasi #'q lev))- (quasicons
- (quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))- (quasi #'q lev))))
- (_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
- (#(x ...) (quasivector (vquasi #'(x ...) lev)))
- (p #'("quote" p))))- (define (vquasi p lev)
- (syntax-case p ()
- ((p . q)
- (syntax-case #'p (unquote unquote-splicing)
- ((unquote p ...)
- (if (= lev 0)
- (quasilist* #'(("value" p) ...) (vquasi #'q lev))- (quasicons
- (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))- (vquasi #'q lev))))
- ((unquote-splicing p ...)
- (if (= lev 0)
- (quasiappend #'(("value" p) ...) (vquasi #'q lev))- (quasicons
- (quasicons
- #'("quote" unquote-splicing)- (quasi #'(p ...) (- lev 1)))
- (vquasi #'q lev))))
- (_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
- (() #'("quote" ()))))- (define (quasicons x y)
- (with-syntax ((x x) (y y))
- (syntax-case #'y ()
- (("quote" dy)- (syntax-case #'x ()
- (("quote" dx) #'("quote" (dx . dy)))- (_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))- (("list" . stuff) #'("list" x . stuff))- (("list*" . stuff) #'("list*" x . stuff))- (_ #'("list*" x y)))))- (define (quasiappend x y)
- (syntax-case y ()
- (("quote" ())- (cond
- ((null? x) #'("quote" ()))- ((null? (cdr x)) (car x))
- (else (with-syntax (((p ...) x)) #'("append" p ...)))))- (_
- (cond
- ((null? x) y)
- (else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))- (define (quasilist* x y)
- (let f ((x x))
- (if (null? x)
- y
- (quasicons (car x) (f (cdr x))))))
- (define (quasivector x)
- (syntax-case x ()
- (("quote" (x ...)) #'("quote" #(x ...)))- (_
- (let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))- (syntax-case y ()
- (("quote" (y ...)) (k #'(("quote" y) ...)))- (("list" y ...) (k #'(y ...)))- (("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))- (else #`("list->vector" #,x)))))))- (define (emit x)
- (syntax-case x ()
- (("quote" x) #''x)- (("list" x ...) #`(list #,@(map emit #'(x ...))))- ; could emit list* for 3+ arguments if implementation supports list*
- (("list*" x ... y)- (let f ((x* #'(x ...)))
- (if (null? x*)
- (emit #'y)
- #`(cons #,(emit (car x*)) #,(f (cdr x*))))))
- (("append" x ...) #`(append #,@(map emit #'(x ...))))- (("vector" x ...) #`(vector #,@(map emit #'(x ...))))- (("list->vector" x) #`(list->vector #,(emit #'x)))- (("value" x) #'x)))- (lambda (x)
- (syntax-case x ()
- ; convert to intermediate language, combining introduced (but not
- ; unquoted source) quote expressions where possible and choosing
- ; optimal construction code otherwise, then emit Scheme code
- ; corresponding to the intermediate language forms.
- ((_ e) (emit (quasi #'e 0)))))))
-
-(define-syntax unquote
- (lambda (x)
- (syntax-error x "misplaced")))
-
-(define-syntax unquote-splicing
- (lambda (x)
- (syntax-error x "misplaced")))
-
-(define-syntax quasisyntax
- (lambda (x)
- (define (qs q n b* k)
- (syntax-case q (quasisyntax unsyntax unsyntax-splicing)
- ((quasisyntax . d)
- (qs #'d (+ n 1) b*
- (lambda (b* dnew)
- (k b*
- (if (eq? dnew #'d)
- q
- (with-syntax ((d dnew)) #'(quasisyntax . d)))))))
- ((unsyntax . d)
- (not (= n 0))
- (qs #'d (- n 1) b*
- (lambda (b* dnew)
- (k b*
- (if (eq? dnew #'d)
- q
- (with-syntax ((d dnew)) #'(unsyntax . d)))))))
- ((unsyntax-splicing . d)
- (not (= n 0))
- (qs #'d (- n 1) b*
- (lambda (b* dnew)
- (k b*
- (if (eq? dnew #'d)
- q
- (with-syntax ((d dnew)) #'(unsyntax-splicing . d)))))))
- ((unsyntax q)
- (= n 0)
- (with-syntax (((t) (generate-temporaries #'(q))))
- (k (cons #'(t q) b*) #'t)))
- (((unsyntax q ...) . d)
- (= n 0)
- (qs #'d n b*
- (lambda (b* dnew)
- (with-syntax (((t ...) (generate-temporaries #'(q ...))))
- (k (append #'((t q) ...) b*)
- (with-syntax ((d dnew)) #'(t ... . d)))))))
- (((unsyntax-splicing q ...) . d)
- (= n 0)
- (qs #'d n b*
- (lambda (b* dnew)
- (with-syntax (((t ...) (generate-temporaries #'(q ...))))
- (k (append #'(((t (... ...)) q) ...) b*)
- (with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
- (with-syntax ((d dnew)) #'(m ... ... . d))))))))
- ((a . d)
- (qs #'a n b*
- (lambda (b* anew)
- (qs #'d n b*
- (lambda (b* dnew)
- (k b*
- (if (and (eq? anew #'a) (eq? dnew #'d))
- q
- (with-syntax ((a anew) (d dnew)) #'(a . d)))))))))
- (#(x ...)
- (vqs #'(x ...) n b*
- (lambda (b* xnew*)
- (k b*
- (if (let same? ((x* #'(x ...)) (xnew* xnew*))
- (if (null? x*)
- (null? xnew*)
- (and (not (null? xnew*))
- (eq? (car x*) (car xnew*))
- (same? (cdr x*) (cdr xnew*)))))
- q
- (with-syntax (((x ...) xnew*)) #'#(x ...)))))))
- (_ (k b* q))))
- (define (vqs x* n b* k)
- (if (null? x*)
- (k b* '())
- (vqs (cdr x*) n b*
- (lambda (b* xnew*)
- (syntax-case (car x*) (unsyntax unsyntax-splicing)
- ((unsyntax q ...)
- (= n 0)
- (with-syntax (((t ...) (generate-temporaries #'(q ...))))
- (k (append #'((t q) ...) b*)
- (append #'(t ...) xnew*))))
- ((unsyntax-splicing q ...)
- (= n 0)
- (with-syntax (((t ...) (generate-temporaries #'(q ...))))
- (k (append #'(((t (... ...)) q) ...) b*)
- (with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
- (append #'(m ... ...) xnew*)))))
- (_ (qs (car x*) n b*
- (lambda (b* xnew)
- (k b* (cons xnew xnew*))))))))))
- (syntax-case x ()
- ((_ x)
- (qs #'x 0 '()
- (lambda (b* xnew)
- (if (eq? xnew #'x)
- #'(syntax x)
- (with-syntax (((b ...) b*) (x xnew))
- #'(with-syntax (b ...) (syntax x))))))))))
-
-(define-syntax unsyntax
- (lambda (x)
- (syntax-error x "misplaced")))
-
-(define-syntax unsyntax-splicing
- (lambda (x)
- (syntax-error x "misplaced")))
-
-(define-syntax include
- (lambda (x)
- (define read-file
- (lambda (fn k)
- (let ((p (open-input-file fn)))
- (let f ()
- (let ((x (read p)))
- (if (eof-object? x)
- (begin (close-input-port p) '())
- (cons (datum->syntax-object k x) (f))))))))
- (syntax-case x ()
- ((k filename)
- (let ((fn (syntax-object->datum (syntax filename))))
- (with-syntax (((exp ...) (read-file fn (syntax k))))
- (syntax (begin exp ...))))))))
-
-(define-syntax case
- (lambda (x)
- (syntax-case x ()
- ((_ e m1 m2 ...)
- (with-syntax
- ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
- (if (null? clauses)
- (syntax-case clause (else)
- ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
- (((k ...) e1 e2 ...)
- (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
- (_ (syntax-error x)))
- (with-syntax ((rest (f (car clauses) (cdr clauses))))
- (syntax-case clause (else)
- (((k ...) e1 e2 ...)
- (syntax (if (memv t '(k ...))
- (begin e1 e2 ...)
- rest)))
- (_ (syntax-error x))))))))
- (syntax (let ((t e)) body)))))))
-
-(define-syntax identifier-syntax
- (syntax-rules (set!)
- ((_ e)
- (lambda (x)
- (syntax-case x ()
- (id (identifier? (syntax id)) (syntax e))
- ((_ x (... ...)) (syntax (e x (... ...)))))))
- ((_ (id exp1) ((set! var val) exp2))
- (and (identifier? (syntax id)) (identifier? (syntax var)))
- (cons 'macro!
- (lambda (x)
- (syntax-case x (set!)
- ((set! var val) (syntax exp2))
- ((id x (... ...)) (syntax (exp1 x (... ...))))
- (id (identifier? (syntax id)) (syntax exp1))))))))
-
--- a/femtolisp/lib/sort.scm
+++ /dev/null
@@ -1,193 +1,0 @@
-;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
-;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
-;;;
-;;; This code is in the public domain.
-
-;;; Updated: 11 June 1991
-;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
-;;; Updated: 19 June 1995
-;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09
-;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
-;;; jaffer: 2006-10-08:
-;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument.
-;;; jaffer: 2006-11-05:
-;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once
-;;; per element.
-
-;(require 'array)
-
-;;; (sorted? sequence less?)
-;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
-;;; such that for all 1 <= i <= m,
-;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
-;@
-(define (sorted? seq less? . opt-key)
- (define key (if (null? opt-key) identity (car opt-key)))
- (cond ((null? seq) #t)
- ((array? seq)
- (let ((dimax (+ -1 (car (array-dimensions seq)))))
- (or (<= dimax 1)
- (let loop ((idx (+ -1 dimax))
- (last (key (array-ref seq dimax))))
- (or (negative? idx)
- (let ((nxt (key (array-ref seq idx))))
- (and (less? nxt last)
- (loop (+ -1 idx) nxt))))))))
- ((null? (cdr seq)) #t)
- (else
- (let loop ((last (key (car seq)))
- (next (cdr seq)))
- (or (null? next)
- (let ((nxt (key (car next))))
- (and (not (less? nxt last))
- (loop nxt (cdr next)))))))))
-
-;;; (merge a b less?)
-;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
-;;; and returns a new list in which the elements of a and b have been stably
-;;; interleaved so that (sorted? (merge a b less?) less?).
-;;; Note: this does _not_ accept arrays. See below.
-;@
-(define (merge a b less? . opt-key)
- (define key (if (null? opt-key) identity (car opt-key)))
- (cond ((null? a) b)
- ((null? b) a)
- (else
- (let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
- (y (car b)) (ky (key (car b))) (b (cdr b)))
- ;; The loop handles the merging of non-empty lists. It has
- ;; been written this way to save testing and car/cdring.
- (if (less? ky kx)
- (if (null? b)
- (cons y (cons x a))
- (cons y (loop x kx a (car b) (key (car b)) (cdr b))))
- ;; x <= y
- (if (null? a)
- (cons x (cons y b))
- (cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
-
-(define (sort:merge! a b less? key)
- (define (loop r a kcara b kcarb)
- (cond ((less? kcarb kcara)
- (set-cdr! r b)
- (if (null? (cdr b))
- (set-cdr! b a)
- (loop b a kcara (cdr b) (key (cadr b)))))
- (else ; (car a) <= (car b)
- (set-cdr! r a)
- (if (null? (cdr a))
- (set-cdr! a b)
- (loop a (cdr a) (key (cadr a)) b kcarb)))))
- (cond ((null? a) b)
- ((null? b) a)
- (else
- (let ((kcara (key (car a)))
- (kcarb (key (car b))))
- (cond
- ((less? kcarb kcara)
- (if (null? (cdr b))
- (set-cdr! b a)
- (loop b a kcara (cdr b) (key (cadr b))))
- b)
- (else ; (car a) <= (car b)
- (if (null? (cdr a))
- (set-cdr! a b)
- (loop a (cdr a) (key (cadr a)) b kcarb))
- a))))))
-
-;;; takes two sorted lists a and b and smashes their cdr fields to form a
-;;; single sorted list including the elements of both.
-;;; Note: this does _not_ accept arrays.
-;@
-(define (merge! a b less? . opt-key)
- (sort:merge! a b less? (if (null? opt-key) identity (car opt-key))))
-
-(define (sort:sort-list! seq less? key)
- (define keyer (if key car identity))
- (define (step n)
- (cond ((> n 2) (let* ((j (quotient n 2))
- (a (step j))
- (k (- n j))
- (b (step k)))
- (sort:merge! a b less? keyer)))
- ((= n 2) (let ((x (car seq))
- (y (cadr seq))
- (p seq))
- (set! seq (cddr seq))
- (cond ((less? (keyer y) (keyer x))
- (set-car! p y)
- (set-car! (cdr p) x)))
- (set-cdr! (cdr p) '())
- p))
- ((= n 1) (let ((p seq))
- (set! seq (cdr seq))
- (set-cdr! p '())
- p))
- (else '())))
- (define (key-wrap! lst)
- (cond ((null? lst))
- (else (set-car! lst (cons (key (car lst)) (car lst)))
- (key-wrap! (cdr lst)))))
- (define (key-unwrap! lst)
- (cond ((null? lst))
- (else (set-car! lst (cdar lst))
- (key-unwrap! (cdr lst)))))
- (cond (key
- (key-wrap! seq)
- (set! seq (step (length seq)))
- (key-unwrap! seq)
- seq)
- (else
- (step (length seq)))))
-
-(define (rank-1-array->list array)
- (define dimensions (array-dimensions array))
- (do ((idx (+ -1 (car dimensions)) (+ -1 idx))
- (lst '() (cons (array-ref array idx) lst)))
- ((< idx 0) lst)))
-
-;;; (sort! sequence less?)
-;;; sorts the list, array, or string sequence destructively. It uses
-;;; a version of merge-sort invented, to the best of my knowledge, by
-;;; David H. D. Warren, and first used in the DEC-10 Prolog system.
-;;; R. A. O'Keefe adapted it to work destructively in Scheme.
-;;; A. Jaffer modified to always return the original list.
-;@
-(define (sort! seq less? . opt-key)
- (define key (if (null? opt-key) #f (car opt-key)))
- (cond ((array? seq)
- (let ((dims (array-dimensions seq)))
- (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
- (cdr sorted))
- (i 0 (+ i 1)))
- ((null? sorted) seq)
- (array-set! seq (car sorted) i))))
- (else ; otherwise, assume it is a list
- (let ((ret (sort:sort-list! seq less? key)))
- (if (not (eq? ret seq))
- (do ((crt ret (cdr crt)))
- ((eq? (cdr crt) seq)
- (set-cdr! crt ret)
- (let ((scar (car seq)) (scdr (cdr seq)))
- (set-car! seq (car ret)) (set-cdr! seq (cdr ret))
- (set-car! ret scar) (set-cdr! ret scdr)))))
- seq))))
-
-;;; (sort sequence less?)
-;;; sorts a array, string, or list non-destructively. It does this
-;;; by sorting a copy of the sequence. My understanding is that the
-;;; Standard says that the result of append is always "newly
-;;; allocated" except for sharing structure with "the last argument",
-;;; so (append x '()) ought to be a standard way of copying a list x.
-;@
-(define (sort seq less? . opt-key)
- (define key (if (null? opt-key) #f (car opt-key)))
- (cond ((array? seq)
- (let ((dims (array-dimensions seq)))
- (define newra (apply make-array seq dims))
- (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
- (cdr sorted))
- (i 0 (+ i 1)))
- ((null? sorted) newra)
- (array-set! newra (car sorted) i))))
- (else (sort:sort-list! (append seq '()) less? key))))
--- a/femtolisp/mkboot0.lsp
+++ /dev/null
@@ -1,20 +1,0 @@
-; -*- scheme -*-
-
-(if (not (bound? 'top-level-value)) (set! top-level-value %eval))
-(if (not (bound? 'set-top-level-value!)) (set! set-top-level-value! set))
-(if (not (bound? 'eof-object?)) (set! eof-object? (lambda (x) #f)))
-
-;(load "compiler.lsp")
-
-(define (compile-file inf)
- (let ((in (file inf :read)))
- (let next ((E (read in)))
- (if (not (io.eof? in))
- (begin (print (compile-thunk (expand E)))
- (princ "\n")
- (next (read in)))))
- (io.close in)))
-
-(for-each (lambda (file)
- (compile-file file))
- (cdr *argv*))
--- a/femtolisp/mkboot1.lsp
+++ /dev/null
@@ -1,5 +1,0 @@
-; -*- scheme -*-
-
-(load "system.lsp")
-(load "compiler.lsp")
-(make-system-image "flisp.boot")
--- a/femtolisp/opaque_type_template.c
+++ /dev/null
@@ -1,63 +1,0 @@
-#include <stdlib.h>
-#include <stdio.h>
-#include <stdarg.h>
-#include <string.h>
-#include <assert.h>
-#include <sys/types.h>
-#include "llt.h"
-#include "flisp.h"
-
-// global replace TYPE with your type name to make your very own type!
-
-static value_t TYPEsym;
-static fltype_t *TYPEtype;
-
-void print_TYPE(value_t v, ios_t *f, int princ)
-{-}
-
-void print_traverse_TYPE(value_t self)
-{-}
-
-void free_TYPE(value_t self)
-{-}
-
-void relocate_TYPE(value_t oldv, value_t newv)
-{-}
-
-cvtable_t TYPE_vtable = { print_TYPE, relocate_TYPE, free_TYPE,- print_traverse_TYPE };
-
-int isTYPE(value_t v)
-{- return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == TYPEtype;
-}
-
-value_t fl_TYPEp(value_t *args, uint32_t nargs)
-{- argcount("TYPE?", nargs, 1);- return isTYPE(args[0]) ? FL_T : FL_F;
-}
-
-static TYPE_t *toTYPE(value_t v, char *fname)
-{- if (!isTYPE(v))
- type_error(fname, "TYPE", v);
- return (TYPE_t*)cv_data((cvalue_t*)ptr(v));
-}
-
-static builtinspec_t TYPEfunc_info[] = {- { "TYPE?", fl_TYPEp },- { NULL, NULL }-};
-
-void TYPE_init()
-{- TYPEsym = symbol("TYPE");- TYPEtype = define_opaque_type(TYPEsym, sizeof(TYPE_t),
- &TYPE_vtable, NULL);
- assign_global_builtins(TYPEfunc_info);
-}
--- a/femtolisp/opcodes.h
+++ /dev/null
@@ -1,101 +1,0 @@
-#ifndef __OPCODES_H_
-#define __OPCODES_H_
-
-enum {- OP_NOP=0, OP_DUP, OP_POP, OP_CALL, OP_TCALL, OP_JMP, OP_BRF, OP_BRT,
- OP_JMPL, OP_BRFL, OP_BRTL, OP_RET,
-
- OP_EQ, OP_EQV, OP_EQUAL, OP_ATOMP, OP_NOT, OP_NULLP, OP_BOOLEANP,
- OP_SYMBOLP, OP_NUMBERP, OP_BOUNDP, OP_PAIRP, OP_BUILTINP, OP_VECTORP,
- OP_FIXNUMP, OP_FUNCTIONP,
-
- OP_CONS, OP_LIST, OP_CAR, OP_CDR, OP_SETCAR, OP_SETCDR,
- OP_APPLY,
-
- OP_ADD, OP_SUB, OP_MUL, OP_DIV, OP_IDIV, OP_NUMEQ, OP_LT, OP_COMPARE,
-
- OP_VECTOR, OP_AREF, OP_ASET,
-
- OP_LOADT, OP_LOADF, OP_LOADNIL, OP_LOAD0, OP_LOAD1, OP_LOADI8,
- OP_LOADV, OP_LOADVL,
- OP_LOADG, OP_LOADGL,
- OP_LOADA, OP_LOADAL, OP_LOADC, OP_LOADCL,
- OP_SETG, OP_SETGL,
- OP_SETA, OP_SETAL, OP_SETC, OP_SETCL,
-
- OP_CLOSURE, OP_ARGC, OP_VARGC, OP_TRYCATCH, OP_FOR,
- OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_LARGC, OP_LVARGC,
- OP_LOADA0, OP_LOADA1, OP_LOADC00, OP_LOADC01, OP_CALLL, OP_TCALLL,
- OP_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL,
- OP_OPTARGS, OP_BRBOUND, OP_KEYARGS,
-
- OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST, OP_EOF_OBJECT,
-
- N_OPCODES
-};
-
-#ifdef USE_COMPUTED_GOTO
-#define VM_LABELS \
- static void *vm_labels[] = { \-NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
- &&L_OP_BRF, &&L_OP_BRT, \
- &&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
- \
- &&L_OP_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, &&L_OP_NOT, \
- &&L_OP_NULLP, &&L_OP_BOOLEANP, \
- &&L_OP_SYMBOLP, &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, \
- &&L_OP_BUILTINP, &&L_OP_VECTORP, \
- &&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
- \
- &&L_OP_CONS, &&L_OP_LIST, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_SETCAR, \
- &&L_OP_SETCDR, &&L_OP_APPLY, \
- \
- &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, &&L_OP_IDIV, &&L_OP_NUMEQ, \
- &&L_OP_LT, &&L_OP_COMPARE, \
- \
- &&L_OP_VECTOR, &&L_OP_AREF, &&L_OP_ASET, \
- \
- &&L_OP_LOADT, &&L_OP_LOADF, &&L_OP_LOADNIL, &&L_OP_LOAD0, &&L_OP_LOAD1, \
- &&L_OP_LOADI8, \
- &&L_OP_LOADV, &&L_OP_LOADVL, \
- &&L_OP_LOADG, &&L_OP_LOADGL, \
- &&L_OP_LOADA, &&L_OP_LOADAL, &&L_OP_LOADC, &&L_OP_LOADCL, \
- &&L_OP_SETG, &&L_OP_SETGL, \
- &&L_OP_SETA, &&L_OP_SETAL, &&L_OP_SETC, &&L_OP_SETCL, \
- \
- &&L_OP_CLOSURE, &&L_OP_ARGC, &&L_OP_VARGC, &&L_OP_TRYCATCH, \
- &&L_OP_FOR, \
- &&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, &&L_OP_NEG, &&L_OP_LARGC, \
- &&L_OP_LVARGC, \
- &&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01, \
- &&L_OP_CALLL, &&L_OP_TCALLL, &&L_OP_BRNE, &&L_OP_BRNEL, &&L_OP_CADR,\
- &&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL, \
- &&L_OP_OPTARGS, &&L_OP_BRBOUND, &&L_OP_KEYARGS \
- }
-
-#define VM_APPLY_LABELS \
- static void *vm_apply_labels[] = { \-NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
- &&L_OP_BRF, &&L_OP_BRT, \
- &&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
- \
- &&L_OP_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, &&L_OP_NOT, \
- &&L_OP_NULLP, &&L_OP_BOOLEANP, \
- &&L_OP_SYMBOLP, &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, \
- &&L_OP_BUILTINP, &&L_OP_VECTORP, \
- &&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
- \
- &&L_OP_CONS, &&apply_list, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_SETCAR, \
- &&L_OP_SETCDR, &&apply_apply, \
- \
- &&apply_add, &&apply_sub, &&apply_mul, &&apply_div, &&L_OP_IDIV, &&L_OP_NUMEQ, \
- &&L_OP_LT, &&L_OP_COMPARE, \
- \
- &&apply_vector, &&L_OP_AREF, &&L_OP_ASET \
- }
-#else
-#define VM_LABELS
-#define VM_APPLY_LABELS
-#endif
-
-#endif
--- a/femtolisp/print.c
+++ /dev/null
@@ -1,773 +1,0 @@
-extern void *memrchr(const void *s, int c, size_t n);
-
-static htable_t printconses;
-static u_int32_t printlabel;
-static int print_pretty;
-static int print_princ;
-static fixnum_t print_length;
-static fixnum_t print_level;
-static fixnum_t P_LEVEL;
-static int SCR_WIDTH = 80;
-
-static int HPOS=0, VPOS;
-static void outc(char c, ios_t *f)
-{- ios_putc(c, f);
- if (c == '\n')
- HPOS = 0;
- else
- HPOS++;
-}
-static void outs(char *s, ios_t *f)
-{- ios_puts(s, f);
- HPOS += u8_strwidth(s);
-}
-static void outsn(char *s, ios_t *f, size_t n)
-{- ios_write(f, s, n);
- HPOS += u8_strwidth(s);
-}
-static int outindent(int n, ios_t *f)
-{- // move back to left margin if we get too indented
- if (n > SCR_WIDTH-12)
- n = 2;
- int n0 = n;
- ios_putc('\n', f);- VPOS++;
- HPOS = n;
- while (n >= 8) {- ios_putc('\t', f);- n -= 8;
- }
- while (n) {- ios_putc(' ', f);- n--;
- }
- return n0;
-}
-
-void fl_print_chr(char c, ios_t *f)
-{- outc(c, f);
-}
-
-void fl_print_str(char *s, ios_t *f)
-{- outs(s, f);
-}
-
-void print_traverse(value_t v)
-{- value_t *bp;
- while (iscons(v)) {- if (ismarked(v)) {- bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
- if (*bp == (value_t)HT_NOTFOUND)
- *bp = fixnum(printlabel++);
- return;
- }
- mark_cons(v);
- print_traverse(car_(v));
- v = cdr_(v);
- }
- if (!ismanaged(v) || issymbol(v))
- return;
- if (ismarked(v)) {- bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
- if (*bp == (value_t)HT_NOTFOUND)
- *bp = fixnum(printlabel++);
- return;
- }
- if (isvector(v)) {- if (vector_size(v) > 0)
- mark_cons(v);
- unsigned int i;
- for(i=0; i < vector_size(v); i++)
- print_traverse(vector_elt(v,i));
- }
- else if (iscprim(v)) {- mark_cons(v);
- }
- else if (isclosure(v)) {- mark_cons(v);
- function_t *f = (function_t*)ptr(v);
- print_traverse(f->bcode);
- print_traverse(f->vals);
- print_traverse(f->env);
- }
- else {- assert(iscvalue(v));
- cvalue_t *cv = (cvalue_t*)ptr(v);
- // don't consider shared references to ""
- if (!cv_isstr(cv) || cv_len(cv)!=0)
- mark_cons(v);
- fltype_t *t = cv_class(cv);
- if (t->vtable != NULL && t->vtable->print_traverse != NULL)
- t->vtable->print_traverse(v);
- }
-}
-
-static void print_symbol_name(ios_t *f, char *name)
-{- int i, escape=0, charescape=0;
-
- if ((name[0] == '\0') ||
- (name[0] == '.' && name[1] == '\0') ||
- (name[0] == '#') ||
- isnumtok(name, NULL))
- escape = 1;
- i=0;
- while (name[i]) {- if (!symchar(name[i])) {- escape = 1;
- if (name[i]=='|' || name[i]=='\\') {- charescape = 1;
- break;
- }
- }
- i++;
- }
- if (escape) {- if (charescape) {- outc('|', f);- i=0;
- while (name[i]) {- if (name[i]=='|' || name[i]=='\\')
- outc('\\', f);- outc(name[i], f);
- i++;
- }
- outc('|', f);- }
- else {- outc('|', f);- outs(name, f);
- outc('|', f);- }
- }
- else {- outs(name, f);
- }
-}
-
-/*
- The following implements a simple pretty-printing algorithm. This is
- an unlimited-width approach that doesn't require an extra pass.
- It uses some heuristics to guess whether an expression is "small",
- and avoids wrapping symbols across lines. The result is high
- performance and nice output for typical code. Quality is poor for
- pathological or deeply-nested expressions, but those are difficult
- to print anyway.
-*/
-#define SMALL_STR_LEN 20
-static inline int tinyp(value_t v)
-{- if (issymbol(v))
- return (u8_strwidth(symbol_name(v)) < SMALL_STR_LEN);
- if (fl_isstring(v))
- return (cv_len((cvalue_t*)ptr(v)) < SMALL_STR_LEN);
- return (isfixnum(v) || isbuiltin(v) || v==FL_F || v==FL_T || v==FL_NIL ||
- v == FL_EOF);
-}
-
-static int smallp(value_t v)
-{- if (tinyp(v)) return 1;
- if (fl_isnumber(v)) return 1;
- if (iscons(v)) {- if (tinyp(car_(v)) && (tinyp(cdr_(v)) ||
- (iscons(cdr_(v)) && tinyp(car_(cdr_(v))) &&
- cdr_(cdr_(v))==NIL)))
- return 1;
- return 0;
- }
- if (isvector(v)) {- size_t s = vector_size(v);
- return (s == 0 || (tinyp(vector_elt(v,0)) &&
- (s == 1 || (s == 2 &&
- tinyp(vector_elt(v,1))))));
- }
- return 0;
-}
-
-static int specialindent(value_t head)
-{- // indent these forms 2 spaces, not lined up with the first argument
- if (head == LAMBDA || head == TRYCATCH || head == definesym ||
- head == defmacrosym || head == forsym)
- return 2;
- return -1;
-}
-
-static int lengthestimate(value_t v)
-{- // get the width of an expression if we can do so cheaply
- if (issymbol(v))
- return u8_strwidth(symbol_name(v));
- return -1;
-}
-
-static int allsmallp(value_t v)
-{- int n = 1;
- while (iscons(v)) {- if (!smallp(car_(v)))
- return 0;
- v = cdr_(v);
- n++;
- if (n > 25)
- return n;
- }
- return n;
-}
-
-static int indentafter3(value_t head, value_t v)
-{- // for certain X always indent (X a b c) after b
- return ((head == forsym) && !allsmallp(cdr_(v)));
-}
-
-static int indentafter2(value_t head, value_t v)
-{- // for certain X always indent (X a b) after a
- return ((head == definesym || head == defmacrosym) &&
- !allsmallp(cdr_(v)));
-}
-
-static int indentevery(value_t v)
-{- // indent before every subform of a special form, unless every
- // subform is "small"
- value_t c = car_(v);
- if (c == LAMBDA || c == setqsym)
- return 0;
- if (c == IF) // TODO: others
- return !allsmallp(cdr_(v));
- return 0;
-}
-
-static int blockindent(value_t v)
-{- // in this case we switch to block indent mode, where the head
- // is no longer considered special:
- // (a b c d e
- // f g h i j)
- return (allsmallp(v) > 9);
-}
-
-static void print_pair(ios_t *f, value_t v)
-{- value_t cd;
- char *op = NULL;
- if (iscons(cdr_(v)) && cdr_(cdr_(v)) == NIL &&
- !ptrhash_has(&printconses, (void*)cdr_(v)) &&
- (((car_(v) == QUOTE) && (op = "'")) ||
- ((car_(v) == BACKQUOTE) && (op = "`")) ||
- ((car_(v) == COMMA) && (op = ",")) ||
- ((car_(v) == COMMAAT) && (op = ",@")) ||
- ((car_(v) == COMMADOT) && (op = ",.")))) {- // special prefix syntax
- unmark_cons(v);
- unmark_cons(cdr_(v));
- outs(op, f);
- fl_print_child(f, car_(cdr_(v)));
- return;
- }
- int startpos = HPOS;
- outc('(', f);- int newindent=HPOS, blk=blockindent(v);
- int lastv, n=0, si, ind=0, est, always=0, nextsmall, thistiny;
- if (!blk) always = indentevery(v);
- value_t head = car_(v);
- int after3 = indentafter3(head, v);
- int after2 = indentafter2(head, v);
- int n_unindented = 1;
- while (1) {- cd = cdr_(v);
- if (print_length >= 0 && n >= print_length && cd!=NIL) {- outsn("...)", f, 4);- break;
- }
- lastv = VPOS;
- unmark_cons(v);
- fl_print_child(f, car_(v));
- if (!iscons(cd) || ptrhash_has(&printconses, (void*)cd)) {- if (cd != NIL) {- outsn(" . ", f, 3);- fl_print_child(f, cd);
- }
- outc(')', f);- break;
- }
-
- if (!print_pretty ||
- ((head == LAMBDA) && n == 0)) {- // never break line before lambda-list
- ind = 0;
- }
- else {- est = lengthestimate(car_(cd));
- nextsmall = smallp(car_(cd));
- thistiny = tinyp(car_(v));
- ind = (((VPOS > lastv) ||
- (HPOS>SCR_WIDTH/2 && !nextsmall && !thistiny && n>0)) ||
-
- (HPOS > SCR_WIDTH-4) ||
-
- (est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
-
- ((head == LAMBDA) && !nextsmall) ||
-
- (n > 0 && always) ||
-
- (n == 2 && after3) ||
- (n == 1 && after2) ||
-
- (n_unindented >= 3 && !nextsmall) ||
-
- (n == 0 && !smallp(head)));
- }
-
- if (ind) {- newindent = outindent(newindent, f);
- n_unindented = 1;
- }
- else {- n_unindented++;
- outc(' ', f);- if (n==0) {- // set indent level after printing head
- si = specialindent(head);
- if (si != -1)
- newindent = startpos + si;
- else if (!blk)
- newindent = HPOS;
- }
- }
- n++;
- v = cd;
- }
-}
-
-static void cvalue_print(ios_t *f, value_t v);
-
-static int print_circle_prefix(ios_t *f, value_t v)
-{- value_t label;
- if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) !=
- (value_t)HT_NOTFOUND) {- if (!ismarked(v)) {- HPOS+=ios_printf(f, "#%ld#", numval(label));
- return 1;
- }
- HPOS+=ios_printf(f, "#%ld=", numval(label));
- }
- if (ismanaged(v))
- unmark_cons(v);
- return 0;
-}
-
-void fl_print_child(ios_t *f, value_t v)
-{- char *name;
- if (print_level >= 0 && P_LEVEL >= print_level &&
- (iscons(v) || isvector(v) || isclosure(v))) {- outc('#', f);- return;
- }
- P_LEVEL++;
-
- switch (tag(v)) {- case TAG_NUM :
- case TAG_NUM1: HPOS+=ios_printf(f, "%ld", numval(v)); break;
- case TAG_SYM:
- name = symbol_name(v);
- if (print_princ)
- outs(name, f);
- else if (ismanaged(v)) {- outsn("#:", f, 2);- outs(name, f);
- }
- else
- print_symbol_name(f, name);
- break;
- case TAG_FUNCTION:
- if (v == FL_T) {- outsn("#t", f, 2);- }
- else if (v == FL_F) {- outsn("#f", f, 2);- }
- else if (v == FL_NIL) {- outsn("()", f, 2);- }
- else if (v == FL_EOF) {- outsn("#<eof>", f, 6);- }
- else if (isbuiltin(v)) {- if (!print_princ)
- outsn("#.", f, 2);- outs(builtin_names[uintval(v)], f);
- }
- else {- assert(isclosure(v));
- if (!print_princ) {- if (print_circle_prefix(f, v)) break;
- function_t *fn = (function_t*)ptr(v);
- outs("#fn(", f);- char *data = cvalue_data(fn->bcode);
- size_t i, sz = cvalue_len(fn->bcode);
- for(i=0; i < sz; i++) data[i] += 48;
- fl_print_child(f, fn->bcode);
- for(i=0; i < sz; i++) data[i] -= 48;
- outc(' ', f);- fl_print_child(f, fn->vals);
- if (fn->env != NIL) {- outc(' ', f);- fl_print_child(f, fn->env);
- }
- if (fn->name != LAMBDA) {- outc(' ', f);- fl_print_child(f, fn->name);
- }
- outc(')', f);- }
- else {- outs("#<function>", f);- }
- }
- break;
- case TAG_CVALUE:
- case TAG_CPRIM:
- if (v == UNBOUND) { outs("#<undefined>", f); break; }- case TAG_VECTOR:
- case TAG_CONS:
- if (print_circle_prefix(f, v)) break;
- if (isvector(v)) {- outc('[', f);- int newindent = HPOS, est;
- int i, sz = vector_size(v);
- for(i=0; i < sz; i++) {- if (print_length >= 0 && i >= print_length && i < sz-1) {- outsn("...", f, 3);- break;
- }
- fl_print_child(f, vector_elt(v,i));
- if (i < sz-1) {- if (!print_pretty) {- outc(' ', f);- }
- else {- est = lengthestimate(vector_elt(v,i+1));
- if (HPOS > SCR_WIDTH-4 ||
- (est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
- (HPOS > SCR_WIDTH/2 &&
- !smallp(vector_elt(v,i+1)) &&
- !tinyp(vector_elt(v,i))))
- newindent = outindent(newindent, f);
- else
- outc(' ', f);- }
- }
- }
- outc(']', f);- break;
- }
- if (iscvalue(v) || iscprim(v))
- cvalue_print(f, v);
- else
- print_pair(f, v);
- break;
- }
- P_LEVEL--;
-}
-
-static void print_string(ios_t *f, char *str, size_t sz)
-{- char buf[512];
- size_t i = 0;
- uint8_t c;
- static char hexdig[] = "0123456789abcdef";
-
- outc('"', f);- if (!u8_isvalid(str, sz)) {- // alternate print algorithm that preserves data if it's not UTF-8
- for(i=0; i < sz; i++) {- c = str[i];
- if (c == '\\')
- outsn("\\\\", f, 2);- else if (c == '"')
- outsn("\\\"", f, 2);- else if (c >= 32 && c < 0x7f)
- outc(c, f);
- else {- outsn("\\x", f, 2);- outc(hexdig[c>>4], f);
- outc(hexdig[c&0xf], f);
- }
- }
- }
- else {- while (i < sz) {- size_t n = u8_escape(buf, sizeof(buf), str, &i, sz, 1, 0);
- outsn(buf, f, n-1);
- }
- }
- outc('"', f);-}
-
-static numerictype_t sym_to_numtype(value_t type);
-
-// 'weak' means we don't need to accurately reproduce the type, so
-// for example #int32(0) can be printed as just 0. this is used
-// printing in a context where a type is already implied, e.g. inside
-// an array.
-static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
- int weak)
-{- if (type == bytesym) {- unsigned char ch = *(unsigned char*)data;
- if (print_princ)
- outc(ch, f);
- else if (weak)
- HPOS+=ios_printf(f, "0x%hhx", ch);
- else
- HPOS+=ios_printf(f, "#byte(0x%hhx)", ch);
- }
- else if (type == wcharsym) {- uint32_t wc = *(uint32_t*)data;
- char seq[8];
- size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1);
- seq[nb] = '\0';
- if (print_princ) {- // TODO: better multibyte handling
- outs(seq, f);
- }
- else {- outsn("#\\", f, 2);- if (wc == 0x00) outsn("nul", f, 3);- else if (wc == 0x07) outsn("alarm", f, 5);- else if (wc == 0x08) outsn("backspace", f, 9);- else if (wc == 0x09) outsn("tab", f, 3);- else if (wc == 0x0A) outsn("linefeed", f, 8);- //else if (wc == 0x0A) outsn("newline", f, 7);- else if (wc == 0x0B) outsn("vtab", f, 4);- else if (wc == 0x0C) outsn("page", f, 4);- else if (wc == 0x0D) outsn("return", f, 6);- else if (wc == 0x1B) outsn("esc", f, 3);- else if (wc == 0x20) outsn("space", f, 5);- else if (wc == 0x7F) outsn("delete", f, 6);- else if (iswprint(wc)) outs(seq, f);
- else HPOS+=ios_printf(f, "x%04x", (int)wc);
- }
- }
- else if (type == floatsym || type == doublesym) {- char buf[64];
- double d;
- int ndec;
- if (type == floatsym) { d = (double)*(float*)data; ndec = 8; }- else { d = *(double*)data; ndec = 16; }- if (!DFINITE(d)) {- char *rep;
- if (isnan(d))
- rep = sign_bit(d) ? "-nan.0" : "+nan.0";
- else
- rep = sign_bit(d) ? "-inf.0" : "+inf.0";
- if (type == floatsym && !print_princ && !weak)
- HPOS+=ios_printf(f, "#%s(%s)", symbol_name(type), rep);
- else
- outs(rep, f);
- }
- else if (d == 0) {- if (1/d < 0)
- outsn("-0.0", f, 4);- else
- outsn("0.0", f, 3);- if (type == floatsym && !print_princ && !weak)
- outc('f', f);- }
- else {- snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10);
- int hasdec = (strpbrk(buf, ".eE") != NULL);
- outs(buf, f);
- if (!hasdec) outsn(".0", f, 2);- if (type == floatsym && !print_princ && !weak)
- outc('f', f);- }
- }
- else if (type == uint64sym
-#ifdef BITS64
- || type == ulongsym
-#endif
- ) {- uint64_t ui64 = *(uint64_t*)data;
- if (weak || print_princ)
- HPOS += ios_printf(f, "%llu", ui64);
- else
- HPOS += ios_printf(f, "#%s(%llu)", symbol_name(type), ui64);
- }
- else if (issymbol(type)) {- // handle other integer prims. we know it's smaller than uint64
- // at this point, so int64 is big enough to capture everything.
- int64_t i64 = conv_to_int64(data, sym_to_numtype(type));
- if (weak || print_princ)
- HPOS += ios_printf(f, "%lld", i64);
- else
- HPOS += ios_printf(f, "#%s(%lld)", symbol_name(type), i64);
- }
- else if (iscons(type)) {- if (car_(type) == arraysym) {- value_t eltype = car(cdr_(type));
- size_t cnt, elsize;
- if (iscons(cdr_(cdr_(type)))) {- cnt = toulong(car_(cdr_(cdr_(type))), "length");
- elsize = cnt ? len/cnt : 0;
- }
- else {- // incomplete array type
- int junk;
- elsize = ctype_sizeof(eltype, &junk);
- cnt = elsize ? len/elsize : 0;
- }
- if (eltype == bytesym) {- if (print_princ) {- ios_write(f, data, len);
- /*
- char *nl = memrchr(data, '\n', len);
- if (nl)
- HPOS = u8_strwidth(nl+1);
- else
- HPOS += u8_strwidth(data);
- */
- }
- else {- print_string(f, (char*)data, len);
- }
- return;
- }
- else if (eltype == wcharsym) {- // TODO wchar
- }
- else {- }
- size_t i;
- if (!weak) {- if (eltype == uint8sym) {- outsn("#vu8(", f, 5);- }
- else {- outsn("#array(", f, 7);- fl_print_child(f, eltype);
- if (cnt > 0)
- outc(' ', f);- }
- }
- else {- outc('[', f);- }
- for(i=0; i < cnt; i++) {- if (i > 0)
- outc(' ', f);- cvalue_printdata(f, data, elsize, eltype, 1);
- data += elsize;
- }
- if (!weak)
- outc(')', f);- else
- outc(']', f);- }
- else if (car_(type) == enumsym) {- int n = *(int*)data;
- value_t syms = car(cdr_(type));
- assert(isvector(syms));
- if (!weak) {- outsn("#enum(", f, 6);- fl_print_child(f, syms);
- outc(' ', f);- }
- if (n >= (int)vector_size(syms)) {- cvalue_printdata(f, data, len, int32sym, 1);
- }
- else {- fl_print_child(f, vector_elt(syms, n));
- }
- if (!weak)
- outc(')', f);- }
- }
-}
-
-static void cvalue_print(ios_t *f, value_t v)
-{- cvalue_t *cv = (cvalue_t*)ptr(v);
- void *data = cptr(v);
- value_t label;
-
- if (cv_class(cv) == builtintype) {- void *fptr = *(void**)data;
- label = (value_t)ptrhash_get(&reverse_dlsym_lookup_table, cv);
- if (label == (value_t)HT_NOTFOUND) {- HPOS += ios_printf(f, "#<builtin @0x%08lx>",
- (unsigned long)(builtin_t)fptr);
- }
- else {- if (print_princ) {- outs(symbol_name(label), f);
- }
- else {- outsn("#fn(", f, 4);- outs(symbol_name(label), f);
- outc(')', f);- }
- }
- }
- else if (cv_class(cv)->vtable != NULL &&
- cv_class(cv)->vtable->print != NULL) {- cv_class(cv)->vtable->print(v, f);
- }
- else {- value_t type = cv_type(cv);
- size_t len = iscprim(v) ? cv_class(cv)->size : cv_len(cv);
- cvalue_printdata(f, data, len, type, 0);
- }
-}
-
-static void set_print_width()
-{- value_t pw = symbol_value(printwidthsym);
- if (!isfixnum(pw)) return;
- SCR_WIDTH = numval(pw);
-}
-
-void fl_print(ios_t *f, value_t v)
-{- print_pretty = (symbol_value(printprettysym) != FL_F);
- if (print_pretty)
- set_print_width();
- print_princ = (symbol_value(printreadablysym) == FL_F);
-
- value_t pl = symbol_value(printlengthsym);
- if (isfixnum(pl)) print_length = numval(pl);
- else print_length = -1;
- pl = symbol_value(printlevelsym);
- if (isfixnum(pl)) print_level = numval(pl);
- else print_level = -1;
- P_LEVEL = 0;
-
- printlabel = 0;
- print_traverse(v);
- HPOS = VPOS = 0;
-
- fl_print_child(f, v);
-
- if (print_level >= 0 || print_length >= 0) {- memset(consflags, 0, 4*bitvector_nwords(heapsize/sizeof(cons_t)));
- }
-
- if ((iscons(v) || isvector(v) || isfunction(v) || iscvalue(v)) &&
- !fl_isstring(v) && v!=FL_T && v!=FL_F && v!=FL_NIL) {- htable_reset(&printconses, 32);
- }
-}
--- a/femtolisp/read.c
+++ /dev/null
@@ -1,685 +1,0 @@
-enum {- TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
- TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
- TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE, TOK_SHARPOPEN,
- TOK_OPENB, TOK_CLOSEB, TOK_SHARPSYM, TOK_GENSYM, TOK_DOUBLEQUOTE
-};
-
-#define F value2c(ios_t*,readstate->source)
-
-// defines which characters are ordinary symbol characters.
-// exceptions are '.', which is an ordinary symbol character
-// unless it's the only character in the symbol, and '#', which is
-// an ordinary symbol character unless it's the first character.
-static inline int symchar(char c)
-{- static char *special = "()[]'\";`,\\| \f\n\r\t\v";
- return !strchr(special, c);
-}
-
-int isnumtok_base(char *tok, value_t *pval, int base)
-{- char *end;
- int64_t i64;
- uint64_t ui64;
- double d;
- if (*tok == '\0')
- return 0;
- if (!((tok[0]=='0' && tok[1]=='x') || (base >= 15)) &&
- strpbrk(tok, ".eEpP")) {- d = strtod(tok, &end);
- if (*end == '\0') {- if (pval) *pval = mk_double(d);
- return 1;
- }
- // floats can end in f or f0
- if (end > tok && end[0] == 'f' &&
- (end[1] == '\0' ||
- (end[1] == '0' && end[2] == '\0'))) {- if (pval) *pval = mk_float((float)d);
- return 1;
- }
- }
-
- if (tok[0] == '+') {- if (!strcmp(tok,"+NaN") || !strcasecmp(tok,"+nan.0")) {- if (pval) *pval = mk_double(D_PNAN);
- return 1;
- }
- if (!strcmp(tok,"+Inf") || !strcasecmp(tok,"+inf.0")) {- if (pval) *pval = mk_double(D_PINF);
- return 1;
- }
- }
- else if (tok[0] == '-') {- if (!strcmp(tok,"-NaN") || !strcasecmp(tok,"-nan.0")) {- if (pval) *pval = mk_double(D_NNAN);
- return 1;
- }
- if (!strcmp(tok,"-Inf") || !strcasecmp(tok,"-inf.0")) {- if (pval) *pval = mk_double(D_NINF);
- return 1;
- }
- errno = 0;
- i64 = strtoll(tok, &end, base);
- if (errno)
- return 0;
- if (pval) *pval = return_from_int64(i64);
- return (*end == '\0');
- }
- errno = 0;
- ui64 = strtoull(tok, &end, base);
- if (errno)
- return 0;
- if (pval) *pval = return_from_uint64(ui64);
- return (*end == '\0');
-}
-
-static int isnumtok(char *tok, value_t *pval)
-{- return isnumtok_base(tok, pval, 0);
-}
-
-static int read_numtok(char *tok, value_t *pval, int base)
-{- int result;
- errno = 0;
- result = isnumtok_base(tok, pval, base);
- if (errno == ERANGE)
- lerrorf(ParseError, "read: overflow in numeric constant %s", tok);
- return result;
-}
-
-static u_int32_t toktype = TOK_NONE;
-static value_t tokval;
-static char buf[256];
-
-static char nextchar()
-{- int ch;
- char c;
- ios_t *f = F;
-
- do {- if (f->bpos < f->size) {- ch = f->buf[f->bpos++];
- }
- else {- ch = ios_getc(f);
- if (ch == IOS_EOF)
- return 0;
- }
- c = (char)ch;
- if (c == ';') {- // single-line comment
- do {- ch = ios_getc(f);
- if (ch == IOS_EOF)
- return 0;
- } while ((char)ch != '\n');
- c = (char)ch;
- }
- } while (c==' ' || isspace(c));
- return c;
-}
-
-static void take(void)
-{- toktype = TOK_NONE;
-}
-
-static void accumchar(char c, int *pi)
-{- buf[(*pi)++] = c;
- if (*pi >= (int)(sizeof(buf)-1))
- lerror(ParseError, "read: token too long");
-}
-
-// return: 1 if escaped (forced to be symbol)
-static int read_token(char c, int digits)
-{- int i=0, ch, escaped=0, issym=0, first=1;
-
- while (1) {- if (!first) {- ch = ios_getc(F);
- if (ch == IOS_EOF)
- goto terminate;
- c = (char)ch;
- }
- first = 0;
- if (c == '|') {- issym = 1;
- escaped = !escaped;
- }
- else if (c == '\\') {- issym = 1;
- ch = ios_getc(F);
- if (ch == IOS_EOF)
- goto terminate;
- accumchar((char)ch, &i);
- }
- else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {- break;
- }
- else {- accumchar(c, &i);
- }
- }
- ios_ungetc(c, F);
- terminate:
- buf[i++] = '\0';
- return issym;
-}
-
-static value_t do_read_sexpr(value_t label);
-
-static u_int32_t peek()
-{- char c, *end;
- fixnum_t x;
- int ch, base;
-
- if (toktype != TOK_NONE)
- return toktype;
- c = nextchar();
- if (ios_eof(F)) return TOK_NONE;
- if (c == '(') {- toktype = TOK_OPEN;
- }
- else if (c == ')') {- toktype = TOK_CLOSE;
- }
- else if (c == '[') {- toktype = TOK_OPENB;
- }
- else if (c == ']') {- toktype = TOK_CLOSEB;
- }
- else if (c == '\'') {- toktype = TOK_QUOTE;
- }
- else if (c == '`') {- toktype = TOK_BQ;
- }
- else if (c == '"') {- toktype = TOK_DOUBLEQUOTE;
- }
- else if (c == '#') {- ch = ios_getc(F); c = (char)ch;
- if (ch == IOS_EOF)
- lerror(ParseError, "read: invalid read macro");
- if (c == '.') {- toktype = TOK_SHARPDOT;
- }
- else if (c == '\'') {- toktype = TOK_SHARPQUOTE;
- }
- else if (c == '\\') {- uint32_t cval;
- if (ios_getutf8(F, &cval) == IOS_EOF)
- lerror(ParseError, "read: end of input in character constant");
- if (cval == (uint32_t)'u' || cval == (uint32_t)'U' ||
- cval == (uint32_t)'x') {- read_token('u', 0);- if (buf[1] != '\0') { // not a solitary 'u','U','x'- if (!read_numtok(&buf[1], &tokval, 16))
- lerror(ParseError,
- "read: invalid hex character constant");
- cval = numval(tokval);
- }
- }
- else if (cval >= 'a' && cval <= 'z') {- read_token((char)cval, 0);
- tokval = symbol(buf);
- if (buf[1] == '\0') /* one character */;
- else if (tokval == nulsym) cval = 0x00;
- else if (tokval == alarmsym) cval = 0x07;
- else if (tokval == backspacesym) cval = 0x08;
- else if (tokval == tabsym) cval = 0x09;
- else if (tokval == linefeedsym) cval = 0x0A;
- else if (tokval == newlinesym) cval = 0x0A;
- else if (tokval == vtabsym) cval = 0x0B;
- else if (tokval == pagesym) cval = 0x0C;
- else if (tokval == returnsym) cval = 0x0D;
- else if (tokval == escsym) cval = 0x1B;
- else if (tokval == spacesym) cval = 0x20;
- else if (tokval == deletesym) cval = 0x7F;
- else
- lerrorf(ParseError, "read: unknown character #\\%s", buf);
- }
- toktype = TOK_NUM;
- tokval = mk_wchar(cval);
- }
- else if (c == '(') {- toktype = TOK_SHARPOPEN;
- }
- else if (c == '<') {- lerror(ParseError, "read: unreadable object");
- }
- else if (isdigit(c)) {- read_token(c, 1);
- c = (char)ios_getc(F);
- if (c == '#')
- toktype = TOK_BACKREF;
- else if (c == '=')
- toktype = TOK_LABEL;
- else
- lerror(ParseError, "read: invalid label");
- errno = 0;
- x = strtol(buf, &end, 10);
- if (*end != '\0' || errno)
- lerror(ParseError, "read: invalid label");
- tokval = fixnum(x);
- }
- else if (c == '!') {- // #! single line comment for shbang script support
- do {- ch = ios_getc(F);
- } while (ch != IOS_EOF && (char)ch != '\n');
- return peek();
- }
- else if (c == '|') {- // multiline comment
- int commentlevel=1;
- while (1) {- ch = ios_getc(F);
- hashpipe_gotc:
- if (ch == IOS_EOF)
- lerror(ParseError, "read: eof within comment");
- if ((char)ch == '|') {- ch = ios_getc(F);
- if ((char)ch == '#') {- commentlevel--;
- if (commentlevel == 0)
- break;
- else
- continue;
- }
- goto hashpipe_gotc;
- }
- else if ((char)ch == '#') {- ch = ios_getc(F);
- if ((char)ch == '|')
- commentlevel++;
- else
- goto hashpipe_gotc;
- }
- }
- // this was whitespace, so keep peeking
- return peek();
- }
- else if (c == ';') {- // datum comment
- (void)do_read_sexpr(UNBOUND); // skip
- return peek();
- }
- else if (c == ':') {- // gensym
- ch = ios_getc(F);
- if ((char)ch == 'g')
- ch = ios_getc(F);
- read_token((char)ch, 0);
- errno = 0;
- x = strtol(buf, &end, 10);
- if (*end != '\0' || buf[0] == '\0' || errno)
- lerror(ParseError, "read: invalid gensym label");
- toktype = TOK_GENSYM;
- tokval = fixnum(x);
- }
- else if (symchar(c)) {- read_token(ch, 0);
-
- if (((c == 'b' && (base= 2)) ||
- (c == 'o' && (base= 8)) ||
- (c == 'd' && (base=10)) ||
- (c == 'x' && (base=16))) &&
- (isdigit_base(buf[1],base) ||
- buf[1]=='-')) {- if (!read_numtok(&buf[1], &tokval, base))
- lerrorf(ParseError, "read: invalid base %d constant", base);
- return (toktype=TOK_NUM);
- }
-
- toktype = TOK_SHARPSYM;
- tokval = symbol(buf);
- }
- else {- lerror(ParseError, "read: unknown read macro");
- }
- }
- else if (c == ',') {- toktype = TOK_COMMA;
- ch = ios_getc(F);
- if (ch == IOS_EOF)
- return toktype;
- if ((char)ch == '@')
- toktype = TOK_COMMAAT;
- else if ((char)ch == '.')
- toktype = TOK_COMMADOT;
- else
- ios_ungetc((char)ch, F);
- }
- else {- if (!read_token(c, 0)) {- if (buf[0]=='.' && buf[1]=='\0') {- return (toktype=TOK_DOT);
- }
- else {- if (read_numtok(buf, &tokval, 0))
- return (toktype=TOK_NUM);
- }
- }
- toktype = TOK_SYM;
- tokval = symbol(buf);
- }
- return toktype;
-}
-
-// NOTE: this is NOT an efficient operation. it is only used by the
-// reader, and requires at least 1 and up to 3 garbage collections!
-static value_t vector_grow(value_t v)
-{- size_t i, s = vector_size(v);
- size_t d = vector_grow_amt(s);
- PUSH(v);
- assert(s+d > s);
- value_t newv = alloc_vector(s+d, 1);
- v = Stack[SP-1];
- for(i=0; i < s; i++)
- vector_elt(newv, i) = vector_elt(v, i);
- // use gc to rewrite references from the old vector to the new
- Stack[SP-1] = newv;
- if (s > 0) {- ((size_t*)ptr(v))[0] |= 0x1;
- vector_elt(v, 0) = newv;
- gc(0);
- }
- return POP();
-}
-
-static value_t read_vector(value_t label, u_int32_t closer)
-{- value_t v=the_empty_vector, elt;
- u_int32_t i=0;
- PUSH(v);
- if (label != UNBOUND)
- ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
- while (peek() != closer) {- if (ios_eof(F))
- lerror(ParseError, "read: unexpected end of input");
- if (i >= vector_size(v)) {- v = Stack[SP-1] = vector_grow(v);
- if (label != UNBOUND)
- ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
- }
- elt = do_read_sexpr(UNBOUND);
- v = Stack[SP-1];
- assert(i < vector_size(v));
- vector_elt(v,i) = elt;
- i++;
- }
- take();
- if (i > 0)
- vector_setsize(v, i);
- return POP();
-}
-
-static value_t read_string()
-{- char *buf, *temp;
- char eseq[10];
- size_t i=0, j, sz = 64, ndig;
- int c;
- value_t s;
- u_int32_t wc;
-
- buf = malloc(sz);
- while (1) {- if (i >= sz-4) { // -4: leaves room for longest utf8 sequence- sz *= 2;
- temp = realloc(buf, sz);
- if (temp == NULL) {- free(buf);
- lerror(ParseError, "read: out of memory reading string");
- }
- buf = temp;
- }
- c = ios_getc(F);
- if (c == IOS_EOF) {- free(buf);
- lerror(ParseError, "read: unexpected end of input in string");
- }
- if (c == '"')
- break;
- else if (c == '\\') {- c = ios_getc(F);
- if (c == IOS_EOF) {- free(buf);
- lerror(ParseError, "read: end of input in escape sequence");
- }
- j=0;
- if (octal_digit(c)) {- do {- eseq[j++] = c;
- c = ios_getc(F);
- } while (octal_digit(c) && j<3 && (c!=IOS_EOF));
- if (c!=IOS_EOF) ios_ungetc(c, F);
- eseq[j] = '\0';
- wc = strtol(eseq, NULL, 8);
- // \DDD and \xXX read bytes, not characters
- buf[i++] = ((char)wc);
- }
- else if ((c=='x' && (ndig=2)) ||
- (c=='u' && (ndig=4)) ||
- (c=='U' && (ndig=8))) {- c = ios_getc(F);
- while (hex_digit(c) && j<ndig && (c!=IOS_EOF)) {- eseq[j++] = c;
- c = ios_getc(F);
- }
- if (c!=IOS_EOF) ios_ungetc(c, F);
- eseq[j] = '\0';
- if (j) wc = strtol(eseq, NULL, 16);
- else {- free(buf);
- lerror(ParseError, "read: invalid escape sequence");
- }
- if (ndig == 2)
- buf[i++] = ((char)wc);
- else
- i += u8_wc_toutf8(&buf[i], wc);
- }
- else {- buf[i++] = read_escape_control_char((char)c);
- }
- }
- else {- buf[i++] = c;
- }
- }
- s = cvalue_string(i);
- memcpy(cvalue_data(s), buf, i);
- free(buf);
- return s;
-}
-
-// build a list of conses. this is complicated by the fact that all conses
-// can move whenever a new cons is allocated. we have to refer to every cons
-// through a handle to a relocatable pointer (i.e. a pointer on the stack).
-static void read_list(value_t *pval, value_t label)
-{- value_t c, *pc;
- u_int32_t t;
-
- PUSH(NIL);
- pc = &Stack[SP-1]; // to keep track of current cons cell
- t = peek();
- while (t != TOK_CLOSE) {- if (ios_eof(F))
- lerror(ParseError, "read: unexpected end of input");
- c = mk_cons(); car_(c) = cdr_(c) = NIL;
- if (iscons(*pc)) {- cdr_(*pc) = c;
- }
- else {- *pval = c;
- if (label != UNBOUND)
- ptrhash_put(&readstate->backrefs, (void*)label, (void*)c);
- }
- *pc = c;
- c = do_read_sexpr(UNBOUND); // must be on separate lines due to
- car_(*pc) = c; // undefined evaluation order
-
- t = peek();
- if (t == TOK_DOT) {- take();
- c = do_read_sexpr(UNBOUND);
- cdr_(*pc) = c;
- t = peek();
- if (ios_eof(F))
- lerror(ParseError, "read: unexpected end of input");
- if (t != TOK_CLOSE)
- lerror(ParseError, "read: expected ')'");
- }
- }
- take();
- (void)POP();
-}
-
-// label is the backreference we'd like to fix up with this read
-static value_t do_read_sexpr(value_t label)
-{- value_t v, sym, oldtokval, *head;
- value_t *pv;
- u_int32_t t;
- char c;
-
- t = peek();
- take();
- switch (t) {- case TOK_CLOSE:
- lerror(ParseError, "read: unexpected ')'");
- case TOK_CLOSEB:
- lerror(ParseError, "read: unexpected ']'");
- case TOK_DOT:
- lerror(ParseError, "read: unexpected '.'");
- case TOK_SYM:
- case TOK_NUM:
- return tokval;
- case TOK_COMMA:
- head = &COMMA; goto listwith;
- case TOK_COMMAAT:
- head = &COMMAAT; goto listwith;
- case TOK_COMMADOT:
- head = &COMMADOT; goto listwith;
- case TOK_BQ:
- head = &BACKQUOTE; goto listwith;
- case TOK_QUOTE:
- head = "E;
- listwith:
- v = cons_reserve(2);
- car_(v) = *head;
- cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS);
- car_(cdr_(v)) = cdr_(cdr_(v)) = NIL;
- PUSH(v);
- if (label != UNBOUND)
- ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
- v = do_read_sexpr(UNBOUND);
- car_(cdr_(Stack[SP-1])) = v;
- return POP();
- case TOK_SHARPQUOTE:
- // femtoLisp doesn't need symbol-function, so #' does nothing
- return do_read_sexpr(label);
- case TOK_OPEN:
- PUSH(NIL);
- read_list(&Stack[SP-1], label);
- return POP();
- case TOK_SHARPSYM:
- sym = tokval;
- if (sym == tsym || sym == Tsym)
- return FL_T;
- else if (sym == fsym || sym == Fsym)
- return FL_F;
- // constructor notation
- c = nextchar();
- if (c != '(') {- take();
- lerrorf(ParseError, "read: expected argument list for %s",
- symbol_name(tokval));
- }
- PUSH(NIL);
- read_list(&Stack[SP-1], UNBOUND);
- if (sym == vu8sym) {- sym = arraysym;
- Stack[SP-1] = fl_cons(uint8sym, Stack[SP-1]);
- }
- else if (sym == fnsym) {- sym = FUNCTION;
- }
- v = symbol_value(sym);
- if (v == UNBOUND)
- fl_raise(fl_list2(UnboundError, sym));
- return fl_apply(v, POP());
- case TOK_OPENB:
- return read_vector(label, TOK_CLOSEB);
- case TOK_SHARPOPEN:
- return read_vector(label, TOK_CLOSE);
- case TOK_SHARPDOT:
- // eval-when-read
- // evaluated expressions can refer to existing backreferences, but they
- // cannot see pending labels. in other words:
- // (... #2=#.#0# ... ) OK
- // (... #2=#.(#2#) ... ) DO NOT WANT
- sym = do_read_sexpr(UNBOUND);
- if (issymbol(sym)) {- v = symbol_value(sym);
- if (v == UNBOUND)
- fl_raise(fl_list2(UnboundError, sym));
- return v;
- }
- return fl_toplevel_eval(sym);
- case TOK_LABEL:
- // create backreference label
- if (ptrhash_has(&readstate->backrefs, (void*)tokval))
- lerrorf(ParseError, "read: label %ld redefined", numval(tokval));
- oldtokval = tokval;
- v = do_read_sexpr(tokval);
- ptrhash_put(&readstate->backrefs, (void*)oldtokval, (void*)v);
- return v;
- case TOK_BACKREF:
- // look up backreference
- v = (value_t)ptrhash_get(&readstate->backrefs, (void*)tokval);
- if (v == (value_t)HT_NOTFOUND)
- lerrorf(ParseError, "read: undefined label %ld", numval(tokval));
- return v;
- case TOK_GENSYM:
- pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval);
- if (*pv == (value_t)HT_NOTFOUND)
- *pv = fl_gensym(NULL, 0);
- return *pv;
- case TOK_DOUBLEQUOTE:
- return read_string();
- }
- return FL_UNSPECIFIED;
-}
-
-value_t fl_read_sexpr(value_t f)
-{- value_t v;
- fl_readstate_t state;
- state.prev = readstate;
- htable_new(&state.backrefs, 8);
- htable_new(&state.gensyms, 8);
- state.source = f;
- readstate = &state;
- assert(toktype == TOK_NONE);
- fl_gc_handle(&tokval);
-
- v = do_read_sexpr(UNBOUND);
-
- fl_free_gc_handles(1);
- readstate = state.prev;
- free_readstate(&state);
- return v;
-}
--- a/femtolisp/string.c
+++ /dev/null
@@ -1,416 +1,0 @@
-/*
- string functions
-*/
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <setjmp.h>
-#include <stdarg.h>
-#include <assert.h>
-#include <ctype.h>
-#include <wchar.h>
-#include <wctype.h>
-#include <sys/types.h>
-#include <sys/time.h>
-#include <errno.h>
-#include "llt.h"
-#include "flisp.h"
-
-value_t fl_stringp(value_t *args, u_int32_t nargs)
-{- argcount("string?", nargs, 1);- return fl_isstring(args[0]) ? FL_T : FL_F;
-}
-
-value_t fl_string_count(value_t *args, u_int32_t nargs)
-{- size_t start = 0;
- if (nargs < 1 || nargs > 3)
- argcount("string.count", nargs, 1);- if (!fl_isstring(args[0]))
- type_error("string.count", "string", args[0]);- size_t len = cv_len((cvalue_t*)ptr(args[0]));
- size_t stop = len;
- if (nargs > 1) {- start = toulong(args[1], "string.count");
- if (start > len)
- bounds_error("string.count", args[0], args[1]);- if (nargs > 2) {- stop = toulong(args[2], "string.count");
- if (stop > len)
- bounds_error("string.count", args[0], args[2]);- if (stop <= start)
- return fixnum(0);
- }
- }
- char *str = cvalue_data(args[0]);
- return size_wrap(u8_charnum(str+start, stop-start));
-}
-
-value_t fl_string_width(value_t *args, u_int32_t nargs)
-{- argcount("string.width", nargs, 1);- if (iscprim(args[0])) {- cprim_t *cp = (cprim_t*)ptr(args[0]);
- if (cp_class(cp) == wchartype) {- int w = wcwidth(*(uint32_t*)cp_data(cp));
- if (w < 0)
- return FL_F;
- return fixnum(w);
- }
- }
- char *s = tostring(args[0], "string.width");
- return size_wrap(u8_strwidth(s));
-}
-
-value_t fl_string_reverse(value_t *args, u_int32_t nargs)
-{- argcount("string.reverse", nargs, 1);- if (!fl_isstring(args[0]))
- type_error("string.reverse", "string", args[0]);- size_t len = cv_len((cvalue_t*)ptr(args[0]));
- value_t ns = cvalue_string(len);
- u8_reverse(cvalue_data(ns), cvalue_data(args[0]), len);
- return ns;
-}
-
-value_t fl_string_encode(value_t *args, u_int32_t nargs)
-{- argcount("string.encode", nargs, 1);- if (iscvalue(args[0])) {- cvalue_t *cv = (cvalue_t*)ptr(args[0]);
- fltype_t *t = cv_class(cv);
- if (t->eltype == wchartype) {- size_t nc = cv_len(cv) / sizeof(uint32_t);
- uint32_t *ptr = (uint32_t*)cv_data(cv);
- size_t nbytes = u8_codingsize(ptr, nc);
- value_t str = cvalue_string(nbytes);
- ptr = cv_data((cvalue_t*)ptr(args[0])); // relocatable pointer
- u8_toutf8(cvalue_data(str), nbytes, ptr, nc);
- return str;
- }
- }
- type_error("string.encode", "wchar array", args[0]);-}
-
-value_t fl_string_decode(value_t *args, u_int32_t nargs)
-{- int term=0;
- if (nargs == 2) {- term = (args[1] != FL_F);
- }
- else {- argcount("string.decode", nargs, 1);- }
- if (!fl_isstring(args[0]))
- type_error("string.decode", "string", args[0]);- cvalue_t *cv = (cvalue_t*)ptr(args[0]);
- char *ptr = (char*)cv_data(cv);
- size_t nb = cv_len(cv);
- size_t nc = u8_charnum(ptr, nb);
- size_t newsz = nc*sizeof(uint32_t);
- if (term) newsz += sizeof(uint32_t);
- value_t wcstr = cvalue(wcstringtype, newsz);
- ptr = cv_data((cvalue_t*)ptr(args[0])); // relocatable pointer
- uint32_t *pwc = cvalue_data(wcstr);
- u8_toucs(pwc, nc, ptr, nb);
- if (term) pwc[nc] = 0;
- return wcstr;
-}
-
-extern value_t fl_buffer(value_t *args, u_int32_t nargs);
-extern value_t stream_to_string(value_t *ps);
-
-value_t fl_string(value_t *args, u_int32_t nargs)
-{- if (nargs == 1 && fl_isstring(args[0]))
- return args[0];
- value_t arg, buf = fl_buffer(NULL, 0);
- ios_t *s = value2c(ios_t*,buf);
- uint32_t i;
- value_t oldpr = symbol_value(printreadablysym);
- value_t oldpp = symbol_value(printprettysym);
- set(printreadablysym, FL_F);
- set(printprettysym, FL_F);
- FOR_ARGS(i,0,arg,args) {- fl_print(s, args[i]);
- }
- set(printreadablysym, oldpr);
- set(printprettysym, oldpp);
- fl_gc_handle(&buf);
- value_t outp = stream_to_string(&buf);
- fl_free_gc_handles(1);
- return outp;
-}
-
-value_t fl_string_split(value_t *args, u_int32_t nargs)
-{- argcount("string.split", nargs, 2);- char *s = tostring(args[0], "string.split");
- char *delim = tostring(args[1], "string.split");
- size_t len = cv_len((cvalue_t*)ptr(args[0]));
- size_t dlen = cv_len((cvalue_t*)ptr(args[1]));
- size_t ssz, tokend=0, tokstart=0, i=0;
- value_t first=FL_NIL, c=FL_NIL, last;
- size_t junk;
- fl_gc_handle(&first);
- fl_gc_handle(&last);
-
- do {- // find and allocate next token
- tokstart = tokend = i;
- while (i < len &&
- !u8_memchr(delim, u8_nextmemchar(s, &i), dlen, &junk))
- tokend = i;
- ssz = tokend - tokstart;
- last = c; // save previous cons cell
- c = fl_cons(cvalue_string(ssz), FL_NIL);
-
- // we've done allocation; reload movable pointers
- s = cv_data((cvalue_t*)ptr(args[0]));
- delim = cv_data((cvalue_t*)ptr(args[1]));
-
- if (ssz) memcpy(cv_data((cvalue_t*)ptr(car_(c))), &s[tokstart], ssz);
-
- // link new cell
- if (last == FL_NIL)
- first = c; // first time, save first cons
- else
- ((cons_t*)ptr(last))->cdr = c;
-
- // note this tricky condition: if the string ends with a
- // delimiter, we need to go around one more time to add an
- // empty string. this happens when (i==len && tokend<i)
- } while (i < len || (i==len && (tokend!=i)));
- fl_free_gc_handles(2);
- return first;
-}
-
-value_t fl_string_sub(value_t *args, u_int32_t nargs)
-{- if (nargs != 2)
- argcount("string.sub", nargs, 3);- char *s = tostring(args[0], "string.sub");
- size_t len = cv_len((cvalue_t*)ptr(args[0]));
- size_t i1, i2;
- i1 = toulong(args[1], "string.sub");
- if (i1 > len)
- bounds_error("string.sub", args[0], args[1]);- if (nargs == 3) {- i2 = toulong(args[2], "string.sub");
- if (i2 > len)
- bounds_error("string.sub", args[0], args[2]);- }
- else {- i2 = len;
- }
- if (i2 <= i1)
- return cvalue_string(0);
- value_t ns = cvalue_string(i2-i1);
- memcpy(cv_data((cvalue_t*)ptr(ns)), &s[i1], i2-i1);
- return ns;
-}
-
-value_t fl_string_char(value_t *args, u_int32_t nargs)
-{- argcount("string.char", nargs, 2);- char *s = tostring(args[0], "string.char");
- size_t len = cv_len((cvalue_t*)ptr(args[0]));
- size_t i = toulong(args[1], "string.char");
- if (i >= len)
- bounds_error("string.char", args[0], args[1]);- size_t sl = u8_seqlen(&s[i]);
- if (sl > len || i > len-sl)
- bounds_error("string.char", args[0], args[1]);- return mk_wchar(u8_nextchar(s, &i));
-}
-
-value_t fl_char_upcase(value_t *args, u_int32_t nargs)
-{- argcount("char.upcase", nargs, 1);- cprim_t *cp = (cprim_t*)ptr(args[0]);
- if (!iscprim(args[0]) || cp_class(cp) != wchartype)
- type_error("char.upcase", "wchar", args[0]);- return mk_wchar(towupper(*(int32_t*)cp_data(cp)));
-}
-value_t fl_char_downcase(value_t *args, u_int32_t nargs)
-{- argcount("char.downcase", nargs, 1);- cprim_t *cp = (cprim_t*)ptr(args[0]);
- if (!iscprim(args[0]) || cp_class(cp) != wchartype)
- type_error("char.downcase", "wchar", args[0]);- return mk_wchar(towlower(*(int32_t*)cp_data(cp)));
-}
-
-static value_t mem_find_byte(char *s, char c, size_t start, size_t len)
-{- char *p = memchr(s+start, c, len-start);
- if (p == NULL)
- return FL_F;
- return size_wrap((size_t)(p - s));
-}
-
-value_t fl_string_find(value_t *args, u_int32_t nargs)
-{- char cbuf[8];
- size_t start = 0;
- if (nargs == 3)
- start = toulong(args[2], "string.find");
- else
- argcount("string.find", nargs, 2);- char *s = tostring(args[0], "string.find");
- size_t len = cv_len((cvalue_t*)ptr(args[0]));
- if (start > len)
- bounds_error("string.find", args[0], args[2]);- char *needle; size_t needlesz;
-
- value_t v = args[1];
- cprim_t *cp = (cprim_t*)ptr(v);
- if (iscprim(v) && cp_class(cp) == wchartype) {- uint32_t c = *(uint32_t*)cp_data(cp);
- if (c <= 0x7f)
- return mem_find_byte(s, (char)c, start, len);
- needlesz = u8_toutf8(cbuf, sizeof(cbuf), &c, 1);
- needle = cbuf;
- }
- else if (iscprim(v) && cp_class(cp) == bytetype) {- return mem_find_byte(s, *(char*)cp_data(cp), start, len);
- }
- else if (fl_isstring(v)) {- cvalue_t *cv = (cvalue_t*)ptr(v);
- needlesz = cv_len(cv);
- needle = (char*)cv_data(cv);
- }
- else {- type_error("string.find", "string", args[1]);- }
- if (needlesz > len-start)
- return FL_F;
- else if (needlesz == 1)
- return mem_find_byte(s, needle[0], start, len);
- else if (needlesz == 0)
- return size_wrap(start);
- size_t i;
- for(i=start; i < len-needlesz+1; i++) {- if (s[i] == needle[0]) {- if (!memcmp(&s[i+1], needle+1, needlesz-1))
- return size_wrap(i);
- }
- }
- return FL_F;
-}
-
-value_t fl_string_inc(value_t *args, u_int32_t nargs)
-{- if (nargs < 2 || nargs > 3)
- argcount("string.inc", nargs, 2);- char *s = tostring(args[0], "string.inc");
- size_t len = cv_len((cvalue_t*)ptr(args[0]));
- size_t i = toulong(args[1], "string.inc");
- size_t cnt = 1;
- if (nargs == 3)
- cnt = toulong(args[2], "string.inc");
- while (cnt--) {- if (i >= len)
- bounds_error("string.inc", args[0], args[1]);- (void)(isutf(s[++i]) || isutf(s[++i]) || isutf(s[++i]) || ++i);
- }
- return size_wrap(i);
-}
-
-value_t fl_string_dec(value_t *args, u_int32_t nargs)
-{- if (nargs < 2 || nargs > 3)
- argcount("string.dec", nargs, 2);- char *s = tostring(args[0], "string.dec");
- size_t len = cv_len((cvalue_t*)ptr(args[0]));
- size_t i = toulong(args[1], "string.dec");
- size_t cnt = 1;
- if (nargs == 3)
- cnt = toulong(args[2], "string.dec");
- // note: i is allowed to start at index len
- if (i > len)
- bounds_error("string.dec", args[0], args[1]);- while (cnt--) {- if (i == 0)
- bounds_error("string.dec", args[0], args[1]);- (void)(isutf(s[--i]) || isutf(s[--i]) || isutf(s[--i]) || --i);
- }
- return size_wrap(i);
-}
-
-static unsigned long get_radix_arg(value_t arg, char *fname)
-{- unsigned long radix = toulong(arg, fname);
- if (radix < 2 || radix > 36)
- lerrorf(ArgError, "%s: invalid radix", fname);
- return radix;
-}
-
-value_t fl_numbertostring(value_t *args, u_int32_t nargs)
-{- if (nargs < 1 || nargs > 2)
- argcount("number->string", nargs, 2);- value_t n = args[0];
- int neg = 0;
- uint64_t num;
- if (isfixnum(n)) num = numval(n);
- else if (!iscprim(n)) type_error("number->string", "integer", n);- else num = conv_to_uint64(cp_data((cprim_t*)ptr(n)),
- cp_numtype((cprim_t*)ptr(n)));
- if (numval(fl_compare(args[0],fixnum(0))) < 0) {- num = -num;
- neg = 1;
- }
- unsigned long radix = 10;
- if (nargs == 2)
- radix = get_radix_arg(args[1], "number->string");
- char buf[128];
- char *str = uint2str(buf, sizeof(buf), num, radix);
- if (neg && str > &buf[0])
- *(--str) = '-';
- return string_from_cstr(str);
-}
-
-value_t fl_stringtonumber(value_t *args, uint32_t nargs)
-{- if (nargs < 1 || nargs > 2)
- argcount("string->number", nargs, 2);- char *str = tostring(args[0], "string->number");
- value_t n;
- ulong radix = 0;
- if (nargs == 2)
- radix = get_radix_arg(args[1], "string->number");
- if (!isnumtok_base(str, &n, (int)radix))
- return FL_F;
- return n;
-}
-
-static builtinspec_t stringfunc_info[] = {- { "string", fl_string },- { "string?", fl_stringp },- { "string.count", fl_string_count },- { "string.width", fl_string_width },- { "string.split", fl_string_split },- { "string.sub", fl_string_sub },- { "string.find", fl_string_find },- { "string.char", fl_string_char },- { "string.inc", fl_string_inc },- { "string.dec", fl_string_dec },- { "string.reverse", fl_string_reverse },- { "string.encode", fl_string_encode },- { "string.decode", fl_string_decode },-
- { "char.upcase", fl_char_upcase },- { "char.downcase", fl_char_downcase },-
- { "number->string", fl_numbertostring },- { "string->number", fl_stringtonumber },-
- { NULL, NULL }-};
-
-void stringfuncs_init()
-{- assign_global_builtins(stringfunc_info);
-}
--- a/femtolisp/system.lsp
+++ /dev/null
@@ -1,1072 +1,0 @@
-; -*- scheme -*-
-; femtoLisp standard library
-; by Jeff Bezanson (C) 2009
-; Distributed under the BSD License
-
-(define (void) #t) ; the unspecified value
-
-(define *builtins*
- (vector
- 0 0 0 0 0 0 0 0 0 0 0 0
- (lambda (x y) (eq? x y)) (lambda (x y) (eqv? x y))
- (lambda (x y) (equal? x y)) (lambda (x) (atom? x))
- (lambda (x) (not x)) (lambda (x) (null? x))
- (lambda (x) (boolean? x)) (lambda (x) (symbol? x))
- (lambda (x) (number? x)) (lambda (x) (bound? x))
- (lambda (x) (pair? x)) (lambda (x) (builtin? x))
- (lambda (x) (vector? x)) (lambda (x) (fixnum? x))
- (lambda (x) (function? x)) (lambda (x y) (cons x y))
- (lambda rest (apply list rest)) (lambda (x) (car x))
- (lambda (x) (cdr x)) (lambda (x y) (set-car! x y))
- (lambda (x y) (set-cdr! x y)) (lambda rest (apply apply rest))
- (lambda rest (apply + rest)) (lambda rest (apply - rest))
- (lambda rest (apply * rest)) (lambda rest (apply / rest))
- (lambda rest (apply div0 rest)) (lambda (x y) (= x y))
- (lambda (x y) (< x y)) (lambda (x y) (compare x y))
- (lambda rest (apply vector rest)) (lambda (x y) (aref x y))
- (lambda (x y z) (aset! x y z))))
-
-(if (not (bound? '*syntax-environment*))
- (define *syntax-environment* (table)))
-
-(define (set-syntax! s v) (put! *syntax-environment* s v))
-(define (symbol-syntax s) (get *syntax-environment* s #f))
-
-(define-macro (define-macro form . body)
- `(set-syntax! ',(car form)
- (lambda ,(cdr form) ,@body)))
-
-#;(define (map1 f lst acc)
- (cdr
- (prog1 acc
- (while (pair? lst)
- (begin (set! acc
- (cdr (set-cdr! acc (cons (f (car lst)) ()))))
- (set! lst (cdr lst)))))))
-
-#;(define (mapn f lsts)
- (if (null? (car lsts))
- ()
- (cons (apply f (map1 car lsts (list ())))
- (mapn f (map1 cdr lsts (list ()))))))
-
-#;(define (map f lst . lsts)
- (if (null? lsts)
- (map1 f lst (list ()))
- (mapn f (cons lst lsts))))
-
-(define-macro (letrec binds . body)
- `((lambda ,(map car binds)
- ,.(map (lambda (b) `(set! ,@b)) binds)
- ,@body)
- ,.(map (lambda (x) (void)) binds)))
-
-(define-macro (let binds . body)
- (let ((lname #f))
- (if (symbol? binds)
- (begin (set! lname binds)
- (set! binds (car body))
- (set! body (cdr body))))
- (let ((thelambda
- `(lambda ,(map (lambda (c) (if (pair? c) (car c) c))
- binds)
- ,@body))
- (theargs
- (map (lambda (c) (if (pair? c) (cadr c) (void))) binds)))
- (cons (if lname
- `(letrec ((,lname ,thelambda)) ,lname)
- thelambda)
- theargs))))
-
-(define-macro (cond . clauses)
- (define (cond-clauses->if lst)
- (if (atom? lst)
- #f
- (let ((clause (car lst)))
- (if (or (eq? (car clause) 'else)
- (eq? (car clause) #t))
- (if (null? (cdr clause))
- (car clause)
- (cons 'begin (cdr clause)))
- (if (null? (cdr clause))
- ; test by itself
- (list 'or
- (car clause)
- (cond-clauses->if (cdr lst)))
- ; test => expression
- (if (eq? (cadr clause) '=>)
- (if (1arg-lambda? (caddr clause))
- ; test => (lambda (x) ...)
- (let ((var (caadr (caddr clause))))
- `(let ((,var ,(car clause)))
- (if ,var ,(cons 'begin (cddr (caddr clause)))
- ,(cond-clauses->if (cdr lst)))))
- ; test => proc
- (let ((b (gensym)))
- `(let ((,b ,(car clause)))
- (if ,b
- (,(caddr clause) ,b)
- ,(cond-clauses->if (cdr lst))))))
- (list 'if
- (car clause)
- (cons 'begin (cdr clause))
- (cond-clauses->if (cdr lst)))))))))
- (cond-clauses->if clauses))
-
-; standard procedures ---------------------------------------------------------
-
-(define (member item lst)
- (cond ((atom? lst) #f)
- ((equal? (car lst) item) lst)
- (#t (member item (cdr lst)))))
-(define (memv item lst)
- (cond ((atom? lst) #f)
- ((eqv? (car lst) item) lst)
- (#t (memv item (cdr lst)))))
-
-(define (assoc item lst)
- (cond ((atom? lst) #f)
- ((equal? (caar lst) item) (car lst))
- (#t (assoc item (cdr lst)))))
-(define (assv item lst)
- (cond ((atom? lst) #f)
- ((eqv? (caar lst) item) (car lst))
- (#t (assv item (cdr lst)))))
-
-(define (> a b) (< b a))
-(define (<= a b) (or (< a b) (= a b)))
-(define (>= a b) (or (< b a) (= a b)))
-(define (negative? x) (< x 0))
-(define (zero? x) (= x 0))
-(define (positive? x) (> x 0))
-(define (even? x) (= (logand x 1) 0))
-(define (odd? x) (not (even? x)))
-(define (identity x) x)
-(define (1+ n) (+ n 1))
-(define (1- n) (- n 1))
-(define (mod0 x y) (- x (* (div0 x y) y)))
-(define (div x y) (+ (div0 x y)
- (or (and (< x 0)
- (or (and (< y 0) 1)
- -1))
- 0)))
-(define (mod x y) (- x (* (div x y) y)))
-(define (random n)
- (if (integer? n)
- (mod (rand) n)
- (* (rand.double) n)))
-(define (abs x) (if (< x 0) (- x) x))
-(define (max x0 . xs)
- (if (null? xs) x0
- (foldl (lambda (a b) (if (< a b) b a)) x0 xs)))
-(define (min x0 . xs)
- (if (null? xs) x0
- (foldl (lambda (a b) (if (< a b) a b)) x0 xs)))
-(define (char? x) (eq? (typeof x) 'wchar))
-(define (array? x) (or (vector? x)
- (let ((t (typeof x)))
- (and (pair? t) (eq? (car t) 'array)))))
-(define (closure? x) (and (function? x) (not (builtin? x))))
-
-(define (caar x) (car (car x)))
-(define (cadr x) (car (cdr x)))
-(define (cdar x) (cdr (car x)))
-(define (cddr x) (cdr (cdr x)))
-(define (caaar x) (car (car (car x))))
-(define (caadr x) (car (car (cdr x))))
-(define (cadar x) (car (cdr (car x))))
-(define (caddr x) (car (cdr (cdr x))))
-(define (cdaar x) (cdr (car (car x))))
-(define (cdadr x) (cdr (car (cdr x))))
-(define (cddar x) (cdr (cdr (car x))))
-(define (cdddr x) (cdr (cdr (cdr x))))
-(define (caaaar x) (car (car (car (car x)))))
-(define (caaadr x) (car (car (car (cdr x)))))
-(define (caadar x) (car (car (cdr (car x)))))
-(define (caaddr x) (car (car (cdr (cdr x)))))
-(define (cadaar x) (car (cdr (car (car x)))))
-(define (cadadr x) (car (cdr (car (cdr x)))))
-(define (caddar x) (car (cdr (cdr (car x)))))
-(define (cadddr x) (car (cdr (cdr (cdr x)))))
-(define (cdaaar x) (cdr (car (car (car x)))))
-(define (cdaadr x) (cdr (car (car (cdr x)))))
-(define (cdadar x) (cdr (car (cdr (car x)))))
-(define (cdaddr x) (cdr (car (cdr (cdr x)))))
-(define (cddaar x) (cdr (cdr (car (car x)))))
-(define (cddadr x) (cdr (cdr (car (cdr x)))))
-(define (cdddar x) (cdr (cdr (cdr (car x)))))
-(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
-
-(let ((*values* (list '*values*)))
- (set! values
- (lambda vs
- (if (and (pair? vs) (null? (cdr vs)))
- (car vs)
- (cons *values* vs))))
- (set! call-with-values
- (lambda (producer consumer)
- (let ((res (producer)))
- (if (and (pair? res) (eq? *values* (car res)))
- (apply consumer (cdr res))
- (consumer res))))))
-
-; list utilities --------------------------------------------------------------
-
-(define (every pred lst)
- (or (atom? lst)
- (and (pred (car lst))
- (every pred (cdr lst)))))
-
-(define (any pred lst)
- (and (pair? lst)
- (or (pred (car lst))
- (any pred (cdr lst)))))
-
-(define (list? a) (or (null? a) (and (pair? a) (list? (cdr a)))))
-
-(define (list-tail lst n)
- (if (<= n 0) lst
- (list-tail (cdr lst) (- n 1))))
-
-(define (list-head lst n)
- (if (<= n 0) ()
- (cons (car lst)
- (list-head (cdr lst) (- n 1)))))
-
-(define (list-ref lst n)
- (car (list-tail lst n)))
-
-; bounded length test
-; use this instead of (= (length lst) n), since it avoids unnecessary
-; work and always terminates.
-(define (length= lst n)
- (cond ((< n 0) #f)
- ((= n 0) (atom? lst))
- ((atom? lst) (= n 0))
- (else (length= (cdr lst) (- n 1)))))
-
-(define (length> lst n)
- (cond ((< n 0) lst)
- ((= n 0) (and (pair? lst) lst))
- ((atom? lst) (< n 0))
- (else (length> (cdr lst) (- n 1)))))
-
-(define (last-pair l)
- (if (atom? (cdr l))
- l
- (last-pair (cdr l))))
-
-(define (lastcdr l)
- (if (atom? l)
- l
- (cdr (last-pair l))))
-
-(define (to-proper l)
- (cond ((null? l) l)
- ((atom? l) (list l))
- (else (cons (car l) (to-proper (cdr l))))))
-
-(define (map! f lst)
- (prog1 lst
- (while (pair? lst)
- (set-car! lst (f (car lst)))
- (set! lst (cdr lst)))))
-
-(define (filter pred lst)
- (define (filter- f lst acc)
- (cdr
- (prog1 acc
- (while (pair? lst)
- (begin (if (pred (car lst))
- (set! acc
- (cdr (set-cdr! acc (cons (car lst) ())))))
- (set! lst (cdr lst)))))))
- (filter- pred lst (list ())))
-
-(define (separate pred lst)
- (define (separate- pred lst yes no)
- (let ((vals
- (prog1
- (cons yes no)
- (while (pair? lst)
- (begin (if (pred (car lst))
- (set! yes
- (cdr (set-cdr! yes (cons (car lst) ()))))
- (set! no
- (cdr (set-cdr! no (cons (car lst) ())))))
- (set! lst (cdr lst)))))))
- (values (cdr (car vals)) (cdr (cdr vals)))))
- (separate- pred lst (list ()) (list ())))
-
-(define (count f l)
- (define (count- f l n)
- (if (null? l)
- n
- (count- f (cdr l) (if (f (car l))
- (+ n 1)
- n))))
- (count- f l 0))
-
-(define (nestlist f zero n)
- (if (<= n 0) ()
- (cons zero (nestlist f (f zero) (- n 1)))))
-
-(define (foldr f zero lst)
- (if (null? lst) zero
- (f (car lst) (foldr f zero (cdr lst)))))
-
-(define (foldl f zero lst)
- (if (null? lst) zero
- (foldl f (f (car lst) zero) (cdr lst))))
-
-(define (reverse- zero lst)
- (if (null? lst) zero
- (reverse- (cons (car lst) zero) (cdr lst))))
-
-(define (reverse lst) (reverse- () lst))
-
-(define (reverse!- prev l)
- (while (pair? l)
- (set! l (prog1 (cdr l)
- (set-cdr! l (prog1 prev
- (set! prev l))))))
- prev)
-
-(define (reverse! l) (reverse!- () l))
-
-(define (copy-tree l)
- (if (atom? l) l
- (cons (copy-tree (car l))
- (copy-tree (cdr l)))))
-
-(define (delete-duplicates lst)
- (if (atom? lst)
- lst
- (let ((elt (car lst))
- (tail (cdr lst)))
- (if (member elt tail)
- (delete-duplicates tail)
- (cons elt
- (delete-duplicates tail))))))
-
-; backquote -------------------------------------------------------------------
-
-(define (revappend l1 l2) (reverse- l2 l1))
-(define (nreconc l1 l2) (reverse!- l2 l1))
-
-(define (self-evaluating? x)
- (or (and (atom? x)
- (not (symbol? x)))
- (and (constant? x)
- (symbol? x)
- (eq x (top-level-value x)))))
-
-(define-macro (quasiquote x) (bq-process x 0))
-
-(define (splice-form? x)
- (or (and (pair? x) (or (eq? (car x) 'unquote-splicing)
- (eq? (car x) 'unquote-nsplicing)
- (and (eq? (car x) 'unquote)
- (length> x 2))))
- (eq? x 'unquote)))
-
-;; bracket without splicing
-(define (bq-bracket1 x d)
- (if (and (pair? x) (eq? (car x) 'unquote))
- (if (= d 0)
- (cadr x)
- (list cons ''unquote
- (bq-process (cdr x) (- d 1))))
- (bq-process x d)))
-
-(define (bq-bracket x d)
- (cond ((atom? x) (list list (bq-process x d)))
- ((eq? (car x) 'unquote)
- (if (= d 0)
- (cons list (cdr x))
- (list list (list cons ''unquote
- (bq-process (cdr x) (- d 1))))))
- ((eq? (car x) 'unquote-splicing)
- (if (= d 0)
- (list 'copy-list (cadr x))
- (list list (list list ''unquote-splicing
- (bq-process (cadr x) (- d 1))))))
- ((eq? (car x) 'unquote-nsplicing)
- (if (= d 0)
- (cadr x)
- (list list (list list ''unquote-nsplicing
- (bq-process (cadr x) (- d 1))))))
- (else (list list (bq-process x d)))))
-
-(define (bq-process x d)
- (cond ((symbol? x) (list 'quote x))
- ((vector? x)
- (let ((body (bq-process (vector->list x) d)))
- (if (eq? (car body) list)
- (cons vector (cdr body))
- (list apply vector body))))
- ((atom? x) x)
- ((eq? (car x) 'quasiquote)
- (list list ''quasiquote (bq-process (cadr x) (+ d 1))))
- ((eq? (car x) 'unquote)
- (if (and (= d 0) (length= x 2))
- (cadr x)
- (list cons ''unquote (bq-process (cdr x) (- d 1)))))
- ((or (> d 0) (not (any splice-form? x)))
- (let ((lc (lastcdr x))
- (forms (map (lambda (x) (bq-bracket1 x d)) x)))
- (if (null? lc)
- (cons list forms)
- (if (null? (cdr forms))
- (list cons (car forms) (bq-process lc d))
- (nconc (cons list* forms) (list (bq-process lc d)))))))
- (else
- (let loop ((p x) (q ()))
- (cond ((null? p) ;; proper list
- (cons 'nconc (reverse! q)))
- ((pair? p)
- (cond ((eq? (car p) 'unquote)
- ;; (... . ,x)
- (cons 'nconc
- (nreconc q
- (if (= d 0)
- (cdr p)
- (list (list list ''unquote)
- (bq-process (cdr p)
- (- d 1)))))))
- (else
- (loop (cdr p) (cons (bq-bracket (car p) d) q)))))
- (else
- ;; (... . x)
- (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))
-
-; standard macros -------------------------------------------------------------
-
-(define (quote-value v)
- (if (self-evaluating? v)
- v
- (list 'quote v)))
-
-(define-macro (let* binds . body)
- (if (atom? binds) `((lambda () ,@body))
- `((lambda (,(caar binds))
- ,@(if (pair? (cdr binds))
- `((let* ,(cdr binds) ,@body))
- body))
- ,(cadar binds))))
-
-(define-macro (when c . body) (list 'if c (cons 'begin body) #f))
-(define-macro (unless c . body) (list 'if c #f (cons 'begin body)))
-
-(define-macro (case key . clauses)
- (define (vals->cond key v)
- (cond ((eq? v 'else) 'else)
- ((null? v) #f)
- ((symbol? v) `(eq? ,key ,(quote-value v)))
- ((atom? v) `(eqv? ,key ,(quote-value v)))
- ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v))))
- ((every symbol? v)
- `(memq ,key ',v))
- (else `(memv ,key ',v))))
- (let ((g (gensym)))
- `(let ((,g ,key))
- (cond ,.(map (lambda (clause)
- (cons (vals->cond g (car clause))
- (cdr clause)))
- clauses)))))
-
-(define-macro (do vars test-spec . commands)
- (let ((loop (gensym))
- (test-expr (car test-spec))
- (vars (map car vars))
- (inits (map cadr vars))
- (steps (map (lambda (x)
- (if (pair? (cddr x))
- (caddr x)
- (car x)))
- vars)))
- `(letrec ((,loop (lambda ,vars
- (if ,test-expr
- (begin
- ,@(cdr test-spec))
- (begin
- ,@commands
- (,loop ,.steps))))))
- (,loop ,.inits))))
-
-; SRFI 8
-(define-macro (receive formals expr . body)
- `(call-with-values (lambda () ,expr)
- (lambda ,formals ,@body)))
-
-(define-macro (dotimes var . body)
- (let ((v (car var))
- (cnt (cadr var)))
- `(for 0 (- ,cnt 1)
- (lambda (,v) ,@body))))
-
-(define (map-int f n)
- (if (<= n 0)
- ()
- (let ((first (cons (f 0) ()))
- (acc ()))
- (set! acc first)
- (for 1 (- n 1)
- (lambda (i)
- (begin (set-cdr! acc (cons (f i) ()))
- (set! acc (cdr acc)))))
- first)))
-
-(define (iota n) (map-int identity n))
-
-(define (for-each f l . lsts)
- (define (for-each-n f lsts)
- (if (pair? (car lsts))
- (begin (apply f (map car lsts))
- (for-each-n f (map cdr lsts)))))
- (if (null? lsts)
- (while (pair? l)
- (begin (f (car l))
- (set! l (cdr l))))
- (for-each-n f (cons l lsts)))
- #t)
-
-(define-macro (with-bindings binds . body)
- (let ((vars (map car binds))
- (vals (map cadr binds))
- (olds (map (lambda (x) (gensym)) binds)))
- `(let ,(map list olds vars)
- ,@(map (lambda (v val) `(set! ,v ,val)) vars vals)
- (unwind-protect
- (begin ,@body)
- (begin ,@(map (lambda (v old) `(set! ,v ,old)) vars olds))))))
-
-; exceptions ------------------------------------------------------------------
-
-(define (error . args) (raise (cons 'error args)))
-
-(define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value)))
-(define-macro (catch tag expr)
- (let ((e (gensym)))
- `(trycatch ,expr
- (lambda (,e) (if (and (pair? ,e)
- (eq (car ,e) 'thrown-value)
- (eq (cadr ,e) ,tag))
- (caddr ,e)
- (raise ,e))))))
-
-(define-macro (unwind-protect expr finally)
- (let ((e (gensym))
- (thk (gensym)))
- `(let ((,thk (lambda () ,finally)))
- (prog1 (trycatch ,expr
- (lambda (,e) (begin (,thk) (raise ,e))))
- (,thk)))))
-
-; debugging utilities ---------------------------------------------------------
-
-(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
-
-(define traced?
- (letrec ((sample-traced-lambda (lambda args (begin (write (cons 'x args))
- (newline)
- (apply #.apply args)))))
- (lambda (f)
- (and (closure? f)
- (equal? (function:code f)
- (function:code sample-traced-lambda))))))
-
-(define (trace sym)
- (let* ((func (top-level-value sym))
- (args (gensym)))
- (if (not (traced? func))
- (set-top-level-value! sym
- (eval
- `(lambda ,args
- (begin (write (cons ',sym ,args))
- (newline)
- (apply ',func ,args)))))))
- 'ok)
-
-(define (untrace sym)
- (let ((func (top-level-value sym)))
- (if (traced? func)
- (set-top-level-value! sym
- (aref (function:vals func) 2)))))
-
-(define-macro (time expr)
- (let ((t0 (gensym)))
- `(let ((,t0 (time.now)))
- (prog1
- ,expr
- (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))
-
-; text I/O --------------------------------------------------------------------
-
-(define (print . args) (for-each write args))
-(define (princ . args)
- (with-bindings ((*print-readably* #f))
- (for-each write args)))
-
-(define (newline (port *output-stream*))
- (io.write port *linefeed*)
- #t)
-
-(define (io.readline s) (io.readuntil s #\linefeed))
-
-; call f on a stream until the stream runs out of data
-(define (read-all-of f s)
- (let loop ((lines ())
- (curr (f s)))
- (if (io.eof? s)
- (reverse! lines)
- (loop (cons curr lines) (f s)))))
-
-(define (io.readlines s) (read-all-of io.readline s))
-(define (read-all s) (read-all-of read s))
-
-(define (io.readall s)
- (let ((b (buffer)))
- (io.copy b s)
- (let ((str (io.tostring! b)))
- (if (and (equal? str "") (io.eof? s))
- (eof-object)
- str))))
-
-(define-macro (with-output-to stream . body)
- `(with-bindings ((*output-stream* ,stream))
- ,@body))
-(define-macro (with-input-from stream . body)
- `(with-bindings ((*input-stream* ,stream))
- ,@body))
-
-; vector functions ------------------------------------------------------------
-
-(define (list->vector l) (apply vector l))
-(define (vector->list v)
- (let ((n (length v))
- (l ()))
- (for 1 n
- (lambda (i)
- (set! l (cons (aref v (- n i)) l))))
- l))
-
-(define (vector.map f v)
- (let* ((n (length v))
- (nv (vector.alloc n)))
- (for 0 (- n 1)
- (lambda (i)
- (aset! nv i (f (aref v i)))))
- nv))
-
-; table functions -------------------------------------------------------------
-
-(define (table.pairs t)
- (table.foldl (lambda (k v z) (cons (cons k v) z))
- () t))
-(define (table.keys t)
- (table.foldl (lambda (k v z) (cons k z))
- () t))
-(define (table.values t)
- (table.foldl (lambda (k v z) (cons v z))
- () t))
-(define (table.clone t)
- (let ((nt (table)))
- (table.foldl (lambda (k v z) (put! nt k v))
- () t)
- nt))
-(define (table.invert t)
- (let ((nt (table)))
- (table.foldl (lambda (k v z) (put! nt v k))
- () t)
- nt))
-(define (table.foreach f t)
- (table.foldl (lambda (k v z) (begin (f k v) #t)) () t))
-
-; string functions ------------------------------------------------------------
-
-(define (string.tail s n) (string.sub s (string.inc s 0 n)))
-
-(define *whitespace*
- (string.encode #array(wchar 9 10 11 12 13 32 133 160 5760 6158 8192
- 8193 8194 8195 8196 8197 8198 8199 8200
- 8201 8202 8232 8233 8239 8287 12288)))
-
-(define (string.trim s at-start at-end)
- (define (trim-start s chars i L)
- (if (and (< i L)
- (string.find chars (string.char s i)))
- (trim-start s chars (string.inc s i) L)
- i))
- (define (trim-end s chars i)
- (if (and (> i 0)
- (string.find chars (string.char s (string.dec s i))))
- (trim-end s chars (string.dec s i))
- i))
- (let ((L (length s)))
- (string.sub s
- (trim-start s at-start 0 L)
- (trim-end s at-end L))))
-
-(define (string.map f s)
- (let ((b (buffer))
- (n (length s)))
- (let ((i 0))
- (while (< i n)
- (begin (io.putc b (f (string.char s i)))
- (set! i (string.inc s i)))))
- (io.tostring! b)))
-
-(define (string.rep s k)
- (cond ((< k 4)
- (cond ((<= k 0) "")
- ((= k 1) (string s))
- ((= k 2) (string s s))
- (else (string s s s))))
- ((odd? k) (string s (string.rep s (- k 1))))
- (else (string.rep (string s s) (/ k 2)))))
-
-(define (string.lpad s n c) (string (string.rep c (- n (string.count s))) s))
-(define (string.rpad s n c) (string s (string.rep c (- n (string.count s)))))
-
-(define (print-to-string v)
- (let ((b (buffer)))
- (write v b)
- (io.tostring! b)))
-
-(define (string.join strlist sep)
- (if (null? strlist) ""
- (let ((b (buffer)))
- (io.write b (car strlist))
- (for-each (lambda (s) (begin (io.write b sep)
- (io.write b s)))
- (cdr strlist))
- (io.tostring! b))))
-
-; toplevel --------------------------------------------------------------------
-
-(define (macrocall? e) (and (symbol? (car e))
- (symbol-syntax (car e))))
-
-(define (macroexpand-1 e)
- (if (atom? e) e
- (let ((f (macrocall? e)))
- (if f (apply f (cdr e))
- e))))
-
-(define (expand e)
- ; symbol resolves to toplevel; i.e. has no shadowing definition
- (define (top? s env) (not (or (bound? s) (assq s env))))
-
- (define (splice-begin body)
- (cond ((atom? body) body)
- ((equal? body '((begin)))
- body)
- ((and (pair? (car body))
- (eq? (caar body) 'begin))
- (append (splice-begin (cdar body)) (splice-begin (cdr body))))
- (else
- (cons (car body) (splice-begin (cdr body))))))
-
- (define *expanded* (list '*expanded*))
-
- (define (expand-body body env)
- (if (atom? body) body
- (let* ((body (if (top? 'begin env)
- (splice-begin body)
- body))
- (def? (top? 'define env))
- (dvars (if def? (get-defined-vars body) ()))
- (env (nconc (map list dvars) env)))
- (if (not def?)
- (map (lambda (x) (expand-in x env)) body)
- (let* ((ex-nondefs ; expand non-definitions
- (let loop ((body body))
- (cond ((atom? body) body)
- ((and (pair? (car body))
- (eq? 'define (caar body)))
- (cons (car body) (loop (cdr body))))
- (else
- (let ((form (expand-in (car body) env)))
- (set! env (nconc
- (map list (get-defined-vars form))
- env))
- (cons
- (cons *expanded* form)
- (loop (cdr body))))))))
- (body ex-nondefs))
- (while (pair? body) ; now expand deferred definitions
- (if (not (eq? *expanded* (caar body)))
- (set-car! body (expand-in (car body) env))
- (set-car! body (cdar body)))
- (set! body (cdr body)))
- ex-nondefs)))))
-
- (define (expand-lambda-list l env)
- (if (atom? l) l
- (cons (if (and (pair? (car l)) (pair? (cdr (car l))))
- (list (caar l) (expand-in (cadar l) env))
- (car l))
- (expand-lambda-list (cdr l) env))))
-
- (define (l-vars l)
- (cond ((atom? l) (list l))
- ((pair? (car l)) (cons (caar l) (l-vars (cdr l))))
- (else (cons (car l) (l-vars (cdr l))))))
-
- (define (expand-lambda e env)
- (let ((formals (cadr e))
- (name (lastcdr e))
- (body (cddr e))
- (vars (l-vars (cadr e))))
- (let ((env (nconc (map list vars) env)))
- `(lambda ,(expand-lambda-list formals env)
- ,.(expand-body body env)
- . ,name))))
-
- (define (expand-define e env)
- (if (or (null? (cdr e)) (atom? (cadr e)))
- (if (null? (cddr e))
- e
- `(define ,(cadr e) ,(expand-in (caddr e) env)))
- (let ((formals (cdadr e))
- (name (caadr e))
- (body (cddr e))
- (vars (l-vars (cdadr e))))
- (let ((env (nconc (map list vars) env)))
- `(define ,(cons name (expand-lambda-list formals env))
- ,.(expand-body body env))))))
-
- (define (expand-let-syntax e env)
- (let ((binds (cadr e)))
- (cons 'begin
- (expand-body (cddr e)
- (nconc
- (map (lambda (bind)
- (list (car bind)
- ((compile-thunk
- (expand-in (cadr bind) env)))
- env))
- binds)
- env)))))
-
- ; given let-syntax definition environment (menv) and environment
- ; at the point of the macro use (lenv), return the environment to
- ; expand the macro use in. TODO
- (define (local-expansion-env menv lenv) menv)
-
- (define (expand-in e env)
- (if (atom? e) e
- (let* ((head (car e))
- (bnd (assq head env))
- (default (lambda ()
- (let loop ((e e))
- (if (atom? e) e
- (cons (if (atom? (car e))
- (car e)
- (expand-in (car e) env))
- (loop (cdr e))))))))
- (cond ((and bnd (pair? (cdr bnd))) ; local macro
- (expand-in (apply (cadr bnd) (cdr e))
- (local-expansion-env (caddr bnd) env)))
- ((or bnd ; bound lexical or toplevel var
- (not (symbol? head))
- (bound? head))
- (default))
- ((macrocall? e) => (lambda (f)
- (expand-in (apply f (cdr e)) env)))
- ((eq? head 'quote) e)
- ((eq? head 'lambda) (expand-lambda e env))
- ((eq? head 'define) (expand-define e env))
- ((eq? head 'let-syntax) (expand-let-syntax e env))
- (else (default))))))
- (expand-in e ()))
-
-(define (eval x) ((compile-thunk (expand x))))
-
-(define (load-process x) (eval x))
-
-(define (load filename)
- (let ((F (file filename :read)))
- (trycatch
- (let next (prev E v)
- (if (not (io.eof? F))
- (next (read F)
- prev
- (load-process E))
- (begin (io.close F)
- ; evaluate last form in almost-tail position
- (load-process E))))
- (lambda (e)
- (begin
- (io.close F)
- (raise `(load-error ,filename ,e)))))))
-
-(define *banner* (string.tail "
-; _
-; |_ _ _ |_ _ | . _ _
-; | (-||||_(_)|__|_)|_)
-;-------------------|----------------------------------------------------------
-
-" 1))
-
-(define (repl)
- (define (prompt)
- (princ "> ") (io.flush *output-stream*)
- (let ((v (trycatch (read)
- (lambda (e) (begin (io.discardbuffer *input-stream*)
- (raise e))))))
- (and (not (io.eof? *input-stream*))
- (let ((V (load-process v)))
- (print V)
- (set! that V)
- #t))))
- (define (reploop)
- (when (trycatch (and (prompt) (newline))
- (lambda (e)
- (top-level-exception-handler e)
- #t))
- (begin (newline)
- (reploop))))
- (reploop)
- (newline))
-
-(define (top-level-exception-handler e)
- (with-output-to *stderr*
- (print-exception e)
- (print-stack-trace (stacktrace))))
-
-(define (print-stack-trace st)
- (define (find-in-f f tgt path)
- (let ((path (cons (function:name f) path)))
- (if (eq? (function:code f) (function:code tgt))
- (throw 'ffound path)
- (let ((v (function:vals f)))
- (for 0 (1- (length v))
- (lambda (i) (if (closure? (aref v i))
- (find-in-f (aref v i) tgt path))))))))
- (define (fn-name f e)
- (let ((p (catch 'ffound
- (begin
- (for-each (lambda (topfun)
- (find-in-f topfun f ()))
- e)
- #f))))
- (if p
- (symbol (string.join (map string (reverse! p)) "/"))
- 'lambda)))
- (let ((st (reverse! (list-tail st (if *interactive* 5 4))))
- (e (filter closure? (map (lambda (s) (and (bound? s)
- (top-level-value s)))
- (environment))))
- (n 0))
- (for-each
- (lambda (f)
- (princ "#" n " ")
- (print (cons (fn-name (aref f 0) e)
- (cdr (vector->list f))))
- (newline)
- (set! n (+ n 1)))
- st)))
-
-(define (print-exception e)
- (cond ((and (pair? e)
- (eq? (car e) 'type-error)
- (length= e 4))
- (princ "type error: " (cadr e) ": expected " (caddr e) ", got ")
- (print (cadddr e)))
-
- ((and (pair? e)
- (eq? (car e) 'bounds-error)
- (length= e 4))
- (princ (cadr e) ": index " (cadddr e) " out of bounds for ")
- (print (caddr e)))
-
- ((and (pair? e)
- (eq? (car e) 'unbound-error)
- (pair? (cdr e)))
- (princ "eval: variable " (cadr e) " has no value"))
-
- ((and (pair? e)
- (eq? (car e) 'error))
- (princ "error: ")
- (apply princ (cdr e)))
-
- ((and (pair? e)
- (eq? (car e) 'load-error))
- (print-exception (caddr e))
- (princ "in file " (cadr e)))
-
- ((and (list? e)
- (length= e 2))
- (print (car e))
- (princ ": ")
- (let ((msg (cadr e)))
- ((if (or (string? msg) (symbol? msg))
- princ print)
- msg)))
-
- (else (princ "*** Unhandled exception: ")
- (print e)))
-
- (princ *linefeed*))
-
-(define (simple-sort l)
- (if (or (null? l) (null? (cdr l))) l
- (let ((piv (car l)))
- (receive (less grtr)
- (separate (lambda (x) (< x piv)) (cdr l))
- (nconc (simple-sort less)
- (list piv)
- (simple-sort grtr))))))
-
-(define (make-system-image fname)
- (let ((f (file fname :write :create :truncate))
- (excludes '(*linefeed* *directory-separator* *argv* that
- *print-pretty* *print-width* *print-readably*
- *print-level* *print-length* *os-name*)))
- (with-bindings ((*print-pretty* #t)
- (*print-readably* #t))
- (let ((syms
- (filter (lambda (s)
- (and (bound? s)
- (not (constant? s))
- (or (not (builtin? (top-level-value s)))
- (not (equal? (string s) ; alias of builtin
- (string (top-level-value s)))))
- (not (memq s excludes))
- (not (iostream? (top-level-value s)))))
- (simple-sort (environment)))))
- (write (apply nconc (map list syms (map top-level-value syms))) f)
- (io.write f *linefeed*))
- (io.close f))))
-
-; initialize globals that need to be set at load time
-(define (__init_globals)
- (if (or (eq? *os-name* 'win32)
- (eq? *os-name* 'win64)
- (eq? *os-name* 'windows))
- (begin (set! *directory-separator* "\\")
- (set! *linefeed* "\r\n"))
- (begin (set! *directory-separator* "/")
- (set! *linefeed* "\n")))
- (set! *output-stream* *stdout*)
- (set! *input-stream* *stdin*)
- (set! *error-stream* *stderr*))
-
-(define (__script fname)
- (trycatch (load fname)
- (lambda (e) (begin (top-level-exception-handler e)
- (exit 1)))))
-
-(define (__start argv)
- (__init_globals)
- (if (pair? (cdr argv))
- (begin (set! *argv* (cdr argv))
- (set! *interactive* #f)
- (__script (cadr argv)))
- (begin (set! *argv* argv)
- (set! *interactive* #t)
- (princ *banner*)
- (repl)))
- (exit 0))
--- a/femtolisp/table.c
+++ /dev/null
@@ -1,211 +1,0 @@
-#include <stdlib.h>
-#include <stdio.h>
-#include <stdarg.h>
-#include <string.h>
-#include <assert.h>
-#include <sys/types.h>
-#include <setjmp.h>
-#include "llt.h"
-#include "flisp.h"
-#include "equalhash.h"
-
-static value_t tablesym;
-static fltype_t *tabletype;
-
-void print_htable(value_t v, ios_t *f)
-{- htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(v));
- size_t i;
- int first=1;
- fl_print_str("#table(", f);- for(i=0; i < h->size; i+=2) {- if (h->table[i+1] != HT_NOTFOUND) {- if (!first) fl_print_str(" ", f);- fl_print_child(f, (value_t)h->table[i]);
- fl_print_chr(' ', f);- fl_print_child(f, (value_t)h->table[i+1]);
- first = 0;
- }
- }
- fl_print_chr(')', f);-}
-
-void print_traverse_htable(value_t self)
-{- htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(self));
- size_t i;
- for(i=0; i < h->size; i+=2) {- if (h->table[i+1] != HT_NOTFOUND) {- print_traverse((value_t)h->table[i]);
- print_traverse((value_t)h->table[i+1]);
- }
- }
-}
-
-void free_htable(value_t self)
-{- htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(self));
- htable_free(h);
-}
-
-void relocate_htable(value_t oldv, value_t newv)
-{- htable_t *oldh = (htable_t*)cv_data((cvalue_t*)ptr(oldv));
- htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(newv));
- if (oldh->table == &oldh->_space[0])
- h->table = &h->_space[0];
- size_t i;
- for(i=0; i < h->size; i++) {- if (h->table[i] != HT_NOTFOUND)
- h->table[i] = (void*)relocate_lispvalue((value_t)h->table[i]);
- }
-}
-
-cvtable_t table_vtable = { print_htable, relocate_htable, free_htable,- print_traverse_htable };
-
-int ishashtable(value_t v)
-{- return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == tabletype;
-}
-
-value_t fl_tablep(value_t *args, uint32_t nargs)
-{- argcount("table?", nargs, 1);- return ishashtable(args[0]) ? FL_T : FL_F;
-}
-
-static htable_t *totable(value_t v, char *fname)
-{- if (!ishashtable(v))
- type_error(fname, "table", v);
- return (htable_t*)cv_data((cvalue_t*)ptr(v));
-}
-
-value_t fl_table(value_t *args, uint32_t nargs)
-{- size_t cnt = (size_t)nargs;
- if (cnt & 1)
- lerror(ArgError, "table: arguments must come in pairs");
- value_t nt;
- // prevent small tables from being added to finalizer list
- if (cnt <= HT_N_INLINE) {- tabletype->vtable->finalize = NULL;
- nt = cvalue(tabletype, sizeof(htable_t));
- tabletype->vtable->finalize = free_htable;
- }
- else {- nt = cvalue(tabletype, 2*sizeof(void*));
- }
- htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(nt));
- htable_new(h, cnt/2);
- uint32_t i;
- value_t k=FL_NIL, arg=FL_NIL;
- FOR_ARGS(i,0,arg,args) {- if (i&1)
- equalhash_put(h, (void*)k, (void*)arg);
- else
- k = arg;
- }
- return nt;
-}
-
-// (put! table key value)
-value_t fl_table_put(value_t *args, uint32_t nargs)
-{- argcount("put!", nargs, 3);- htable_t *h = totable(args[0], "put!");
- void **table0 = h->table;
- equalhash_put(h, (void*)args[1], (void*)args[2]);
- // register finalizer if we outgrew inline space
- if (table0 == &h->_space[0] && h->table != &h->_space[0]) {- cvalue_t *cv = (cvalue_t*)ptr(args[0]);
- add_finalizer(cv);
- cv->len = 2*sizeof(void*);
- }
- return args[0];
-}
-
-static void key_error(char *fname, value_t key)
-{- lerrorf(fl_list2(KeyError, key), "%s: key not found", fname);
-}
-
-// (get table key [default])
-value_t fl_table_get(value_t *args, uint32_t nargs)
-{- if (nargs != 3)
- argcount("get", nargs, 2);- htable_t *h = totable(args[0], "get");
- value_t v = (value_t)equalhash_get(h, (void*)args[1]);
- if (v == (value_t)HT_NOTFOUND) {- if (nargs == 3)
- return args[2];
- key_error("get", args[1]);- }
- return v;
-}
-
-// (has? table key)
-value_t fl_table_has(value_t *args, uint32_t nargs)
-{- argcount("has", nargs, 2);- htable_t *h = totable(args[0], "has");
- return equalhash_has(h, (void*)args[1]) ? FL_T : FL_F;
-}
-
-// (del! table key)
-value_t fl_table_del(value_t *args, uint32_t nargs)
-{- argcount("del!", nargs, 2);- htable_t *h = totable(args[0], "del!");
- if (!equalhash_remove(h, (void*)args[1]))
- key_error("del!", args[1]);- return args[0];
-}
-
-value_t fl_table_foldl(value_t *args, uint32_t nargs)
-{- argcount("table.foldl", nargs, 3);- value_t f=args[0], zero=args[1], t=args[2];
- htable_t *h = totable(t, "table.foldl");
- size_t i, n = h->size;
- void **table = h->table;
- fl_gc_handle(&f);
- fl_gc_handle(&zero);
- fl_gc_handle(&t);
- for(i=0; i < n; i+=2) {- if (table[i+1] != HT_NOTFOUND) {- zero = fl_applyn(3, f,
- (value_t)table[i],
- (value_t)table[i+1],
- zero);
- // reload pointer
- h = (htable_t*)cv_data((cvalue_t*)ptr(t));
- if (h->size != n)
- lerror(EnumerationError, "table.foldl: table modified");
- table = h->table;
- }
- }
- fl_free_gc_handles(3);
- return zero;
-}
-
-static builtinspec_t tablefunc_info[] = {- { "table", fl_table },- { "table?", fl_tablep },- { "put!", fl_table_put },- { "get", fl_table_get },- { "has?", fl_table_has },- { "del!", fl_table_del },- { "table.foldl", fl_table_foldl },- { NULL, NULL }-};
-
-void table_init()
-{- tablesym = symbol("table");- tabletype = define_opaque_type(tablesym, sizeof(htable_t),
- &table_vtable, NULL);
- assign_global_builtins(tablefunc_info);
-}
--- a/femtolisp/tests/100x100.lsp
+++ /dev/null
@@ -1,1 +1,0 @@
-'#0=(#198=(#197=(#196=(#195=(#194=(#193=(#192=(#191=(#190=(#189=(#188=(#187=(#186=(#185=(#184=(#183=(#182=(#181=(#180=(#179=(#178=(#177=(#176=(#175=(#174=(#173=(#172=(#171=(#170=(#169=(#168=(#167=(#166=(#165=(#164=(#163=(#162=(#161=(#160=(#159=(#158=(#157=(#156=(#155=(#154=(#153=(#152=(#151=(#150=(#149=(#148=(#147=(#146=(#145=(#144=(#143=(#142=(#141=(#140=(#139=(#138=(#137=(#136=(#135=(#134=(#133=(#132=(#131=(#130=(#129=(#128=(#127=(#126=(#125=(#124=(#123=(#122=(#121=(#120=(#119=(#118=(#117=(#116=(#115=(#114=(#113=(#112=(#111=(#110=(#109=(#108=(#107=(#106=(#105=(#104=(#103=(#102=(#101=(#100=(#0# . #1=(#9999=(#9998=(#9997=(#9996=(#9995=(#9994=(#9993=(#9992=(#9991=(#9990=(#9989=(#9988=(#9987=(#9986=(#9985=(#9984=(#9983=(#9982=(#9981=(#9980=(#9979=(#9978=(#9977=(#9976=(#9975=(#9974=(#9973=(#9972=(#9971=(#9970=(#9969=(#9968=(#9967=(#9966=(#9965=(#9964=(#9963=(#9962=(#9961=(#9960=(#9959=(#9958=(#9957=(#9956=(#9955=(#9954=(#9953=(#9952=(#9951=(#9950=(#9949=(#9948=(#9947=(#9946=(#9945=(#9944=(#9943=(#9942=(#9941=(#9940=(#9939=(#9938=(#9937=(#9936=(#9935=(#9934=(#9933=(#9932=(#9931=(#9930=(#9929=(#9928=(#9927=(#9926=(#9925=(#9924=(#9923=(#9922=(#9921=(#9920=(#9919=(#9918=(#9917=(#9916=(#9915=(#9914=(#9913=(#9912=(#9911=(#9910=(#9909=(#9908=(#9907=(#9906=(#9905=(#9904=(#9903=(#9902=(#9901=(#1# . #2=(#9900=(#9899=(#9898=(#9897=(#9896=(#9895=(#9894=(#9893=(#9892=(#9891=(#9890=(#9889=(#9888=(#9887=(#9886=(#9885=(#9884=(#9883=(#9882=(#9881=(#9880=(#9879=(#9878=(#9877=(#9876=(#9875=(#9874=(#9873=(#9872=(#9871=(#9870=(#9869=(#9868=(#9867=(#9866=(#9865=(#9864=(#9863=(#9862=(#9861=(#9860=(#9859=(#9858=(#9857=(#9856=(#9855=(#9854=(#9853=(#9852=(#9851=(#9850=(#9849=(#9848=(#9847=(#9846=(#9845=(#9844=(#9843=(#9842=(#9841=(#9840=(#9839=(#9838=(#9837=(#9836=(#9835=(#9834=(#9833=(#9832=(#9831=(#9830=(#9829=(#9828=(#9827=(#9826=(#9825=(#9824=(#9823=(#9822=(#9821=(#9820=(#9819=(#9818=(#9817=(#9816=(#9815=(#9814=(#9813=(#9812=(#9811=(#9810=(#9809=(#9808=(#9807=(#9806=(#9805=(#9804=(#9803=(#9802=(#2# . #3=(#9801=(#9800=(#9799=(#9798=(#9797=(#9796=(#9795=(#9794=(#9793=(#9792=(#9791=(#9790=(#9789=(#9788=(#9787=(#9786=(#9785=(#9784=(#9783=(#9782=(#9781=(#9780=(#9779=(#9778=(#9777=(#9776=(#9775=(#9774=(#9773=(#9772=(#9771=(#9770=(#9769=(#9768=(#9767=(#9766=(#9765=(#9764=(#9763=(#9762=(#9761=(#9760=(#9759=(#9758=(#9757=(#9756=(#9755=(#9754=(#9753=(#9752=(#9751=(#9750=(#9749=(#9748=(#9747=(#9746=(#9745=(#9744=(#9743=(#9742=(#9741=(#9740=(#9739=(#9738=(#9737=(#9736=(#9735=(#9734=(#9733=(#9732=(#9731=(#9730=(#9729=(#9728=(#9727=(#9726=(#9725=(#9724=(#9723=(#9722=(#9721=(#9720=(#9719=(#9718=(#9717=(#9716=(#9715=(#9714=(#9713=(#9712=(#9711=(#9710=(#9709=(#9708=(#9707=(#9706=(#9705=(#9704=(#9703=(#3# . #4=(#9702=(#9701=(#9700=(#9699=(#9698=(#9697=(#9696=(#9695=(#9694=(#9693=(#9692=(#9691=(#9690=(#9689=(#9688=(#9687=(#9686=(#9685=(#9684=(#9683=(#9682=(#9681=(#9680=(#9679=(#9678=(#9677=(#9676=(#9675=(#9674=(#9673=(#9672=(#9671=(#9670=(#9669=(#9668=(#9667=(#9666=(#9665=(#9664=(#9663=(#9662=(#9661=(#9660=(#9659=(#9658=(#9657=(#9656=(#9655=(#9654=(#9653=(#9652=(#9651=(#9650=(#9649=(#9648=(#9647=(#9646=(#9645=(#9644=(#9643=(#9642=(#9641=(#9640=(#9639=(#9638=(#9637=(#9636=(#9635=(#9634=(#9633=(#9632=(#9631=(#9630=(#9629=(#9628=(#9627=(#9626=(#9625=(#9624=(#9623=(#9622=(#9621=(#9620=(#9619=(#9618=(#9617=(#9616=(#9615=(#9614=(#9613=(#9612=(#9611=(#9610=(#9609=(#9608=(#9607=(#9606=(#9605=(#9604=(#4# . #5=(#9603=(#9602=(#9601=(#9600=(#9599=(#9598=(#9597=(#9596=(#9595=(#9594=(#9593=(#9592=(#9591=(#9590=(#9589=(#9588=(#9587=(#9586=(#9585=(#9584=(#9583=(#9582=(#9581=(#9580=(#9579=(#9578=(#9577=(#9576=(#9575=(#9574=(#9573=(#9572=(#9571=(#9570=(#9569=(#9568=(#9567=(#9566=(#9565=(#9564=(#9563=(#9562=(#9561=(#9560=(#9559=(#9558=(#9557=(#9556=(#9555=(#9554=(#9553=(#9552=(#9551=(#9550=(#9549=(#9548=(#9547=(#9546=(#9545=(#9544=(#9543=(#9542=(#9541=(#9540=(#9539=(#9538=(#9537=(#9536=(#9535=(#9534=(#9533=(#9532=(#9531=(#9530=(#9529=(#9528=(#9527=(#9526=(#9525=(#9524=(#9523=(#9522=(#9521=(#9520=(#9519=(#9518=(#9517=(#9516=(#9515=(#9514=(#9513=(#9512=(#9511=(#9510=(#9509=(#9508=(#9
\ No newline at end of file
--- a/femtolisp/tests/argv.lsp
+++ /dev/null
@@ -1,1 +1,0 @@
-(print *argv*) (princ "\n")
--- a/femtolisp/tests/ast/asttools.lsp
+++ /dev/null
@@ -1,171 +1,0 @@
-; -*- scheme -*-
-; utilities for AST processing
-
-(define (symconcat s1 s2)
- (symbol (string s1 s2)))
-
-(define (list-adjoin item lst)
- (if (member item lst)
- lst
- (cons item lst)))
-
-(define (index-of item lst start)
- (cond ((null? lst) #f)
- ((eq item (car lst)) start)
- (#t (index-of item (cdr lst) (+ start 1)))))
-
-(define (each f l)
- (if (null? l) l
- (begin (f (car l))
- (each f (cdr l)))))
-
-(define (maptree-pre f tr)
- (let ((new-t (f tr)))
- (if (pair? new-t)
- (map (lambda (e) (maptree-pre f e)) new-t)
- new-t)))
-
-(define (maptree-post f tr)
- (if (not (pair? tr))
- (f tr)
- (let ((new-t (map (lambda (e) (maptree-post f e)) tr)))
- (f new-t))))
-
-(define (foldtree-pre f t zero)
- (if (not (pair? t))
- (f t zero)
- (foldl t (lambda (e state) (foldtree-pre f e state)) (f t zero))))
-
-(define (foldtree-post f t zero)
- (if (not (pair? t))
- (f t zero)
- (f t (foldl t (lambda (e state) (foldtree-post f e state)) zero))))
-
-; general tree transformer
-; folds in preorder (foldtree-pre), maps in postorder (maptree-post)
-; therefore state changes occur immediately, just by looking at the current node,
-; while transformation follows evaluation order. this seems to be the most natural
-; approach.
-; (mapper tree state) - should return transformed tree given current state
-; (folder tree state) - should return new state
-(define (map&fold t zero mapper folder)
- (let ((head (and (pair? t) (car t))))
- (cond ((eq? head 'quote)
- t)
- ((or (eq? head 'the) (eq? head 'meta))
- (list head
- (cadr t)
- (map&fold (caddr t) zero mapper folder)))
- (else
- (let ((new-s (folder t zero)))
- (mapper
- (if (pair? t)
- ; head symbol is a tag; never transform it
- (cons (car t)
- (map (lambda (e) (map&fold e new-s mapper folder))
- (cdr t)))
- t)
- new-s))))))
-
-; convert to proper list, i.e. remove "dots", and append
-(define (append.2 l tail)
- (cond ((null? l) tail)
- ((atom? l) (cons l tail))
- (#t (cons (car l) (append.2 (cdr l) tail)))))
-
-; transform code by calling (f expr env) on each subexpr, where
-; env is a list of lexical variables in effect at that point.
-(define (lexical-walk f t)
- (map&fold t () f
- (lambda (tree state)
- (if (and (eq? (car t) 'lambda)
- (pair? (cdr t)))
- (append.2 (cadr t) state)
- state))))
-
-; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
-(define (flatten-left-op op e)
- (maptree-post (lambda (node)
- (if (and (pair? node)
- (eq (car node) op)
- (pair? (cdr node))
- (pair? (cadr node))
- (eq (caadr node) op))
- (cons op
- (append (cdadr node) (cddr node)))
- node))
- e))
-
-; convert all local variable references to (lexref rib slot name)
-; where rib is the nesting level and slot is the stack slot#
-; name is just there for reference
-; this assumes lambda is the only remaining naming form
-(define (lookup-var v env lev)
- (if (null? env) v
- (let ((i (index-of v (car env) 0)))
- (if i (list 'lexref lev i v)
- (lookup-var v (cdr env) (+ lev 1))))))
-(define (lvc- e env)
- (cond ((symbol? e) (lookup-var e env 0))
- ((pair? e)
- (if (eq (car e) 'quote)
- e
- (let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
- (newenv (if newvs (cons newvs env) env)))
- (if newvs
- (cons 'lambda
- (cons (cadr e)
- (map (lambda (se) (lvc- se newenv))
- (cddr e))))
- (map (lambda (se) (lvc- se env)) e)))))
- (#t e)))
-(define (lexical-var-conversion e)
- (lvc- e ()))
-
-; convert let to lambda
-(define (let-expand e)
- (maptree-post (lambda (n)
- (if (and (pair? n) (eq (car n) 'let))
- `((lambda ,(map car (cadr n)) ,@(cddr n))
- ,@(map cadr (cadr n)))
- n))
- e))
-
-; alpha renaming
-; transl is an assoc list ((old-sym-name . new-sym-name) ...)
-(define (alpha-rename e transl)
- (map&fold e
- ()
- ; mapper: replace symbol if unbound
- (lambda (t env)
- (if (symbol? t)
- (let ((found (assq t transl)))
- (if (and found
- (not (memq t env)))
- (cdr found)
- t))
- t))
- ; folder: add locals to environment if entering a new scope
- (lambda (t env)
- (if (and (pair? t) (or (eq? (car t) 'let)
- (eq? (car t) 'lambda)))
- (append (cadr t) env)
- env))))
-
-; flatten op with any associativity
-(define-macro (flatten-all-op op e)
- `(pattern-expand
- (pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...))
- (cons ',op (append l (cdr inner) r)))
- ,e))
-
-(define-macro (pattern-lambda pat body)
- (let* ((args (patargs pat))
- (expander `(lambda ,args ,body)))
- `(lambda (expr)
- (let ((m (match ',pat expr)))
- (if m
- ; matches; perform expansion
- (apply ,expander (map (lambda (var) (cdr (or (assq var m) '(0 . #f))))
- ',args))
- #f)))))
--- a/femtolisp/tests/ast/datetimeR.lsp
+++ /dev/null
@@ -1,79 +1,0 @@
-'(r-expressions
- (<- Sys.time (function () (r-call structure (r-call .Internal (r-call Sys.time)) (*named* class (r-call c "POSIXt" "POSIXct"))) ()))
- (<- Sys.timezone (function () (r-call as.vector (r-call Sys.getenv "TZ")) ()))
- (<- as.POSIXlt (function ((*named* x *r-missing*) (*named* tz "")) (r-block (<- fromchar (function ((*named* x *r-missing*)) (r-block (<- xx (r-call r-index x 1)) (if (r-call is.na xx) (r-block (<- j 1) (while (&& (r-call is.na xx) (r-call <= (<- j (r-call + j 1)) (r-call length x))) (<- xx (r-call r-index x j))) (if (r-call is.na xx) (<- f "%Y-%m-%d")))) (if (\|\| (\|\| (\|\| (\|\| (\|\| (\|\| (r-call is.na xx) (r-call ! (r-call is.na (r-call strptime xx (<- f "%Y-%m-%d %H:%M:%OS"))))) (r-call ! (r-call is.na (r-call strptime xx (<- f "%Y/%m/%d %H:%M:%OS"))))) (r-call ! (r-call is.na (r-call strptime xx (<- f "%Y-%m-%d %H:%M"))))) (r-call ! (r-call is.na (r-call strptime xx (<- f "%Y/%m/%d %H:%M"))))) (r-call ! (r-call is.na (r-call strptime xx (<- f "%Y-%m-%d"))))) (r-call ! (r-call is.na (r-call strptime xx (<- f "%Y/%m/%d"))))) (r-block (<- res (r-call strptime x f)) (if (r-call nchar tz) (<- (r-call attr res "tzone") tz)) (return res))) (r-call stop "character string is not in a standard unambiguous format")) ())) (if (r-call inherits x "POSIXlt") (return x)) (if (r-call inherits x "Date") (return (r-call .Internal (r-call Date2POSIXlt x)))) (<- tzone (r-call attr x "tzone")) (if (\|\| (r-call inherits x "date") (r-call inherits x "dates")) (<- x (r-call as.POSIXct x))) (if (r-call is.character x) (return (r-call fromchar (r-call unclass x)))) (if (r-call is.factor x) (return (r-call fromchar (r-call as.character x)))) (if (&& (r-call is.logical x) (r-call all (r-call is.na x))) (<- x (r-call as.POSIXct.default x))) (if (r-call ! (r-call inherits x "POSIXct")) (r-call stop (r-call gettextf "do not know how to convert '%s' to class \"POSIXlt\"" (r-call deparse (substitute x))))) (if (&& (missing tz) (r-call ! (r-call is.null tzone))) (<- tz (r-call r-index tzone 1))) (r-call .Internal (r-call as.POSIXlt x tz))) ()))
- (<- as.POSIXct (function ((*named* x *r-missing*) (*named* tz "")) (r-call UseMethod "as.POSIXct") ()))
- (<- as.POSIXct.Date (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call structure (r-call * (r-call unclass x) 86400) (*named* class (r-call c "POSIXt" "POSIXct"))) ()))
- (<- as.POSIXct.date (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (if (r-call inherits x "date") (r-block (<- x (r-call * (r-call - x 3653) 86400)) (return (r-call structure x (*named* class (r-call c "POSIXt" "POSIXct"))))) (r-call stop (r-call gettextf "'%s' is not a \"date\" object" (r-call deparse (substitute x)))))) ()))
- (<- as.POSIXct.dates (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (if (r-call inherits x "dates") (r-block (<- z (r-call attr x "origin")) (<- x (r-call * (r-call as.numeric x) 86400)) (if (&& (r-call == (r-call length z) 3) (r-call is.numeric z)) (<- x (r-call + x (r-call as.numeric (r-call ISOdate (r-call r-index z 3) (r-call r-index z 1) (r-call r-index z 2) 0))))) (return (r-call structure x (*named* class (r-call c "POSIXt" "POSIXct"))))) (r-call stop (r-call gettextf "'%s' is not a \"dates\" object" (r-call deparse (substitute x)))))) ()))
- (<- as.POSIXct.POSIXlt (function ((*named* x *r-missing*) (*named* tz "")) (r-block (<- tzone (r-call attr x "tzone")) (if (&& (missing tz) (r-call ! (r-call is.null tzone))) (<- tz (r-call r-index tzone 1))) (r-call structure (r-call .Internal (r-call as.POSIXct x tz)) (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone tz))) ()))
- (<- as.POSIXct.default (function ((*named* x *r-missing*) (*named* tz "")) (r-block (if (r-call inherits x "POSIXct") (return x)) (if (\|\| (r-call is.character x) (r-call is.factor x)) (return (r-call as.POSIXct (r-call as.POSIXlt x) tz))) (if (&& (r-call is.logical x) (r-call all (r-call is.na x))) (return (r-call structure (r-call as.numeric x) (*named* class (r-call c "POSIXt" "POSIXct"))))) (r-call stop (r-call gettextf "do not know how to convert '%s' to class \"POSIXlt\"" (r-call deparse (substitute x))))) ()))
- (<- as.numeric.POSIXlt (function ((*named* x *r-missing*)) (r-call as.POSIXct x) ()))
- (<- format.POSIXlt (function ((*named* x *r-missing*) (*named* format "") (*named* usetz *r-false*) (*named* ... *r-missing*)) (r-block (if (r-call ! (r-call inherits x "POSIXlt")) (r-call stop "wrong class")) (if (r-call == format "") (r-block (<- times (r-call unlist (r-call r-index (r-call unclass x) (r-call : 1 3)))) (<- secs ($ x sec)) (<- secs (r-call r-index secs (r-call ! (r-call is.na secs)))) (<- np (r-call getOption "digits.secs")) (if (r-call is.null np) (<- np 0) (<- np (r-call min 6 np))) (if (r-call >= np 1) (r-block (for i (r-call - (r-call : 1 np) 1) (if (r-call all (r-call < (r-call abs (r-call - secs (r-call round secs i))) 1e-06)) (r-block (<- np i) (break)))))) (<- format (if (r-call all (r-call == (r-call r-index times (r-call ! (r-call is.na times))) 0)) "%Y-%m-%d" (if (r-call == np 0) "%Y-%m-%d %H:%M:%S" (r-call paste "%Y-%m-%d %H:%M:%OS" np (*named* sep ""))))))) (r-call .Internal (r-call format.POSIXlt x format usetz))) ()))
- (<- strftime format.POSIXlt)
- (<- strptime (function ((*named* x *r-missing*) (*named* format *r-missing*) (*named* tz "")) (r-call .Internal (r-call strptime (r-call as.character x) format tz)) ()))
- (<- format.POSIXct (function ((*named* x *r-missing*) (*named* format "") (*named* tz "") (*named* usetz *r-false*) (*named* ... *r-missing*)) (r-block (if (r-call ! (r-call inherits x "POSIXct")) (r-call stop "wrong class")) (if (&& (missing tz) (r-call ! (r-call is.null (<- tzone (r-call attr x "tzone"))))) (<- tz tzone)) (r-call structure (r-call format.POSIXlt (r-call as.POSIXlt x tz) format usetz r-dotdotdot) (*named* names (r-call names x)))) ()))
- (<- print.POSIXct (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call print (r-call format x (*named* usetz *r-true*) r-dotdotdot) r-dotdotdot) (r-call invisible x)) ()))
- (<- print.POSIXlt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call print (r-call format x (*named* usetz *r-true*)) r-dotdotdot) (r-call invisible x)) ()))
- (<- summary.POSIXct (function ((*named* object *r-missing*) (*named* digits 15) (*named* ... *r-missing*)) (r-block (<- x (r-call r-index (r-call summary.default (r-call unclass object) (*named* digits digits) r-dotdotdot) (r-call : 1 6))) (<- (r-call class x) (r-call oldClass object)) (<- (r-call attr x "tzone") (r-call attr object "tzone")) x) ()))
- (<- summary.POSIXlt (function ((*named* object *r-missing*) (*named* digits 15) (*named* ... *r-missing*)) (r-call summary (r-call as.POSIXct object) (*named* digits digits) r-dotdotdot) ()))
- (<- "+.POSIXt" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (r-block (switch (r-call attr x "units") (*named* secs x) (*named* mins (r-call * 60 x)) (*named* hours (r-call * (r-call * 60 60) x)) (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) x)))) ())) (if (r-call == (r-call nargs) 1) (return e1)) (if (&& (r-call inherits e1 "POSIXt") (r-call inherits e2 "POSIXt")) (r-call stop "binary + is not defined for \"POSIXt\" objects")) (if (r-call inherits e1 "POSIXlt") (<- e1 (r-call as.POSIXct e1))) (if (r-call inherits e2 "POSIXlt") (<- e2 (r-call as.POSIXct e2))) (if (r-call inherits e1 "difftime") (<- e1 (r-call coerceTimeUnit e1))) (if (r-call inherits e2 "difftime") (<- e2 (r-call coerceTimeUnit e2))) (r-call structure (r-call + (r-call unclass e1) (r-call unclass e2)) (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone (r-call check_tzones e1 e2)))) ()))
- (<- "-.POSIXt" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (r-block (switch (r-call attr x "units") (*named* secs x) (*named* mins (r-call * 60 x)) (*named* hours (r-call * (r-call * 60 60) x)) (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) x)))) ())) (if (r-call ! (r-call inherits e1 "POSIXt")) (r-call stop "Can only subtract from POSIXt objects")) (if (r-call == (r-call nargs) 1) (r-call stop "unary - is not defined for \"POSIXt\" objects")) (if (r-call inherits e2 "POSIXt") (return (r-call difftime e1 e2))) (if (r-call inherits e2 "difftime") (<- e2 (r-call unclass (r-call coerceTimeUnit e2)))) (if (r-call ! (r-call is.null (r-call attr e2 "class"))) (r-call stop "can only subtract numbers from POSIXt objects")) (r-call structure (r-call - (r-call unclass (r-call as.POSIXct e1)) e2) (*named* class (r-call c "POSIXt" "POSIXct")))) ()))
- (<- Ops.POSIXt (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (if (r-call == (r-call nargs) 1) (r-call stop "unary" .Generic " not defined for \"POSIXt\" objects")) (<- boolean (switch .Generic (*named* < *r-missing*) (*named* > *r-missing*) (*named* == *r-missing*) (*named* != *r-missing*) (*named* <= *r-missing*) (*named* >= *r-true*) *r-false*)) (if (r-call ! boolean) (r-call stop .Generic " not defined for \"POSIXt\" objects")) (if (\|\| (r-call inherits e1 "POSIXlt") (r-call is.character e1)) (<- e1 (r-call as.POSIXct e1))) (if (\|\| (r-call inherits e2 "POSIXlt") (r-call is.character e1)) (<- e2 (r-call as.POSIXct e2))) (r-call check_tzones e1 e2) (r-call NextMethod .Generic)) ()))
- (<- Math.POSIXt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call stop .Generic " not defined for POSIXt objects")) ()))
- (<- check_tzones (function ((*named* ... *r-missing*)) (r-block (<- tzs (r-call unique (r-call sapply (r-call list r-dotdotdot) (function ((*named* x *r-missing*)) (r-block (<- y (r-call attr x "tzone")) (if (r-call is.null y) "" y)) ())))) (<- tzs (r-call r-index tzs (r-call != tzs ""))) (if (r-call > (r-call length tzs) 1) (r-call warning "'tzone' attributes are inconsistent")) (if (r-call length tzs) (r-call r-index tzs 1) ())) ()))
- (<- Summary.POSIXct (function ((*named* ... *r-missing*) (*named* na.rm *r-missing*)) (r-block (<- ok (switch .Generic (*named* max *r-missing*) (*named* min *r-missing*) (*named* range *r-true*) *r-false*)) (if (r-call ! ok) (r-call stop .Generic " not defined for \"POSIXct\" objects")) (<- args (r-call list r-dotdotdot)) (<- tz (r-call do.call "check_tzones" args)) (<- val (r-call NextMethod .Generic)) (<- (r-call class val) (r-call oldClass (r-call r-aref args 1))) (<- (r-call attr val "tzone") tz) val) ()))
- (<- Summary.POSIXlt (function ((*named* ... *r-missing*) (*named* na.rm *r-missing*)) (r-block (<- ok (switch .Generic (*named* max *r-missing*) (*named* min *r-missing*) (*named* range *r-true*) *r-false*)) (if (r-call ! ok) (r-call stop .Generic " not defined for \"POSIXlt\" objects")) (<- args (r-call list r-dotdotdot)) (<- tz (r-call do.call "check_tzones" args)) (<- args (r-call lapply args as.POSIXct)) (<- val (r-call do.call .Generic (r-call c args (*named* na.rm na.rm)))) (r-call as.POSIXlt (r-call structure val (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone tz)))) ()))
- (<- "[.POSIXct" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- cl (r-call oldClass x)) (<- (r-call class x) ()) (<- val (r-call NextMethod "[")) (<- (r-call class val) cl) (<- (r-call attr val "tzone") (r-call attr x "tzone")) val) ()))
- (<- "[[.POSIXct" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- cl (r-call oldClass x)) (<- (r-call class x) ()) (<- val (r-call NextMethod "[[")) (<- (r-call class val) cl) (<- (r-call attr val "tzone") (r-call attr x "tzone")) val) ()))
- (<- "[<-.POSIXct" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* value *r-missing*)) (r-block (if (r-call ! (r-call as.logical (r-call length value))) (return x)) (<- value (r-call as.POSIXct value)) (<- cl (r-call oldClass x)) (<- tz (r-call attr x "tzone")) (<- (r-call class x) (<- (r-call class value) ())) (<- x (r-call NextMethod .Generic)) (<- (r-call class x) cl) (<- (r-call attr x "tzone") tz) x) ()))
- (<- as.character.POSIXt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call format x r-dotdotdot) ()))
- (<- as.data.frame.POSIXct as.data.frame.vector)
- (<- is.na.POSIXlt (function ((*named* x *r-missing*)) (r-call is.na (r-call as.POSIXct x)) ()))
- (<- c.POSIXct (function ((*named* ... *r-missing*) (*named* recursive *r-false*)) (r-call structure (r-call c (r-call unlist (r-call lapply (r-call list r-dotdotdot) unclass))) (*named* class (r-call c "POSIXt" "POSIXct"))) ()))
- (<- c.POSIXlt (function ((*named* ... *r-missing*) (*named* recursive *r-false*)) (r-call as.POSIXlt (r-call do.call "c" (r-call lapply (r-call list r-dotdotdot) as.POSIXct))) ()))
- (<- all.equal.POSIXct (function ((*named* target *r-missing*) (*named* current *r-missing*) (*named* ... *r-missing*) (*named* scale 1)) (r-block (r-call check_tzones target current) (r-call NextMethod "all.equal")) ()))
- (<- ISOdatetime (function ((*named* year *r-missing*) (*named* month *r-missing*) (*named* day *r-missing*) (*named* hour *r-missing*) (*named* min *r-missing*) (*named* sec *r-missing*) (*named* tz "")) (r-block (<- x (r-call paste year month day hour min sec (*named* sep "-"))) (r-call as.POSIXct (r-call strptime x "%Y-%m-%d-%H-%M-%OS" (*named* tz tz)) (*named* tz tz))) ()))
- (<- ISOdate (function ((*named* year *r-missing*) (*named* month *r-missing*) (*named* day *r-missing*) (*named* hour 12) (*named* min 0) (*named* sec 0) (*named* tz "GMT")) (r-call ISOdatetime year month day hour min sec tz) ()))
- (<- as.matrix.POSIXlt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call as.matrix (r-call as.data.frame (r-call unclass x)) r-dotdotdot)) ()))
- (<- mean.POSIXct (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call structure (r-call mean (r-call unclass x) r-dotdotdot) (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone (r-call attr x "tzone"))) ()))
- (<- mean.POSIXlt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call as.POSIXlt (r-call mean (r-call as.POSIXct x) r-dotdotdot)) ()))
- (<- difftime (function ((*named* time1 *r-missing*) (*named* time2 *r-missing*) (*named* tz "") (*named* units (r-call c "auto" "secs" "mins" "hours" "days" "weeks"))) (r-block (<- time1 (r-call as.POSIXct time1 (*named* tz tz))) (<- time2 (r-call as.POSIXct time2 (*named* tz tz))) (<- z (r-call - (r-call unclass time1) (r-call unclass time2))) (<- units (r-call match.arg units)) (if (r-call == units "auto") (r-block (if (r-call all (r-call is.na z)) (<- units "secs") (r-block (<- zz (r-call min (r-call abs z) (*named* na.rm *r-true*))) (if (\|\| (r-call is.na zz) (r-call < zz 60)) (<- units "secs") (if (r-call < zz 3600) (<- units "mins") (if (r-call < zz 86400) (<- units "hours") (<- units "days")))))))) (switch units (*named* secs (r-call structure z (*named* units "secs") (*named* class "difftime"))) (*named* mins (r-call structure (r-call / z 60) (*named* units "mins") (*named* class "difftime"))) (*named* hours (r-call structure (r-call / z 3600) (*named* units "hours") (*named* class "difftime"))) (*named* days (r-call structure (r-call / z 86400) (*named* units "days") (*named* class "difftime"))) (*named* weeks (r-call structure (r-call / z (r-call * 7 86400)) (*named* units "weeks") (*named* class "difftime"))))) ()))
- (<- as.difftime (function ((*named* tim *r-missing*) (*named* format "%X") (*named* units "auto")) (r-block (if (r-call inherits tim "difftime") (return tim)) (if (r-call is.character tim) (r-block (r-call difftime (r-call strptime tim (*named* format format)) (r-call strptime "0:0:0" (*named* format "%X")) (*named* units units))) (r-block (if (r-call ! (r-call is.numeric tim)) (r-call stop "'tim' is not character or numeric")) (if (r-call == units "auto") (r-call stop "need explicit units for numeric conversion")) (if (r-call ! (r-call %in% units (r-call c "secs" "mins" "hours" "days" "weeks"))) (r-call stop "invalid units specified")) (r-call structure tim (*named* units units) (*named* class "difftime"))))) ()))
- (<- units (function ((*named* x *r-missing*)) (r-call UseMethod "units") ()))
- (<- "units<-" (function ((*named* x *r-missing*) (*named* value *r-missing*)) (r-call UseMethod "units<-") ()))
- (<- units.difftime (function ((*named* x *r-missing*)) (r-call attr x "units") ()))
- (<- "units<-.difftime" (function ((*named* x *r-missing*) (*named* value *r-missing*)) (r-block (<- from (r-call units x)) (if (r-call == from value) (return x)) (if (r-call ! (r-call %in% value (r-call c "secs" "mins" "hours" "days" "weeks"))) (r-call stop "invalid units specified")) (<- sc (r-call cumprod (r-call c (*named* secs 1) (*named* mins 60) (*named* hours 60) (*named* days 24) (*named* weeks 7)))) (<- newx (r-call / (r-call * (r-call as.vector x) (r-call r-index sc from)) (r-call r-index sc value))) (r-call structure newx (*named* units value) (*named* class "difftime"))) ()))
- (<- as.double.difftime (function ((*named* x *r-missing*) (*named* units "auto") (*named* ... *r-missing*)) (r-block (if (r-call != units "auto") (<- (r-call units x) units)) (r-call as.double (r-call as.vector x))) ()))
- (<- as.data.frame.difftime as.data.frame.vector)
- (<- format.difftime (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call paste (r-call format (r-call unclass x) r-dotdotdot) (r-call units x)) ()))
- (<- print.difftime (function ((*named* x *r-missing*) (*named* digits (r-call getOption "digits")) (*named* ... *r-missing*)) (r-block (if (\|\| (r-call is.array x) (r-call > (r-call length x) 1)) (r-block (r-call cat "Time differences in " (r-call attr x "units") "\n" (*named* sep "")) (<- y (r-call unclass x)) (<- (r-call attr y "units") ()) (r-call print y)) (r-call cat "Time difference of " (r-call format (r-call unclass x) (*named* digits digits)) " " (r-call attr x "units") "\n" (*named* sep ""))) (r-call invisible x)) ()))
- (<- round.difftime (function ((*named* x *r-missing*) (*named* digits 0) (*named* ... *r-missing*)) (r-block (<- units (r-call attr x "units")) (r-call structure (r-call NextMethod) (*named* units units) (*named* class "difftime"))) ()))
- (<- "[.difftime" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- cl (r-call oldClass x)) (<- (r-call class x) ()) (<- val (r-call NextMethod "[")) (<- (r-call class val) cl) (<- (r-call attr val "units") (r-call attr x "units")) val) ()))
- (<- Ops.difftime (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (r-block (switch (r-call attr x "units") (*named* secs x) (*named* mins (r-call * 60 x)) (*named* hours (r-call * (r-call * 60 60) x)) (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) x)))) ())) (if (r-call == (r-call nargs) 1) (r-block (switch .Generic (*named* + (r-block)) (*named* - (r-block (<- (r-call r-index e1 *r-missing*) (r-call - (r-call unclass e1))))) (r-call stop "unary" .Generic " not defined for \"difftime\" objects")) (return e1))) (<- boolean (switch .Generic (*named* < *r-missing*) (*named* > *r-missing*) (*named* == *r-missing*) (*named* != *r-missing*) (*named* <= *r-missing*) (*named* >= *r-true*) *r-false*)) (if boolean (r-block (if (&& (r-call inherits e1 "difftime") (r-call inherits e2 "difftime")) (r-block (<- e1 (r-call coerceTimeUnit e1)) (<- e2 (r-call coerceTimeUnit e2)))) (r-call NextMethod .Generic)) (if (\|\| (r-call == .Generic "+") (r-call == .Generic "-")) (r-block (if (&& (r-call inherits e1 "difftime") (r-call ! (r-call inherits e2 "difftime"))) (return (r-call structure (r-call NextMethod .Generic) (*named* units (r-call attr e1 "units")) (*named* class "difftime")))) (if (&& (r-call ! (r-call inherits e1 "difftime")) (r-call inherits e2 "difftime")) (return (r-call structure (r-call NextMethod .Generic) (*named* units (r-call attr e2 "units")) (*named* class "difftime")))) (<- u1 (r-call attr e1 "units")) (if (r-call == (r-call attr e2 "units") u1) (r-block (r-call structure (r-call NextMethod .Generic) (*named* units u1) (*named* class "difftime"))) (r-block (<- e1 (r-call coerceTimeUnit e1)) (<- e2 (r-call coerceTimeUnit e2)) (r-call structure (r-call NextMethod .Generic) (*named* units "secs") (*named* class "difftime"))))) (r-block (r-call stop .Generic "not defined for \"difftime\" objects"))))) ()))
- (<- "*.difftime" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (if (&& (r-call inherits e1 "difftime") (r-call inherits e2 "difftime")) (r-call stop "both arguments of * cannot be \"difftime\" objects")) (if (r-call inherits e2 "difftime") (r-block (<- tmp e1) (<- e1 e2) (<- e2 tmp))) (r-call structure (r-call * e2 (r-call unclass e1)) (*named* units (r-call attr e1 "units")) (*named* class "difftime"))) ()))
- (<- "/.difftime" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (if (r-call inherits e2 "difftime") (r-call stop "second argument of / cannot be a \"difftime\" object")) (r-call structure (r-call / (r-call unclass e1) e2) (*named* units (r-call attr e1 "units")) (*named* class "difftime"))) ()))
- (<- Math.difftime (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call stop .Generic "not defined for \"difftime\" objects")) ()))
- (<- mean.difftime (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* na.rm *r-false*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (r-block (r-call as.vector (switch (r-call attr x "units") (*named* secs x) (*named* mins (r-call * 60 x)) (*named* hours (r-call * (r-call * 60 60) x)) (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) x))))) ())) (if (r-call length (r-call list r-dotdotdot)) (r-block (<- args (r-call c (r-call lapply (r-call list x r-dotdotdot) coerceTimeUnit) (*named* na.rm na.rm))) (r-call structure (r-call do.call "mean" args) (*named* units "secs") (*named* class "difftime"))) (r-block (r-call structure (r-call mean (r-call as.vector x) (*named* na.rm na.rm)) (*named* units (r-call attr x "units")) (*named* class "difftime"))))) ()))
- (<- Summary.difftime (function ((*named* ... *r-missing*) (*named* na.rm *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (r-block (r-call as.vector (switch (r-call attr x "units") (*named* secs x) (*named* mins (r-call * 60 x)) (*named* hours (r-call * (r-call * 60 60) x)) (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) x))))) ())) (<- ok (switch .Generic (*named* max *r-missing*) (*named* min *r-missing*) (*named* range *r-true*) *r-false*)) (if (r-call ! ok) (r-call stop .Generic " not defined for \"difftime\" objects")) (<- args (r-call c (r-call lapply (r-call list r-dotdotdot) coerceTimeUnit) (*named* na.rm na.rm))) (r-call structure (r-call do.call .Generic args) (*named* units "secs") (*named* class "difftime"))) ()))
- (<- seq.POSIXt (function ((*named* from *r-missing*) (*named* to *r-missing*) (*named* by *r-missing*) (*named* length.out ()) (*named* along.with ()) (*named* ... *r-missing*)) (r-block (if (missing from) (r-call stop "'from' must be specified")) (if (r-call ! (r-call inherits from "POSIXt")) (r-call stop "'from' must be a POSIXt object")) (<- cfrom (r-call as.POSIXct from)) (if (r-call != (r-call length cfrom) 1) (r-call stop "'from' must be of length 1")) (<- tz (r-call attr cfrom "tzone")) (if (r-call ! (missing to)) (r-block (if (r-call ! (r-call inherits to "POSIXt")) (r-call stop "'to' must be a POSIXt object")) (if (r-call != (r-call length (r-call as.POSIXct to)) 1) (r-call stop "'to' must be of length 1")))) (if (r-call ! (missing along.with)) (r-block (<- length.out (r-call length along.with))) (if (r-call ! (r-call is.null length.out)) (r-block (if (r-call != (r-call length length.out) 1) (r-call stop "'length.out' must be of length 1")) (<- length.out (r-call ceiling length.out))))) (<- status (r-call c (r-call ! (missing to)) (r-call ! (missing by)) (r-call ! (r-call is.null length.out)))) (if (r-call != (r-call sum status) 2) (r-call stop "exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")) (if (missing by) (r-block (<- from (r-call unclass cfrom)) (<- to (r-call unclass (r-call as.POSIXct to))) (<- res (r-call seq.int from to (*named* length.out length.out))) (return (r-call structure res (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone tz))))) (if (r-call != (r-call length by) 1) (r-call stop "'by' must be of length 1")) (<- valid 0) (if (r-call inherits by "difftime") (r-block (<- by (r-call * (switch (r-call attr by "units") (*named* secs 1) (*named* mins 60) (*named* hours 3600) (*named* days 86400) (*named* weeks (r-call * 7 86400))) (r-call unclass by)))) (if (r-call is.character by) (r-block (<- by2 (r-call r-aref (r-call strsplit by " " (*named* fixed *r-true*)) 1)) (if (\|\| (r-call > (r-call length by2) 2) (r-call < (r-call length by2) 1)) (r-call stop "invalid 'by' string")) (<- valid (r-call pmatch (r-call r-index by2 (r-call length by2)) (r-call c "secs" "mins" "hours" "days" "weeks" "months" "years" "DSTdays"))) (if (r-call is.na valid) (r-call stop "invalid string for 'by'")) (if (r-call <= valid 5) (r-block (<- by (r-call r-index (r-call c 1 60 3600 86400 (r-call * 7 86400)) valid)) (if (r-call == (r-call length by2) 2) (<- by (r-call * by (r-call as.integer (r-call r-index by2 1)))))) (<- by (if (r-call == (r-call length by2) 2) (r-call as.integer (r-call r-index by2 1)) 1)))) (if (r-call ! (r-call is.numeric by)) (r-call stop "invalid mode for 'by'")))) (if (r-call is.na by) (r-call stop "'by' is NA")) (if (r-call <= valid 5) (r-block (<- from (r-call unclass (r-call as.POSIXct from))) (if (r-call ! (r-call is.null length.out)) (<- res (r-call seq.int from (*named* by by) (*named* length.out length.out))) (r-block (<- to (r-call unclass (r-call as.POSIXct to))) (<- res (r-call + (r-call seq.int 0 (r-call - to from) by) from)))) (return (r-call structure res (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone tz)))) (r-block (<- r1 (r-call as.POSIXlt from)) (if (r-call == valid 7) (r-block (if (missing to) (r-block (<- yr (r-call seq.int ($ r1 year) (*named* by by) (*named* length length.out)))) (r-block (<- to (r-call as.POSIXlt to)) (<- yr (r-call seq.int ($ r1 year) ($ to year) by)))) (<- ($ r1 year) yr) (<- ($ r1 isdst) (r-call - 1)) (<- res (r-call as.POSIXct r1))) (if (r-call == valid 6) (r-block (if (missing to) (r-block (<- mon (r-call seq.int ($ r1 mon) (*named* by by) (*named* length length.out)))) (r-block (<- to (r-call as.POSIXlt to)) (<- mon (r-call seq.int ($ r1 mon) (r-call + (r-call * 12 (r-call - ($ to year) ($ r1 year))) ($ to mon)) by)))) (<- ($ r1 mon) mon) (<- ($ r1 isdst) (r-call - 1)) (<- res (r-call as.POSIXct r1))) (if (r-call == valid 8) (r-block (if (r-call ! (missing to)) (r-block (<- length.out (r-call + 2 (r-call floor (r-call / (r-call - (r-call unclass (r-call as.POSIXct to)) (r-call unclass (r-call as.POSI
\ No newline at end of file
- (<- cut.POSIXt (function ((*named* x *r-missing*) (*named* breaks *r-missing*) (*named* labels ()) (*named* start.on.monday *r-true*) (*named* right *r-false*) (*named* ... *r-missing*)) (r-block (if (r-call ! (r-call inherits x "POSIXt")) (r-call stop "'x' must be a date-time object")) (<- x (r-call as.POSIXct x)) (if (r-call inherits breaks "POSIXt") (r-block (<- breaks (r-call as.POSIXct breaks))) (if (&& (r-call is.numeric breaks) (r-call == (r-call length breaks) 1)) (r-block) (if (&& (r-call is.character breaks) (r-call == (r-call length breaks) 1)) (r-block (<- by2 (r-call r-aref (r-call strsplit breaks " " (*named* fixed *r-true*)) 1)) (if (\|\| (r-call > (r-call length by2) 2) (r-call < (r-call length by2) 1)) (r-call stop "invalid specification of 'breaks'")) (<- valid (r-call pmatch (r-call r-index by2 (r-call length by2)) (r-call c "secs" "mins" "hours" "days" "weeks" "months" "years" "DSTdays"))) (if (r-call is.na valid) (r-call stop "invalid specification of 'breaks'")) (<- start (r-call as.POSIXlt (r-call min x (*named* na.rm *r-true*)))) (<- incr 1) (if (r-call > valid 1) (r-block (<- ($ start sec) 0) (<- incr 59.99))) (if (r-call > valid 2) (r-block (<- ($ start min) 0) (<- incr (r-call - 3600 1)))) (if (r-call > valid 3) (r-block (<- ($ start hour) 0) (<- incr (r-call - 86400 1)))) (if (r-call == valid 5) (r-block (<- ($ start mday) (r-call - ($ start mday) ($ start wday))) (if start.on.monday (<- ($ start mday) (r-call + ($ start mday) (r-call ifelse (r-call > ($ start wday) 0) 1 (r-call - 6))))) (<- incr (r-call * 7 86400)))) (if (r-call == valid 6) (r-block (<- ($ start mday) 1) (<- incr (r-call * 31 86400)))) (if (r-call == valid 7) (r-block (<- ($ start mon) 0) (<- ($ start mday) 1) (<- incr (r-call * 366 86400)))) (if (r-call == valid 8) (<- incr (r-call * 25 3600))) (if (r-call == (r-call length by2) 2) (<- incr (r-call * incr (r-call as.integer (r-call r-index by2 1))))) (<- maxx (r-call max x (*named* na.rm *r-true*))) (<- breaks (r-call seq.int start (r-call + maxx incr) breaks)) (<- breaks (r-call r-index breaks (r-call : 1 (r-call + 1 (r-call max (r-call which (r-call < breaks maxx)))))))) (r-call stop "invalid specification of 'breaks'")))) (<- res (r-call cut (r-call unclass x) (r-call unclass breaks) (*named* labels labels) (*named* right right) r-dotdotdot)) (if (r-call is.null labels) (<- (r-call levels res) (r-call as.character (r-call r-index breaks (r-call - (r-call length breaks)))))) res) ()))
- (<- julian (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call UseMethod "julian") ()))
- (<- julian.POSIXt (function ((*named* x *r-missing*) (*named* origin (r-call as.POSIXct "1970-01-01" (*named* tz "GMT"))) (*named* ... *r-missing*)) (r-block (if (r-call != (r-call length origin) 1) (r-call stop "'origin' must be of length one")) (<- res (r-call difftime (r-call as.POSIXct x) origin (*named* units "days"))) (r-call structure res (*named* origin origin))) ()))
- (<- weekdays (function ((*named* x *r-missing*) (*named* abbreviate *r-missing*)) (r-call UseMethod "weekdays") ()))
- (<- weekdays.POSIXt (function ((*named* x *r-missing*) (*named* abbreviate *r-false*)) (r-block (r-call format x (r-call ifelse abbreviate "%a" "%A"))) ()))
- (<- months (function ((*named* x *r-missing*) (*named* abbreviate *r-missing*)) (r-call UseMethod "months") ()))
- (<- months.POSIXt (function ((*named* x *r-missing*) (*named* abbreviate *r-false*)) (r-block (r-call format x (r-call ifelse abbreviate "%b" "%B"))) ()))
- (<- quarters (function ((*named* x *r-missing*) (*named* abbreviate *r-missing*)) (r-call UseMethod "quarters") ()))
- (<- quarters.POSIXt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (<- x (r-call %/% ($ (r-call as.POSIXlt x) mon) 3)) (r-call paste "Q" (r-call + x 1) (*named* sep ""))) ()))
- (<- trunc.POSIXt (function ((*named* x *r-missing*) (*named* units (r-call c "secs" "mins" "hours" "days"))) (r-block (<- units (r-call match.arg units)) (<- x (r-call as.POSIXlt x)) (if (r-call > (r-call length ($ x sec)) 0) (switch units (*named* secs (r-block (<- ($ x sec) (r-call trunc ($ x sec))))) (*named* mins (r-block (<- ($ x sec) 0))) (*named* hours (r-block (<- ($ x sec) 0) (<- ($ x min) 0))) (*named* days (r-block (<- ($ x sec) 0) (<- ($ x min) 0) (<- ($ x hour) 0) (<- ($ x isdst) (r-call - 1)))))) x) ()))
- (<- round.POSIXt (function ((*named* x *r-missing*) (*named* units (r-call c "secs" "mins" "hours" "days"))) (r-block (if (&& (r-call is.numeric units) (r-call == units 0)) (<- units "secs")) (<- units (r-call match.arg units)) (<- x (r-call as.POSIXct x)) (<- x (r-call + x (switch units (*named* secs 0.5) (*named* mins 30) (*named* hours 1800) (*named* days 43200)))) (r-call trunc.POSIXt x (*named* units units))) ()))
- (<- "[.POSIXlt" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- val (r-call lapply x "[" r-dotdotdot (*named* drop drop))) (<- (r-call attributes val) (r-call attributes x)) val) ()))
- (<- "[<-.POSIXlt" (function ((*named* x *r-missing*) (*named* i *r-missing*) (*named* value *r-missing*)) (r-block (if (r-call ! (r-call as.logical (r-call length value))) (return x)) (<- value (r-call as.POSIXlt value)) (<- cl (r-call oldClass x)) (<- (r-call class x) (<- (r-call class value) ())) (for n (r-call names x) (<- (r-call r-index (r-call r-aref x n) i) (r-call r-aref value n))) (<- (r-call class x) cl) x) ()))
- (<- as.data.frame.POSIXlt (function ((*named* x *r-missing*) (*named* row.names ()) (*named* optional *r-false*) (*named* ... *r-missing*)) (r-block (<- value (r-call as.data.frame.POSIXct (r-call as.POSIXct x) row.names optional r-dotdotdot)) (if (r-call ! optional) (<- (r-call names value) (r-call r-aref (r-call deparse (substitute x)) 1))) value) ()))
- (<- rep.POSIXct (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (<- y (r-call NextMethod)) (r-call structure y (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone (r-call attr x "tzone")))) ()))
- (<- rep.POSIXlt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (<- y (r-call lapply x rep r-dotdotdot)) (<- (r-call attributes y) (r-call attributes x)) y) ()))
- (<- diff.POSIXt (function ((*named* x *r-missing*) (*named* lag 1) (*named* differences 1) (*named* ... *r-missing*)) (r-block (<- ismat (r-call is.matrix x)) (<- r (if (r-call inherits x "POSIXlt") (r-call as.POSIXct x) x)) (<- xlen (if ismat (r-call r-index (r-call dim x) 1) (r-call length r))) (if (\|\| (\|\| (\|\| (r-call > (r-call length lag) 1) (r-call > (r-call length differences) 1)) (r-call < lag 1)) (r-call < differences 1)) (r-call stop "'lag' and 'differences' must be integers >= 1")) (if (r-call >= (r-call * lag differences) xlen) (return (r-call structure (r-call numeric 0) (*named* class "difftime") (*named* units "secs")))) (<- i1 (r-call : (r-call - 1) (r-call - lag))) (if ismat (for i (r-call : 1 differences) (<- r (r-call - (r-call r-index r i1 *r-missing* (*named* drop *r-false*)) (r-call r-index r (r-call : (r-call - (r-call nrow r)) (r-call - (r-call + (r-call - (r-call nrow r) lag) 1))) *r-missing* (*named* drop *r-false*))))) (for i (r-call : 1 differences) (<- r (r-call - (r-call r-index r i1) (r-call r-index r (r-call : (r-call - (r-call length r)) (r-call - (r-call + (r-call - (r-call length r) lag) 1)))))))) r) ()))
- (<- duplicated.POSIXlt (function ((*named* x *r-missing*) (*named* incomparables *r-false*) (*named* ... *r-missing*)) (r-block (<- x (r-call as.POSIXct x)) (r-call NextMethod "duplicated" x)) ()))
- (<- unique.POSIXlt (function ((*named* x *r-missing*) (*named* incomparables *r-false*) (*named* ... *r-missing*)) (r-call r-index x (r-call ! (r-call duplicated x incomparables r-dotdotdot))) ()))
- (<- sort.POSIXlt (function ((*named* x *r-missing*) (*named* decreasing *r-false*) (*named* na.last NA) (*named* ... *r-missing*)) (r-call r-index x (r-call order (r-call as.POSIXct x) (*named* na.last na.last) (*named* decreasing decreasing))) ())))
--- a/femtolisp/tests/ast/match.lsp
+++ /dev/null
@@ -1,181 +1,0 @@
-; -*- scheme -*-
-; tree regular expression pattern matching
-; by Jeff Bezanson
-
-(define (unique lst)
- (if (null? lst)
- ()
- (cons (car lst)
- (filter (lambda (x) (not (eq x (car lst))))
- (unique (cdr lst))))))
-
-; list of special pattern symbols that cannot be variable names
-(define metasymbols '(_ ...))
-
-; expression tree pattern matching
-; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
-; mapping variables to captured subexpressions, or #f if no match.
-; when a match succeeds, __ is always bound to the whole matched expression.
-;
-; p is an expression in the following pattern language:
-;
-; _ match anything, not captured
-; <func> any scheme function; matches if (func expr) returns #t
-; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
-; must match the same thing.
-; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
-; subpatterns matched recursively.
-; (-/ <ex>) match <ex> literally
-; (-^ <p>) complement of pattern <p>
-; (-- <var> <p>) match <p> and capture as <var> if match succeeds
-;
-; regular match constructs:
-; ... match any number of anything
-; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
-; (-* <p>) match any number of <p>
-; (-? <p>) match 0 or 1 of <p>
-; (-+ <p>) match at least 1 of <p>
-; all of these can be wrapped in (-- var ) for capturing purposes
-; This is NP-complete. Be careful.
-;
-(define (match- p expr state)
- (cond ((symbol? p)
- (cond ((eq p '_) state)
- (#t
- (let ((capt (assq p state)))
- (if capt
- (and (equal? expr (cdr capt)) state)
- (cons (cons p expr) state))))))
-
- ((procedure? p)
- (and (p expr) state))
-
- ((pair? p)
- (cond ((eq (car p) '-/) (and (equal? (cadr p) expr) state))
- ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
- ((eq (car p) '--)
- (and (match- (caddr p) expr state)
- (cons (cons (cadr p) expr) state)))
- ((eq (car p) '-$) ; greedy alternation for toplevel pattern
- (match-alt (cdr p) () (list expr) state #f 1))
- (#t
- (and (pair? expr)
- (equal? (car p) (car expr))
- (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
-
- (#t
- (and (equal? p expr) state))))
-
-; match an alternation
-(define (match-alt alt prest expr state var L)
- (if (null? alt) #f ; no alternatives left
- (let ((subma (match- (car alt) (car expr) state)))
- (or (and subma
- (match-seq prest (cdr expr)
- (if var
- (cons (cons var (car expr))
- subma)
- subma)
- (- L 1)))
- (match-alt (cdr alt) prest expr state var L)))))
-
-; match generalized kleene star (try consuming min to max)
-(define (match-star- p prest expr state var min max L sofar)
- (cond ; case 0: impossible to match
- ((> min max) #f)
- ; case 1: only allowed to match 0 subexpressions
- ((= max 0) (match-seq prest expr
- (if var (cons (cons var (reverse sofar)) state)
- state)
- L))
- ; case 2: must match at least 1
- ((> min 0)
- (and (match- p (car expr) state)
- (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
- (cons (car expr) sofar))))
- ; otherwise, must match either 0 or between 1 and max subexpressions
- (#t
- (or (match-star- p prest expr state var 0 0 L sofar)
- (match-star- p prest expr state var 1 max L sofar)))))
-(define (match-star p prest expr state var min max L)
- (match-star- p prest expr state var min max L ()))
-
-; match sequences of expressions
-(define (match-seq p expr state L)
- (cond ((not state) #f)
- ((null? p) (if (null? expr) state #f))
- (#t
- (let ((subp (car p))
- (var #f))
- (if (and (pair? subp)
- (eq (car subp) '--))
- (begin (set! var (cadr subp))
- (set! subp (caddr subp)))
- #f)
- (let ((head (if (pair? subp) (car subp) ())))
- (cond ((eq subp '...)
- (match-star '_ (cdr p) expr state var 0 L L))
- ((eq head '-*)
- (match-star (cadr subp) (cdr p) expr state var 0 L L))
- ((eq head '-+)
- (match-star (cadr subp) (cdr p) expr state var 1 L L))
- ((eq head '-?)
- (match-star (cadr subp) (cdr p) expr state var 0 1 L))
- ((eq head '-$)
- (match-alt (cdr subp) (cdr p) expr state var L))
- (#t
- (and (pair? expr)
- (match-seq (cdr p) (cdr expr)
- (match- (car p) (car expr) state)
- (- L 1))))))))))
-
-(define (match p expr) (match- p expr (list (cons '__ expr))))
-
-; given a pattern p, return the list of capturing variables it uses
-(define (patargs- p)
- (cond ((and (symbol? p)
- (not (member p metasymbols)))
- (list p))
-
- ((pair? p)
- (if (eq (car p) '-/)
- ()
- (unique (apply append (map patargs- (cdr p))))))
-
- (#t ())))
-(define (patargs p)
- (cons '__ (patargs- p)))
-
-; try to transform expr using a pattern-lambda from plist
-; returns the new expression, or expr if no matches
-(define (apply-patterns plist expr)
- (if (null? plist) expr
- (if (procedure? plist)
- (let ((enew (plist expr)))
- (if (not enew)
- expr
- enew))
- (let ((enew ((car plist) expr)))
- (if (not enew)
- (apply-patterns (cdr plist) expr)
- enew)))))
-
-; top-down fixed-point macroexpansion. this is a typical algorithm,
-; but it may leave some structure that matches a pattern unexpanded.
-; the advantage is that non-terminating cases cannot arise as a result
-; of expression composition. in other words, if the outer loop terminates
-; on all inputs for a given set of patterns, then the whole algorithm
-; terminates. pattern sets that violate this should be easier to detect,
-; for example
-; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
-; TODO: ignore quoted expressions
-(define (pattern-expand plist expr)
- (if (not (pair? expr))
- expr
- (let ((enew (apply-patterns plist expr)))
- (if (eq enew expr)
- ; expr didn't change; move to subexpressions
- (cons (car expr)
- (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
- ; expr changed; iterate
- (pattern-expand plist enew)))))
--- a/femtolisp/tests/ast/match.scm
+++ /dev/null
@@ -1,174 +1,0 @@
-; tree regular expression pattern matching
-; by Jeff Bezanson
-
-; list of special pattern symbols that cannot be variable names
-(define metasymbols '(_ ...))
-
-; expression tree pattern matching
-; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
-; mapping variables to captured subexpressions, or #f if no match.
-; when a match succeeds, __ is always bound to the whole matched expression.
-;
-; p is an expression in the following pattern language:
-;
-; _ match anything, not captured
-; <func> any scheme function; matches if (func expr) returns #t
-; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
-; must match the same thing.
-; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
-; subpatterns matched recursively.
-; (-/ <ex>) match <ex> literally
-; (-^ <p>) complement of pattern <p>
-; (-- <var> <p>) match <p> and capture as <var> if match succeeds
-;
-; regular match constructs:
-; ... match any number of anything
-; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
-; (-* <p>) match any number of <p>
-; (-? <p>) match 0 or 1 of <p>
-; (-+ <p>) match at least 1 of <p>
-; all of these can be wrapped in (-- var ) for capturing purposes
-; This is NP-complete. Be careful.
-;
-(define (match- p expr state)
- (cond ((symbol? p)
- (cond ((eq? p '_) state)
- (else
- (let ((capt (assq p state)))
- (if capt
- (and (equal? expr (cdr capt)) state)
- (cons (cons p expr) state))))))
-
- ((procedure? p)
- (and (p expr) state))
-
- ((pair? p)
- (cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state))
- ((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state))
- ((eq? (car p) '--)
- (and (match- (caddr p) expr state)
- (cons (cons (cadr p) expr) state)))
- ((eq? (car p) '-$) ; greedy alternation for toplevel pattern
- (match-alt (cdr p) () (list expr) state #f 1))
- (else
- (and (pair? expr)
- (equal? (car p) (car expr))
- (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
-
- (else
- (and (equal? p expr) state))))
-
-; match an alternation
-(define (match-alt alt prest expr state var L)
- (if (null? alt) #f ; no alternatives left
- (let ((subma (match- (car alt) (car expr) state)))
- (or (and subma
- (match-seq prest (cdr expr)
- (if var
- (cons (cons var (car expr))
- subma)
- subma)
- (- L 1)))
- (match-alt (cdr alt) prest expr state var L)))))
-
-; match generalized kleene star (try consuming min to max)
-(define (match-star p prest expr state var min max L)
- (define (match-star- p prest expr state var min max L sofar)
- (cond ; case 0: impossible to match
- ((> min max) #f)
- ; case 1: only allowed to match 0 subexpressions
- ((= max 0) (match-seq prest expr
- (if var (cons (cons var (reverse sofar)) state)
- state)
- L))
- ; case 2: must match at least 1
- ((> min 0)
- (and (match- p (car expr) state)
- (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
- (cons (car expr) sofar))))
- ; otherwise, must match either 0 or between 1 and max subexpressions
- (else
- (or (match-star- p prest expr state var 0 0 L sofar)
- (match-star- p prest expr state var 1 max L sofar)))))
-
- (match-star- p prest expr state var min max L ()))
-
-; match sequences of expressions
-(define (match-seq p expr state L)
- (cond ((not state) #f)
- ((null? p) (if (null? expr) state #f))
- (else
- (let ((subp (car p))
- (var #f))
- (if (and (pair? subp)
- (eq? (car subp) '--))
- (begin (set! var (cadr subp))
- (set! subp (caddr subp)))
- #f)
- (let ((head (if (pair? subp) (car subp) ())))
- (cond ((eq? subp '...)
- (match-star '_ (cdr p) expr state var 0 L L))
- ((eq? head '-*)
- (match-star (cadr subp) (cdr p) expr state var 0 L L))
- ((eq? head '-+)
- (match-star (cadr subp) (cdr p) expr state var 1 L L))
- ((eq? head '-?)
- (match-star (cadr subp) (cdr p) expr state var 0 1 L))
- ((eq? head '-$)
- (match-alt (cdr subp) (cdr p) expr state var L))
- (else
- (and (pair? expr)
- (match-seq (cdr p) (cdr expr)
- (match- (car p) (car expr) state)
- (- L 1))))))))))
-
-(define (match p expr) (match- p expr (list (cons '__ expr))))
-
-; given a pattern p, return the list of capturing variables it uses
-(define (patargs p)
- (define (patargs- p)
- (cond ((and (symbol? p)
- (not (member p metasymbols)))
- (list p))
-
- ((pair? p)
- (if (eq? (car p) '-/)
- ()
- (delete-duplicates (apply append (map patargs- (cdr p))))))
-
- (else ())))
- (cons '__ (patargs- p)))
-
-; try to transform expr using a pattern-lambda from plist
-; returns the new expression, or expr if no matches
-(define (apply-patterns plist expr)
- (if (null? plist) expr
- (if (procedure? plist)
- (let ((enew (plist expr)))
- (if (not enew)
- expr
- enew))
- (let ((enew ((car plist) expr)))
- (if (not enew)
- (apply-patterns (cdr plist) expr)
- enew)))))
-
-; top-down fixed-point macroexpansion. this is a typical algorithm,
-; but it may leave some structure that matches a pattern unexpanded.
-; the advantage is that non-terminating cases cannot arise as a result
-; of expression composition. in other words, if the outer loop terminates
-; on all inputs for a given set of patterns, then the whole algorithm
-; terminates. pattern sets that violate this should be easier to detect,
-; for example
-; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
-; TODO: ignore quoted expressions
-(define (pattern-expand plist expr)
- (if (not (pair? expr))
- expr
- (let ((enew (apply-patterns plist expr)))
- (if (eq? enew expr)
- ; expr didn't change; move to subexpressions
- (cons (car expr)
- (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
- ; expr changed; iterate
- (pattern-expand plist enew)))))
--- a/femtolisp/tests/ast/rpasses-out.lsp
+++ /dev/null
@@ -1,1701 +1,0 @@
-'(r-expressions (<- Sys.time (lambda ()
- (let () (r-block (r-call structure (r-call
- .Internal (r-call
- Sys.time))
- (*named* class (r-call
- c "POSIXt" "POSIXct")))))))
- (<- Sys.timezone (lambda ()
- (let ()
- (r-block (r-call as.vector (r-call
- Sys.getenv
- "TZ"))))))
- (<- as.POSIXlt (lambda (x tz)
- (let ((x ())
- (tzone ())
- (fromchar ())
- (tz ()))
- (r-block (when (missing tz)
- (<- tz ""))
- (<- fromchar (lambda (x)
- (let ((res ())
- (f ())
- (j ())
- (xx ()))
- (r-block (<-
- xx (r-call r-index x 1))
- (if (r-call is.na xx) (r-block (<- j 1)
- (while (&& (r-call is.na xx)
- (r-call <= (<- j (r-call + j 1))
- (r-call length x)))
- (<- xx (r-call r-index x j)))
- (if (r-call is.na xx)
- (<- f "%Y-%m-%d"))))
- (if (|\|\|| (r-call is.na xx) (r-call ! (r-call is.na (r-call strptime xx
- (<- f "%Y-%m-%d %H:%M:%OS"))))
- (r-call ! (r-call is.na (r-call strptime xx
- (<- f "%Y/%m/%d %H:%M:%OS"))))
- (r-call ! (r-call is.na (r-call strptime xx
- (<- f "%Y-%m-%d %H:%M"))))
- (r-call ! (r-call is.na (r-call strptime xx
- (<- f "%Y/%m/%d %H:%M"))))
- (r-call ! (r-call is.na (r-call strptime xx
- (<- f "%Y-%m-%d"))))
- (r-call ! (r-call is.na (r-call strptime xx
- (<- f "%Y/%m/%d")))))
- (r-block (<- res (r-call strptime x f))
- (if (r-call nchar tz) (r-block (<- res (r-call attr<- res "tzone"
- tz))
- tz))
- (return res)))
- (r-call stop "character string is not in a standard unambiguous format")))))
- (if (r-call inherits x "POSIXlt")
- (return x))
- (if (r-call inherits x "Date")
- (return (r-call .Internal (r-call
- Date2POSIXlt x))))
- (<- tzone (r-call attr x "tzone"))
- (if (|\|\|| (r-call inherits x "date")
- (r-call inherits x "dates"))
- (<- x (r-call as.POSIXct x)))
- (if (r-call is.character x)
- (return (r-call fromchar (r-call
- unclass x))))
- (if (r-call is.factor x)
- (return (r-call fromchar (r-call
- as.character x))))
- (if (&& (r-call is.logical x)
- (r-call all (r-call is.na
- x)))
- (<- x (r-call
- as.POSIXct.default x)))
- (if (r-call ! (r-call inherits x
- "POSIXct"))
- (r-call stop (r-call gettextf
- "do not know how to convert '%s' to class \"POSIXlt\""
- (r-call deparse (substitute x)))))
- (if (&& (missing tz)
- (r-call ! (r-call is.null
- tzone)))
- (<- tz (r-call r-index tzone
- 1)))
- (r-call .Internal (r-call
- as.POSIXlt x
- tz))))))
- (<- as.POSIXct (lambda (x tz)
- (let ((tz ()))
- (r-block (when (missing tz)
- (<- tz ""))
- (r-call UseMethod "as.POSIXct")))))
- (<- as.POSIXct.Date (lambda (x ...)
- (let ()
- (r-block (r-call structure (r-call *
- (r-call unclass x) 86400)
- (*named* class (r-call
- c "POSIXt" "POSIXct")))))))
- (<- as.POSIXct.date (lambda (x ...)
- (let ((x ()))
- (r-block (if (r-call inherits x "date")
- (r-block (<- x (r-call
- * (r-call - x 3653) 86400))
- (return (r-call
- structure x (*named* class (r-call c "POSIXt" "POSIXct")))))
- (r-call stop (r-call
- gettextf "'%s' is not a \"date\" object"
- (r-call deparse (substitute x)))))))))
- (<- as.POSIXct.dates (lambda (x ...)
- (let ((x ())
- (z ()))
- (r-block (if (r-call inherits x "dates")
- (r-block (<- z (r-call
- attr x "origin"))
- (<- x (r-call
- * (r-call as.numeric x) 86400))
- (if (&& (r-call
- == (r-call length z) 3)
- (r-call is.numeric z))
- (<- x (r-call + x
- (r-call as.numeric (r-call ISOdate (r-call r-index z 3)
- (r-call r-index z 1)
- (r-call r-index z 2) 0)))))
- (return (r-call
- structure x (*named* class (r-call c "POSIXt" "POSIXct")))))
- (r-call stop (r-call
- gettextf "'%s' is not a \"dates\" object"
- (r-call deparse (substitute x)))))))))
- (<- as.POSIXct.POSIXlt (lambda (x tz)
- (let ((tzone ())
- (tz ()))
- (r-block (when (missing tz)
- (<- tz ""))
- (<- tzone (r-call attr x
- "tzone"))
- (if (&& (missing tz)
- (r-call ! (r-call
- is.null tzone)))
- (<- tz (r-call
- r-index tzone
- 1)))
- (r-call structure (r-call
- .Internal (r-call as.POSIXct x tz))
- (*named* class (r-call
- c "POSIXt" "POSIXct"))
- (*named* tzone tz))))))
- (<- as.POSIXct.default (lambda (x tz)
- (let ((tz ()))
- (r-block (when (missing tz)
- (<- tz ""))
- (if (r-call inherits x "POSIXct")
- (return x))
- (if (|\|\|| (r-call
- is.character
- x)
- (r-call
- is.factor x))
- (return (r-call
- as.POSIXct
- (r-call
- as.POSIXlt
- x)
- tz)))
- (if (&& (r-call
- is.logical x)
- (r-call all (r-call
- is.na x)))
- (return (r-call
- structure (r-call
- as.numeric x)
- (*named*
- class (r-call
- c "POSIXt" "POSIXct")))))
- (r-call stop (r-call
- gettextf "do not know how to convert '%s' to class \"POSIXlt\""
- (r-call
- deparse (substitute x))))))))
- (<- as.numeric.POSIXlt (lambda (x)
- (let ()
- (r-block (r-call as.POSIXct x)))))
- (<- format.POSIXlt (lambda (x format usetz ...)
- (let ((np ())
- (secs ())
- (times ())
- (usetz ())
- (format ()))
- (r-block (when (missing format)
- (<- format ""))
- (when (missing usetz)
- (<- usetz *r-false*))
- (if (r-call ! (r-call
- inherits x "POSIXlt"))
- (r-call stop "wrong class"))
- (if (r-call == format "")
- (r-block (<- times (r-call
- unlist (r-call r-index (r-call unclass x)
- (r-call : 1 3))))
- (<- secs (r-call
- r-aref x (index-in-strlist sec (r-call attr x #0="names"))))
- (<- secs (r-call
- r-index secs (r-call ! (r-call is.na secs))))
- (<- np (r-call
- getOption "digits.secs"))
- (if (r-call
- is.null np)
- (<- np 0)
- (<- np (r-call
- min 6 np)))
- (if (r-call >=
- np 1)
- (r-block (for
- i (r-call - (r-call : 1 np) 1)
- (if (r-call all (r-call < (r-call abs (r-call - secs
- (r-call round secs i)))
- 9.9999999999999995e-07))
- (r-block (<- np i) (break))))))
- (<- format (if
- (r-call all (r-call == (r-call r-index times
- (r-call ! (r-call is.na times)))
- 0))
- "%Y-%m-%d" (if (r-call == np 0) "%Y-%m-%d %H:%M:%S"
- (r-call paste "%Y-%m-%d %H:%M:%OS" np
- (*named* sep "")))))))
- (r-call .Internal (r-call
- format.POSIXlt x format usetz))))))
- (<- strftime format.POSIXlt)
- (<- strptime (lambda (x format tz)
- (let ((tz ()))
- (r-block (when (missing tz)
- (<- tz ""))
- (r-call .Internal (r-call strptime
- (r-call as.character x) format tz))))))
- (<- format.POSIXct (lambda (x format tz usetz ...)
- (let ((tzone ())
- (usetz ())
- (tz ())
- (format ()))
- (r-block (when (missing format)
- (<- format ""))
- (when (missing tz)
- (<- tz ""))
- (when (missing usetz)
- (<- usetz *r-false*))
- (if (r-call ! (r-call
- inherits x "POSIXct"))
- (r-call stop "wrong class"))
- (if (&& (missing tz)
- (r-call ! (r-call
- is.null (<- tzone (r-call attr x "tzone")))))
- (<- tz tzone))
- (r-call structure (r-call
- format.POSIXlt (r-call as.POSIXlt x tz) format usetz r-dotdotdot)
- (*named* names (r-call
- names x)))))))
- (<- print.POSIXct (lambda (x ...)
- (let ()
- (r-block (r-call print (r-call format
- x (*named* usetz *r-true*) r-dotdotdot)
- r-dotdotdot)
- (r-call invisible x)))))
- (<- print.POSIXlt (lambda (x ...)
- (let ()
- (r-block (r-call print (r-call format
- x (*named* usetz *r-true*))
- r-dotdotdot)
- (r-call invisible x)))))
- (<- summary.POSIXct (lambda (object digits ...)
- (let ((x ())
- (digits ()))
- (r-block (when (missing digits)
- (<- digits 15))
- (<- x (r-call r-index (r-call
- summary.default (r-call unclass object)
- (*named* digits digits) r-dotdotdot)
- (r-call : 1 6)))
- (r-block (ref= %r:1 (r-call
- oldClass object))
- (<- x (r-call
- class<- x
- %r:1))
- %r:1)
- (r-block (ref= %r:2 (r-call
- attr object "tzone"))
- (<- x (r-call
- attr<- x "tzone"
- %r:2))
- %r:2)
- x))))
- (<- summary.POSIXlt (lambda (object digits ...)
- (let ((digits ()))
- (r-block (when (missing digits)
- (<- digits 15))
- (r-call summary (r-call
- as.POSIXct
- object)
- (*named* digits
- digits)
- r-dotdotdot)))))
- (<- "+.POSIXt" (lambda (e1 e2)
- (let ((e2 ())
- (e1 ())
- (coerceTimeUnit ()))
- (r-block (<- coerceTimeUnit (lambda (x)
- (let ()
- (r-block (switch (r-call attr x "units")
- (*named* secs x) (*named* mins (r-call * 60 x))
- (*named* hours (r-call * (r-call * 60 60) x))
- (*named* days (r-call * (r-call * (r-call * 60 60) 24) x))
- (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60)
- 24)
- 7)
- x)))))))
- (if (r-call == (r-call nargs) 1)
- (return e1))
- (if (&& (r-call inherits e1 "POSIXt")
- (r-call inherits e2 "POSIXt"))
- (r-call stop "binary + is not defined for \"POSIXt\" objects"))
- (if (r-call inherits e1 "POSIXlt")
- (<- e1 (r-call as.POSIXct e1)))
- (if (r-call inherits e2 "POSIXlt")
- (<- e2 (r-call as.POSIXct e2)))
- (if (r-call inherits e1 "difftime")
- (<- e1 (r-call coerceTimeUnit
- e1)))
- (if (r-call inherits e2 "difftime")
- (<- e2 (r-call coerceTimeUnit
- e2)))
- (r-call structure (r-call + (r-call
- unclass e1)
- (r-call unclass e2))
- (*named* class (r-call c
- "POSIXt" "POSIXct"))
- (*named* tzone (r-call
- check_tzones e1 e2)))))))
- (<- "-.POSIXt" (lambda (e1 e2)
- (let ((e2 ())
- (coerceTimeUnit ()))
- (r-block (<- coerceTimeUnit (lambda (x)
- (let ()
- (r-block (switch (r-call attr x "units")
- (*named* secs x) (*named* mins (r-call * 60 x))
- (*named* hours (r-call * (r-call * 60 60) x))
- (*named* days (r-call * (r-call * (r-call * 60 60) 24) x))
- (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60)
- 24)
- 7)
- x)))))))
- (if (r-call ! (r-call inherits e1
- "POSIXt"))
- (r-call stop "Can only subtract from POSIXt objects"))
- (if (r-call == (r-call nargs) 1)
- (r-call stop "unary - is not defined for \"POSIXt\" objects"))
- (if (r-call inherits e2 "POSIXt")
- (return (r-call difftime e1
- e2)))
- (if (r-call inherits e2 "difftime")
- (<- e2 (r-call unclass (r-call
- coerceTimeUnit e2))))
- (if (r-call ! (r-call is.null (r-call
- attr e2 "class")))
- (r-call stop "can only subtract numbers from POSIXt objects"))
- (r-call structure (r-call - (r-call
- unclass (r-call as.POSIXct e1))
- e2)
- (*named* class (r-call c
- "POSIXt" "POSIXct")))))))
- (<- Ops.POSIXt (lambda (e1 e2)
- (let ((e2 ())
- (e1 ())
- (boolean ()))
- (r-block (if (r-call == (r-call nargs) 1)
- (r-call stop "unary" .Generic
- " not defined for \"POSIXt\" objects"))
- (<- boolean (switch .Generic (*named*
- < *r-missing*)
- (*named* >
- *r-missing*)
- (*named* ==
- *r-missing*)
- (*named* !=
- *r-missing*)
- (*named* <=
- *r-missing*)
- (*named* >=
- *r-true*)
- *r-false*))
- (if (r-call ! boolean)
- (r-call stop .Generic
- " not defined for \"POSIXt\" objects"))
- (if (|\|\|| (r-call inherits e1
- "POSIXlt")
- (r-call is.character
- e1))
- (<- e1 (r-call as.POSIXct e1)))
- (if (|\|\|| (r-call inherits e2
- "POSIXlt")
- (r-call is.character
- e1))
- (<- e2 (r-call as.POSIXct e2)))
- (r-call check_tzones e1 e2)
- (r-call NextMethod .Generic)))))
- (<- Math.POSIXt (lambda (x ...)
- (let () (r-block (r-call stop .Generic
- " not defined for POSIXt objects")))))
- (<- check_tzones (lambda (...)
- (let ((tzs ()))
- (r-block (<- tzs (r-call unique (r-call
- sapply (r-call list r-dotdotdot) (lambda (x)
- (let ((y ()))
- (r-block (<- y (r-call attr x "tzone"))
- (if (r-call is.null y) "" y)))))))
- (<- tzs (r-call r-index tzs
- (r-call != tzs
- "")))
- (if (r-call > (r-call length
- tzs)
- 1)
- (r-call warning "'tzone' attributes are inconsistent"))
- (if (r-call length tzs)
- (r-call r-index tzs 1)
- ())))))
- (<- Summary.POSIXct (lambda (... na.rm)
- (let ((val ())
- (tz ())
- (args ())
- (ok ()))
- (r-block (<- ok (switch .Generic (*named*
- max *r-missing*)
- (*named* min
- *r-missing*)
- (*named*
- range
- *r-true*)
- *r-false*))
- (if (r-call ! ok)
- (r-call stop .Generic
- " not defined for \"POSIXct\" objects"))
- (<- args (r-call list
- r-dotdotdot))
- (<- tz (r-call do.call "check_tzones"
- args))
- (<- val (r-call NextMethod
- .Generic))
- (r-block (ref= %r:3 (r-call
- oldClass (r-call r-aref args 1)))
- (<- val (r-call
- class<- val %r:3))
- %r:3)
- (r-block (<- val (r-call
- attr<- val "tzone" tz))
- tz)
- val))))
- (<- Summary.POSIXlt (lambda (... na.rm)
- (let ((val ())
- (tz ())
- (args ())
- (ok ()))
- (r-block (<- ok (switch .Generic (*named*
- max *r-missing*)
- (*named* min
- *r-missing*)
- (*named*
- range
- *r-true*)
- *r-false*))
- (if (r-call ! ok)
- (r-call stop .Generic
- " not defined for \"POSIXlt\" objects"))
- (<- args (r-call list
- r-dotdotdot))
- (<- tz (r-call do.call "check_tzones"
- args))
- (<- args (r-call lapply args
- as.POSIXct))
- (<- val (r-call do.call
- .Generic (r-call
- c args (*named* na.rm na.rm))))
- (r-call as.POSIXlt (r-call
- structure val (*named* class (r-call c "POSIXt" "POSIXct"))
- (*named* tzone tz)))))))
- (<- "[.POSIXct" (lambda (x ... drop)
- (let ((val ())
- (x ())
- (cl ())
- (drop ()))
- (r-block (when (missing drop)
- (<- drop *r-true*))
- (<- cl (r-call oldClass x))
- (r-block (<- x (r-call class<-
- x ()))
- ())
- (<- val (r-call NextMethod "["))
- (r-block (<- val (r-call class<-
- val cl))
- cl)
- (r-block (ref= %r:4 (r-call attr
- x "tzone"))
- (<- val (r-call attr<-
- val "tzone" %r:4))
- %r:4)
- val))))
- (<- "[[.POSIXct" (lambda (x ... drop)
- (let ((val ())
- (x ())
- (cl ())
- (drop ()))
- (r-block (when (missing drop)
- (<- drop *r-true*))
- (<- cl (r-call oldClass x))
- (r-block (<- x (r-call class<-
- x ()))
- ())
- (<- val (r-call NextMethod "[["))
- (r-block (<- val (r-call
- class<- val
- cl))
- cl)
- (r-block (ref= %r:5 (r-call
- attr x "tzone"))
- (<- val (r-call attr<-
- val "tzone" %r:5))
- %r:5)
- val))))
- (<- "[<-.POSIXct" (lambda (x ... value)
- (let ((x ())
- (tz ())
- (cl ())
- (value ()))
- (r-block (if (r-call ! (r-call
- as.logical (r-call
- length value)))
- (return x))
- (<- value (r-call as.POSIXct
- value))
- (<- cl (r-call oldClass x))
- (<- tz (r-call attr x "tzone"))
- (r-block (ref= %r:6 (r-block
- (<- value (r-call class<- value
- ()))
- ()))
- (<- x (r-call class<-
- x %r:6))
- %r:6)
- (<- x (r-call NextMethod
- .Generic))
- (r-block (<- x (r-call class<-
- x cl))
- cl)
- (r-block (<- x (r-call attr<-
- x "tzone" tz))
- tz)
- x))))
- (<- as.character.POSIXt (lambda (x ...)
- (let ()
- (r-block (r-call format x
- r-dotdotdot)))))
- (<- as.data.frame.POSIXct as.data.frame.vector)
- (<- is.na.POSIXlt (lambda (x)
- (let ()
- (r-block (r-call is.na (r-call
- as.POSIXct x))))))
- (<- c.POSIXct (lambda (... recursive)
- (let ((recursive ()))
- (r-block (when (missing recursive)
- (<- recursive *r-false*))
- (r-call structure (r-call c (r-call
- unlist (r-call lapply (r-call list r-dotdotdot) unclass)))
- (*named* class (r-call c
- "POSIXt" "POSIXct")))))))
- (<- c.POSIXlt (lambda (... recursive)
- (let ((recursive ()))
- (r-block (when (missing recursive)
- (<- recursive *r-false*))
- (r-call as.POSIXlt (r-call do.call
- "c" (r-call lapply (r-call list r-dotdotdot) as.POSIXct)))))))
- (<- all.equal.POSIXct (lambda (target current ... scale)
- (let ((scale ()))
- (r-block (when (missing scale)
- (<- scale 1))
- (r-call check_tzones
- target current)
- (r-call NextMethod "all.equal")))))
- (<- ISOdatetime (lambda (year month day hour min sec tz)
- (let ((x ())
- (tz ()))
- (r-block (when (missing tz)
- (<- tz ""))
- (<- x (r-call paste year month
- day hour min sec
- (*named* sep "-")))
- (r-call as.POSIXct (r-call
- strptime x
- "%Y-%m-%d-%H-%M-%OS"
- (*named* tz
- tz))
- (*named* tz tz))))))
- (<- ISOdate (lambda (year month day hour min sec tz)
- (let ((tz ())
- (sec ())
- (min ())
- (hour ()))
- (r-block (when (missing hour)
- (<- hour 12))
- (when (missing min)
- (<- min 0))
- (when (missing sec)
- (<- sec 0))
- (when (missing tz)
- (<- tz "GMT"))
- (r-call ISOdatetime year month day
- hour min sec tz)))))
- (<- as.matrix.POSIXlt (lambda (x ...)
- (let ()
- (r-block (r-call as.matrix (r-call
- as.data.frame (r-call unclass x))
- r-dotdotdot)))))
- (<- mean.POSIXct (lambda (x ...)
- (let ()
- (r-block (r-call structure (r-call mean
- (r-call unclass x) r-dotdotdot)
- (*named* class (r-call
- c "POSIXt" "POSIXct"))
- (*named* tzone (r-call
- attr x "tzone")))))))
- (<- mean.POSIXlt (lambda (x ...)
- (let ()
- (r-block (r-call as.POSIXlt (r-call mean
- (r-call as.POSIXct x) r-dotdotdot))))))
- (<- difftime (lambda (time1 time2 tz units)
- (let ((zz ())
- (z ())
- (time2 ())
- (time1 ())
- (units ())
- (tz ()))
- (r-block (when (missing tz)
- (<- tz ""))
- (when (missing units)
- (<- units (r-call c "auto" "secs"
- "mins" "hours"
- "days" "weeks")))
- (<- time1 (r-call as.POSIXct time1
- (*named* tz tz)))
- (<- time2 (r-call as.POSIXct time2
- (*named* tz tz)))
- (<- z (r-call - (r-call unclass
- time1)
- (r-call unclass time2)))
- (<- units (r-call match.arg units))
- (if (r-call == units "auto")
- (r-block (if (r-call all (r-call
- is.na z))
- (<- units "secs")
- (r-block (<- zz (r-call
- min (r-call abs z) (*named* na.rm *r-true*)))
- (if (|\|\|| (r-call is.na zz) (r-call < zz 60))
- (<- units "secs") (if (r-call < zz 3600)
- (<- units "mins")
- (if (r-call < zz 86400)
- (<- units "hours")
- (<- units "days"))))))))
- (switch units (*named* secs (r-call
- structure z (*named* units "secs")
- (*named* class "difftime")))
- (*named* mins (r-call
- structure (r-call
- / z 60)
- (*named*
- units "mins")
- (*named*
- class "difftime")))
- (*named* hours (r-call
- structure
- (r-call /
- z 3600)
- (*named*
- units "hours")
- (*named*
- class "difftime")))
- (*named* days (r-call
- structure (r-call
- / z 86400)
- (*named*
- units "days")
- (*named*
- class "difftime")))
- (*named* weeks (r-call
- structure
- (r-call /
- z (r-call * 7 86400))
- (*named*
- units "weeks")
- (*named*
- class "difftime"))))))))
- (<- as.difftime (lambda (tim format units)
- (let ((units ())
- (format ()))
- (r-block (when (missing format)
- (<- format "%X"))
- (when (missing units)
- (<- units "auto"))
- (if (r-call inherits tim "difftime")
- (return tim))
- (if (r-call is.character tim)
- (r-block (r-call difftime (r-call
- strptime tim (*named* format format))
- (r-call
- strptime "0:0:0" (*named* format "%X"))
- (*named*
- units units)))
- (r-block (if (r-call ! (r-call
- is.numeric tim))
- (r-call stop "'tim' is not character or numeric"))
- (if (r-call ==
- units "auto")
- (r-call stop "need explicit units for numeric conversion"))
- (if (r-call ! (r-call
- %in% units (r-call c "secs" "mins" "hours" "days" "weeks")))
- (r-call stop "invalid units specified"))
- (r-call structure
- tim (*named*
- units units)
- (*named*
- class "difftime"))))))))
- (<- units (lambda (x)
- (let () (r-block (r-call UseMethod "units")))))
- (<- "units<-" (lambda (x value)
- (let () (r-block (r-call UseMethod "units<-")))))
- (<- units.difftime (lambda (x)
- (let ()
- (r-block (r-call attr x "units")))))
- (<- "units<-.difftime" (lambda (x value)
- (let ((newx ())
- (sc ())
- (from ()))
- (r-block (<- from (r-call units x))
- (if (r-call == from value)
- (return x))
- (if (r-call ! (r-call
- %in% value (r-call c "secs" "mins" "hours" "days" "weeks")))
- (r-call stop "invalid units specified"))
- (<- sc (r-call cumprod (r-call
- c (*named* secs 1) (*named* mins 60)
- (*named* hours 60) (*named* days 24) (*named* weeks 7))))
- (<- newx (r-call / (r-call
- * (r-call as.vector x) (r-call r-index sc from))
- (r-call r-index sc value)))
- (r-call structure newx
- (*named* units
- value)
- (*named* class "difftime"))))))
- (<- as.double.difftime (lambda (x units ...)
- (let ((x ())
- (units ()))
- (r-block (when (missing units)
- (<- units "auto"))
- (if (r-call != units "auto")
- (r-block (<- x (r-call
- units<- x units))
- units))
- (r-call as.double (r-call
- as.vector x))))))
- (<- as.data.frame.difftime
- as.data.frame.vector)
- (<- format.difftime (lambda (x ...)
- (let ()
- (r-block (r-call paste (r-call format
- (r-call unclass x) r-dotdotdot)
- (r-call units x))))))
- (<- print.difftime (lambda (x digits ...)
- (let ((y ())
- (digits ()))
- (r-block (when (missing digits)
- (<- digits (r-call
- getOption
- "digits")))
- (if (|\|\|| (r-call is.array
- x)
- (r-call > (r-call
- length x)
- 1))
- (r-block (r-call cat "Time differences in "
- (r-call attr x "units") "\n" (*named* sep ""))
- (<- y (r-call
- unclass x))
- (r-block (<- y
- (r-call attr<- y "units"
- ()))
- ())
- (r-call print y))
- (r-call cat "Time difference of "
- (r-call format (r-call
- unclass x)
- (*named* digits digits))
- " " (r-call attr
- x "units")
- "\n" (*named* sep
- "")))
- (r-call invisible x)))))
- (<- round.difftime (lambda (x digits ...)
- (let ((units ())
- (digits ()))
- (r-block (when (missing digits)
- (<- digits 0))
- (<- units (r-call attr x "units"))
- (r-call structure (r-call
- NextMethod)
- (*named* units units)
- (*named* class "difftime"))))))
- (<- "[.difftime" (lambda (x ... drop)
- (let ((val ())
- (x ())
- (cl ())
- (drop ()))
- (r-block (when (missing drop)
- (<- drop *r-true*))
- (<- cl (r-call oldClass x))
- (r-block (<- x (r-call class<-
- x ()))
- ())
- (<- val (r-call NextMethod "["))
- (r-block (<- val (r-call
- class<- val
- cl))
- cl)
- (r-block (ref= %r:7 (r-call
- attr x "units"))
- (<- val (r-call attr<-
- val "units" %r:7))
- %r:7)
- val))))
- (<- Ops.difftime (lambda (e1 e2)
- (let ((u1 ())
- (e2 ())
- (boolean ())
- (e1 ())
- (coerceTimeUnit ()))
- (r-block (<- coerceTimeUnit (lambda (x)
- (let () (r-block (switch (r-call attr x "units")
- (*named* secs x)
- (*named* mins (r-call * 60 x))
- (*named* hours (r-call * (r-call * 60 60) x))
- (*named* days (r-call * (r-call * (r-call * 60 60)
- 24)
- x))
- (*named* weeks (r-call * (r-call * (r-call * (r-call
- * 60 60)
- 24)
- 7)
- x)))))))
- (if (r-call == (r-call nargs)
- 1)
- (r-block (switch .Generic
- (*named* + (r-block)) (*named* - (r-block (r-block (ref= %r:8 (r-call - (r-call
- unclass e1)))
- (<- e1 (r-call r-index<-
- e1
- *r-missing*
- %r:8))
- %r:8)))
- (r-call stop "unary" .Generic
- " not defined for \"difftime\" objects"))
- (return e1)))
- (<- boolean (switch .Generic (*named*
- < *r-missing*)
- (*named* >
- *r-missing*)
- (*named* ==
- *r-missing*)
- (*named* !=
- *r-missing*)
- (*named* <=
- *r-missing*)
- (*named* >=
- *r-true*)
- *r-false*))
- (if boolean (r-block (if (&& (r-call
- inherits e1 "difftime")
- (r-call inherits e2 "difftime"))
- (r-block (<- e1 (r-call coerceTimeUnit e1))
- (<- e2 (r-call coerceTimeUnit e2))))
- (r-call NextMethod .Generic))
- (if (|\|\|| (r-call ==
- .Generic "+")
- (r-call ==
- .Generic "-"))
- (r-block (if (&& (r-call
- inherits e1 "difftime")
- (r-call ! (r-call inherits e2 "difftime")))
- (return (r-call structure (r-call NextMethod .Generic)
- (*named* units (r-call attr e1 "units"))
- (*named* class "difftime"))))
- (if (&& (r-call
- ! (r-call inherits e1 "difftime"))
- (r-call inherits e2 "difftime"))
- (return (r-call structure (r-call NextMethod .Generic)
- (*named* units (r-call attr e2 "units"))
- (*named* class "difftime"))))
- (<- u1 (r-call
- attr e1 "units"))
- (if (r-call ==
- (r-call attr e2 "units") u1)
- (r-block (r-call structure (r-call NextMethod .Generic)
- (*named* units u1) (*named* class "difftime")))
- (r-block (<- e1 (r-call coerceTimeUnit e1))
- (<- e2 (r-call coerceTimeUnit e2))
- (r-call structure (r-call NextMethod .Generic)
- (*named* units "secs")
- (*named* class "difftime")))))
- (r-block (r-call stop
- .Generic "not defined for \"difftime\" objects"))))))))
- (<- "*.difftime" (lambda (e1 e2)
- (let ((e2 ())
- (e1 ())
- (tmp ()))
- (r-block (if (&& (r-call inherits e1 "difftime")
- (r-call inherits e2 "difftime"))
- (r-call stop "both arguments of * cannot be \"difftime\" objects"))
- (if (r-call inherits e2 "difftime")
- (r-block (<- tmp e1)
- (<- e1 e2)
- (<- e2 tmp)))
- (r-call structure (r-call * e2
- (r-call unclass e1))
- (*named* units (r-call
- attr e1 "units"))
- (*named* class "difftime"))))))
- (<- "/.difftime" (lambda (e1 e2)
- (let ()
- (r-block (if (r-call inherits e2 "difftime")
- (r-call stop "second argument of / cannot be a \"difftime\" object"))
- (r-call structure (r-call / (r-call
- unclass e1)
- e2)
- (*named* units (r-call
- attr e1 "units"))
- (*named* class "difftime"))))))
- (<- Math.difftime (lambda (x ...)
- (let ()
- (r-block (r-call stop .Generic
- "not defined for \"difftime\" objects")))))
- (<- mean.difftime (lambda (x ... na.rm)
- (let ((args ())
- (coerceTimeUnit ())
- (na.rm ()))
- (r-block (when (missing na.rm)
- (<- na.rm *r-false*))
- (<- coerceTimeUnit (lambda (x)
- (let () (r-block (r-call as.vector (switch (r-call attr x "units")
- (*named* secs x)
- (*named* mins (r-call * 60 x))
- (*named* hours (r-call * (r-call
- * 60 60)
- x))
- (*named* days (r-call * (r-call *
- (r-call * 60 60) 24)
- x))
- (*named* weeks (r-call * (r-call
- * (r-call * (r-call * 60 60) 24) 7)
- x))))))))
- (if (r-call length (r-call
- list r-dotdotdot))
- (r-block (<- args (r-call
- c (r-call lapply (r-call list x r-dotdotdot) coerceTimeUnit)
- (*named* na.rm na.rm)))
- (r-call structure
- (r-call do.call "mean" args) (*named* units "secs")
- (*named* class "difftime")))
- (r-block (r-call structure
- (r-call mean (r-call as.vector x)
- (*named* na.rm na.rm))
- (*named* units (r-call attr x "units"))
- (*named* class "difftime"))))))))
- (<- Summary.difftime (lambda (... na.rm)
- (let ((args ())
- (ok ())
- (coerceTimeUnit ()))
- (r-block (<- coerceTimeUnit (lambda (x)
- (let () (r-block (r-call as.vector (switch (r-call attr x "units")
- (*named* secs x)
- (*named* mins (r-call * 60 x))
- (*named* hours (r-call * (r-call
- * 60 60)
- x))
- (*named* days (r-call * (r-call *
- (r-call * 60 60) 24)
- x))
- (*named* weeks (r-call * (r-call
- * (r-call * (r-call * 60 60) 24) 7)
- x))))))))
- (<- ok (switch .Generic (*named*
- max *r-missing*)
- (*named* min
- *r-missing*)
- (*named*
- range
- *r-true*)
- *r-false*))
- (if (r-call ! ok)
- (r-call stop .Generic
- " not defined for \"difftime\" objects"))
- (<- args (r-call c (r-call
- lapply (r-call list r-dotdotdot) coerceTimeUnit)
- (*named* na.rm na.rm)))
- (r-call structure (r-call
- do.call .Generic args)
- (*named* units "secs")
- (*named* class "difftime"))))))
- (<- seq.POSIXt (lambda (from to by length.out along.with ...)
- (let ((mon ())
- (yr ())
- (r1 ())
- (by2 ())
- (by ())
- (valid ())
- (res ())
- (to ())
- (from ())
- (status ())
- (tz ())
- (cfrom ())
- (along.with ())
- (length.out ()))
- (r-block (when (missing length.out)
- (<- length.out ()))
- (when (missing along.with)
- (<- along.with ()))
- (if (missing from)
- (r-call stop "'from' must be specified"))
- (if (r-call ! (r-call inherits
- from "POSIXt"))
- (r-call stop "'from' must be a POSIXt object"))
- (<- cfrom (r-call as.POSIXct from))
- (if (r-call != (r-call length
- cfrom)
- 1)
- (r-call stop "'from' must be of length 1"))
- (<- tz (r-call attr cfrom "tzone"))
- (if (r-call ! (missing to))
- (r-block (if (r-call ! (r-call
- inherits to "POSIXt"))
- (r-call stop "'to' must be a POSIXt object"))
- (if (r-call != (r-call
- length (r-call as.POSIXct to))
- 1)
- (r-call stop "'to' must be of length 1"))))
- (if (r-call ! (missing along.with))
- (r-block (<- length.out (r-call
- length along.with)))
- (if (r-call ! (r-call is.null
- length.out))
- (r-block (if (r-call !=
- (r-call length length.out) 1)
- (r-call stop
- "'length.out' must be of length 1"))
- (<- length.out
- (r-call
- ceiling
- length.out)))))
- (<- status (r-call c (r-call ! (missing
- to))
- (r-call ! (missing
- by))
- (r-call ! (r-call
- is.null length.out))))
- (if (r-call != (r-call sum status)
- 2)
- (r-call stop "exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified"))
- (if (missing by)
- (r-block (<- from (r-call
- unclass cfrom))
- (<- to (r-call
- unclass (r-call
- as.POSIXct to)))
- (<- res (r-call
- seq.int
- from to (*named*
- length.out length.out)))
- (return (r-call
- structure
- res (*named*
- class (r-call c "POSIXt" "POSIXct"))
- (*named*
- tzone tz)))))
- (if (r-call != (r-call length by)
- 1)
- (r-call stop "'by' must be of length 1"))
- (<- valid 0)
- (if (r-call inherits by "difftime")
- (r-block (<- by (r-call * (switch
- (r-call attr by "units") (*named* secs 1)
- (*named* mins 60) (*named* hours 3600) (*named* days 86400)
- (*named* weeks (r-call * 7 86400)))
- (r-call unclass by))))
- (if (r-call is.character by)
- (r-block (<- by2 (r-call
- r-aref (r-call strsplit by " "
- (*named* fixed *r-true*))
- 1))
- (if (|\|\|| (r-call
- > (r-call length by2) 2)
- (r-call < (r-call length by2) 1))
- (r-call stop
- "invalid 'by' string"))
- (<- valid (r-call
- pmatch (r-call r-index by2
- (r-call length by2))
- (r-call c "secs" "mins" "hours" "days" "weeks" "months" "years" "DSTdays")))
- (if (r-call
- is.na valid)
- (r-call stop
- "invalid string for 'by'"))
- (if (r-call <=
- valid 5)
- (r-block (<-
- by (r-call r-index (r-call c 1 60 3600 86400
- (r-call * 7 86400))
- valid))
- (if (r-call == (r-call length by2) 2) (<- by (r-call * by
- (r-call as.integer (r-call
- r-index by2 1))))))
- (<- by (if
- (r-call == (r-call length by2) 2) (r-call as.integer (r-call r-index by2 1))
- 1))))
- (if (r-call ! (r-call
- is.numeric by))
- (r-call stop "invalid mode for 'by'"))))
- (if (r-call is.na by)
- (r-call stop "'by' is NA"))
- (if (r-call <= valid 5)
- (r-block (<- from (r-call
- unclass (r-call as.POSIXct from)))
- (if (r-call ! (r-call
- is.null length.out))
- (<- res (r-call
- seq.int from (*named* by by)
- (*named* length.out length.out)))
- (r-block (<- to
- (r-call unclass (r-call as.POSIXct to)))
- (<- res (r-call + (r-call seq.int 0
- (r-call - to from) by)
- from))))
- (return (r-call
- structure
- res (*named*
- class (r-call c "POSIXt" "POSIXct"))
- (*named*
- tzone tz))))
- (r-block (<- r1 (r-call
- as.POSIXlt
- from))
- (if (r-call == valid
- 7)
- (r-block (if (missing
- to)
- (r-block (<- yr (r-call seq.int (r-call r-aref r1
- (index-in-strlist year (r-call attr
- r1 #0#)))
- (*named* by by)
- (*named* length length.out))))
- (r-block (<- to (r-call as.POSIXlt to))
- (<- yr (r-call seq.int (r-call r-aref r1
- (index-in-strlist year (r-call attr
- r1 #0#)))
- (r-call r-aref to
- (index-in-strlist year (r-call attr to #0#)))
- by))))
- (r-block (<- r1 (r-call r-aref<- r1
- (index-in-strlist year (r-call attr r1 #0#)) yr))
- yr)
- (r-block (ref= %r:9 (r-call - 1)) (<- r1 (r-call r-aref<- r1
- (index-in-strlist isdst (r-call
- attr r1 #0#))
- %r:9))
- %r:9)
- (<- res (r-call as.POSIXct r1)))
- (if (r-call ==
- valid 6)
- (r-block (if
- (missing to) (r-block (<- mon (r-call seq.int (r-call r-aref r1
- (index-in-strlist mon
- (r-call attr r1 #0#)))
- (*named* by by)
- (*named* length length.out))))
- (r-block (<- to (r-call as.POSIXlt to))
- (<- mon (r-call seq.int (r-call r-aref r1
- (index-in-strlist mon (r-call attr
- r1 #0#)))
- (r-call + (r-call * 12
- (r-call - (r-call r-aref to
- (index-in-strlist
- year (r-call
- attr to #0#)))
- (r-call r-aref r1
- (index-in-strlist
- year (r-call attr
- r1 #0#)))))
- (r-call r-aref to
- (index-in-strlist mon (r-call attr
- to #0#))))
- by))))
- (r-block (<- r1 (r-call r-aref<- r1
- (index-in-strlist mon (r-call attr r1 #0#)) mon))
- mon)
- (r-block (ref= %r:10 (r-call - 1)) (<- r1 (r-call r-aref<- r1
- (index-in-strlist isdst (r-call
- attr r1 #0#))
- %r:10))
- %r:10)
- (<- res (r-call as.POSIXct r1)))
- (if (r-call
- == valid 8)
- (r-block (if (r-call ! (missing to)) (r-block (<- length.out (r-call + 2
- (r-call floor (r-call / (r-call - (r-call unclass (r-call as.POSIXct to))
- (r-call unclass (r-call as.POSIXct from)))
- 86400))))))
- (r-block (ref= %r:11 (r-call seq.int (r-call r-aref r1
- (index-in-strlist mday
- (r-call attr r1 #0#)))
- (*named* by by)
- (*named* length length.out)))
- (<- r1 (r-call r-aref<- r1
- (index-in-strlist mday (r-call attr r1 #0#))
- %r:11))
- %r:11)
- (r-block (ref= %r:12 (r-call - 1))
- (<- r1 (r-call r-aref<- r1
- (index-in-strlist isdst (r-call attr r1 #0#))
- %r:12))
- %r:12)
- (<- res (r-call as.POSIXct r1))
- (if (r-call ! (missing to)) (<- res (r-call r-index res
- (r-call <= res
- (r-call
- as.POSIXct to)))))))))
- (return res)))))))
- (<- cut.POSIXt (lambda (x breaks labels start.on.monday right
- ...)
- (let ((res ())
- (maxx ())
- (incr ())
- (start ())
- (valid ())
- (by2 ())
- (breaks ())
- (x ())
- (right ())
- (start.on.monday ())
- (labels ()))
- (r-block (when (missing labels)
- (<- labels ()))
- (when (missing start.on.monday)
- (<- start.on.monday
- *r-true*))
- (when (missing right)
- (<- right *r-false*))
- (if (r-call ! (r-call inherits x
- "POSIXt"))
- (r-call stop "'x' must be a date-time object"))
- (<- x (r-call as.POSIXct x))
- (if (r-call inherits breaks "POSIXt")
- (r-block (<- breaks (r-call
- as.POSIXct breaks)))
- (if (&& (r-call is.numeric
- breaks)
- (r-call == (r-call
- length breaks)
- 1))
- (r-block)
- (if (&& (r-call
- is.character
- breaks)
- (r-call == (r-call
- length breaks)
- 1))
- (r-block (<- by2 (r-call
- r-aref (r-call strsplit breaks " "
- (*named* fixed *r-true*))
- 1))
- (if (|\|\||
- (r-call > (r-call length by2) 2) (r-call < (r-call length by2) 1))
- (r-call stop "invalid specification of 'breaks'"))
- (<- valid (r-call
- pmatch (r-call r-index by2
- (r-call length by2))
- (r-call c "secs" "mins" "hours" "days" "weeks" "months" "years" "DSTdays")))
- (if (r-call
- is.na valid)
- (r-call stop "invalid specification of 'breaks'"))
- (<- start (r-call
- as.POSIXlt (r-call min x
- (*named* na.rm *r-true*))))
- (<- incr 1)
- (if (r-call
- > valid 1)
- (r-block (r-block (<- start (r-call r-aref<- start
- (index-in-strlist sec (r-call attr start
- #0#))
- 0))
- 0)
- (<- incr 59.990000000000002)))
- (if (r-call
- > valid 2)
- (r-block (r-block (<- start (r-call r-aref<- start
- (index-in-strlist min (r-call attr start
- #0#))
- 0))
- 0)
- (<- incr (r-call - 3600 1))))
- (if (r-call
- > valid 3)
- (r-block (r-block (<- start (r-call r-aref<- start
- (index-in-strlist hour (r-call attr start
- #0#))
- 0))
- 0)
- (<- incr (r-call - 86400 1))))
- (if (r-call
- == valid 5)
- (r-block (r-block (ref= %r:13 (r-call - (r-call r-aref start
- (index-in-strlist mday (r-call
- attr start #0#)))
- (r-call r-aref start
- (index-in-strlist wday (r-call
- attr start #0#)))))
- (<- start (r-call r-aref<- start
- (index-in-strlist mday (r-call attr start
- #0#))
- %r:13))
- %r:13)
- (if start.on.monday (r-block (ref= %r:14 (r-call + (r-call r-aref
- start (index-in-strlist mday (r-call attr start #0#)))
- (r-call ifelse (r-call
- > (r-call r-aref start
- (index-in-strlist wday (r-call attr start #0#)))
- 0)
- 1 (r-call
- - 6))))
- (<- start (r-call r-aref<- start
- (index-in-strlist
- mday (r-call attr
- start #0#))
- %r:14))
- %r:14))
- (<- incr (r-call * 7 86400))))
- (if (r-call
- == valid 6)
- (r-block (r-block (<- start (r-call r-aref<- start
- (index-in-strlist mday (r-call attr start
- #0#))
- 1))
- 1)
- (<- incr (r-call * 31 86400))))
- (if (r-call
- == valid 7)
- (r-block (r-block (<- start (r-call r-aref<- start
- (index-in-strlist mon (r-call attr start
- #0#))
- 0))
- 0)
- (r-block (<- start (r-call r-aref<- start
- (index-in-strlist mday (r-call attr start
- #0#))
- 1))
- 1)
- (<- incr (r-call * 366 86400))))
- (if (r-call
- == valid 8)
- (<- incr (r-call * 25 3600)))
- (if (r-call
- == (r-call length by2) 2)
- (<- incr (r-call * incr
- (r-call as.integer (r-call r-index by2 1)))))
- (<- maxx (r-call
- max x (*named* na.rm *r-true*)))
- (<- breaks
- (r-call seq.int start
- (r-call + maxx incr) breaks))
- (<- breaks
- (r-call r-index breaks
- (r-call : 1
- (r-call + 1
- (r-call max (r-call which (r-call < breaks maxx))))))))
- (r-call stop "invalid specification of 'breaks'"))))
- (<- res (r-call cut (r-call
- unclass x)
- (r-call unclass
- breaks)
- (*named* labels
- labels)
- (*named* right
- right)
- r-dotdotdot))
- (if (r-call is.null labels)
- (r-block (ref= %r:15 (r-call
- as.character (r-call r-index breaks
- (r-call - (r-call length breaks)))))
- (<- res (r-call
- levels<-
- res %r:15))
- %r:15))
- res))))
- (<- julian (lambda (x ...)
- (let () (r-block (r-call UseMethod "julian")))))
- (<- julian.POSIXt (lambda (x origin ...)
- (let ((res ())
- (origin ()))
- (r-block (when (missing origin)
- (<- origin (r-call
- as.POSIXct
- "1970-01-01"
- (*named* tz
- "GMT"))))
- (if (r-call != (r-call length
- origin)
- 1)
- (r-call stop "'origin' must be of length one"))
- (<- res (r-call difftime (r-call
- as.POSIXct x)
- origin (*named*
- units "days")))
- (r-call structure res
- (*named* origin origin))))))
- (<- weekdays (lambda (x abbreviate)
- (let () (r-block (r-call UseMethod "weekdays")))))
- (<- weekdays.POSIXt (lambda (x abbreviate)
- (let ((abbreviate ()))
- (r-block (when (missing abbreviate)
- (<- abbreviate
- *r-false*))
- (r-call format x
- (r-call ifelse
- abbreviate
- "%a" "%A"))))))
- (<- months (lambda (x abbreviate)
- (let () (r-block (r-call UseMethod "months")))))
- (<- months.POSIXt (lambda (x abbreviate)
- (let ((abbreviate ()))
- (r-block (when (missing abbreviate)
- (<- abbreviate *r-false*))
- (r-call format x
- (r-call ifelse
- abbreviate "%b"
- "%B"))))))
- (<- quarters (lambda (x abbreviate)
- (let () (r-block (r-call UseMethod "quarters")))))
- (<- quarters.POSIXt (lambda (x ...)
- (let ((x ()))
- (r-block (<- x (r-call %/% (r-block
- (ref= %r:0 (r-call as.POSIXlt x)) (r-call r-aref %r:0
- (index-in-strlist mon (r-call attr
- %r:0 #0#))))
- 3))
- (r-call paste "Q"
- (r-call + x 1)
- (*named* sep ""))))))
- (<- trunc.POSIXt (lambda (x units)
- (let ((x ())
- (units ()))
- (r-block (when (missing units)
- (<- units (r-call c "secs"
- "mins" "hours" "days")))
- (<- units (r-call match.arg
- units))
- (<- x (r-call as.POSIXlt x))
- (if (r-call > (r-call length (r-call
- r-aref x (index-in-strlist sec (r-call attr x #0#))))
- 0)
- (switch units (*named* secs
- (r-block (r-block (ref= %r:16 (r-call trunc (r-call r-aref x
- (index-in-strlist sec (r-call
- attr x #0#)))))
- (<- x (r-call r-aref<- x
- (index-in-strlist sec (r-call attr x #0#))
- %r:16))
- %r:16)))
- (*named* mins (r-block
- (r-block (<- x (r-call r-aref<- x
- (index-in-strlist sec (r-call attr x #0#)) 0))
- 0)))
- (*named* hours (r-block
- (r-block (<- x (r-call r-aref<- x
- (index-in-strlist sec (r-call attr x #0#)) 0))
- 0)
- (r-block (<- x (r-call r-aref<- x
- (index-in-strlist min (r-call attr x #0#)) 0))
- 0)))
- (*named* days (r-block
- (r-block (<- x (r-call r-aref<- x
- (index-in-strlist sec (r-call attr x #0#)) 0))
- 0)
- (r-block (<- x (r-call r-aref<- x
- (index-in-strlist min (r-call attr x #0#)) 0))
- 0)
- (r-block (<- x (r-call r-aref<- x
- (index-in-strlist hour (r-call attr x #0#)) 0))
- 0)
- (r-block (ref= %r:17 (r-call - 1)) (<- x (r-call r-aref<- x
- (index-in-strlist isdst (r-call
- attr x #0#))
- %r:17))
- %r:17)))))
- x))))
- (<- round.POSIXt (lambda (x units)
- (let ((x ())
- (units ()))
- (r-block (when (missing units)
- (<- units (r-call c "secs"
- "mins" "hours" "days")))
- (if (&& (r-call is.numeric
- units)
- (r-call == units 0))
- (<- units "secs"))
- (<- units (r-call match.arg
- units))
- (<- x (r-call as.POSIXct x))
- (<- x (r-call + x
- (switch units (*named*
- secs 0.5)
- (*named* mins 30) (*named* hours 1800) (*named* days 43200))))
- (r-call trunc.POSIXt x
- (*named* units units))))))
- (<- "[.POSIXlt" (lambda (x ... drop)
- (let ((val ())
- (drop ()))
- (r-block (when (missing drop)
- (<- drop *r-true*))
- (<- val (r-call lapply x "["
- r-dotdotdot (*named*
- drop drop)))
- (r-block (ref= %r:18 (r-call
- attributes x))
- (<- val (r-call
- attributes<-
- val %r:18))
- %r:18)
- val))))
- (<- "[<-.POSIXlt" (lambda (x i value)
- (let ((x ())
- (cl ())
- (value ()))
- (r-block (if (r-call ! (r-call
- as.logical (r-call
- length value)))
- (return x))
- (<- value (r-call as.POSIXlt
- value))
- (<- cl (r-call oldClass x))
- (r-block (ref= %r:19 (r-block
- (<- value (r-call class<- value
- ()))
- ()))
- (<- x (r-call class<-
- x %r:19))
- %r:19)
- (for n (r-call names x)
- (r-block (ref= %r:20 (r-call
- r-aref value n))
- (r-block (ref=
- %r:21 (r-call r-index<- (r-call r-aref x n) i %r:20))
- (<- x (r-call r-aref<- x n %r:21)) %r:21)
- %r:20))
- (r-block (<- x (r-call class<-
- x cl))
- cl)
- x))))
- (<- as.data.frame.POSIXlt (lambda (x row.names optional ...)
- (let ((value ())
- (optional ())
- (row.names ()))
- (r-block (when (missing
- row.names)
- (<- row.names ()))
- (when (missing
- optional)
- (<- optional
- *r-false*))
- (<- value (r-call
- as.data.frame.POSIXct
- (r-call
- as.POSIXct x)
- row.names
- optional
- r-dotdotdot))
- (if (r-call ! optional)
- (r-block (ref=
- %r:22 (r-call r-aref (r-call deparse (substitute x)) 1))
- (<- value (r-call names<- value %r:22)) %r:22))
- value))))
- (<- rep.POSIXct (lambda (x ...)
- (let ((y ()))
- (r-block (<- y (r-call NextMethod))
- (r-call structure y
- (*named* class (r-call
- c "POSIXt" "POSIXct"))
- (*named* tzone (r-call
- attr x "tzone")))))))
- (<- rep.POSIXlt (lambda (x ...)
- (let ((y ()))
- (r-block (<- y (r-call lapply x rep
- r-dotdotdot))
- (r-block (ref= %r:23 (r-call
- attributes x))
- (<- y (r-call
- attributes<- y
- %r:23))
- %r:23)
- y))))
- (<- diff.POSIXt (lambda (x lag differences ...)
- (let ((i1 ())
- (xlen ())
- (r ())
- (ismat ())
- (differences ())
- (lag ()))
- (r-block (when (missing lag)
- (<- lag 1))
- (when (missing differences)
- (<- differences 1))
- (<- ismat (r-call is.matrix x))
- (<- r (if (r-call inherits x "POSIXlt")
- (r-call as.POSIXct x)
- x))
- (<- xlen (if ismat (r-call
- r-index (r-call
- dim x)
- 1)
- (r-call length r)))
- (if (|\|\|| (r-call > (r-call
- length lag)
- 1)
- (r-call > (r-call
- length differences)
- 1)
- (r-call < lag 1)
- (r-call <
- differences
- 1))
- (r-call stop "'lag' and 'differences' must be integers >= 1"))
- (if (r-call >= (r-call * lag
- differences)
- xlen)
- (return (r-call structure (r-call
- numeric 0)
- (*named*
- class "difftime")
- (*named*
- units "secs"))))
- (<- i1 (r-call : (r-call - 1)
- (r-call - lag)))
- (if ismat (for i (r-call : 1
- differences)
- (<- r (r-call - (r-call
- r-index r i1 *r-missing*
- (*named* drop *r-false*))
- (r-call r-index r
- (r-call : (r-call - (r-call nrow r))
- (r-call - (r-call + (r-call - (r-call nrow r) lag) 1)))
- *r-missing* (*named* drop *r-false*)))))
- (for i (r-call : 1
- differences)
- (<- r (r-call - (r-call
- r-index r i1)
- (r-call
- r-index r
- (r-call :
- (r-call - (r-call length r)) (r-call - (r-call + (r-call - (r-call length r)
- lag)
- 1))))))))
- r))))
- (<- duplicated.POSIXlt (lambda (x incomparables ...)
- (let ((x ())
- (incomparables ()))
- (r-block (when (missing
- incomparables)
- (<- incomparables
- *r-false*))
- (<- x (r-call as.POSIXct
- x))
- (r-call NextMethod "duplicated"
- x)))))
- (<- unique.POSIXlt (lambda (x incomparables ...)
- (let ((incomparables ()))
- (r-block (when (missing incomparables)
- (<- incomparables
- *r-false*))
- (r-call r-index x
- (r-call ! (r-call
- duplicated x incomparables r-dotdotdot)))))))
- (<- sort.POSIXlt (lambda (x decreasing na.last ...)
- (let ((na.last ())
- (decreasing ()))
- (r-block (when (missing decreasing)
- (<- decreasing *r-false*))
- (when (missing na.last)
- (<- na.last NA))
- (r-call r-index x
- (r-call order (r-call
- as.POSIXct x)
- (*named*
- na.last
- na.last)
- (*named*
- decreasing
- decreasing))))))))
--- a/femtolisp/tests/ast/rpasses.lsp
+++ /dev/null
@@ -1,110 +1,0 @@
-; -*- scheme -*-
-(load "match.lsp")
-(load "asttools.lsp")
-
-(define missing-arg-tag '*r-missing*)
-
-; tree inspection utils
-
-(define (assigned-var e)
- (and (pair? e)
- (or (eq (car e) '<-) (eq (car e) 'ref=))
- (symbol? (cadr e))
- (cadr e)))
-
-(define (func-argnames f)
- (let ((argl (cadr f)))
- (if (eq argl '*r-null*) ()
- (map cadr argl))))
-
-; transformations
-
-(let ((ctr 0))
- (set! r-gensym (lambda ()
- (prog1 (symbol (string "%r:" ctr))
- (set! ctr (+ ctr 1))))))
-
-(define (dollarsign-transform e)
- (pattern-expand
- (pattern-lambda ($ lhs name)
- (let* ((g (if (not (pair? lhs)) lhs (r-gensym)))
- (n (if (symbol? name)
- name ;(symbol->string name)
- name))
- (expr `(r-call
- r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
- (if (not (pair? lhs))
- expr
- `(r-block (ref= ,g ,lhs) ,expr))))
- e))
-
-; lower r expressions of the form f(lhs,...) <- rhs
-; TODO: if there are any special forms that can be f in this expression,
-; they need to be handled separately. For example a$b can be lowered
-; to an index assignment (by dollarsign-transform), after which
-; this transform applies. I don't think there are any others though.
-(define (fancy-assignment-transform e)
- (pattern-expand
- (pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
- (<<- (r-call f lhs ...) rhs))
- (let ((g (if (pair? rhs) (r-gensym) rhs))
- (op (car __)))
- `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ())
- (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
- ,g)))
- e))
-
-; map an arglist with default values to appropriate init code
-; function(x=blah) { ... } gets-; if (missing(x)) x = blah
-; added to its body
-(define (gen-default-inits arglist)
- (map (lambda (arg)
- (let ((name (cadr arg))
- (default (caddr arg)))
- `(when (missing ,name)
- (<- ,name ,default))))
- (filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) arglist)))
-
-; convert r function expressions to lambda
-(define (normalize-r-functions e)
- (maptree-post (lambda (n)
- (if (and (pair? n) (eq (car n) 'function))
- `(lambda ,(func-argnames n)
- (r-block ,@(gen-default-inits (cadr n))
- ,@(if (and (pair? (caddr n))
- (eq (car (caddr n)) 'r-block))
- (cdr (caddr n))
- (list (caddr n)))))
- n))
- e))
-
-(define (find-assigned-vars n)
- (let ((vars ()))
- (maptree-pre (lambda (s)
- (if (not (pair? s)) s
- (cond ((eq (car s) 'lambda) ())
- ((eq (car s) '<-)
- (set! vars (list-adjoin (cadr s) vars))
- (cddr s))
- (#t s))))
- n)
- vars))
-
-; introduce let based on assignment statements
-(define (letbind-locals e)
- (maptree-post (lambda (n)
- (if (and (pair? n) (eq (car n) 'lambda))
- (let ((vars (find-assigned-vars (cddr n))))
- `(lambda ,(cadr n) (let ,(map (lambda (v) (list v ()))
- vars)
- ,@(cddr n))))
- n))
- e))
-
-(define (compile-ish e)
- (letbind-locals
- (normalize-r-functions
- (fancy-assignment-transform
- (dollarsign-transform
- (flatten-all-op && (flatten-all-op \|\| e)))))))
--- a/femtolisp/tests/color.lsp
+++ /dev/null
@@ -1,89 +1,0 @@
-; -*- scheme -*-
-
-; dictionaries ----------------------------------------------------------------
-(define (dict-new) ())
-
-(define (dict-extend dl key value)
- (cond ((null? dl) (list (cons key value)))
- ((equal? key (caar dl)) (cons (cons key value) (cdr dl)))
- (else (cons (car dl) (dict-extend (cdr dl) key value)))))
-
-(define (dict-lookup dl key)
- (cond ((null? dl) ())
- ((equal? key (caar dl)) (cdar dl))
- (else (dict-lookup (cdr dl) key))))
-
-(define (dict-keys dl) (map car dl))
-
-; graphs ----------------------------------------------------------------------
-(define (graph-empty) (dict-new))
-
-(define (graph-connect g n1 n2)
- (dict-extend
- (dict-extend g n2 (cons n1 (dict-lookup g n2)))
- n1
- (cons n2 (dict-lookup g n1))))
-
-(define (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1)))
-
-(define (graph-neighbors g n) (dict-lookup g n))
-
-(define (graph-nodes g) (dict-keys g))
-
-(define (graph-add-node g n1) (dict-extend g n1 ()))
-
-(define (graph-from-edges edge-list)
- (if (null? edge-list)
- (graph-empty)
- (graph-connect (graph-from-edges (cdr edge-list))
- (caar edge-list)
- (cdar edge-list))))
-
-; graph coloring --------------------------------------------------------------
-(define (node-colorable? g coloring node-to-color color-of-node)
- (not (member
- color-of-node
- (map
- (lambda (n)
- (let ((color-pair (assq n coloring)))
- (if (pair? color-pair) (cdr color-pair) ())))
- (graph-neighbors g node-to-color)))))
-
-(define (try-each f lst)
- (if (null? lst) #f
- (let ((ret (f (car lst))))
- (if ret ret (try-each f (cdr lst))))))
-
-(define (color-node g coloring colors uncolored-nodes color)
- (cond
- ((null? uncolored-nodes) coloring)
- ((node-colorable? g coloring (car uncolored-nodes) color)
- (let ((new-coloring
- (cons (cons (car uncolored-nodes) color) coloring)))
- (try-each (lambda (c)
- (color-node g new-coloring colors (cdr uncolored-nodes) c))
- colors)))))
-
-(define (color-graph g colors)
- (if (null? colors)
- (and (null? (graph-nodes g)) ())
- (color-node g () colors (graph-nodes g) (car colors))))
-
-(define (color-pairs pairs colors)
- (color-graph (graph-from-edges pairs) colors))
-
-; queens ----------------------------------------------------------------------
-(define (can-attack x y)
- (let ((x1 (mod x 5))
- (y1 (truncate (/ x 5)))
- (x2 (mod y 5))
- (y2 (truncate (/ y 5))))
- (or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1))))))
-
-(define (generate-5x5-pairs)
- (let ((result ()))
- (dotimes (x 25)
- (dotimes (y 25)
- (if (and (not (= x y)) (can-attack x y))
- (set! result (cons (cons x y) result)) ())))
- result))
--- a/femtolisp/tests/equal.scm
+++ /dev/null
@@ -1,68 +1,0 @@
-; Terminating equal predicate
-; by Jeff Bezanson
-;
-; This version only considers pairs and simple atoms.
-
-; equal?, with bounded recursion. returns 0 if we suspect
-; nontermination, otherwise #t or #f for the correct answer.
-(define (bounded-equal a b N)
- (cond ((<= N 0) 0)
- ((and (pair? a) (pair? b))
- (let ((as
- (bounded-equal (car a) (car b) (- N 1))))
- (if (number? as)
- 0
- (and as
- (bounded-equal (cdr a) (cdr b) (- N 1))))))
- (else (eq? a b))))
-
-; union-find algorithm
-
-; find equivalence class of a cons cell, or #f if not yet known
-; the root of a class is a cons that is its own class
-(define (class table key)
- (let ((c (hashtable-ref table key #f)))
- (if (or (not c) (eq? c key))
- c
- (class table c))))
-
-; move a and b to the same equivalence class, given c and cb
-; as the current values of (class table a) and (class table b)
-; Note: this is not quite optimal. We blindly pick 'a' as the
-; root of the new class, but we should pick whichever class is
-; larger.
-(define (union! table a b c cb)
- (let ((ca (if c c a)))
- (if cb
- (hashtable-set! table cb ca))
- (hashtable-set! table a ca)
- (hashtable-set! table b ca)))
-
-; cyclic equal. first, attempt to compare a and b as best
-; we can without recurring. if we can't prove them different,
-; set them equal and move on.
-(define (cyc-equal a b table)
- (cond ((eq? a b) #t)
- ((not (and (pair? a) (pair? b))) (eq? a b))
- (else
- (let ((aa (car a)) (da (cdr a))
- (ab (car b)) (db (cdr b)))
- (cond ((or (not (eq? (atom? aa) (atom? ab)))
- (not (eq? (atom? da) (atom? db)))) #f)
- ((and (atom? aa)
- (not (eq? aa ab))) #f)
- ((and (atom? da)
- (not (eq? da db))) #f)
- (else
- (let ((ca (class table a))
- (cb (class table b)))
- (if (and ca cb (eq? ca cb))
- #t
- (begin (union! table a b ca cb)
- (and (cyc-equal aa ab table)
- (cyc-equal da db table)))))))))))
-
-(define (equal a b)
- (let ((guess (bounded-equal a b 2048)))
- (if (boolean? guess) guess
- (cyc-equal a b (make-eq-hashtable)))))
--- a/femtolisp/tests/err.lsp
+++ /dev/null
@@ -1,4 +1,0 @@
-(define (f x) (begin (list-tail '(1) 3) 3))
-(f 2)
-a
-(trycatch a (lambda (e) (print (stacktrace))))
--- a/femtolisp/tests/hashtest.lsp
+++ /dev/null
@@ -1,40 +1,0 @@
-; -*- scheme -*-
-
-(define (hins1)
- (let ((h (table)))
- (dotimes (n 200000)
- (put! h (mod (rand) 1000) 'apple))
- h))
-
-(define (hread h)
- (dotimes (n 200000)
- (get h (mod (rand) 10000) nil)))
-
-(time (dotimes (i 100000)
- (table :a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :foo 8 :bar 9)))
-(time (dotimes (i 100000) (table :a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :foo 8)))
-(time (dotimes (i 100000) (table :a 1 :b 2 :c 3 :d 4)))
-(time (dotimes (i 100000) (table :a 1 :b 2)))
-(time (dotimes (i 100000) (table)))
-
-#t
-
-#|
-
-with HT_N_INLINE==16
-Elapsed time: 0.0796329975128174 seconds
-Elapsed time: 0.0455679893493652 seconds
-Elapsed time: 0.0272290706634521 seconds
-Elapsed time: 0.0177979469299316 seconds
-Elapsed time: 0.0102229118347168 seconds
-
-
-with HT_N_INLINE==8
-
-Elapsed time: 0.1010119915008545 seconds
-Elapsed time: 0.174872875213623 seconds
-Elapsed time: 0.0322129726409912 seconds
-Elapsed time: 0.0195930004119873 seconds
-Elapsed time: 0.008836030960083 seconds
-
-|#
--- a/femtolisp/tests/perf.lsp
+++ /dev/null
@@ -1,37 +1,0 @@
-(load "test.lsp")
-
-(princ "colorgraph: ")
-(load "tcolor.lsp")
-
-(princ "fib(34): ")
-(assert (equal? (time (fib 34)) 5702887))
-(princ "yfib(32): ")
-(assert (equal? (time (yfib 32)) 2178309))
-
-(princ "sort: ")
-(set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
-(time (simple-sort r))
-
-(princ "expand: ")
-(time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2))))
-
-(define (my-append . lsts)
- (cond ((null? lsts) ())
- ((null? (cdr lsts)) (car lsts))
- (else (letrec ((append2 (lambda (l d)
- (if (null? l) d
- (cons (car l)
- (append2 (cdr l) d))))))
- (append2 (car lsts) (apply my-append (cdr lsts)))))))
-
-(princ "append: ")
-(set! L (map-int (lambda (x) (map-int identity 20)) 20))
-(time (dotimes (n 1000) (apply my-append L)))
-
-(path.cwd "ast")
-(princ "p-lambda: ")
-(load "rpasses.lsp")
-(define *input* (load "datetimeR.lsp"))
-(time (set! *output* (compile-ish *input*)))
-(assert (equal? *output* (load "rpasses-out.lsp")))
-(path.cwd "..")
--- a/femtolisp/tests/pisum.lsp
+++ /dev/null
@@ -1,8 +1,0 @@
-(define (pisum)
- (dotimes (j 500)
- ((label sumloop
- (lambda (i sum)
- (if (> i 10000)
- sum
- (sumloop (+ i 1) (+ sum (/ (* i i)))))))
- 1.0 0.0)))
--- a/femtolisp/tests/printcases.lsp
+++ /dev/null
@@ -1,26 +1,0 @@
-expand
-append
-bq-process
-
-(define (syntax-environment)
- (map (lambda (s) (cons s (symbol-syntax s)))
- (filter symbol-syntax (environment))))
-
-(syntax-environment)
-
-(symbol-syntax 'try)
-
-(map-int (lambda (x) `(a b c d e)) 90)
-
-(list->vector (map-int (lambda (x) `(a b c d e)) 90))
-
-'((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y))
-
-'((lambda (x y) (if (< x y) x yffffffffffffffffffff)) (a b c) (d e f) 2 3 (r t y))
-
-'((lambda (x y) (if (< x y) x y)) (a b c) (d (e zz zzz) f) 2 3 (r t y))
-
-'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
- (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
- (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
- (3 . d) (2 . c) (0 . b) (1 . a))
--- a/femtolisp/tests/tcolor.lsp
+++ /dev/null
@@ -1,16 +1,0 @@
-; -*- scheme -*-
-; color for performance
-
-(load "color.lsp")
-
-; 100x color 5 queens
-(define Q (generate-5x5-pairs))
-(define (ct)
- (set! C (color-pairs Q '(a b c d e)))
- (dotimes (n 99) (color-pairs Q '(a b c d e))))
-(time (ct))
-(assert (equal? C
- '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
- (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
- (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
- (3 . d) (2 . c) (0 . b) (1 . a))))
--- a/femtolisp/tests/test.lsp
+++ /dev/null
@@ -1,294 +1,0 @@
-; -*- scheme -*-
-
-; make label self-evaluating, but evaluating the lambda in the process
-;(defmacro labl (name f)
-; (list list ''labl (list 'quote name) f))
-
-(define-macro (labl name f)
- `(let (,name) (set! ,name ,f)))
-
-;(define (reverse lst)
-; ((label rev-help (lambda (lst result)
-; (if (null? lst) result
-; (rev-help (cdr lst) (cons (car lst) result)))))
-; lst ()))
-
-(define (append- . lsts)
- ((label append-h
- (lambda (lsts)
- (cond ((null? lsts) ())
- ((null? (cdr lsts)) (car lsts))
- (#t ((label append2 (lambda (l d)
- (if (null? l) d
- (cons (car l)
- (append2 (cdr l) d)))))
- (car lsts) (append-h (cdr lsts)))))))
- lsts))
-
-;(princ 'Hello '| | 'world! "\n")
-;(filter (lambda (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0))
-(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
-;(princ (time (fib 34)) "\n")
-;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8))
-;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6)))
-;(dotimes (i 80000) (list 1 2 3 4 5))
-;(set! a (map-int identity 10000))
-;(dotimes (i 200) (rfoldl cons () a))
-
-#|
-(define-macro (dotimes var . body)
- (let ((v (car var))
- (cnt (cadr var)))
- `(let ((,v 0))
- (while (< ,v ,cnt)
- (prog1
- ,(cons 'begin body)
- (set! ,v (+ ,v 1)))))))
-
-(define (map-int f n)
- (if (<= n 0)
- ()
- (let ((first (cons (f 0) ())))
- ((label map-int-
- (lambda (acc i n)
- (if (= i n)
- first
- (begin (set-cdr! acc (cons (f i) ()))
- (map-int- (cdr acc) (+ i 1) n)))))
- first 1 n))))
-|#
-
-(define-macro (labl name fn)
- `((lambda (,name) (set! ,name ,fn)) ()))
-
-(define (square x) (* x x))
-(define (expt b p)
- (cond ((= p 0) 1)
- ((= b 0) 0)
- ((even? p) (square (expt b (div0 p 2))))
- (#t (* b (expt b (- p 1))))))
-
-(define (gcd a b)
- (cond ((= a 0) b)
- ((= b 0) a)
- ((< a b) (gcd a (- b a)))
- (#t (gcd b (- a b)))))
-
-; like eval-when-compile
-(define-macro (literal expr)
- (let ((v (eval expr)))
- (if (self-evaluating? v) v (list quote v))))
-
-(define (cardepth l)
- (if (atom? l) 0
- (+ 1 (cardepth (car l)))))
-
-(define (nestlist f zero n)
- (if (<= n 0) ()
- (cons zero (nestlist f (f zero) (- n 1)))))
-
-(define (mapl f . lsts)
- ((label mapl-
- (lambda (lsts)
- (if (null? (car lsts)) ()
- (begin (apply f lsts) (mapl- (map cdr lsts))))))
- lsts))
-
-; test to see if a symbol begins with :
-(define (keywordp s)
- (and (>= s '|:|) (<= s '|:~|)))
-
-; swap the cars and cdrs of every cons in a structure
-(define (swapad c)
- (if (atom? c) c
- (set-cdr! c (K (swapad (car c))
- (set-car! c (swapad (cdr c)))))))
-
-(define (without x l)
- (filter (lambda (e) (not (eq e x))) l))
-
-(define (conscount c)
- (if (pair? c) (+ 1
- (conscount (car c))
- (conscount (cdr c)))
- 0))
-
-; _ Welcome to
-; (_ _ _ |_ _ | . _ _ 2
-; | (-||||_(_)|__|_)|_)
-; ==================|==
-
-;[` _ ,_ |- | . _ 2
-;| (/_||||_()|_|_\|)
-; |
-
-(define-macro (while- test . forms)
- `((label -loop- (lambda ()
- (if ,test
- (begin ,@forms
- (-loop-))
- ())))))
-
-; this would be a cool use of thunking to handle 'finally' clauses, but
-; this code doesn't work in the case where the user manually re-raises
-; inside a catch block. one way to handle it would be to replace all
-; their uses of 'raise' with '*_try_finally_raise_*' which calls the thunk.
-; (try expr
-; (catch (TypeError e) . exprs)
-; (catch (IOError e) . exprs)
-; (finally . exprs))
-(define-macro (try expr . forms)
- (let ((final (f-body (cdr (or (assq 'finally forms) '(())))))
- (body (foldr
- ; create a function to check for and handle one exception
- ; type, and pass off control to the next when no match
- (lambda (catc next)
- (let ((var (cadr (cadr catc)))
- (extype (caadr catc))
- (todo (f-body (cddr catc))))
- `(lambda (,var)
- (if (or (eq ,var ',extype)
- (and (pair? ,var)
- (eq (car ,var) ',extype)))
- ,todo
- (,next ,var)))))
-
- ; default function; no matches so re-raise
- '(lambda (e) (begin (*_try_finally_thunk_*) (raise e)))
-
- ; make list of catch forms
- (filter (lambda (f) (eq (car f) 'catch)) forms))))
- `(let ((*_try_finally_thunk_* (lambda () ,final)))
- (prog1 (attempt ,expr ,body)
- (*_try_finally_thunk_*)))))
-
-(define Y
- (lambda (f)
- ((lambda (h)
- (f (lambda (x) ((h h) x))))
- (lambda (h)
- (f (lambda (x) ((h h) x)))))))
-
-(define yfib
- (Y (lambda (fib)
- (lambda (n)
- (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
-
-;(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) )))
-;(tt)
-;(tt)
-;(tt)
-
-(define-macro (accumulate-while cnd what . body)
- (let ((acc (gensym)))
- `(let ((,acc (list ())))
- (cdr
- (prog1 ,acc
- (while ,cnd
- (begin (set! ,acc
- (cdr (set-cdr! ,acc (cons ,what ()))))
- ,@body)))))))
-
-(define-macro (accumulate-for var lo hi what . body)
- (let ((acc (gensym)))
- `(let ((,acc (list ())))
- (cdr
- (prog1 ,acc
- (for ,lo ,hi
- (lambda (,var)
- (begin (set! ,acc
- (cdr (set-cdr! ,acc (cons ,what ()))))
- ,@body))))))))
-
-(define (map-indexed f lst)
- (if (atom? lst) lst
- (let ((i 0))
- (accumulate-while (pair? lst) (f (car lst) i)
- (begin (set! lst (cdr lst))
- (set! i (1+ i)))))))
-
-(define (string.findall haystack needle . offs)
- (define (sub h n offs lst)
- (let ((i (string.find h n offs)))
- (if i
- (sub h n (string.inc h i) (cons i lst))
- (reverse! lst))))
- (sub haystack needle (if (null? offs) 0 (car offs)) ()))
-
-(let ((*profiles* (table)))
- (set! profile
- (lambda (s)
- (let ((f (top-level-value s)))
- (put! *profiles* s (cons 0 0))
- (set-top-level-value! s
- (lambda args
- (define tt (get *profiles* s))
- (define count (car tt))
- (define time (cdr tt))
- (define t0 (time.now))
- (define v (apply f args))
- (set-cdr! tt (+ time (- (time.now) t0)))
- (set-car! tt (+ count 1))
- v)))))
- (set! show-profiles
- (lambda ()
- (define pr (filter (lambda (x) (> (cadr x) 0))
- (table.pairs *profiles*)))
- (define width (+ 4
- (apply max
- (map (lambda (x)
- (length (string x)))
- (cons 'Function
- (map car pr))))))
- (princ (string.rpad "Function" width #\ )
- "#Calls Time (seconds)")
- (newline)
- (princ (string.rpad "--------" width #\ )
- "------ --------------")
- (newline)
- (for-each
- (lambda (p)
- (princ (string.rpad (string (caddr p)) width #\ )
- (string.rpad (string (cadr p)) 11 #\ )
- (car p))
- (newline))
- (simple-sort (map (lambda (l) (reverse (to-proper l)))
- pr)))))
- (set! clear-profiles
- (lambda ()
- (for-each (lambda (k)
- (put! *profiles* k (cons 0 0)))
- (table.keys *profiles*)))))
-
-#;(for-each profile
- '(emit encode-byte-code const-to-idx-vec
- index-of lookup-sym in-env? any every
- compile-sym compile-if compile-begin
- compile-arglist expand builtin->instruction
- compile-app separate nconc get-defined-vars
- compile-in compile compile-f delete-duplicates
- map length> length= count filter append
- lastcdr to-proper reverse reverse! list->vector
- table.foreach list-head list-tail assq memq assoc member
- assv memv nreconc bq-process))
-
-(define (filt1 pred lst)
- (define (filt1- pred lst accum)
- (if (null? lst) accum
- (if (pred (car lst))
- (filt1- pred (cdr lst) (cons (car lst) accum))
- (filt1- pred (cdr lst) accum))))
- (filt1- pred lst ()))
-
-(define (filto pred lst (accum ()))
- (if (atom? lst) accum
- (if (pred (car lst))
- (filto pred (cdr lst) (cons (car lst) accum))
- (filto pred (cdr lst) accum))))
-
-; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
-(define (pairwise? pred . args)
- (or (null? args)
- (let f ((a (car args)) (d (cdr args)))
- (or (null? d)
- (and (pred a (car d)) (f (car d) (cdr d)))))))
--- a/femtolisp/tests/tme.lsp
+++ /dev/null
@@ -1,4 +1,0 @@
-(let ((t (table)))
- (time (dotimes (i 2000000)
- (put! t (rand) (rand)))))
-#t
--- a/femtolisp/tests/torture.scm
+++ /dev/null
@@ -1,24 +1,0 @@
-(define ones (map (lambda (x) 1) (iota 1000000)))
-
-(write (apply + ones))
-(newline)
-
-(define (big n)
- (if (<= n 0)
- 0
- `(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
-
-(define nst (big 100000))
-
-(write (eval nst))
-(newline)
-
-(define longg (cons '+ ones))
-(write (eval longg))
-(newline)
-
-(define (f x)
- (begin (write x)
- (newline)
- (f (+ x 1))
- 0))
--- a/femtolisp/tests/torus.lsp
+++ /dev/null
@@ -1,48 +1,0 @@
-; -*- scheme -*-
-(define (maplist f l)
- (if (null? l) ()
- (cons (f l) (maplist f (cdr l)))))
-
-; produce a beautiful, toroidal cons structure
-; make m copies of a CDR-circular list of length n, and connect corresponding
-; conses in CAR-circular loops
-; replace maplist 'identity' with 'copy-tree' for rapdily exploding memory use
-(define (torus m n)
- (let* ((l (map-int identity n))
- (g l)
- (prev g))
- (dotimes (i (- m 1))
- (set! prev g)
- (set! g (maplist identity g))
- (set-cdr! (last-pair prev) prev))
- (set-cdr! (last-pair g) g)
- (let ((a l)
- (b g))
- (dotimes (i n)
- (set-car! a b)
- (set! a (cdr a))
- (set! b (cdr b))))
- l))
-
-(define (cyl m n)
- (let* ((l (map-int identity n))
- (g l))
- (dotimes (i (- m 1))
- (set! g (maplist identity g)))
- (let ((a l)
- (b g))
- (dotimes (i n)
- (set-car! a b)
- (set! a (cdr a))
- (set! b (cdr b))))
- l))
-
-(time (begin (print (torus 100 100)) ()))
-;(time (dotimes (i 1) (load "100x100.lsp")))
-; with ltable
-; printing time: 0.415sec
-; reading time: 0.165sec
-
-; with ptrhash
-; printing time: 0.081sec
-; reading time: 0.0264sec
--- a/femtolisp/tests/unittest.lsp
+++ /dev/null
@@ -1,274 +1,0 @@
-; -*- scheme -*-
-(define-macro (assert-fail expr . what)
- `(assert (trycatch (begin ,expr #f)
- (lambda (e) ,(if (null? what) #t
- `(eq? (car e) ',(car what)))))))
-
-(define (every-int n)
- (list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n)
- (int64 n) (uint64 n)))
-
-(define (every-sint n)
- (list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n)))
-
-(define (each f l)
- (if (atom? l) ()
- (begin (f (car l))
- (each f (cdr l)))))
-
-(define (each^2 f l m)
- (each (lambda (o) (each (lambda (p) (f o p)) m)) l))
-
-(define (test-lt a b)
- (each^2 (lambda (neg pos)
- (begin
- (eval `(assert (= -1 (compare ,neg ,pos))))
- (eval `(assert (= 1 (compare ,pos ,neg))))))
- a
- b))
-
-(define (test-eq a b)
- (each^2 (lambda (a b)
- (begin
- (eval `(assert (= 0 (compare ,a ,b))))))
- a
- b))
-
-(test-lt (every-sint -1) (every-int 1))
-(test-lt (every-int 0) (every-int 1))
-(test-eq (every-int 88) (every-int 88))
-(test-eq (every-sint -88) (every-sint -88))
-
-(define (test-square a)
- (each (lambda (i) (eval `(assert (>= (* ,i ,i) 0))))
- a))
-
-(test-square (every-sint -67))
-(test-square (every-int 3))
-(test-square (every-int 0x80000000))
-(test-square (every-sint 0x80000000))
-(test-square (every-sint -0x80000000))
-
-(assert (= (* 128 0x02000001) 0x100000080))
-
-(assert (= (/ 1) 1))
-(assert (= (/ -1) -1))
-(assert (= (/ 2.0) 0.5))
-
-(assert (= (- 4999950000 4999941999) 8001))
-
-(assert (not (eqv? 10 #\newline)))
-(assert (not (eqv? #\newline 10)))
-
-; tricky cases involving INT_MIN
-(assert (< (- #uint32(0x80000000)) 0))
-(assert (> (- #int32(0x80000000)) 0))
-(assert (< (- #uint64(0x8000000000000000)) 0))
-(assert (> (- #int64(0x8000000000000000)) 0))
-
-(assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000))))
-(assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
- #uint64(0x8000000000000000)))
-(assert (equal? (* 2 #int64(0x4000000000000000))
- #uint64(0x8000000000000000)))
-
-(assert (equal? (uint64 (double -123)) #uint64(0xffffffffffffff85)))
-
-(assert (equal? (string 'sym #byte(65) #wchar(945) "blah") "symA\u03B1blah"))
-
-; NaNs
-(assert (equal? +nan.0 +nan.0))
-(assert (not (= +nan.0 +nan.0)))
-(assert (not (= +nan.0 -nan.0)))
-(assert (equal? (< +nan.0 3) (> 3 +nan.0)))
-(assert (equal? (< +nan.0 (double 3)) (> (double 3) +nan.0)))
-(assert (equal? (< +nan.0 3) (> (double 3) +nan.0)))
-(assert (equal? (< +nan.0 (double 3)) (> 3 +nan.0)))
-(assert (equal? (< +nan.0 3) (< +nan.0 (double 3))))
-(assert (equal? (> +nan.0 3) (> +nan.0 (double 3))))
-(assert (equal? (< 3 +nan.0) (> +nan.0 (double 3))))
-(assert (equal? (> 3 +nan.0) (> (double 3) +nan.0)))
-(assert (not (>= +nan.0 +nan.0)))
-
-; -0.0 etc.
-(assert (not (equal? 0.0 0)))
-(assert (equal? 0.0 0.0))
-(assert (not (equal? -0.0 0.0)))
-(assert (not (equal? -0.0 0)))
-(assert (not (eqv? 0.0 0)))
-(assert (not (eqv? -0.0 0)))
-(assert (not (eqv? -0.0 0.0)))
-(assert (= 0.0 -0.0))
-
-; this crashed once
-(for 1 10 (lambda (i) 0))
-
-; failing applications
-(assert-fail ((lambda (x) x) 1 2))
-(assert-fail ((lambda (x) x)))
-(assert-fail ((lambda (x y . z) z) 1))
-(assert-fail (car 'x) type-error)
-(assert-fail gjegherqpfdf___trejif unbound-error)
-
-; long argument lists
-(assert (= (apply + (iota 100000)) 4999950000))
-(define ones (map (lambda (x) 1) (iota 80000)))
-(assert (= (eval `(if (< 2 1)
- (+ ,@ones)
- (+ ,@(cdr ones))))
- 79999))
-
-(define MAX_ARGS 255)
-
-(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 1))))
-(define f (compile `(lambda ,as ,(lastcdr as))))
-(assert (equal? (apply f (iota (+ MAX_ARGS 0))) `()))
-(assert (equal? (apply f (iota (+ MAX_ARGS 1))) `(,MAX_ARGS)))
-(assert (equal? (apply f (iota (+ MAX_ARGS 2))) `(,MAX_ARGS ,(+ MAX_ARGS 1))))
-
-(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 100))))
-(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
- ,(car (last-pair as)))))
-(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
-(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
- (lambda () ,(car (last-pair as))))))
-(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
-
-(define as (map-int (lambda (x) (gensym)) 1000))
-(define f (compile `(lambda ,as ,(car (last-pair as)))))
-(assert (equal? (apply f (iota 1000)) 999))
-
-(define as (apply list* (map-int (lambda (x) (gensym)) 995)))
-(define f (compile `(lambda ,as ,(lastcdr as))))
-(assert (equal? (apply f (iota 994)) '()))
-(assert (equal? (apply f (iota 995)) '(994)))
-(assert (equal? (apply f (iota 1000)) '(994 995 996 997 998 999)))
-
-; optional arguments
-(assert (equal? ((lambda ((b 0)) b)) 0))
-(assert (equal? ((lambda (a (b 2)) (list a b)) 1) '(1 2)))
-(assert (equal? ((lambda (a (b 2)) (list a b)) 1 3) '(1 3)))
-(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1) '(1 2 3)))
-(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8) '(1 8 3)))
-(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8 9) '(1 8 9)))
-(assert (equal? ((lambda ((x 0) . r) (list x r))) '(0 ())))
-(assert (equal? ((lambda ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
-
-; keyword arguments
-(assert (keyword? kw:))
-(assert (not (keyword? 'kw)))
-(assert (not (keyword? ':)))
-(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
- '(1 0 0 (8 4 5))))
-(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
- '(0 2 3 (1))))
-(define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d))
-(assert (equal? (keys4 a: 10) '(10 3 7 6)))
-(assert (equal? (keys4 b: 10) '(8 10 7 6)))
-(assert (equal? (keys4 c: 10) '(8 3 10 6)))
-(assert (equal? (keys4 d: 10) '(8 3 7 10)))
-(assert-fail (keys4 e: 10)) ; unsupported keyword
-(assert-fail (keys4 a: 1 b:)) ; keyword with no argument
-
-; cvalues and arrays
-(assert (equal? (typeof "") '(array byte)))
-(assert-fail (aref #(1) 3) bounds-error)
-(define iarr (array 'int64 32 16 8 7 1))
-(assert (equal? (aref iarr 0) 32))
-(assert (equal? (aref iarr #int8(3)) 7))
-
-; gensyms
-(assert (gensym? (gensym)))
-(assert (not (gensym? 'a)))
-(assert (not (eq? (gensym) (gensym))))
-(assert (not (equal? (string (gensym)) (string (gensym)))))
-(let ((gs (gensym))) (assert (eq? gs gs)))
-
-; eof object
-(assert (eof-object? (eof-object)))
-(assert (not (eof-object? 1)))
-(assert (not (eof-object? 'a)))
-(assert (not (eof-object? '())))
-(assert (not (eof-object? #f)))
-(assert (not (null? (eof-object))))
-(assert (not (builtin? (eof-object))))
-(assert (not (function? (eof-object))))
-
-; ok, a couple end-to-end tests as well
-(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
-(assert (equal? (fib 20) 6765))
-
-(load "color.lsp")
-(assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e))
- '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
- (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
- (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
- (3 . d) (2 . c) (0 . b) (1 . a))))
-
-; hashing strange things
-(assert (equal?
- (hash '#0=(1 1 #0# . #0#))
- (hash '#1=(1 1 #1# 1 1 #1# . #1#))))
-
-(assert (not (equal?
- (hash '#0=(1 1 #0# . #0#))
- (hash '#1=(1 2 #1# 1 1 #1# . #1#)))))
-
-(assert (equal?
- (hash '#0=((1 . #0#) . #0#))
- (hash '#1=((1 . #1#) (1 . #1#) . #1#))))
-
-(assert (not (equal?
- (hash '#0=((1 . #0#) . #0#))
- (hash '#1=((2 . #1#) (1 . #1#) . #1#)))))
-
-(assert (not (equal?
- (hash '#0=((1 . #0#) . #0#))
- (hash '#1=((1 . #1#) (2 . #1#) . #1#)))))
-
-(assert (equal?
- (hash '(#0=(#0#) 0))
- (hash '(#1=(((((#1#))))) 0))))
-
-(assert (not (equal?
- (hash '(#0=(#0#) 0))
- (hash '(#1=(((((#1#))))) 1)))))
-
-(assert (equal?
- (hash #0=[1 [2 [#0#]] 3])
- (hash #1=[1 [2 [[1 [2 [#1#]] 3]]] 3])))
-
-(assert (not (equal?
- (hash #0=[1 [2 [#0#]] 3])
- (hash #1=[1 [2 [[5 [2 [#1#]] 3]]] 3]))))
-
-(assert (equal?
- (hash #0=[1 #0# [2 [#0#]] 3])
- (hash #1=[1 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3])))
-
-(assert (not (equal?
- (hash #0=[1 #0# [2 [#0#]] 3])
- (hash #1=[6 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3]))))
-
-(assert (equal?
- (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])
- (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])))
-
-(assert (not (equal?
- (hash [6 1 [2 [[3 1 [2 [1]] 3]]] 3])
- (hash [6 1 [2 [[1 1 [2 [1]] 3]]] 3]))))
-
-(assert (equal? (hash '#0=(1 . #0#))
- (hash '#1=(1 1 . #1#))))
-
-(assert (not (equal? (hash '#0=(1 1 . #0#))
- (hash '#1=(1 #0# . #1#)))))
-
-(assert (not (equal? (hash (iota 10))
- (hash (iota 20)))))
-
-(assert (not (equal? (hash (iota 41))
- (hash (iota 42)))))
-
-(princ "all tests pass\n")
-#t
--- a/femtolisp/tests/wt.lsp
+++ /dev/null
@@ -1,28 +1,0 @@
-(define-macro (while- test . forms)
- `((label -loop- (lambda ()
- (if ,test
- (begin ,@forms
- (-loop-))
- ())))))
-
-(define (tw)
- (set! i 0)
- (while (< i 10000000) (set! i (+ i 1))))
-
-(define (tw2)
- (letrec ((loop (lambda ()
- (if (< i 10000000)
- (begin (set! i (+ i 1))
- (loop))
- ()))))
- (loop)))
-
-#|
-interpreter:
-while: 1.82sec
-macro: 2.98sec
-
-compiler:
-while: 0.72sec
-macro: 1.24sec
-|#
--- a/femtolisp/tiny/Makefile
+++ /dev/null
@@ -1,22 +1,0 @@
-CC = gcc
-
-NAME = lisp
-SRC = $(NAME).c
-EXENAME = $(NAME)
-
-FLAGS = -Wall -Wextra
-LIBS =
-
-DEBUGFLAGS = -g -DDEBUG $(FLAGS)
-SHIPFLAGS = -O3 -fomit-frame-pointer $(FLAGS)
-
-default: release
-
-debug: $(SRC)
- $(CC) $(DEBUGFLAGS) $(SRC) -o $(EXENAME) $(LIBS)
-
-release: $(SRC)
- $(CC) $(SHIPFLAGS) $(SRC) -o $(EXENAME) $(LIBS)
-
-clean:
- rm -f $(EXENAME)
--- a/femtolisp/tiny/eval1
+++ /dev/null
@@ -1,390 +1,0 @@
-value_t eval_sexpr(value_t e, value_t *penv)
-{- value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
- value_t *rest;
- cons_t *c;
- symbol_t *sym;
- u_int32_t saveSP;
- int i, nargs, noeval=0;
- number_t s, n;
-
- if (issymbol(e)) {- sym = (symbol_t*)ptr(e);
- if (sym->constant != UNBOUND) return sym->constant;
- v = *penv;
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == e)
- return cdr_(bind);
- v = cdr_(v);
- }
- if ((v = sym->binding) == UNBOUND)
- lerror("eval: error: variable %s has no value\n", sym->name);- return v;
- }
- if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
- lerror("eval: error: stack overflow\n");- saveSP = SP;
- PUSH(e);
- f = eval(car_(e), penv);
- if (isbuiltin(f)) {- // handle builtin function
- if (!isspecial(f)) {- // evaluate argument list, placing arguments on stack
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- while (iscons(v)) {- v = eval(car_(v), penv);
- PUSH(v);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- }
- apply_builtin:
- nargs = SP - saveSP - 1;
- switch (intval(f)) {- // special forms
- case F_QUOTE:
- v = cdr_(Stack[saveSP]);
- if (!iscons(v))
- lerror("quote: error: expected argument\n");- v = car_(v);
- break;
- case F_MACRO:
- case F_LAMBDA:
- v = Stack[saveSP];
- if (*penv != NIL) {- // build a closure (lambda args body . env)
- v = cdr_(v);
- PUSH(car(v));
- argsyms = &Stack[SP-1];
- PUSH(car(cdr_(v)));
- body = &Stack[SP-1];
- v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
- cons(argsyms, cons(body, penv)));
- }
- break;
- case F_LABEL:
- v = Stack[saveSP];
- if (*penv != NIL) {- v = cdr_(v);
- PUSH(car(v)); // name
- pv = &Stack[SP-1];
- PUSH(car(cdr_(v))); // function
- body = &Stack[SP-1];
- *body = eval(*body, penv); // evaluate lambda
- v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
- }
- break;
- case F_IF:
- v = car(cdr_(Stack[saveSP]));
- if (eval(v, penv) != NIL)
- v = car(cdr_(cdr_(Stack[saveSP])));
- else
- v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
- v = eval(v, penv);
- break;
- case F_COND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- c = tocons(car_(*pv), "cond");
- if ((v=eval(c->car, penv)) != NIL) {- *pv = cdr_(car_(*pv));
- // evaluate body forms
- while (iscons(*pv)) {- v = eval(car_(*pv), penv);
- *pv = cdr_(*pv);
- }
- break;
- }
- *pv = cdr_(*pv);
- }
- break;
- case F_AND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = T;
- while (iscons(*pv)) {- if ((v=eval(car_(*pv), penv)) == NIL)
- break;
- *pv = cdr_(*pv);
- }
- break;
- case F_OR:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- if ((v=eval(car_(*pv), penv)) != NIL)
- break;
- *pv = cdr_(*pv);
- }
- break;
- case F_WHILE:
- PUSH(car(cdr(cdr_(Stack[saveSP]))));
- body = &Stack[SP-1];
- Stack[saveSP] = car_(cdr_(Stack[saveSP]));
- value_t *cond = &Stack[saveSP];
- PUSH(NIL); pv = &Stack[SP-1];
- while (eval(*cond, penv) != NIL)
- *pv = eval(*body, penv);
- v = *pv;
- break;
- case F_PROGN:
- // return last arg
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- v = eval(car_(*pv), penv);
- *pv = cdr_(*pv);
- }
- break;
-
- // ordinary functions
- case F_SET:
- argcount("set", nargs, 2);- e = Stack[SP-2];
- v = *penv;
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == e) {- cdr_(bind) = (v=Stack[SP-1]);
- SP=saveSP; return v;
- }
- v = cdr_(v);
- }
- tosymbol(e, "set")->binding = (v=Stack[SP-1]);
- break;
- case F_BOUNDP:
- argcount("boundp", nargs, 1);- if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
- v = NIL;
- else
- v = T;
- break;
- case F_EQ:
- argcount("eq", nargs, 2);- v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
- break;
- case F_CONS:
- argcount("cons", nargs, 2);- v = mk_cons();
- car_(v) = Stack[SP-2];
- cdr_(v) = Stack[SP-1];
- break;
- case F_CAR:
- argcount("car", nargs, 1);- v = car(Stack[SP-1]);
- break;
- case F_CDR:
- argcount("cdr", nargs, 1);- v = cdr(Stack[SP-1]);
- break;
- case F_RPLACA:
- argcount("rplaca", nargs, 2);- car(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_RPLACD:
- argcount("rplacd", nargs, 2);- cdr(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_ATOM:
- argcount("atom", nargs, 1);- v = ((!iscons(Stack[SP-1])) ? T : NIL);
- break;
- case F_SYMBOLP:
- argcount("symbolp", nargs, 1);- v = ((issymbol(Stack[SP-1])) ? T : NIL);
- break;
- case F_NUMBERP:
- argcount("numberp", nargs, 1);- v = ((isnumber(Stack[SP-1])) ? T : NIL);
- break;
- case F_ADD:
- s = 0;
- for (i=saveSP+1; i < (int)SP; i++) {- n = tonumber(Stack[i], "+");
- s += n;
- }
- v = number(s);
- break;
- case F_SUB:
- if (nargs < 1)
- lerror("-: error: too few arguments\n");- i = saveSP+1;
- s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "-");
- s -= n;
- }
- v = number(s);
- break;
- case F_MUL:
- s = 1;
- for (i=saveSP+1; i < (int)SP; i++) {- n = tonumber(Stack[i], "*");
- s *= n;
- }
- v = number(s);
- break;
- case F_DIV:
- if (nargs < 1)
- lerror("/: error: too few arguments\n");- i = saveSP+1;
- s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "/");
- if (n == 0)
- lerror("/: error: division by zero\n");- s /= n;
- }
- v = number(s);
- break;
- case F_LT:
- argcount("<", nargs, 2);- if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
- v = T;
- else
- v = NIL;
- break;
- case F_NOT:
- argcount("not", nargs, 1);- v = ((Stack[SP-1] == NIL) ? T : NIL);
- break;
- case F_EVAL:
- argcount("eval", nargs, 1);- v = eval(Stack[SP-1], &NIL);
- break;
- case F_PRINT:
- for (i=saveSP+1; i < (int)SP; i++)
- print(stdout, v=Stack[i]);
- break;
- case F_READ:
- argcount("read", nargs, 0);- v = read_sexpr(stdin);
- break;
- case F_LOAD:
- argcount("load", nargs, 1);- v = load_file(tosymbol(Stack[SP-1], "load")->name);
- break;
- case F_PROG1:
- // return first arg
- if (nargs < 1)
- lerror("prog1: error: too few arguments\n");- v = Stack[saveSP+1];
- break;
- case F_APPLY:
- // unpack a list onto the stack
- argcount("apply", nargs, 2);- v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
- f = Stack[SP-2]; // first arg is new function
- POPN(2); // pop apply's args
- if (isbuiltin(f)) {- if (isspecial(f))
- lerror("apply: error: cannot apply special operator "- "%s\n", builtin_names[intval(f)]);
- while (iscons(v)) {- PUSH(car_(v));
- v = cdr_(v);
- }
- goto apply_builtin;
- }
- noeval = 1;
- goto apply_lambda;
- }
- SP = saveSP;
- return v;
- }
- else {- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- apply_lambda:
- if (iscons(f)) {- headsym = car_(f);
- if (headsym == LABEL) {- // (label name (lambda ...)) behaves the same as the lambda
- // alone, except with name bound to the whole label expression
- labl = f;
- f = car(cdr(cdr_(labl)));
- headsym = car(f);
- }
- // apply lambda or macro expression
- PUSH(cdr(cdr(cdr_(f))));
- lenv = &Stack[SP-1];
- PUSH(car_(cdr_(f)));
- argsyms = &Stack[SP-1];
- PUSH(car_(cdr_(cdr_(f))));
- body = &Stack[SP-1];
- if (labl) {- // add label binding to environment
- PUSH(labl);
- PUSH(car_(cdr_(labl)));
- *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
- POPN(3);
- v = Stack[saveSP]; // refetch arglist
- }
- if (headsym == MACRO)
- noeval = 1;
- else if (headsym != LAMBDA)
- lerror("apply: error: head must be lambda, macro, or label\n");- // build a calling environment for the lambda
- // the environment is the argument binds on top of the captured
- // environment
- while (iscons(v)) {- // bind args
- if (!iscons(*argsyms)) {- if (*argsyms == NIL)
- lerror("apply: error: too many arguments\n");- break;
- }
- asym = car_(*argsyms);
- if (!issymbol(asym))
- lerror("apply: error: formal argument not a symbol\n");- v = car_(v);
- if (!noeval) v = eval(v, penv);
- PUSH(v);
- *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
- POPN(2);
- *argsyms = cdr_(*argsyms);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- if (*argsyms != NIL) {- if (issymbol(*argsyms)) {- if (noeval) {- *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
- }
- else {- PUSH(NIL);
- PUSH(NIL);
- rest = &Stack[SP-1];
- // build list of rest arguments
- // we have to build it forwards, which is tricky
- while (iscons(v)) {- v = eval(car_(v), penv);
- PUSH(v);
- v = cons_(&Stack[SP-1], &NIL);
- POP();
- if (iscons(*rest))
- cdr_(*rest) = v;
- else
- Stack[SP-2] = v;
- *rest = v;
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
- }
- }
- else if (iscons(*argsyms)) {- lerror("apply: error: too few arguments\n");- }
- }
- SP = saveSP; // free temporary stack space
- PUSH(*lenv); // preserve environment on stack
- lenv = &Stack[SP-1];
- v = eval(*body, lenv);
- POP();
- // macro: evaluate expansion in the calling environment
- if (headsym == MACRO)
- return eval(v, penv);
- return v;
- }
- type_error("apply", "function", f);- return NIL;
-}
--- a/femtolisp/tiny/eval2
+++ /dev/null
@@ -1,407 +1,0 @@
-value_t eval_sexpr(value_t e, value_t *penv)
-{- value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
- value_t *rest;
- cons_t *c;
- symbol_t *sym;
- u_int32_t saveSP;
- int i, nargs, noeval=0;
- number_t s, n;
-
- if (issymbol(e)) {- sym = (symbol_t*)ptr(e);
- if (sym->constant != UNBOUND) return sym->constant;
- v = *penv;
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == e)
- return cdr_(bind);
- v = cdr_(v);
- }
- if ((v = sym->binding) == UNBOUND)
- lerror("eval: error: variable %s has no value\n", sym->name);- return v;
- }
- if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
- lerror("eval: error: stack overflow\n");- saveSP = SP;
- PUSH(e);
- f = eval(car_(e), penv);
- if (isbuiltin(f)) {- // handle builtin function
- if (!isspecial(f)) {- // evaluate argument list, placing arguments on stack
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- while (iscons(v)) {- v = eval(car_(v), penv);
- PUSH(v);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- }
- apply_builtin:
- nargs = SP - saveSP - 1;
- switch (intval(f)) {- // special forms
- case F_QUOTE:
- v = cdr_(Stack[saveSP]);
- if (!iscons(v))
- lerror("quote: error: expected argument\n");- v = car_(v);
- break;
- case F_MACRO:
- case F_LAMBDA:
- v = Stack[saveSP];
- if (*penv != NIL) {- // build a closure (lambda args body . env)
- v = cdr_(v);
- PUSH(car(v));
- argsyms = &Stack[SP-1];
- PUSH(car(cdr_(v)));
- body = &Stack[SP-1];
- v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
- cons(argsyms, cons(body, penv)));
- }
- break;
- case F_LABEL:
- v = Stack[saveSP];
- if (*penv != NIL) {- v = cdr_(v);
- PUSH(car(v)); // name
- pv = &Stack[SP-1];
- PUSH(car(cdr_(v))); // function
- body = &Stack[SP-1];
- *body = eval(*body, penv); // evaluate lambda
- v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
- }
- break;
- case F_IF:
- v = car(cdr_(Stack[saveSP]));
- if (eval(v, penv) != NIL)
- v = car(cdr_(cdr_(Stack[saveSP])));
- else
- v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
- v = eval(v, penv);
- break;
- case F_COND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- c = tocons(car_(*pv), "cond");
- if ((v=eval(c->car, penv)) != NIL) {- *pv = cdr_(car_(*pv));
- // evaluate body forms
- while (iscons(*pv)) {- v = eval(car_(*pv), penv);
- *pv = cdr_(*pv);
- }
- break;
- }
- *pv = cdr_(*pv);
- }
- break;
- case F_AND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = T;
- while (iscons(*pv)) {- if ((v=eval(car_(*pv), penv)) == NIL)
- break;
- *pv = cdr_(*pv);
- }
- break;
- case F_OR:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- if ((v=eval(car_(*pv), penv)) != NIL)
- break;
- *pv = cdr_(*pv);
- }
- break;
- case F_WHILE:
- PUSH(car(cdr(cdr_(Stack[saveSP]))));
- body = &Stack[SP-1];
- Stack[saveSP] = car_(cdr_(Stack[saveSP]));
- value_t *cond = &Stack[saveSP];
- PUSH(NIL); pv = &Stack[SP-1];
- while (eval(*cond, penv) != NIL)
- *pv = eval(*body, penv);
- v = *pv;
- break;
- case F_PROGN:
- // return last arg
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- v = eval(car_(*pv), penv);
- *pv = cdr_(*pv);
- }
- break;
-
- // ordinary functions
- case F_SET:
- argcount("set", nargs, 2);- e = Stack[SP-2];
- v = *penv;
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == e) {- cdr_(bind) = (v=Stack[SP-1]);
- SP=saveSP; return v;
- }
- v = cdr_(v);
- }
- tosymbol(e, "set")->binding = (v=Stack[SP-1]);
- break;
- case F_BOUNDP:
- argcount("boundp", nargs, 1);- if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
- v = NIL;
- else
- v = T;
- break;
- case F_EQ:
- argcount("eq", nargs, 2);- v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
- break;
- case F_CONS:
- argcount("cons", nargs, 2);- v = mk_cons();
- car_(v) = Stack[SP-2];
- cdr_(v) = Stack[SP-1];
- break;
- case F_CAR:
- argcount("car", nargs, 1);- v = car(Stack[SP-1]);
- break;
- case F_CDR:
- argcount("cdr", nargs, 1);- v = cdr(Stack[SP-1]);
- break;
- case F_RPLACA:
- argcount("rplaca", nargs, 2);- car(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_RPLACD:
- argcount("rplacd", nargs, 2);- cdr(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_ATOM:
- argcount("atom", nargs, 1);- v = ((!iscons(Stack[SP-1])) ? T : NIL);
- break;
- case F_CONSP:
- argcount("consp", nargs, 1);- v = (iscons(Stack[SP-1]) ? T : NIL);
- break;
- case F_SYMBOLP:
- argcount("symbolp", nargs, 1);- v = ((issymbol(Stack[SP-1])) ? T : NIL);
- break;
- case F_NUMBERP:
- argcount("numberp", nargs, 1);- v = ((isnumber(Stack[SP-1])) ? T : NIL);
- break;
- case F_ADD:
- s = 0;
- for (i=saveSP+1; i < (int)SP; i++) {- n = tonumber(Stack[i], "+");
- s += n;
- }
- v = number(s);
- break;
- case F_SUB:
- if (nargs < 1)
- lerror("-: error: too few arguments\n");- i = saveSP+1;
- s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "-");
- s -= n;
- }
- v = number(s);
- break;
- case F_MUL:
- s = 1;
- for (i=saveSP+1; i < (int)SP; i++) {- n = tonumber(Stack[i], "*");
- s *= n;
- }
- v = number(s);
- break;
- case F_DIV:
- if (nargs < 1)
- lerror("/: error: too few arguments\n");- i = saveSP+1;
- s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "/");
- if (n == 0)
- lerror("/: error: division by zero\n");- s /= n;
- }
- v = number(s);
- break;
- case F_LT:
- argcount("<", nargs, 2);- if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
- v = T;
- else
- v = NIL;
- break;
- case F_NOT:
- argcount("not", nargs, 1);- v = ((Stack[SP-1] == NIL) ? T : NIL);
- break;
- case F_EVAL:
- argcount("eval", nargs, 1);- v = eval(Stack[SP-1], &NIL);
- break;
- case F_PRINT:
- for (i=saveSP+1; i < (int)SP; i++)
- print(stdout, v=Stack[i], 0);
- fprintf(stdout, "\n");
- break;
- case F_PRINC:
- for (i=saveSP+1; i < (int)SP; i++)
- print(stdout, v=Stack[i], 1);
- break;
- case F_READ:
- argcount("read", nargs, 0);- v = read_sexpr(stdin);
- break;
- case F_LOAD:
- argcount("load", nargs, 1);- v = load_file(tosymbol(Stack[SP-1], "load")->name);
- break;
- case F_EXIT:
- exit(0);
- break;
- case F_ERROR:
- for (i=saveSP+1; i < (int)SP; i++)
- print(stderr, Stack[i], 1);
- lerror("\n");- break;
- case F_PROG1:
- // return first arg
- if (nargs < 1)
- lerror("prog1: error: too few arguments\n");- v = Stack[saveSP+1];
- break;
- case F_APPLY:
- // unpack a list onto the stack
- argcount("apply", nargs, 2);- v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
- f = Stack[SP-2]; // first arg is new function
- POPN(2); // pop apply's args
- if (isbuiltin(f)) {- if (isspecial(f))
- lerror("apply: error: cannot apply special operator "- "%s\n", builtin_names[intval(f)]);
- while (iscons(v)) {- PUSH(car_(v));
- v = cdr_(v);
- }
- goto apply_builtin;
- }
- noeval = 1;
- goto apply_lambda;
- }
- SP = saveSP;
- return v;
- }
- else {- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- apply_lambda:
- if (iscons(f)) {- headsym = car_(f);
- if (headsym == LABEL) {- // (label name (lambda ...)) behaves the same as the lambda
- // alone, except with name bound to the whole label expression
- labl = f;
- f = car(cdr(cdr_(labl)));
- headsym = car(f);
- }
- // apply lambda or macro expression
- PUSH(cdr(cdr(cdr_(f))));
- lenv = &Stack[SP-1];
- PUSH(car_(cdr_(f)));
- argsyms = &Stack[SP-1];
- PUSH(car_(cdr_(cdr_(f))));
- body = &Stack[SP-1];
- if (labl) {- // add label binding to environment
- PUSH(labl);
- PUSH(car_(cdr_(labl)));
- *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
- POPN(3);
- v = Stack[saveSP]; // refetch arglist
- }
- if (headsym == MACRO)
- noeval = 1;
- else if (headsym != LAMBDA)
- lerror("apply: error: head must be lambda, macro, or label\n");- // build a calling environment for the lambda
- // the environment is the argument binds on top of the captured
- // environment
- while (iscons(v)) {- // bind args
- if (!iscons(*argsyms)) {- if (*argsyms == NIL)
- lerror("apply: error: too many arguments\n");- break;
- }
- asym = car_(*argsyms);
- if (!issymbol(asym))
- lerror("apply: error: formal argument not a symbol\n");- v = car_(v);
- if (!noeval) v = eval(v, penv);
- PUSH(v);
- *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
- POPN(2);
- *argsyms = cdr_(*argsyms);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- if (*argsyms != NIL) {- if (issymbol(*argsyms)) {- if (noeval) {- *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
- }
- else {- PUSH(NIL);
- PUSH(NIL);
- rest = &Stack[SP-1];
- // build list of rest arguments
- // we have to build it forwards, which is tricky
- while (iscons(v)) {- v = eval(car_(v), penv);
- PUSH(v);
- v = cons_(&Stack[SP-1], &NIL);
- POP();
- if (iscons(*rest))
- cdr_(*rest) = v;
- else
- Stack[SP-2] = v;
- *rest = v;
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
- }
- }
- else if (iscons(*argsyms)) {- lerror("apply: error: too few arguments\n");- }
- }
- SP = saveSP; // free temporary stack space
- PUSH(*lenv); // preserve environment on stack
- lenv = &Stack[SP-1];
- v = eval(*body, lenv);
- POP();
- // macro: evaluate expansion in the calling environment
- if (headsym == MACRO)
- return eval(v, penv);
- return v;
- }
- type_error("apply", "function", f);- return NIL;
-}
--- a/femtolisp/tiny/evalt
+++ /dev/null
@@ -1,443 +1,0 @@
-value_t eval_sexpr(value_t e, value_t *penv)
-{- value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
- value_t *rest;
- cons_t *c;
- symbol_t *sym;
- u_int32_t saveSP;
- int i, nargs, noeval=0;
- number_t s, n;
-
- eval_top:
- if (issymbol(e)) {- sym = (symbol_t*)ptr(e);
- if (sym->constant != UNBOUND) return sym->constant;
- v = *penv;
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == e)
- return cdr_(bind);
- v = cdr_(v);
- }
- if ((v = sym->binding) == UNBOUND)
- lerror("eval: error: variable %s has no value\n", sym->name);- return v;
- }
- if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
- lerror("eval: error: stack overflow\n");- saveSP = SP;
- PUSH(e);
- PUSH(*penv);
- f = eval(car_(e), penv);
- *penv = Stack[saveSP+1];
- if (isbuiltin(f)) {- // handle builtin function
- if (!isspecial(f)) {- // evaluate argument list, placing arguments on stack
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- while (iscons(v)) {- v = eval(car_(v), penv);
- *penv = Stack[saveSP+1];
- PUSH(v);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- }
- apply_builtin:
- nargs = SP - saveSP - 2;
- switch (intval(f)) {- // special forms
- case F_QUOTE:
- v = cdr_(Stack[saveSP]);
- if (!iscons(v))
- lerror("quote: error: expected argument\n");- v = car_(v);
- break;
- case F_MACRO:
- case F_LAMBDA:
- v = Stack[saveSP];
- if (*penv != NIL) {- // build a closure (lambda args body . env)
- v = cdr_(v);
- PUSH(car(v));
- argsyms = &Stack[SP-1];
- PUSH(car(cdr_(v)));
- body = &Stack[SP-1];
- v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
- cons(argsyms, cons(body, penv)));
- }
- break;
- case F_LABEL:
- v = Stack[saveSP];
- if (*penv != NIL) {- v = cdr_(v);
- PUSH(car(v)); // name
- pv = &Stack[SP-1];
- PUSH(car(cdr_(v))); // function
- body = &Stack[SP-1];
- *body = eval(*body, penv); // evaluate lambda
- v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
- }
- break;
- case F_IF:
- v = car(cdr_(Stack[saveSP]));
- if (eval(v, penv) != NIL)
- v = car(cdr_(cdr_(Stack[saveSP])));
- else
- v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
- tail_eval(v, Stack[saveSP+1]);
- break;
- case F_COND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- c = tocons(car_(*pv), "cond");
- v = eval(c->car, penv);
- *penv = Stack[saveSP+1];
- if (v != NIL) {- *pv = cdr_(car_(*pv));
- // evaluate body forms
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- v = eval(car_(*pv), penv);
- *penv = Stack[saveSP+1];
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv), *penv);
- }
- break;
- }
- *pv = cdr_(*pv);
- }
- break;
- case F_AND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = T;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- if ((v=eval(car_(*pv), penv)) == NIL) {- SP = saveSP; return NIL;
- }
- *penv = Stack[saveSP+1];
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv), *penv);
- }
- break;
- case F_OR:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- if ((v=eval(car_(*pv), penv)) != NIL) {- SP = saveSP; return v;
- }
- *penv = Stack[saveSP+1];
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv), *penv);
- }
- break;
- case F_WHILE:
- PUSH(car(cdr(cdr_(Stack[saveSP]))));
- body = &Stack[SP-1];
- Stack[saveSP] = car_(cdr_(Stack[saveSP]));
- value_t *cond = &Stack[saveSP];
- PUSH(NIL); pv = &Stack[SP-1];
- while (eval(*cond, penv) != NIL) {- *penv = Stack[saveSP+1];
- *pv = eval(*body, penv);
- *penv = Stack[saveSP+1];
- }
- v = *pv;
- break;
- case F_PROGN:
- // return last arg
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- v = eval(car_(*pv), penv);
- *penv = Stack[saveSP+1];
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv), *penv);
- }
- break;
-
- // ordinary functions
- case F_SET:
- argcount("set", nargs, 2);- e = Stack[SP-2];
- v = *penv;
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == e) {- cdr_(bind) = (v=Stack[SP-1]);
- SP=saveSP; return v;
- }
- v = cdr_(v);
- }
- tosymbol(e, "set")->binding = (v=Stack[SP-1]);
- break;
- case F_BOUNDP:
- argcount("boundp", nargs, 1);- if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
- v = NIL;
- else
- v = T;
- break;
- case F_EQ:
- argcount("eq", nargs, 2);- v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
- break;
- case F_CONS:
- argcount("cons", nargs, 2);- v = mk_cons();
- car_(v) = Stack[SP-2];
- cdr_(v) = Stack[SP-1];
- break;
- case F_CAR:
- argcount("car", nargs, 1);- v = car(Stack[SP-1]);
- break;
- case F_CDR:
- argcount("cdr", nargs, 1);- v = cdr(Stack[SP-1]);
- break;
- case F_RPLACA:
- argcount("rplaca", nargs, 2);- car(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_RPLACD:
- argcount("rplacd", nargs, 2);- cdr(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_ATOM:
- argcount("atom", nargs, 1);- v = ((!iscons(Stack[SP-1])) ? T : NIL);
- break;
- case F_CONSP:
- argcount("consp", nargs, 1);- v = (iscons(Stack[SP-1]) ? T : NIL);
- break;
- case F_SYMBOLP:
- argcount("symbolp", nargs, 1);- v = ((issymbol(Stack[SP-1])) ? T : NIL);
- break;
- case F_NUMBERP:
- argcount("numberp", nargs, 1);- v = ((isnumber(Stack[SP-1])) ? T : NIL);
- break;
- case F_ADD:
- s = 0;
- for (i=saveSP+2; i < (int)SP; i++) {- n = tonumber(Stack[i], "+");
- s += n;
- }
- v = number(s);
- break;
- case F_SUB:
- if (nargs < 1)
- lerror("-: error: too few arguments\n");- i = saveSP+2;
- s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "-");
- s -= n;
- }
- v = number(s);
- break;
- case F_MUL:
- s = 1;
- for (i=saveSP+2; i < (int)SP; i++) {- n = tonumber(Stack[i], "*");
- s *= n;
- }
- v = number(s);
- break;
- case F_DIV:
- if (nargs < 1)
- lerror("/: error: too few arguments\n");- i = saveSP+2;
- s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "/");
- if (n == 0)
- lerror("/: error: division by zero\n");- s /= n;
- }
- v = number(s);
- break;
- case F_LT:
- argcount("<", nargs, 2);- if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
- v = T;
- else
- v = NIL;
- break;
- case F_NOT:
- argcount("not", nargs, 1);- v = ((Stack[SP-1] == NIL) ? T : NIL);
- break;
- case F_EVAL:
- argcount("eval", nargs, 1);- v = Stack[SP-1];
- tail_eval(v, NIL);
- break;
- case F_PRINT:
- for (i=saveSP+2; i < (int)SP; i++)
- print(stdout, v=Stack[i], 0);
- fprintf(stdout, "\n");
- break;
- case F_PRINC:
- for (i=saveSP+2; i < (int)SP; i++)
- print(stdout, v=Stack[i], 1);
- break;
- case F_READ:
- argcount("read", nargs, 0);- v = read_sexpr(stdin);
- break;
- case F_LOAD:
- argcount("load", nargs, 1);- v = load_file(tosymbol(Stack[SP-1], "load")->name);
- break;
- case F_EXIT:
- exit(0);
- break;
- case F_ERROR:
- for (i=saveSP+2; i < (int)SP; i++)
- print(stderr, Stack[i], 1);
- lerror("\n");- break;
- case F_PROG1:
- // return first arg
- if (nargs < 1)
- lerror("prog1: error: too few arguments\n");- v = Stack[saveSP+2];
- break;
- case F_APPLY:
- argcount("apply", nargs, 2);- v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
- f = Stack[SP-2]; // first arg is new function
- POPN(2); // pop apply's args
- if (isbuiltin(f)) {- if (isspecial(f))
- lerror("apply: error: cannot apply special operator "- "%s\n", builtin_names[intval(f)]);
- // unpack arglist onto the stack
- while (iscons(v)) {- PUSH(car_(v));
- v = cdr_(v);
- }
- goto apply_builtin;
- }
- noeval = 1;
- goto apply_lambda;
- }
- SP = saveSP;
- return v;
- }
- else {- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- apply_lambda:
- if (iscons(f)) {- headsym = car_(f);
- if (headsym == LABEL) {- // (label name (lambda ...)) behaves the same as the lambda
- // alone, except with name bound to the whole label expression
- labl = f;
- f = car(cdr(cdr_(labl)));
- headsym = car(f);
- }
- // apply lambda or macro expression
- PUSH(cdr(cdr(cdr_(f))));
- lenv = &Stack[SP-1];
- PUSH(car_(cdr_(f)));
- argsyms = &Stack[SP-1];
- PUSH(car_(cdr_(cdr_(f))));
- body = &Stack[SP-1];
- if (labl) {- // add label binding to environment
- PUSH(labl);
- PUSH(car_(cdr_(labl)));
- *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
- POPN(3);
- v = Stack[saveSP]; // refetch arglist
- }
- if (headsym == MACRO)
- noeval = 1;
- else if (headsym != LAMBDA)
- lerror("apply: error: head must be lambda, macro, or label\n");- // build a calling environment for the lambda
- // the environment is the argument binds on top of the captured
- // environment
- while (iscons(v)) {- // bind args
- if (!iscons(*argsyms)) {- if (*argsyms == NIL)
- lerror("apply: error: too many arguments\n");- break;
- }
- asym = car_(*argsyms);
- if (!issymbol(asym))
- lerror("apply: error: formal argument not a symbol\n");- v = car_(v);
- if (!noeval) {- v = eval(v, penv);
- *penv = Stack[saveSP+1];
- }
- PUSH(v);
- *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
- POPN(2);
- *argsyms = cdr_(*argsyms);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- if (*argsyms != NIL) {- if (issymbol(*argsyms)) {- if (noeval) {- *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
- }
- else {- PUSH(NIL);
- PUSH(NIL);
- rest = &Stack[SP-1];
- // build list of rest arguments
- // we have to build it forwards, which is tricky
- while (iscons(v)) {- v = eval(car_(v), penv);
- *penv = Stack[saveSP+1];
- PUSH(v);
- v = cons_(&Stack[SP-1], &NIL);
- POP();
- if (iscons(*rest))
- cdr_(*rest) = v;
- else
- Stack[SP-2] = v;
- *rest = v;
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
- }
- }
- else if (iscons(*argsyms)) {- lerror("apply: error: too few arguments\n");- }
- }
- noeval = 0;
- // macro: evaluate expansion in the calling environment
- if (headsym == MACRO) {- SP = saveSP;
- PUSH(*lenv);
- lenv = &Stack[SP-1];
- v = eval(*body, lenv);
- tail_eval(v, *penv);
- }
- else {- tail_eval(*body, *lenv);
- }
- // not reached
- }
- type_error("apply", "function", f);- return NIL;
-}
--- a/femtolisp/tiny/flutils.c
+++ /dev/null
@@ -1,119 +1,0 @@
-u_int32_t *bitvector_resize(u_int32_t *b, size_t n)
-{- u_int32_t *p;
- size_t sz = ((n+31)>>5) * 4;
- p = realloc(b, sz);
- if (p == NULL) return NULL;
- memset(p, 0, sz);
- return p;
-}
-
-u_int32_t *mk_bitvector(size_t n)
-{- return bitvector_resize(NULL, n);
-}
-
-void bitvector_set(u_int32_t *b, u_int32_t n, u_int32_t c)
-{- if (c)
- b[n>>5] |= (1<<(n&31));
- else
- b[n>>5] &= ~(1<<(n&31));
-}
-
-u_int32_t bitvector_get(u_int32_t *b, u_int32_t n)
-{- return b[n>>5] & (1<<(n&31));
-}
-
-typedef struct {- size_t n, maxsize;
- unsigned long *items;
-} ltable_t;
-
-void ltable_init(ltable_t *t, size_t n)
-{- t->n = 0;
- t->maxsize = n;
- t->items = (unsigned long*)malloc(n * sizeof(unsigned long));
-}
-
-void ltable_clear(ltable_t *t)
-{- t->n = 0;
-}
-
-void ltable_insert(ltable_t *t, unsigned long item)
-{- unsigned long *p;
-
- if (t->n == t->maxsize) {- p = realloc(t->items, (t->maxsize*2)*sizeof(unsigned long));
- if (p == NULL) return;
- t->items = p;
- t->maxsize *= 2;
- }
- t->items[t->n++] = item;
-}
-
-#define NOTFOUND ((int)-1)
-
-int ltable_lookup(ltable_t *t, unsigned long item)
-{- int i;
- for(i=0; i < (int)t->n; i++)
- if (t->items[i] == item)
- return i;
- return NOTFOUND;
-}
-
-void ltable_adjoin(ltable_t *t, unsigned long item)
-{- if (ltable_lookup(t, item) == NOTFOUND)
- ltable_insert(t, item);
-}
-
-static const u_int32_t offsetsFromUTF8[6] = {- 0x00000000UL, 0x00003080UL, 0x000E2080UL,
- 0x03C82080UL, 0xFA082080UL, 0x82082080UL
-};
-
-static const char trailingBytesForUTF8[256] = {- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
- 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5
-};
-
-int u8_seqlen(const char c)
-{- return trailingBytesForUTF8[(unsigned int)(unsigned char)c] + 1;
-}
-
-#define UEOF ((u_int32_t)EOF)
-
-u_int32_t u8_fgetc(FILE *f)
-{- int amt=0, sz, c;
- u_int32_t ch=0;
-
- c = fgetc(f);
- if (c == EOF)
- return UEOF;
- ch = (u_int32_t)c;
- amt = sz = u8_seqlen(ch);
- while (--amt) {- ch <<= 6;
- c = fgetc(f);
- if (c == EOF)
- return UEOF;
- ch += (u_int32_t)c;
- }
- ch -= offsetsFromUTF8[sz-1];
-
- return ch;
-}
--- a/femtolisp/tiny/lisp-nontail.c
+++ /dev/null
@@ -1,975 +1,0 @@
-/*
- femtoLisp
-
- a minimal interpreter for a minimal lisp dialect
-
- this lisp dialect uses lexical scope and self-evaluating lambda.
- it supports 30-bit integers, symbols, conses, and full macros.
- it is case-sensitive.
- it features a simple compacting copying garbage collector.
- it uses a Scheme-style evaluation rule where any expression may appear in
- head position as long as it evaluates to a function.
- it uses Scheme-style varargs (dotted formal argument lists)
- lambdas can have only 1 body expression; use (progn ...) for multiple
- expressions. this is due to the closure representation
- (lambda args body . env)
-
- by Jeff Bezanson
- Public Domain
-*/
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <setjmp.h>
-#include <stdarg.h>
-#include <ctype.h>
-#include <sys/types.h>
-
-typedef u_int32_t value_t;
-typedef int32_t number_t;
-
-typedef struct {- value_t car;
- value_t cdr;
-} cons_t;
-
-typedef struct _symbol_t {- value_t binding; // global value binding
- value_t constant; // constant binding (used only for builtins)
- struct _symbol_t *left;
- struct _symbol_t *right;
- char name[1];
-} symbol_t;
-
-#define TAG_NUM 0x0
-#define TAG_BUILTIN 0x1
-#define TAG_SYM 0x2
-#define TAG_CONS 0x3
-#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
-#define tag(x) ((x)&0x3)
-#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
-#define tagptr(p,t) (((value_t)(p)) | (t))
-#define number(x) ((value_t)((x)<<2))
-#define numval(x) (((number_t)(x))>>2)
-#define intval(x) (((int)(x))>>2)
-#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
-#define iscons(x) (tag(x) == TAG_CONS)
-#define issymbol(x) (tag(x) == TAG_SYM)
-#define isnumber(x) (tag(x) == TAG_NUM)
-#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
-// functions ending in _ are unsafe, faster versions
-#define car_(v) (((cons_t*)ptr(v))->car)
-#define cdr_(v) (((cons_t*)ptr(v))->cdr)
-#define car(v) (tocons((v),"car")->car)
-#define cdr(v) (tocons((v),"cdr")->cdr)
-#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
-#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
-
-enum {- // special forms
- F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
- F_PROGN,
- // functions
- F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
- F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
- F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
-};
-#define isspecial(v) (intval(v) <= (int)F_PROGN)
-
-static char *builtin_names[] =
- { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",- "progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
- "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
- "prog1", "apply", "rplaca", "rplacd", "boundp" };
-
-static char *stack_bottom;
-#define PROCESS_STACK_SIZE (2*1024*1024)
-#define N_STACK 49152
-static value_t Stack[N_STACK];
-static u_int32_t SP = 0;
-#define PUSH(v) (Stack[SP++] = (v))
-#define POP() (Stack[--SP])
-#define POPN(n) (SP-=(n))
-
-value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
-
-value_t read_sexpr(FILE *f);
-void print(FILE *f, value_t v);
-value_t eval_sexpr(value_t e, value_t *penv);
-value_t load_file(char *fname);
-
-// error utilities ------------------------------------------------------------
-
-jmp_buf toplevel;
-
-void lerror(char *format, ...)
-{- va_list args;
- va_start(args, format);
- vfprintf(stderr, format, args);
- va_end(args);
- longjmp(toplevel, 1);
-}
-
-void type_error(char *fname, char *expected, value_t got)
-{- fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
- print(stderr, got); lerror("\n");-}
-
-// safe cast operators --------------------------------------------------------
-
-#define SAFECAST_OP(type,ctype,cnvt) \
-ctype to##type(value_t v, char *fname) \
-{ \- if (is##type(v)) \
- return (ctype)cnvt(v); \
- type_error(fname, #type, v); \
- return (ctype)0; \
-}
-SAFECAST_OP(cons, cons_t*, ptr)
-SAFECAST_OP(symbol,symbol_t*,ptr)
-SAFECAST_OP(number,number_t, numval)
-
-// symbol table ---------------------------------------------------------------
-
-static symbol_t *symtab = NULL;
-
-static symbol_t *mk_symbol(char *str)
-{- symbol_t *sym;
-
- sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
- sym->left = sym->right = NULL;
- sym->constant = sym->binding = UNBOUND;
- strcpy(&sym->name[0], str);
- return sym;
-}
-
-static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
-{- int x;
-
- while(*ptree != NULL) {- x = strcmp(str, (*ptree)->name);
- if (x == 0)
- return ptree;
- if (x < 0)
- ptree = &(*ptree)->left;
- else
- ptree = &(*ptree)->right;
- }
- return ptree;
-}
-
-value_t symbol(char *str)
-{- symbol_t **pnode;
-
- pnode = symtab_lookup(&symtab, str);
- if (*pnode == NULL)
- *pnode = mk_symbol(str);
- return tagptr(*pnode, TAG_SYM);
-}
-
-// initialization -------------------------------------------------------------
-
-static unsigned char *fromspace;
-static unsigned char *tospace;
-static unsigned char *curheap;
-static unsigned char *lim;
-static u_int32_t heapsize = 64*1024;//bytes
-
-void lisp_init(void)
-{- int i;
-
- fromspace = malloc(heapsize);
- tospace = malloc(heapsize);
- curheap = fromspace;
- lim = curheap+heapsize-sizeof(cons_t);
-
- NIL = symbol("nil"); setc(NIL, NIL);- T = symbol("t"); setc(T, T);- LAMBDA = symbol("lambda");- MACRO = symbol("macro");- LABEL = symbol("label");- QUOTE = symbol("quote");- for (i=0; i < (int)N_BUILTINS; i++)
- setc(symbol(builtin_names[i]), builtin(i));
- setc(symbol("princ"), builtin(F_PRINT));-}
-
-// conses ---------------------------------------------------------------------
-
-void gc(void);
-
-static value_t mk_cons(void)
-{- cons_t *c;
-
- if (curheap > lim)
- gc();
- c = (cons_t*)curheap;
- curheap += sizeof(cons_t);
- return tagptr(c, TAG_CONS);
-}
-
-static value_t cons_(value_t *pcar, value_t *pcdr)
-{- value_t c = mk_cons();
- car_(c) = *pcar; cdr_(c) = *pcdr;
- return c;
-}
-
-value_t *cons(value_t *pcar, value_t *pcdr)
-{- value_t c = mk_cons();
- car_(c) = *pcar; cdr_(c) = *pcdr;
- PUSH(c);
- return &Stack[SP-1];
-}
-
-// collector ------------------------------------------------------------------
-
-static value_t relocate(value_t v)
-{- value_t a, d, nc;
-
- if (!iscons(v))
- return v;
- if (car_(v) == UNBOUND)
- return cdr_(v);
- nc = mk_cons();
- a = car_(v); d = cdr_(v);
- car_(v) = UNBOUND; cdr_(v) = nc;
- car_(nc) = relocate(a);
- cdr_(nc) = relocate(d);
- return nc;
-}
-
-static void trace_globals(symbol_t *root)
-{- while (root != NULL) {- root->binding = relocate(root->binding);
- trace_globals(root->left);
- root = root->right;
- }
-}
-
-void gc(void)
-{- static int grew = 0;
- unsigned char *temp;
- u_int32_t i;
-
- curheap = tospace;
- lim = curheap+heapsize-sizeof(cons_t);
-
- for (i=0; i < SP; i++)
- Stack[i] = relocate(Stack[i]);
- trace_globals(symtab);
-#ifdef VERBOSEGC
- printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);-#endif
- temp = tospace;
- tospace = fromspace;
- fromspace = temp;
-
- // if we're using > 80% of the space, resize tospace so we have
- // more space to fill next time. if we grew tospace last time,
- // grow the other half of the heap this time to catch up.
- if (grew || ((lim-curheap) < (int)(heapsize/5))) {- temp = realloc(tospace, grew ? heapsize : heapsize*2);
- if (temp == NULL)
- lerror("out of memory\n");- tospace = temp;
- if (!grew)
- heapsize*=2;
- grew = !grew;
- }
- if (curheap > lim) // all data was live
- gc();
-}
-
-// read -----------------------------------------------------------------------
-
-enum {- TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
-};
-
-static int symchar(char c)
-{- static char *special = "()';\\|";
- return (!isspace(c) && !strchr(special, c));
-}
-
-static u_int32_t toktype = TOK_NONE;
-static value_t tokval;
-static char buf[256];
-
-static char nextchar(FILE *f)
-{- char c;
- int ch;
-
- do {- ch = fgetc(f);
- if (ch == EOF)
- return 0;
- c = (char)ch;
- if (c == ';') {- // single-line comment
- do {- ch = fgetc(f);
- if (ch == EOF)
- return 0;
- } while ((char)ch != '\n');
- c = (char)ch;
- }
- } while (isspace(c));
- return c;
-}
-
-static void take(void)
-{- toktype = TOK_NONE;
-}
-
-static void accumchar(char c, int *pi)
-{- buf[(*pi)++] = c;
- if (*pi >= (int)(sizeof(buf)-1))
- lerror("read: error: token too long\n");-}
-
-static int read_token(FILE *f, char c)
-{- int i=0, ch, escaped=0;
-
- ungetc(c, f);
- while (1) {- ch = fgetc(f);
- if (ch == EOF)
- goto terminate;
- c = (char)ch;
- if (c == '|') {- escaped = !escaped;
- }
- else if (c == '\\') {- ch = fgetc(f);
- if (ch == EOF)
- goto terminate;
- accumchar((char)ch, &i);
- }
- else if (!escaped && !symchar(c)) {- break;
- }
- else {- accumchar(c, &i);
- }
- }
- ungetc(c, f);
- terminate:
- buf[i++] = '\0';
- return i;
-}
-
-static u_int32_t peek(FILE *f)
-{- char c, *end;
- number_t x;
-
- if (toktype != TOK_NONE)
- return toktype;
- c = nextchar(f);
- if (feof(f)) return TOK_NONE;
- if (c == '(') {- toktype = TOK_OPEN;
- }
- else if (c == ')') {- toktype = TOK_CLOSE;
- }
- else if (c == '\'') {- toktype = TOK_QUOTE;
- }
- else if (isdigit(c) || c=='-') {- read_token(f, c);
- if (buf[0] == '-' && !isdigit(buf[1])) {- toktype = TOK_SYM;
- tokval = symbol(buf);
- }
- else {- x = strtol(buf, &end, 10);
- if (*end != '\0')
- lerror("read: error: invalid integer constant\n");- toktype = TOK_NUM;
- tokval = number(x);
- }
- }
- else {- read_token(f, c);
- if (!strcmp(buf, ".")) {- toktype = TOK_DOT;
- }
- else {- toktype = TOK_SYM;
- tokval = symbol(buf);
- }
- }
- return toktype;
-}
-
-// build a list of conses. this is complicated by the fact that all conses
-// can move whenever a new cons is allocated. we have to refer to every cons
-// through a handle to a relocatable pointer (i.e. a pointer on the stack).
-static void read_list(FILE *f, value_t *pval)
-{- value_t c, *pc;
- u_int32_t t;
-
- PUSH(NIL);
- pc = &Stack[SP-1]; // to keep track of current cons cell
- t = peek(f);
- while (t != TOK_CLOSE) {- if (feof(f))
- lerror("read: error: unexpected end of input\n");- c = mk_cons(); car_(c) = cdr_(c) = NIL;
- if (iscons(*pc))
- cdr_(*pc) = c;
- else
- *pval = c;
- *pc = c;
- c = read_sexpr(f); // must be on separate lines due to undefined
- car_(*pc) = c; // evaluation order
-
- t = peek(f);
- if (t == TOK_DOT) {- take();
- c = read_sexpr(f);
- cdr_(*pc) = c;
- t = peek(f);
- if (feof(f))
- lerror("read: error: unexpected end of input\n");- if (t != TOK_CLOSE)
- lerror("read: error: expected ')'\n");- }
- }
- take();
- POP();
-}
-
-value_t read_sexpr(FILE *f)
-{- value_t v;
-
- switch (peek(f)) {- case TOK_CLOSE:
- take();
- lerror("read: error: unexpected ')'\n");- case TOK_DOT:
- take();
- lerror("read: error: unexpected '.'\n");- case TOK_SYM:
- case TOK_NUM:
- take();
- return tokval;
- case TOK_QUOTE:
- take();
- v = read_sexpr(f);
- PUSH(v);
- v = cons_("E, cons(&Stack[SP-1], &NIL));
- POPN(2);
- return v;
- case TOK_OPEN:
- take();
- PUSH(NIL);
- read_list(f, &Stack[SP-1]);
- return POP();
- }
- return NIL;
-}
-
-// print ----------------------------------------------------------------------
-
-void print(FILE *f, value_t v)
-{- value_t cd;
-
- switch (tag(v)) {- case TAG_NUM: fprintf(f, "%d", numval(v)); break;
- case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
- case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
- builtin_names[intval(v)]); break;
- case TAG_CONS:
- fprintf(f, "(");- while (1) {- print(f, car_(v));
- cd = cdr_(v);
- if (!iscons(cd)) {- if (cd != NIL) {- fprintf(f, " . ");
- print(f, cd);
- }
- fprintf(f, ")");
- break;
- }
- fprintf(f, " ");
- v = cd;
- }
- break;
- }
-}
-
-// eval -----------------------------------------------------------------------
-
-static inline void argcount(char *fname, int nargs, int c)
-{- if (nargs != c)
- lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");-}
-
-#define eval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env))
-
-value_t eval_sexpr(value_t e, value_t *penv)
-{- value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
- value_t *rest;
- cons_t *c;
- symbol_t *sym;
- u_int32_t saveSP;
- int i, nargs, noeval=0;
- number_t s, n;
-
- if (issymbol(e)) {- sym = (symbol_t*)ptr(e);
- if (sym->constant != UNBOUND) return sym->constant;
- v = *penv;
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == e)
- return cdr_(bind);
- v = cdr_(v);
- }
- if ((v = sym->binding) == UNBOUND)
- lerror("eval: error: variable %s has no value\n", sym->name);- return v;
- }
- if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
- lerror("eval: error: stack overflow\n");- saveSP = SP;
- PUSH(e);
- f = eval(car_(e), penv);
- if (isbuiltin(f)) {- // handle builtin function
- if (!isspecial(f)) {- // evaluate argument list, placing arguments on stack
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- while (iscons(v)) {- v = eval(car_(v), penv);
- PUSH(v);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- }
- apply_builtin:
- nargs = SP - saveSP - 1;
- switch (intval(f)) {- // special forms
- case F_QUOTE:
- v = cdr_(Stack[saveSP]);
- if (!iscons(v))
- lerror("quote: error: expected argument\n");- v = car_(v);
- break;
- case F_MACRO:
- case F_LAMBDA:
- v = Stack[saveSP];
- if (*penv != NIL) {- // build a closure (lambda args body . env)
- v = cdr_(v);
- PUSH(car(v));
- argsyms = &Stack[SP-1];
- PUSH(car(cdr_(v)));
- body = &Stack[SP-1];
- v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
- cons(argsyms, cons(body, penv)));
- }
- break;
- case F_LABEL:
- v = Stack[saveSP];
- if (*penv != NIL) {- v = cdr_(v);
- PUSH(car(v)); // name
- pv = &Stack[SP-1];
- PUSH(car(cdr_(v))); // function
- body = &Stack[SP-1];
- *body = eval(*body, penv); // evaluate lambda
- v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
- }
- break;
- case F_IF:
- v = car(cdr_(Stack[saveSP]));
- if (eval(v, penv) != NIL)
- v = car(cdr_(cdr_(Stack[saveSP])));
- else
- v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
- v = eval(v, penv);
- break;
- case F_COND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- c = tocons(car_(*pv), "cond");
- if ((v=eval(c->car, penv)) != NIL) {- *pv = cdr_(car_(*pv));
- // evaluate body forms
- while (iscons(*pv)) {- v = eval(car_(*pv), penv);
- *pv = cdr_(*pv);
- }
- break;
- }
- *pv = cdr_(*pv);
- }
- break;
- case F_AND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = T;
- while (iscons(*pv)) {- if ((v=eval(car_(*pv), penv)) == NIL)
- break;
- *pv = cdr_(*pv);
- }
- break;
- case F_OR:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- if ((v=eval(car_(*pv), penv)) != NIL)
- break;
- *pv = cdr_(*pv);
- }
- break;
- case F_WHILE:
- PUSH(car(cdr(cdr_(Stack[saveSP]))));
- body = &Stack[SP-1];
- Stack[saveSP] = car_(cdr_(Stack[saveSP]));
- value_t *cond = &Stack[saveSP];
- PUSH(NIL); pv = &Stack[SP-1];
- while (eval(*cond, penv) != NIL)
- *pv = eval(*body, penv);
- v = *pv;
- break;
- case F_PROGN:
- // return last arg
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- v = eval(car_(*pv), penv);
- *pv = cdr_(*pv);
- }
- break;
-
- // ordinary functions
- case F_SET:
- argcount("set", nargs, 2);- e = Stack[SP-2];
- v = *penv;
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == e) {- cdr_(bind) = (v=Stack[SP-1]);
- SP=saveSP; return v;
- }
- v = cdr_(v);
- }
- tosymbol(e, "set")->binding = (v=Stack[SP-1]);
- break;
- case F_BOUNDP:
- argcount("boundp", nargs, 1);- if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
- v = NIL;
- else
- v = T;
- break;
- case F_EQ:
- argcount("eq", nargs, 2);- v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
- break;
- case F_CONS:
- argcount("cons", nargs, 2);- v = mk_cons();
- car_(v) = Stack[SP-2];
- cdr_(v) = Stack[SP-1];
- break;
- case F_CAR:
- argcount("car", nargs, 1);- v = car(Stack[SP-1]);
- break;
- case F_CDR:
- argcount("cdr", nargs, 1);- v = cdr(Stack[SP-1]);
- break;
- case F_RPLACA:
- argcount("rplaca", nargs, 2);- car(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_RPLACD:
- argcount("rplacd", nargs, 2);- cdr(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_ATOM:
- argcount("atom", nargs, 1);- v = ((!iscons(Stack[SP-1])) ? T : NIL);
- break;
- case F_SYMBOLP:
- argcount("symbolp", nargs, 1);- v = ((issymbol(Stack[SP-1])) ? T : NIL);
- break;
- case F_NUMBERP:
- argcount("numberp", nargs, 1);- v = ((isnumber(Stack[SP-1])) ? T : NIL);
- break;
- case F_ADD:
- s = 0;
- for (i=saveSP+1; i < (int)SP; i++) {- n = tonumber(Stack[i], "+");
- s += n;
- }
- v = number(s);
- break;
- case F_SUB:
- if (nargs < 1)
- lerror("-: error: too few arguments\n");- i = saveSP+1;
- s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "-");
- s -= n;
- }
- v = number(s);
- break;
- case F_MUL:
- s = 1;
- for (i=saveSP+1; i < (int)SP; i++) {- n = tonumber(Stack[i], "*");
- s *= n;
- }
- v = number(s);
- break;
- case F_DIV:
- if (nargs < 1)
- lerror("/: error: too few arguments\n");- i = saveSP+1;
- s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "/");
- if (n == 0)
- lerror("/: error: division by zero\n");- s /= n;
- }
- v = number(s);
- break;
- case F_LT:
- argcount("<", nargs, 2);- if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
- v = T;
- else
- v = NIL;
- break;
- case F_NOT:
- argcount("not", nargs, 1);- v = ((Stack[SP-1] == NIL) ? T : NIL);
- break;
- case F_EVAL:
- argcount("eval", nargs, 1);- v = eval(Stack[SP-1], &NIL);
- break;
- case F_PRINT:
- for (i=saveSP+1; i < (int)SP; i++)
- print(stdout, v=Stack[i]);
- break;
- case F_READ:
- argcount("read", nargs, 0);- v = read_sexpr(stdin);
- break;
- case F_LOAD:
- argcount("load", nargs, 1);- v = load_file(tosymbol(Stack[SP-1], "load")->name);
- break;
- case F_PROG1:
- // return first arg
- if (nargs < 1)
- lerror("prog1: error: too few arguments\n");- v = Stack[saveSP+1];
- break;
- case F_APPLY:
- // unpack a list onto the stack
- argcount("apply", nargs, 2);- v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
- f = Stack[SP-2]; // first arg is new function
- POPN(2); // pop apply's args
- if (isbuiltin(f)) {- if (isspecial(f))
- lerror("apply: error: cannot apply special operator "- "%s\n", builtin_names[intval(f)]);
- while (iscons(v)) {- PUSH(car_(v));
- v = cdr_(v);
- }
- goto apply_builtin;
- }
- noeval = 1;
- goto apply_lambda;
- }
- SP = saveSP;
- return v;
- }
- else {- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- apply_lambda:
- if (iscons(f)) {- headsym = car_(f);
- if (headsym == LABEL) {- // (label name (lambda ...)) behaves the same as the lambda
- // alone, except with name bound to the whole label expression
- labl = f;
- f = car(cdr(cdr_(labl)));
- headsym = car(f);
- }
- // apply lambda or macro expression
- PUSH(cdr(cdr(cdr_(f))));
- lenv = &Stack[SP-1];
- PUSH(car_(cdr_(f)));
- argsyms = &Stack[SP-1];
- PUSH(car_(cdr_(cdr_(f))));
- body = &Stack[SP-1];
- if (labl) {- // add label binding to environment
- PUSH(labl);
- PUSH(car_(cdr_(labl)));
- *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
- POPN(3);
- v = Stack[saveSP]; // refetch arglist
- }
- if (headsym == MACRO)
- noeval = 1;
- else if (headsym != LAMBDA)
- lerror("apply: error: head must be lambda, macro, or label\n");- // build a calling environment for the lambda
- // the environment is the argument binds on top of the captured
- // environment
- while (iscons(v)) {- // bind args
- if (!iscons(*argsyms)) {- if (*argsyms == NIL)
- lerror("apply: error: too many arguments\n");- break;
- }
- asym = car_(*argsyms);
- if (!issymbol(asym))
- lerror("apply: error: formal argument not a symbol\n");- v = car_(v);
- if (!noeval) v = eval(v, penv);
- PUSH(v);
- *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
- POPN(2);
- *argsyms = cdr_(*argsyms);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- if (*argsyms != NIL) {- if (issymbol(*argsyms)) {- if (noeval) {- *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
- }
- else {- PUSH(NIL);
- PUSH(NIL);
- rest = &Stack[SP-1];
- // build list of rest arguments
- // we have to build it forwards, which is tricky
- while (iscons(v)) {- v = eval(car_(v), penv);
- PUSH(v);
- v = cons_(&Stack[SP-1], &NIL);
- POP();
- if (iscons(*rest))
- cdr_(*rest) = v;
- else
- Stack[SP-2] = v;
- *rest = v;
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
- }
- }
- else if (iscons(*argsyms)) {- lerror("apply: error: too few arguments\n");- }
- }
- SP = saveSP; // free temporary stack space
- PUSH(*lenv); // preserve environment on stack
- lenv = &Stack[SP-1];
- v = eval(*body, lenv);
- POP();
- // macro: evaluate expansion in the calling environment
- if (headsym == MACRO)
- return eval(v, penv);
- return v;
- }
- type_error("apply", "function", f);- return NIL;
-}
-
-// repl -----------------------------------------------------------------------
-
-static char *infile = NULL;
-
-value_t load_file(char *fname)
-{- value_t e, v=NIL;
- char *lastfile = infile;
- FILE *f = fopen(fname, "r");
- infile = fname;
- if (f == NULL) lerror("file not found\n");- while (1) {- e = read_sexpr(f);
- if (feof(f)) break;
- v = eval(e, &NIL);
- }
- infile = lastfile;
- fclose(f);
- return v;
-}
-
-int main(int argc, char* argv[])
-{- value_t v;
-
- stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
- lisp_init();
- if (setjmp(toplevel)) {- SP = 0;
- fprintf(stderr, "\n");
- if (infile) {- fprintf(stderr, "error loading file \"%s\"\n", infile);
- infile = NULL;
- }
- goto repl;
- }
- load_file("system.lsp");- if (argc > 1) { load_file(argv[1]); return 0; }- printf("Welcome to femtoLisp ----------------------------------------------------------\n");- repl:
- while (1) {- printf("> ");- v = read_sexpr(stdin);
- if (feof(stdin)) break;
- print(stdout, v=eval(v, &NIL));
- set(symbol("that"), v);- printf("\n\n");- }
- return 0;
-}
--- a/femtolisp/tiny/lisp.c
+++ /dev/null
@@ -1,1029 +1,0 @@
-/*
- femtoLisp
-
- a minimal interpreter for a minimal lisp dialect
-
- this lisp dialect uses lexical scope and self-evaluating lambda.
- it supports 30-bit integers, symbols, conses, and full macros.
- it is case-sensitive.
- it features a simple compacting copying garbage collector.
- it uses a Scheme-style evaluation rule where any expression may appear in
- head position as long as it evaluates to a function.
- it uses Scheme-style varargs (dotted formal argument lists)
- lambdas can have only 1 body expression; use (progn ...) for multiple
- expressions. this is due to the closure representation
- (lambda args body . env)
-
- by Jeff Bezanson
- Public Domain
-*/
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <setjmp.h>
-#include <stdarg.h>
-#include <ctype.h>
-#include <sys/types.h>
-
-typedef u_int32_t value_t;
-typedef int32_t number_t;
-
-typedef struct {- value_t car;
- value_t cdr;
-} cons_t;
-
-typedef struct _symbol_t {- value_t binding; // global value binding
- value_t constant; // constant binding (used only for builtins)
- struct _symbol_t *left;
- struct _symbol_t *right;
- char name[1];
-} symbol_t;
-
-#define TAG_NUM 0x0
-#define TAG_BUILTIN 0x1
-#define TAG_SYM 0x2
-#define TAG_CONS 0x3
-#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
-#define tag(x) ((x)&0x3)
-#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
-#define tagptr(p,t) (((value_t)(p)) | (t))
-#define number(x) ((value_t)((x)<<2))
-#define numval(x) (((number_t)(x))>>2)
-#define intval(x) (((int)(x))>>2)
-#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
-#define iscons(x) (tag(x) == TAG_CONS)
-#define issymbol(x) (tag(x) == TAG_SYM)
-#define isnumber(x) (tag(x) == TAG_NUM)
-#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
-// functions ending in _ are unsafe, faster versions
-#define car_(v) (((cons_t*)ptr(v))->car)
-#define cdr_(v) (((cons_t*)ptr(v))->cdr)
-#define car(v) (tocons((v),"car")->car)
-#define cdr(v) (tocons((v),"cdr")->cdr)
-#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
-#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
-
-enum {- // special forms
- F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
- F_PROGN,
- // functions
- F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
- F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
- F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
-};
-#define isspecial(v) (intval(v) <= (int)F_PROGN)
-
-static char *builtin_names[] =
- { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",- "progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
- "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
- "prog1", "apply", "rplaca", "rplacd", "boundp" };
-
-static char *stack_bottom;
-#define PROCESS_STACK_SIZE (2*1024*1024)
-#define N_STACK 49152
-static value_t Stack[N_STACK];
-static u_int32_t SP = 0;
-#define PUSH(v) (Stack[SP++] = (v))
-#define POP() (Stack[--SP])
-#define POPN(n) (SP-=(n))
-
-value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
-
-value_t read_sexpr(FILE *f);
-void print(FILE *f, value_t v);
-value_t eval_sexpr(value_t e, value_t *penv);
-value_t load_file(char *fname);
-
-// error utilities ------------------------------------------------------------
-
-jmp_buf toplevel;
-
-void lerror(char *format, ...)
-{- va_list args;
- va_start(args, format);
- vfprintf(stderr, format, args);
- va_end(args);
- longjmp(toplevel, 1);
-}
-
-void type_error(char *fname, char *expected, value_t got)
-{- fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
- print(stderr, got); lerror("\n");-}
-
-// safe cast operators --------------------------------------------------------
-
-#define SAFECAST_OP(type,ctype,cnvt) \
-ctype to##type(value_t v, char *fname) \
-{ \- if (is##type(v)) \
- return (ctype)cnvt(v); \
- type_error(fname, #type, v); \
- return (ctype)0; \
-}
-SAFECAST_OP(cons, cons_t*, ptr)
-SAFECAST_OP(symbol,symbol_t*,ptr)
-SAFECAST_OP(number,number_t, numval)
-
-// symbol table ---------------------------------------------------------------
-
-static symbol_t *symtab = NULL;
-
-static symbol_t *mk_symbol(char *str)
-{- symbol_t *sym;
-
- sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
- sym->left = sym->right = NULL;
- sym->constant = sym->binding = UNBOUND;
- strcpy(&sym->name[0], str);
- return sym;
-}
-
-static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
-{- int x;
-
- while(*ptree != NULL) {- x = strcmp(str, (*ptree)->name);
- if (x == 0)
- return ptree;
- if (x < 0)
- ptree = &(*ptree)->left;
- else
- ptree = &(*ptree)->right;
- }
- return ptree;
-}
-
-value_t symbol(char *str)
-{- symbol_t **pnode;
-
- pnode = symtab_lookup(&symtab, str);
- if (*pnode == NULL)
- *pnode = mk_symbol(str);
- return tagptr(*pnode, TAG_SYM);
-}
-
-// initialization -------------------------------------------------------------
-
-static unsigned char *fromspace;
-static unsigned char *tospace;
-static unsigned char *curheap;
-static unsigned char *lim;
-static u_int32_t heapsize = 64*1024;//bytes
-
-void lisp_init(void)
-{- int i;
-
- fromspace = malloc(heapsize);
- tospace = malloc(heapsize);
- curheap = fromspace;
- lim = curheap+heapsize-sizeof(cons_t);
-
- NIL = symbol("nil"); setc(NIL, NIL);- T = symbol("t"); setc(T, T);- LAMBDA = symbol("lambda");- MACRO = symbol("macro");- LABEL = symbol("label");- QUOTE = symbol("quote");- for (i=0; i < (int)N_BUILTINS; i++)
- setc(symbol(builtin_names[i]), builtin(i));
- setc(symbol("princ"), builtin(F_PRINT));-}
-
-// conses ---------------------------------------------------------------------
-
-void gc(void);
-
-static value_t mk_cons(void)
-{- cons_t *c;
-
- if (curheap > lim)
- gc();
- c = (cons_t*)curheap;
- curheap += sizeof(cons_t);
- return tagptr(c, TAG_CONS);
-}
-
-static value_t cons_(value_t *pcar, value_t *pcdr)
-{- value_t c = mk_cons();
- car_(c) = *pcar; cdr_(c) = *pcdr;
- return c;
-}
-
-value_t *cons(value_t *pcar, value_t *pcdr)
-{- value_t c = mk_cons();
- car_(c) = *pcar; cdr_(c) = *pcdr;
- PUSH(c);
- return &Stack[SP-1];
-}
-
-// collector ------------------------------------------------------------------
-
-static value_t relocate(value_t v)
-{- value_t a, d, nc;
-
- if (!iscons(v))
- return v;
- if (car_(v) == UNBOUND)
- return cdr_(v);
- nc = mk_cons();
- a = car_(v); d = cdr_(v);
- car_(v) = UNBOUND; cdr_(v) = nc;
- car_(nc) = relocate(a);
- cdr_(nc) = relocate(d);
- return nc;
-}
-
-static void trace_globals(symbol_t *root)
-{- while (root != NULL) {- root->binding = relocate(root->binding);
- trace_globals(root->left);
- root = root->right;
- }
-}
-
-void gc(void)
-{- static int grew = 0;
- unsigned char *temp;
- u_int32_t i;
-
- curheap = tospace;
- lim = curheap+heapsize-sizeof(cons_t);
-
- for (i=0; i < SP; i++)
- Stack[i] = relocate(Stack[i]);
- trace_globals(symtab);
-#ifdef VERBOSEGC
- printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);-#endif
- temp = tospace;
- tospace = fromspace;
- fromspace = temp;
-
- // if we're using > 80% of the space, resize tospace so we have
- // more space to fill next time. if we grew tospace last time,
- // grow the other half of the heap this time to catch up.
- if (grew || ((lim-curheap) < (int)(heapsize/5))) {- temp = realloc(tospace, grew ? heapsize : heapsize*2);
- if (temp == NULL)
- lerror("out of memory\n");- tospace = temp;
- if (!grew)
- heapsize*=2;
- grew = !grew;
- }
- if (curheap > lim) // all data was live
- gc();
-}
-
-// read -----------------------------------------------------------------------
-
-enum {- TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
-};
-
-static int symchar(char c)
-{- static char *special = "()';\\|";
- return (!isspace(c) && !strchr(special, c));
-}
-
-static u_int32_t toktype = TOK_NONE;
-static value_t tokval;
-static char buf[256];
-
-static char nextchar(FILE *f)
-{- char c;
- int ch;
-
- do {- ch = fgetc(f);
- if (ch == EOF)
- return 0;
- c = (char)ch;
- if (c == ';') {- // single-line comment
- do {- ch = fgetc(f);
- if (ch == EOF)
- return 0;
- } while ((char)ch != '\n');
- c = (char)ch;
- }
- } while (isspace(c));
- return c;
-}
-
-static void take(void)
-{- toktype = TOK_NONE;
-}
-
-static void accumchar(char c, int *pi)
-{- buf[(*pi)++] = c;
- if (*pi >= (int)(sizeof(buf)-1))
- lerror("read: error: token too long\n");-}
-
-// return: 1 for dot token, 0 for symbol
-static int read_token(FILE *f, char c)
-{- int i=0, ch, escaped=0, dot=(c=='.'), totread=0;
-
- ungetc(c, f);
- while (1) {- ch = fgetc(f); totread++;
- if (ch == EOF)
- goto terminate;
- c = (char)ch;
- if (c == '|') {- escaped = !escaped;
- }
- else if (c == '\\') {- ch = fgetc(f);
- if (ch == EOF)
- goto terminate;
- accumchar((char)ch, &i);
- }
- else if (!escaped && !symchar(c)) {- break;
- }
- else {- accumchar(c, &i);
- }
- }
- ungetc(c, f);
- terminate:
- buf[i++] = '\0';
- return (dot && (totread==2));
-}
-
-static u_int32_t peek(FILE *f)
-{- char c, *end;
- number_t x;
-
- if (toktype != TOK_NONE)
- return toktype;
- c = nextchar(f);
- if (feof(f)) return TOK_NONE;
- if (c == '(') {- toktype = TOK_OPEN;
- }
- else if (c == ')') {- toktype = TOK_CLOSE;
- }
- else if (c == '\'') {- toktype = TOK_QUOTE;
- }
- else if (isdigit(c) || c=='-' || c=='+') {- read_token(f, c);
- x = strtol(buf, &end, 0);
- if (*end != '\0') {- toktype = TOK_SYM;
- tokval = symbol(buf);
- }
- else {- toktype = TOK_NUM;
- tokval = number(x);
- }
- }
- else {- if (read_token(f, c)) {- toktype = TOK_DOT;
- }
- else {- toktype = TOK_SYM;
- tokval = symbol(buf);
- }
- }
- return toktype;
-}
-
-// build a list of conses. this is complicated by the fact that all conses
-// can move whenever a new cons is allocated. we have to refer to every cons
-// through a handle to a relocatable pointer (i.e. a pointer on the stack).
-static void read_list(FILE *f, value_t *pval)
-{- value_t c, *pc;
- u_int32_t t;
-
- PUSH(NIL);
- pc = &Stack[SP-1]; // to keep track of current cons cell
- t = peek(f);
- while (t != TOK_CLOSE) {- if (feof(f))
- lerror("read: error: unexpected end of input\n");- c = mk_cons(); car_(c) = cdr_(c) = NIL;
- if (iscons(*pc))
- cdr_(*pc) = c;
- else
- *pval = c;
- *pc = c;
- c = read_sexpr(f); // must be on separate lines due to undefined
- car_(*pc) = c; // evaluation order
-
- t = peek(f);
- if (t == TOK_DOT) {- take();
- c = read_sexpr(f);
- cdr_(*pc) = c;
- t = peek(f);
- if (feof(f))
- lerror("read: error: unexpected end of input\n");- if (t != TOK_CLOSE)
- lerror("read: error: expected ')'\n");- }
- }
- take();
- POP();
-}
-
-value_t read_sexpr(FILE *f)
-{- value_t v;
-
- switch (peek(f)) {- case TOK_CLOSE:
- take();
- lerror("read: error: unexpected ')'\n");- case TOK_DOT:
- take();
- lerror("read: error: unexpected '.'\n");- case TOK_SYM:
- case TOK_NUM:
- take();
- return tokval;
- case TOK_QUOTE:
- take();
- v = read_sexpr(f);
- PUSH(v);
- v = cons_("E, cons(&Stack[SP-1], &NIL));
- POPN(2);
- return v;
- case TOK_OPEN:
- take();
- PUSH(NIL);
- read_list(f, &Stack[SP-1]);
- return POP();
- }
- return NIL;
-}
-
-// print ----------------------------------------------------------------------
-
-void print(FILE *f, value_t v)
-{- value_t cd;
-
- switch (tag(v)) {- case TAG_NUM: fprintf(f, "%d", numval(v)); break;
- case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
- case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
- builtin_names[intval(v)]); break;
- case TAG_CONS:
- fprintf(f, "(");- while (1) {- print(f, car_(v));
- cd = cdr_(v);
- if (!iscons(cd)) {- if (cd != NIL) {- fprintf(f, " . ");
- print(f, cd);
- }
- fprintf(f, ")");
- break;
- }
- fprintf(f, " ");
- v = cd;
- }
- break;
- }
-}
-
-// eval -----------------------------------------------------------------------
-
-static inline void argcount(char *fname, int nargs, int c)
-{- if (nargs != c)
- lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");-}
-
-#define eval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env))
-#define tail_eval(xpr, env) do { SP = saveSP; \- if (tag(xpr)<0x2) { return (xpr); } \- else { e=(xpr); *penv=(env); goto eval_top; } } while (0)-
-value_t eval_sexpr(value_t e, value_t *penv)
-{- value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
- value_t *rest;
- cons_t *c;
- symbol_t *sym;
- u_int32_t saveSP;
- int i, nargs, noeval=0;
- number_t s, n;
-
- eval_top:
- if (issymbol(e)) {- sym = (symbol_t*)ptr(e);
- if (sym->constant != UNBOUND) return sym->constant;
- v = *penv;
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == e)
- return cdr_(bind);
- v = cdr_(v);
- }
- if ((v = sym->binding) == UNBOUND)
- lerror("eval: error: variable %s has no value\n", sym->name);- return v;
- }
- if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
- lerror("eval: error: stack overflow\n");- saveSP = SP;
- PUSH(e);
- PUSH(*penv);
- f = eval(car_(e), penv);
- *penv = Stack[saveSP+1];
- if (isbuiltin(f)) {- // handle builtin function
- if (!isspecial(f)) {- // evaluate argument list, placing arguments on stack
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- while (iscons(v)) {- v = eval(car_(v), penv);
- *penv = Stack[saveSP+1];
- PUSH(v);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- }
- apply_builtin:
- nargs = SP - saveSP - 2;
- switch (intval(f)) {- // special forms
- case F_QUOTE:
- v = cdr_(Stack[saveSP]);
- if (!iscons(v))
- lerror("quote: error: expected argument\n");- v = car_(v);
- break;
- case F_MACRO:
- case F_LAMBDA:
- v = Stack[saveSP];
- if (*penv != NIL) {- // build a closure (lambda args body . env)
- v = cdr_(v);
- PUSH(car(v));
- argsyms = &Stack[SP-1];
- PUSH(car(cdr_(v)));
- body = &Stack[SP-1];
- v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
- cons(argsyms, cons(body, penv)));
- }
- break;
- case F_LABEL:
- v = Stack[saveSP];
- if (*penv != NIL) {- v = cdr_(v);
- PUSH(car(v)); // name
- pv = &Stack[SP-1];
- PUSH(car(cdr_(v))); // function
- body = &Stack[SP-1];
- *body = eval(*body, penv); // evaluate lambda
- v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
- }
- break;
- case F_IF:
- v = car(cdr_(Stack[saveSP]));
- if (eval(v, penv) != NIL)
- v = car(cdr_(cdr_(Stack[saveSP])));
- else
- v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
- tail_eval(v, Stack[saveSP+1]);
- break;
- case F_COND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- c = tocons(car_(*pv), "cond");
- v = eval(c->car, penv);
- *penv = Stack[saveSP+1];
- if (v != NIL) {- *pv = cdr_(car_(*pv));
- // evaluate body forms
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- v = eval(car_(*pv), penv);
- *penv = Stack[saveSP+1];
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv), *penv);
- }
- break;
- }
- *pv = cdr_(*pv);
- }
- break;
- case F_AND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = T;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- if ((v=eval(car_(*pv), penv)) == NIL) {- SP = saveSP; return NIL;
- }
- *penv = Stack[saveSP+1];
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv), *penv);
- }
- break;
- case F_OR:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- if ((v=eval(car_(*pv), penv)) != NIL) {- SP = saveSP; return v;
- }
- *penv = Stack[saveSP+1];
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv), *penv);
- }
- break;
- case F_WHILE:
- PUSH(cdr(cdr_(Stack[saveSP])));
- body = &Stack[SP-1];
- PUSH(*body);
- Stack[saveSP] = car_(cdr_(Stack[saveSP]));
- value_t *cond = &Stack[saveSP];
- PUSH(NIL);
- pv = &Stack[SP-1];
- while (eval(*cond, penv) != NIL) {- *penv = Stack[saveSP+1];
- *body = Stack[SP-2];
- while (iscons(*body)) {- *pv = eval(car_(*body), penv);
- *penv = Stack[saveSP+1];
- *body = cdr_(*body);
- }
- }
- v = *pv;
- break;
- case F_PROGN:
- // return last arg
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- v = eval(car_(*pv), penv);
- *penv = Stack[saveSP+1];
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv), *penv);
- }
- break;
-
- // ordinary functions
- case F_SET:
- argcount("set", nargs, 2);- e = Stack[SP-2];
- v = *penv;
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == e) {- cdr_(bind) = (v=Stack[SP-1]);
- SP=saveSP; return v;
- }
- v = cdr_(v);
- }
- tosymbol(e, "set")->binding = (v=Stack[SP-1]);
- break;
- case F_BOUNDP:
- argcount("boundp", nargs, 1);- sym = tosymbol(Stack[SP-1], "boundp");
- if (sym->binding == UNBOUND && sym->constant == UNBOUND)
- v = NIL;
- else
- v = T;
- break;
- case F_EQ:
- argcount("eq", nargs, 2);- v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
- break;
- case F_CONS:
- argcount("cons", nargs, 2);- v = mk_cons();
- car_(v) = Stack[SP-2];
- cdr_(v) = Stack[SP-1];
- break;
- case F_CAR:
- argcount("car", nargs, 1);- v = car(Stack[SP-1]);
- break;
- case F_CDR:
- argcount("cdr", nargs, 1);- v = cdr(Stack[SP-1]);
- break;
- case F_RPLACA:
- argcount("rplaca", nargs, 2);- car(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_RPLACD:
- argcount("rplacd", nargs, 2);- cdr(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_ATOM:
- argcount("atom", nargs, 1);- v = ((!iscons(Stack[SP-1])) ? T : NIL);
- break;
- case F_SYMBOLP:
- argcount("symbolp", nargs, 1);- v = ((issymbol(Stack[SP-1])) ? T : NIL);
- break;
- case F_NUMBERP:
- argcount("numberp", nargs, 1);- v = ((isnumber(Stack[SP-1])) ? T : NIL);
- break;
- case F_ADD:
- s = 0;
- for (i=saveSP+2; i < (int)SP; i++) {- n = tonumber(Stack[i], "+");
- s += n;
- }
- v = number(s);
- break;
- case F_SUB:
- if (nargs < 1)
- lerror("-: error: too few arguments\n");- i = saveSP+2;
- s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "-");
- s -= n;
- }
- v = number(s);
- break;
- case F_MUL:
- s = 1;
- for (i=saveSP+2; i < (int)SP; i++) {- n = tonumber(Stack[i], "*");
- s *= n;
- }
- v = number(s);
- break;
- case F_DIV:
- if (nargs < 1)
- lerror("/: error: too few arguments\n");- i = saveSP+2;
- s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "/");
- if (n == 0)
- lerror("/: error: division by zero\n");- s /= n;
- }
- v = number(s);
- break;
- case F_LT:
- argcount("<", nargs, 2);- if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
- v = T;
- else
- v = NIL;
- break;
- case F_NOT:
- argcount("not", nargs, 1);- v = ((Stack[SP-1] == NIL) ? T : NIL);
- break;
- case F_EVAL:
- argcount("eval", nargs, 1);- v = Stack[SP-1];
- tail_eval(v, NIL);
- break;
- case F_PRINT:
- for (i=saveSP+2; i < (int)SP; i++)
- print(stdout, v=Stack[i]);
- break;
- case F_READ:
- argcount("read", nargs, 0);- v = read_sexpr(stdin);
- break;
- case F_LOAD:
- argcount("load", nargs, 1);- v = load_file(tosymbol(Stack[SP-1], "load")->name);
- break;
- case F_PROG1:
- // return first arg
- if (nargs < 1)
- lerror("prog1: error: too few arguments\n");- v = Stack[saveSP+2];
- break;
- case F_APPLY:
- argcount("apply", nargs, 2);- v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
- f = Stack[SP-2]; // first arg is new function
- POPN(2); // pop apply's args
- if (isbuiltin(f)) {- if (isspecial(f))
- lerror("apply: error: cannot apply special operator "- "%s\n", builtin_names[intval(f)]);
- // unpack arglist onto the stack
- while (iscons(v)) {- PUSH(car_(v));
- v = cdr_(v);
- }
- goto apply_builtin;
- }
- noeval = 1;
- goto apply_lambda;
- }
- SP = saveSP;
- return v;
- }
- else {- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- apply_lambda:
- if (iscons(f)) {- headsym = car_(f);
- if (headsym == LABEL) {- // (label name (lambda ...)) behaves the same as the lambda
- // alone, except with name bound to the whole label expression
- labl = f;
- f = car(cdr(cdr_(labl)));
- headsym = car(f);
- }
- // apply lambda or macro expression
- PUSH(cdr(cdr(cdr_(f))));
- lenv = &Stack[SP-1];
- PUSH(car_(cdr_(f)));
- argsyms = &Stack[SP-1];
- PUSH(car_(cdr_(cdr_(f))));
- body = &Stack[SP-1];
- if (labl) {- // add label binding to environment
- PUSH(labl);
- PUSH(car_(cdr_(labl)));
- *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
- POPN(3);
- v = Stack[saveSP]; // refetch arglist
- }
- if (headsym == MACRO)
- noeval = 1;
- else if (headsym != LAMBDA)
- lerror("apply: error: head must be lambda, macro, or label\n");- // build a calling environment for the lambda
- // the environment is the argument binds on top of the captured
- // environment
- while (iscons(v)) {- // bind args
- if (!iscons(*argsyms)) {- if (*argsyms == NIL)
- lerror("apply: error: too many arguments\n");- break;
- }
- asym = car_(*argsyms);
- if (!issymbol(asym))
- lerror("apply: error: formal argument not a symbol\n");- v = car_(v);
- if (!noeval) {- v = eval(v, penv);
- *penv = Stack[saveSP+1];
- }
- PUSH(v);
- *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
- POPN(2);
- *argsyms = cdr_(*argsyms);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- if (*argsyms != NIL) {- if (issymbol(*argsyms)) {- if (noeval) {- *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
- }
- else {- PUSH(NIL);
- PUSH(NIL);
- rest = &Stack[SP-1];
- // build list of rest arguments
- // we have to build it forwards, which is tricky
- while (iscons(v)) {- v = eval(car_(v), penv);
- *penv = Stack[saveSP+1];
- PUSH(v);
- v = cons_(&Stack[SP-1], &NIL);
- POP();
- if (iscons(*rest))
- cdr_(*rest) = v;
- else
- Stack[SP-2] = v;
- *rest = v;
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
- }
- }
- else if (iscons(*argsyms)) {- lerror("apply: error: too few arguments\n");- }
- }
- noeval = 0;
- // macro: evaluate expansion in the calling environment
- if (headsym == MACRO) {- SP = saveSP;
- PUSH(*lenv);
- lenv = &Stack[SP-1];
- v = eval(*body, lenv);
- tail_eval(v, *penv);
- }
- else {- tail_eval(*body, *lenv);
- }
- // not reached
- }
- type_error("apply", "function", f);- return NIL;
-}
-
-// repl -----------------------------------------------------------------------
-
-static char *infile = NULL;
-
-value_t toplevel_eval(value_t expr)
-{- value_t v;
- u_int32_t saveSP = SP;
- PUSH(NIL);
- v = eval(expr, &Stack[SP-1]);
- SP = saveSP;
- return v;
-}
-
-value_t load_file(char *fname)
-{- value_t e, v=NIL;
- char *lastfile = infile;
- FILE *f = fopen(fname, "r");
- infile = fname;
- if (f == NULL) lerror("file not found\n");- while (1) {- e = read_sexpr(f);
- if (feof(f)) break;
- v = toplevel_eval(e);
- }
- infile = lastfile;
- fclose(f);
- return v;
-}
-
-int main(int argc, char* argv[])
-{- value_t v;
-
- stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
- lisp_init();
- if (setjmp(toplevel)) {- SP = 0;
- fprintf(stderr, "\n");
- if (infile) {- fprintf(stderr, "error loading file \"%s\"\n", infile);
- infile = NULL;
- }
- goto repl;
- }
- load_file("system.lsp");- if (argc > 1) { load_file(argv[1]); return 0; }- printf("Welcome to femtoLisp ----------------------------------------------------------\n");- repl:
- while (1) {- printf("> ");- v = read_sexpr(stdin);
- if (feof(stdin)) break;
- print(stdout, v=toplevel_eval(v));
- set(symbol("that"), v);- printf("\n\n");- }
- return 0;
-}
--- a/femtolisp/tiny/lisp2.c
+++ /dev/null
@@ -1,1434 +1,0 @@
-/*
- femtoLisp
-
- a minimal interpreter for a minimal lisp dialect
-
- this lisp dialect uses lexical scope and self-evaluating lambda.
- it supports 30-bit integers, symbols, conses, and full macros.
- it is case-sensitive.
- it features a simple compacting copying garbage collector.
- it uses a Scheme-style evaluation rule where any expression may appear in
- head position as long as it evaluates to a function.
- it uses Scheme-style varargs (dotted formal argument lists)
- lambdas can have only 1 body expression; use (progn ...) for multiple
- expressions. this is due to the closure representation
- (lambda args body . env)
-
- This is a fork of femtoLisp with advanced reading and printing facilities:
- * circular structure can be printed and read
- * #. read macro for eval-when-read and correctly printing builtins
- * read macros for backquote
- * symbol character-escaping printer
-
- * new print algorithm
- 1. traverse & tag all conses to be printed. when you encounter a cons
- that is already tagged, add it to a table to give it a #n# index
- 2. untag a cons when printing it. if cons is in the table, print
- "#n=" before it in the car, " . #n=" in the cdr. if cons is in the
- table but already untagged, print #n# in car or " . #n#" in the cdr.
- * read macros for #n# and #n= using the same kind of table
- * also need a table of read labels to translate from input indexes to
- normalized indexes (0 for first label, 1 for next, etc.)
- * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq"
-
- The value of this extra complexity, and what makes this fork worthy of
- the femtoLisp brand, is that the interpreter is fully "closed" in the
- sense that all representable values can be read and printed.
-
- by Jeff Bezanson
- Public Domain
-*/
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <setjmp.h>
-#include <stdarg.h>
-#include <ctype.h>
-#include <sys/types.h>
-
-typedef u_int32_t value_t;
-typedef int32_t number_t;
-
-typedef struct {- value_t car;
- value_t cdr;
-} cons_t;
-
-typedef struct _symbol_t {- value_t binding; // global value binding
- value_t constant; // constant binding (used only for builtins)
- struct _symbol_t *left;
- struct _symbol_t *right;
- char name[1];
-} symbol_t;
-
-#define TAG_NUM 0x0
-#define TAG_BUILTIN 0x1
-#define TAG_SYM 0x2
-#define TAG_CONS 0x3
-#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
-#define tag(x) ((x)&0x3)
-#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
-#define tagptr(p,t) (((value_t)(p)) | (t))
-#define number(x) ((value_t)((x)<<2))
-#define numval(x) (((number_t)(x))>>2)
-#define intval(x) (((int)(x))>>2)
-#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
-#define iscons(x) (tag(x) == TAG_CONS)
-#define issymbol(x) (tag(x) == TAG_SYM)
-#define isnumber(x) (tag(x) == TAG_NUM)
-#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
-// functions ending in _ are unsafe, faster versions
-#define car_(v) (((cons_t*)ptr(v))->car)
-#define cdr_(v) (((cons_t*)ptr(v))->cdr)
-#define car(v) (tocons((v),"car")->car)
-#define cdr(v) (tocons((v),"cdr")->cdr)
-#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
-#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
-
-enum {- // special forms
- F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
- F_PROGN,
- // functions
- F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
- F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
- F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, F_ERROR, F_EXIT, F_PRINC, F_CONSP,
- F_ASSOC, N_BUILTINS
-};
-#define isspecial(v) (intval(v) <= (number_t)F_PROGN)
-
-static char *builtin_names[] =
- { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",- "progn",
- "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
- "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
- "prog1", "apply", "rplaca", "rplacd", "boundp", "error", "exit", "princ",
- "consp", "assoc" };
-
-static char *stack_bottom;
-#define PROCESS_STACK_SIZE (2*1024*1024)
-#define N_STACK 98304
-static value_t Stack[N_STACK];
-static u_int32_t SP = 0;
-#define PUSH(v) (Stack[SP++] = (v))
-#define POP() (Stack[--SP])
-#define POPN(n) (SP-=(n))
-
-value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
-value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
-
-value_t read_sexpr(FILE *f);
-void print(FILE *f, value_t v, int princ);
-value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend);
-value_t load_file(char *fname);
-value_t toplevel_eval(value_t expr);
-
-#include "flutils.c"
-
-typedef struct _readstate_t {- ltable_t labels;
- ltable_t exprs;
- struct _readstate_t *prev;
-} readstate_t;
-static readstate_t *readstate = NULL;
-
-// error utilities ------------------------------------------------------------
-
-jmp_buf toplevel;
-
-void lerror(char *format, ...)
-{- va_list args;
- va_start(args, format);
-
- while (readstate) {- free(readstate->labels.items);
- free(readstate->exprs.items);
- readstate = readstate->prev;
- }
-
- vfprintf(stderr, format, args);
- va_end(args);
- longjmp(toplevel, 1);
-}
-
-void type_error(char *fname, char *expected, value_t got)
-{- fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
- print(stderr, got, 0); lerror("\n");-}
-
-// safe cast operators --------------------------------------------------------
-
-#define SAFECAST_OP(type,ctype,cnvt) \
-ctype to##type(value_t v, char *fname) \
-{ \- if (is##type(v)) \
- return (ctype)cnvt(v); \
- type_error(fname, #type, v); \
- return (ctype)0; \
-}
-SAFECAST_OP(cons, cons_t*, ptr)
-SAFECAST_OP(symbol,symbol_t*,ptr)
-SAFECAST_OP(number,number_t, numval)
-
-// symbol table ---------------------------------------------------------------
-
-static symbol_t *symtab = NULL;
-
-static symbol_t *mk_symbol(char *str)
-{- symbol_t *sym;
-
- sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
- sym->left = sym->right = NULL;
- sym->constant = sym->binding = UNBOUND;
- strcpy(&sym->name[0], str);
- return sym;
-}
-
-static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
-{- int x;
-
- while(*ptree != NULL) {- x = strcmp(str, (*ptree)->name);
- if (x == 0)
- return ptree;
- if (x < 0)
- ptree = &(*ptree)->left;
- else
- ptree = &(*ptree)->right;
- }
- return ptree;
-}
-
-value_t symbol(char *str)
-{- symbol_t **pnode;
-
- pnode = symtab_lookup(&symtab, str);
- if (*pnode == NULL)
- *pnode = mk_symbol(str);
- return tagptr(*pnode, TAG_SYM);
-}
-
-// initialization -------------------------------------------------------------
-
-static unsigned char *fromspace;
-static unsigned char *tospace;
-static unsigned char *curheap;
-static unsigned char *lim;
-static u_int32_t heapsize = 128*1024;//bytes
-static u_int32_t *consflags;
-static ltable_t printconses;
-
-void lisp_init(void)
-{- int i;
-
- fromspace = malloc(heapsize);
- tospace = malloc(heapsize);
- curheap = fromspace;
- lim = curheap+heapsize-sizeof(cons_t);
- consflags = mk_bitvector(heapsize/sizeof(cons_t));
-
- ltable_init(&printconses, 32);
-
- NIL = symbol("nil"); setc(NIL, NIL);- T = symbol("t"); setc(T, T);- LAMBDA = symbol("lambda");- MACRO = symbol("macro");- LABEL = symbol("label");- QUOTE = symbol("quote");- BACKQUOTE = symbol("backquote");- COMMA = symbol("*comma*");- COMMAAT = symbol("*comma-at*");- COMMADOT = symbol("*comma-dot*");- for (i=0; i < (int)N_BUILTINS; i++)
- setc(symbol(builtin_names[i]), builtin(i));
-}
-
-// conses ---------------------------------------------------------------------
-
-void gc(int mustgrow);
-
-static value_t mk_cons(void)
-{- cons_t *c;
-
- if (curheap > lim)
- gc(0);
- c = (cons_t*)curheap;
- curheap += sizeof(cons_t);
- return tagptr(c, TAG_CONS);
-}
-
-// allocate n consecutive conses
-static value_t cons_reserve(int n)
-{- cons_t *first;
-
- n--;
- if ((cons_t*)curheap > ((cons_t*)lim)-n) {- gc(0);
- while ((cons_t*)curheap > ((cons_t*)lim)-n) {- gc(1);
- }
- }
- first = (cons_t*)curheap;
- curheap += ((n+1)*sizeof(cons_t));
- return tagptr(first, TAG_CONS);
-}
-
-#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace))
-#define ismarked(c) bitvector_get(consflags, cons_index(c))
-#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
-#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
-
-// collector ------------------------------------------------------------------
-
-static value_t relocate(value_t v)
-{- value_t a, d, nc, first, *pcdr;
-
- if (!iscons(v))
- return v;
- // iterative implementation allows arbitrarily long cons chains
- pcdr = &first;
- do {- if ((a=car_(v)) == UNBOUND) {- *pcdr = cdr_(v);
- return first;
- }
- *pcdr = nc = mk_cons();
- d = cdr_(v);
- car_(v) = UNBOUND; cdr_(v) = nc;
- car_(nc) = relocate(a);
- pcdr = &cdr_(nc);
- v = d;
- } while (iscons(v));
- *pcdr = d;
-
- return first;
-}
-
-static void trace_globals(symbol_t *root)
-{- while (root != NULL) {- root->binding = relocate(root->binding);
- trace_globals(root->left);
- root = root->right;
- }
-}
-
-void gc(int mustgrow)
-{- static int grew = 0;
- void *temp;
- u_int32_t i;
- readstate_t *rs;
-
- curheap = tospace;
- lim = curheap+heapsize-sizeof(cons_t);
-
- for (i=0; i < SP; i++)
- Stack[i] = relocate(Stack[i]);
- trace_globals(symtab);
- rs = readstate;
- while (rs) {- for(i=0; i < rs->exprs.n; i++)
- rs->exprs.items[i] = relocate(rs->exprs.items[i]);
- rs = rs->prev;
- }
-#ifdef VERBOSEGC
- printf("gc found %d/%d live conses\n",- (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t));
-#endif
- temp = tospace;
- tospace = fromspace;
- fromspace = temp;
-
- // if we're using > 80% of the space, resize tospace so we have
- // more space to fill next time. if we grew tospace last time,
- // grow the other half of the heap this time to catch up.
- if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {- temp = realloc(tospace, grew ? heapsize : heapsize*2);
- if (temp == NULL)
- lerror("out of memory\n");- tospace = temp;
- if (!grew) {- heapsize*=2;
- }
- else {- temp = bitvector_resize(consflags, heapsize/sizeof(cons_t));
- if (temp == NULL)
- lerror("out of memory\n");- consflags = (u_int32_t*)temp;
- }
- grew = !grew;
- }
- if (curheap > lim) // all data was live
- gc(0);
-}
-
-// read -----------------------------------------------------------------------
-
-enum {- TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
- TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
- TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE
-};
-
-// defines which characters are ordinary symbol characters.
-// the only exception is '.', which is an ordinary symbol character
-// unless it is the only character in the symbol.
-static int symchar(char c)
-{- static char *special = "()';`,\\|";
- return (!isspace(c) && !strchr(special, c));
-}
-
-static u_int32_t toktype = TOK_NONE;
-static value_t tokval;
-static char buf[256];
-
-static char nextchar(FILE *f)
-{- int ch;
- char c;
-
- do {- ch = fgetc(f);
- if (ch == EOF)
- return 0;
- c = (char)ch;
- if (c == ';') {- // single-line comment
- do {- ch = fgetc(f);
- if (ch == EOF)
- return 0;
- } while ((char)ch != '\n');
- c = (char)ch;
- }
- } while (isspace(c));
- return c;
-}
-
-static void take(void)
-{- toktype = TOK_NONE;
-}
-
-static void accumchar(char c, int *pi)
-{- buf[(*pi)++] = c;
- if (*pi >= (int)(sizeof(buf)-1))
- lerror("read: error: token too long\n");-}
-
-// return: 1 for dot token, 0 for symbol
-static int read_token(FILE *f, char c, int digits)
-{- int i=0, ch, escaped=0, dot=(c=='.'), totread=0;
-
- ungetc(c, f);
- while (1) {- ch = fgetc(f); totread++;
- if (ch == EOF)
- goto terminate;
- c = (char)ch;
- if (c == '|') {- escaped = !escaped;
- }
- else if (c == '\\') {- ch = fgetc(f);
- if (ch == EOF)
- goto terminate;
- accumchar((char)ch, &i);
- }
- else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {- break;
- }
- else {- accumchar(c, &i);
- }
- }
- ungetc(c, f);
- terminate:
- buf[i++] = '\0';
- return (dot && (totread==2));
-}
-
-static u_int32_t peek(FILE *f)
-{- char c, *end;
- number_t x;
- int ch;
-
- if (toktype != TOK_NONE)
- return toktype;
- c = nextchar(f);
- if (feof(f)) return TOK_NONE;
- if (c == '(') {- toktype = TOK_OPEN;
- }
- else if (c == ')') {- toktype = TOK_CLOSE;
- }
- else if (c == '\'') {- toktype = TOK_QUOTE;
- }
- else if (c == '`') {- toktype = TOK_BQ;
- }
- else if (c == '#') {- ch = fgetc(f);
- if (ch == EOF)
- lerror("read: error: invalid read macro\n");- if ((char)ch == '.') {- toktype = TOK_SHARPDOT;
- }
- else if ((char)ch == '\'') {- toktype = TOK_SHARPQUOTE;
- }
- else if ((char)ch == '\\') {- u_int32_t cval = u8_fgetc(f);
- toktype = TOK_NUM;
- tokval = number(cval);
- }
- else if (isdigit((char)ch)) {- read_token(f, (char)ch, 1);
- c = (char)fgetc(f);
- if (c == '#')
- toktype = TOK_BACKREF;
- else if (c == '=')
- toktype = TOK_LABEL;
- else
- lerror("read: error: invalid label\n");- x = strtol(buf, &end, 10);
- tokval = number(x);
- }
- else {- lerror("read: error: unknown read macro\n");- }
- }
- else if (c == ',') {- toktype = TOK_COMMA;
- ch = fgetc(f);
- if (ch == EOF)
- return toktype;
- if ((char)ch == '@')
- toktype = TOK_COMMAAT;
- else if ((char)ch == '.')
- toktype = TOK_COMMADOT;
- else
- ungetc((char)ch, f);
- }
- else if (isdigit(c) || c=='-' || c=='+') {- read_token(f, c, 0);
- x = strtol(buf, &end, 0);
- if (*end != '\0') {- toktype = TOK_SYM;
- tokval = symbol(buf);
- }
- else {- toktype = TOK_NUM;
- tokval = number(x);
- }
- }
- else {- if (read_token(f, c, 0)) {- toktype = TOK_DOT;
- }
- else {- toktype = TOK_SYM;
- tokval = symbol(buf);
- }
- }
- return toktype;
-}
-
-static value_t do_read_sexpr(FILE *f, int fixup);
-
-// build a list of conses. this is complicated by the fact that all conses
-// can move whenever a new cons is allocated. we have to refer to every cons
-// through a handle to a relocatable pointer (i.e. a pointer on the stack).
-static void read_list(FILE *f, value_t *pval, int fixup)
-{- value_t c, *pc;
- u_int32_t t;
-
- PUSH(NIL);
- pc = &Stack[SP-1]; // to keep track of current cons cell
- t = peek(f);
- while (t != TOK_CLOSE) {- if (feof(f))
- lerror("read: error: unexpected end of input\n");- c = mk_cons(); car_(c) = cdr_(c) = NIL;
- if (iscons(*pc)) {- cdr_(*pc) = c;
- }
- else {- *pval = c;
- if (fixup != -1)
- readstate->exprs.items[fixup] = c;
- }
- *pc = c;
- c = do_read_sexpr(f,-1); // must be on separate lines due to undefined
- car_(*pc) = c; // evaluation order
-
- t = peek(f);
- if (t == TOK_DOT) {- take();
- c = do_read_sexpr(f,-1);
- cdr_(*pc) = c;
- t = peek(f);
- if (feof(f))
- lerror("read: error: unexpected end of input\n");- if (t != TOK_CLOSE)
- lerror("read: error: expected ')'\n");- }
- }
- take();
- POP();
-}
-
-// fixup is the index of the label we'd like to fix up with this read
-static value_t do_read_sexpr(FILE *f, int fixup)
-{- value_t v, *head;
- u_int32_t t, l;
- int i;
-
- t = peek(f);
- take();
- switch (t) {- case TOK_CLOSE:
- lerror("read: error: unexpected ')'\n");- case TOK_DOT:
- lerror("read: error: unexpected '.'\n");- case TOK_SYM:
- case TOK_NUM:
- return tokval;
- case TOK_COMMA:
- head = &COMMA; goto listwith;
- case TOK_COMMAAT:
- head = &COMMAAT; goto listwith;
- case TOK_COMMADOT:
- head = &COMMADOT; goto listwith;
- case TOK_BQ:
- head = &BACKQUOTE; goto listwith;
- case TOK_QUOTE:
- head = "E;
- listwith:
- v = cons_reserve(2);
- car_(v) = *head;
- cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS);
- car_(cdr_(v)) = cdr_(cdr_(v)) = NIL;
- PUSH(v);
- if (fixup != -1)
- readstate->exprs.items[fixup] = v;
- v = do_read_sexpr(f,-1);
- car_(cdr_(Stack[SP-1])) = v;
- return POP();
- case TOK_SHARPQUOTE:
- // femtoLisp doesn't need symbol-function, so #' does nothing
- return do_read_sexpr(f, fixup);
- case TOK_OPEN:
- PUSH(NIL);
- read_list(f, &Stack[SP-1], fixup);
- return POP();
- case TOK_SHARPDOT:
- // eval-when-read
- // evaluated expressions can refer to existing backreferences, but they
- // cannot see pending labels. in other words:
- // (... #2=#.#0# ... ) OK
- // (... #2=#.(#2#) ... ) DO NOT WANT
- v = do_read_sexpr(f,-1);
- return toplevel_eval(v);
- case TOK_LABEL:
- // create backreference label
- l = numval(tokval);
- if (ltable_lookup(&readstate->labels, l) != NOTFOUND)
- lerror("read: error: label %d redefined\n", l);- ltable_insert(&readstate->labels, l);
- i = readstate->exprs.n;
- ltable_insert(&readstate->exprs, UNBOUND);
- v = do_read_sexpr(f,i);
- readstate->exprs.items[i] = v;
- return v;
- case TOK_BACKREF:
- // look up backreference
- l = numval(tokval);
- i = ltable_lookup(&readstate->labels, l);
- if (i == NOTFOUND || i >= (int)readstate->exprs.n ||
- readstate->exprs.items[i] == UNBOUND)
- lerror("read: error: undefined label %d\n", l);- return readstate->exprs.items[i];
- }
- return NIL;
-}
-
-value_t read_sexpr(FILE *f)
-{- value_t v;
- readstate_t state;
- state.prev = readstate;
- ltable_init(&state.labels, 16);
- ltable_init(&state.exprs, 16);
- readstate = &state;
-
- v = do_read_sexpr(f, -1);
-
- readstate = state.prev;
- free(state.labels.items);
- free(state.exprs.items);
- return v;
-}
-
-// print ----------------------------------------------------------------------
-
-static void print_traverse(value_t v)
-{- while (iscons(v)) {- if (ismarked(v)) {- ltable_adjoin(&printconses, v);
- return;
- }
- mark_cons(v);
- print_traverse(car_(v));
- v = cdr_(v);
- }
-}
-
-static void print_symbol(FILE *f, char *name)
-{- int i, escape=0, charescape=0;
-
- if (name[0] == '\0') {- fprintf(f, "||");
- return;
- }
- if (name[0] == '.' && name[1] == '\0') {- fprintf(f, "|.|");
- return;
- }
- if (name[0] == '#')
- escape = 1;
- i=0;
- while (name[i]) {- if (!symchar(name[i])) {- escape = 1;
- if (name[i]=='|' || name[i]=='\\') {- charescape = 1;
- break;
- }
- }
- i++;
- }
- if (escape) {- if (charescape) {- fprintf(f, "|");
- i=0;
- while (name[i]) {- if (name[i]=='|' || name[i]=='\\')
- fprintf(f, "\\%c", name[i]);
- else
- fprintf(f, "%c", name[i]);
- i++;
- }
- fprintf(f, "|");
- }
- else {- fprintf(f, "|%s|", name);
- }
- }
- else {- fprintf(f, "%s", name);
- }
-}
-
-static void do_print(FILE *f, value_t v, int princ)
-{- value_t cd;
- int label;
- char *name;
-
- switch (tag(v)) {- case TAG_NUM: fprintf(f, "%d", numval(v)); break;
- case TAG_SYM:
- name = ((symbol_t*)ptr(v))->name;
- if (princ)
- fprintf(f, "%s", name);
- else
- print_symbol(f, name);
- break;
- case TAG_BUILTIN: fprintf(f, "#.%s", builtin_names[intval(v)]); break;
- case TAG_CONS:
- if ((label=ltable_lookup(&printconses,v)) != NOTFOUND) {- if (!ismarked(v)) {- fprintf(f, "#%d#", label);
- return;
- }
- fprintf(f, "#%d=", label);
- }
- fprintf(f, "(");- while (1) {- unmark_cons(v);
- do_print(f, car_(v), princ);
- cd = cdr_(v);
- if (!iscons(cd)) {- if (cd != NIL) {- fprintf(f, " . ");
- do_print(f, cd, princ);
- }
- fprintf(f, ")");
- break;
- }
- else {- if ((label=ltable_lookup(&printconses,cd)) != NOTFOUND) {- fprintf(f, " . ");
- do_print(f, cd, princ);
- fprintf(f, ")");
- break;
- }
- }
- fprintf(f, " ");
- v = cd;
- }
- break;
- }
-}
-
-void print(FILE *f, value_t v, int princ)
-{- ltable_clear(&printconses);
- print_traverse(v);
- do_print(f, v, princ);
-}
-
-// eval -----------------------------------------------------------------------
-
-static inline void argcount(char *fname, int nargs, int c)
-{- if (nargs != c)
- lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");-}
-
-// return a cons element of v whose car is item
-static value_t assoc(value_t item, value_t v)
-{- value_t bind;
-
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == item)
- return bind;
- v = cdr_(v);
- }
- return NIL;
-}
-
-#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0,envend))
-#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1,SP))
-#define tail_eval(xpr) do { SP = saveSP; \- if (tag(xpr)<0x2) { return (xpr); } \- else { e=(xpr); goto eval_top; } } while (0)-
-/* stack setup on entry:
- n n+1 ...
- +-----+-----+-----+-----+-----+-----+-----+-----+
- | SYM | VAL | SYM | VAL | CLO | | | |
- +-----+-----+-----+-----+-----+-----+-----+-----+
- ^ ^ ^
- | | |
- penv envend SP (who knows where)
-
- sym is an argument name and val is its binding. CLO is a closed-up
- environment list (which can be empty, i.e. NIL).
- CLO is always there, but there might be zero SYM/VAL pairs.
-
- if tail==1, you are allowed (indeed encouraged) to overwrite this
- environment, otherwise you have to put any new environment on the top
- of the stack.
-*/
-value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
-{- value_t f, v, headsym, asym, *pv, *argsyms, *body, *lenv, *argenv;
- cons_t *c;
- symbol_t *sym;
- u_int32_t saveSP;
- int i, nargs, noeval=0;
- number_t s, n;
-
- eval_top:
- if (issymbol(e)) {- sym = (symbol_t*)ptr(e);
- if (sym->constant != UNBOUND) return sym->constant;
- while (issymbol(*penv)) { // 1. try lookup in argument env- if (*penv == NIL)
- goto get_global;
- if (*penv == e)
- return penv[1];
- penv+=2;
- }
- if ((v=assoc(e,*penv)) != NIL) // 2. closure env
- return cdr_(v);
- get_global:
- if ((v = sym->binding) == UNBOUND) // 3. global env
- lerror("eval: error: variable %s has no value\n", sym->name);- return v;
- }
- if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
- lerror("eval: error: stack overflow\n");- saveSP = SP;
- PUSH(e);
- v = car_(e);
- if (tag(v)<0x2) f = v;
- else if (issymbol(v) && (f=((symbol_t*)ptr(v))->constant)!=UNBOUND) ;
- else f = eval_sexpr(v, penv, 0, envend);
- if (isbuiltin(f)) {- // handle builtin function
- if (!isspecial(f)) {- // evaluate argument list, placing arguments on stack
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- while (iscons(v)) {- v = eval(car_(v));
- PUSH(v);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- }
- apply_builtin:
- nargs = SP - saveSP - 1;
- switch (intval(f)) {- // special forms
- case F_QUOTE:
- v = cdr_(Stack[saveSP]);
- if (!iscons(v)) lerror("quote: error: expected argument\n");- v = car_(v);
- break;
- case F_MACRO:
- case F_LAMBDA:
- // build a closure (lambda args body . env)
- if (issymbol(*penv) && *penv != NIL) {- // cons up and save temporary environment
- PUSH(Stack[envend-1]); // passed-in CLOENV
- // find out how many new conses we need
- nargs = ((int)(&Stack[envend] - penv - 1))>>1;
- if (nargs) {- lenv = penv;
- Stack[SP-1] = cons_reserve(nargs*2);
- c = (cons_t*)ptr(Stack[SP-1]);
- while (1) {- c->car = tagptr(c+1, TAG_CONS);
- (c+1)->car = penv[0];
- (c+1)->cdr = penv[1];
- nargs--;
- if (nargs==0) break;
- penv+=2;
- c->cdr = tagptr(c+2, TAG_CONS);
- c += 2;
- }
- // final cdr points to existing cloenv
- c->cdr = Stack[envend-1];
- // environment representation changed; install
- // the new representation so everybody can see it
- *lenv = Stack[SP-1];
- }
- }
- else {- PUSH(*penv); // env has already been captured; share
- }
- v = cdr_(Stack[saveSP]);
- PUSH(car(v));
- PUSH(car(cdr_(v)));
- c = (cons_t*)ptr(v=cons_reserve(3));
- c->car = (intval(f)==F_LAMBDA ? LAMBDA : MACRO);
- c->cdr = tagptr(c+1, TAG_CONS); c++;
- c->car = Stack[SP-2]; //argsyms
- c->cdr = tagptr(c+1, TAG_CONS); c++;
- c->car = Stack[SP-1]; //body
- c->cdr = Stack[SP-3]; //env
- break;
- case F_LABEL:
- // the syntax of label is (label name (lambda args body))
- // nothing else is guaranteed to work
- v = cdr_(Stack[saveSP]);
- PUSH(car(v));
- PUSH(car(cdr_(v)));
- body = &Stack[SP-1];
- *body = eval(*body); // evaluate lambda
- c = (cons_t*)ptr(cons_reserve(2));
- c->car = Stack[SP-2]; // name
- c->cdr = v = *body; c++;
- c->car = tagptr(c-1, TAG_CONS);
- f = cdr(cdr(v));
- c->cdr = cdr(f);
- // add (name . fn) to front of function's environment
- cdr_(f) = tagptr(c, TAG_CONS);
- break;
- case F_IF:
- v = car(cdr_(Stack[saveSP]));
- if (eval(v) != NIL)
- v = car(cdr_(cdr_(Stack[saveSP])));
- else
- v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
- tail_eval(v);
- break;
- case F_COND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- c = tocons(car_(*pv), "cond");
- v = eval(c->car);
- if (v != NIL) {- *pv = cdr_(car_(*pv));
- // evaluate body forms
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- v = eval(car_(*pv));
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv));
- }
- break;
- }
- *pv = cdr_(*pv);
- }
- break;
- case F_AND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = T;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- if ((v=eval(car_(*pv))) == NIL) {- SP = saveSP; return NIL;
- }
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv));
- }
- break;
- case F_OR:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- if ((v=eval(car_(*pv))) != NIL) {- SP = saveSP; return v;
- }
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv));
- }
- break;
- case F_WHILE:
- PUSH(cdr(cdr_(Stack[saveSP])));
- body = &Stack[SP-1];
- PUSH(*body);
- Stack[saveSP] = car_(cdr_(Stack[saveSP]));
- value_t *cond = &Stack[saveSP];
- PUSH(NIL);
- pv = &Stack[SP-1];
- while (eval(*cond) != NIL) {- *body = Stack[SP-2];
- while (iscons(*body)) {- *pv = eval(car_(*body));
- *body = cdr_(*body);
- }
- }
- v = *pv;
- break;
- case F_PROGN:
- // return last arg
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- v = eval(car_(*pv));
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv));
- }
- break;
-
- // ordinary functions
- case F_SET:
- argcount("set", nargs, 2);- e = Stack[SP-2];
- while (issymbol(*penv)) {- if (*penv == NIL)
- goto set_global;
- if (*penv == e) {- penv[1] = Stack[SP-1];
- SP=saveSP; return penv[1];
- }
- penv+=2;
- }
- if ((v=assoc(e,*penv)) != NIL) {- cdr_(v) = (e=Stack[SP-1]);
- SP=saveSP; return e;
- }
- set_global:
- tosymbol(e, "set")->binding = (v=Stack[SP-1]);
- break;
- case F_BOUNDP:
- argcount("boundp", nargs, 1);- sym = tosymbol(Stack[SP-1], "boundp");
- if (sym->binding == UNBOUND && sym->constant == UNBOUND)
- v = NIL;
- else
- v = T;
- break;
- case F_EQ:
- argcount("eq", nargs, 2);- v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
- break;
- case F_CONS:
- argcount("cons", nargs, 2);- v = mk_cons();
- car_(v) = Stack[SP-2];
- cdr_(v) = Stack[SP-1];
- break;
- case F_CAR:
- argcount("car", nargs, 1);- v = car(Stack[SP-1]);
- break;
- case F_CDR:
- argcount("cdr", nargs, 1);- v = cdr(Stack[SP-1]);
- break;
- case F_RPLACA:
- argcount("rplaca", nargs, 2);- car(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_RPLACD:
- argcount("rplacd", nargs, 2);- cdr(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_ATOM:
- argcount("atom", nargs, 1);- v = ((!iscons(Stack[SP-1])) ? T : NIL);
- break;
- case F_CONSP:
- argcount("consp", nargs, 1);- v = (iscons(Stack[SP-1]) ? T : NIL);
- break;
- case F_SYMBOLP:
- argcount("symbolp", nargs, 1);- v = ((issymbol(Stack[SP-1])) ? T : NIL);
- break;
- case F_NUMBERP:
- argcount("numberp", nargs, 1);- v = ((isnumber(Stack[SP-1])) ? T : NIL);
- break;
- case F_ADD:
- s = 0;
- for (i=saveSP+1; i < (int)SP; i++) {- n = tonumber(Stack[i], "+");
- s += n;
- }
- v = number(s);
- break;
- case F_SUB:
- if (nargs < 1) lerror("-: error: too few arguments\n");- i = saveSP+1;
- s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "-");
- s -= n;
- }
- v = number(s);
- break;
- case F_MUL:
- s = 1;
- for (i=saveSP+1; i < (int)SP; i++) {- n = tonumber(Stack[i], "*");
- s *= n;
- }
- v = number(s);
- break;
- case F_DIV:
- if (nargs < 1) lerror("/: error: too few arguments\n");- i = saveSP+1;
- s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "/");
- if (n == 0) lerror("/: error: division by zero\n");- s /= n;
- }
- v = number(s);
- break;
- case F_LT:
- argcount("<", nargs, 2);- // this implements generic comparison for all atoms
- // strange comparisons (for example with builtins) are resolved
- // arbitrarily but consistently.
- // ordering: number < builtin < symbol < cons
- if (tag(Stack[SP-2]) != tag(Stack[SP-1])) {- v = (tag(Stack[SP-2]) < tag(Stack[SP-1]) ? T : NIL);
- }
- else {- switch (tag(Stack[SP-2])) {- case TAG_NUM:
- v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL;
- break;
- case TAG_SYM:
- v = (strcmp(((symbol_t*)ptr(Stack[SP-2]))->name,
- ((symbol_t*)ptr(Stack[SP-1]))->name) < 0) ?
- T : NIL;
- break;
- case TAG_BUILTIN:
- v = (intval(Stack[SP-2]) < intval(Stack[SP-1])) ? T : NIL;
- break;
- case TAG_CONS:
- lerror("<: error: expected atom\n");- }
- }
- break;
- case F_NOT:
- argcount("not", nargs, 1);- v = ((Stack[SP-1] == NIL) ? T : NIL);
- break;
- case F_EVAL:
- argcount("eval", nargs, 1);- v = Stack[SP-1];
- if (tag(v)<0x2) { SP=saveSP; return v; }- if (tail) {- *penv = NIL;
- envend = SP = (u_int32_t)(penv-&Stack[0]) + 1;
- e=v; goto eval_top;
- }
- else {- PUSH(NIL);
- v = eval_sexpr(v, &Stack[SP-1], 1, SP);
- }
- break;
- case F_PRINT:
- for (i=saveSP+1; i < (int)SP; i++)
- print(stdout, v=Stack[i], 0);
- fprintf(stdout, "\n");
- break;
- case F_PRINC:
- for (i=saveSP+1; i < (int)SP; i++)
- print(stdout, v=Stack[i], 1);
- break;
- case F_READ:
- argcount("read", nargs, 0);- v = read_sexpr(stdin);
- break;
- case F_LOAD:
- argcount("load", nargs, 1);- v = load_file(tosymbol(Stack[SP-1], "load")->name);
- break;
- case F_EXIT:
- exit(0);
- break;
- case F_ERROR:
- for (i=saveSP+1; i < (int)SP; i++)
- print(stderr, Stack[i], 1);
- lerror("\n");- break;
- case F_PROG1:
- // return first arg
- if (nargs < 1) lerror("prog1: error: too few arguments\n");- v = Stack[saveSP+1];
- break;
- case F_ASSOC:
- argcount("assoc", nargs, 2);- v = assoc(Stack[SP-2], Stack[SP-1]);
- break;
- case F_APPLY:
- argcount("apply", nargs, 2);- v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
- f = Stack[SP-2]; // first arg is new function
- POPN(2); // pop apply's args
- if (isbuiltin(f)) {- if (isspecial(f))
- lerror("apply: error: cannot apply special operator "- "%s\n", builtin_names[intval(f)]);
- // unpack arglist onto the stack
- while (iscons(v)) {- PUSH(car_(v));
- v = cdr_(v);
- }
- goto apply_builtin;
- }
- noeval = 1;
- goto apply_lambda;
- }
- SP = saveSP;
- return v;
- }
- else {- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- apply_lambda:
- if (iscons(f)) {- headsym = car_(f);
- // apply lambda or macro expression
- PUSH(cdr(cdr_(f)));
- PUSH(car_(cdr_(f)));
- argsyms = &Stack[SP-1];
- argenv = &Stack[SP]; // argument environment starts now
- if (headsym == MACRO)
- noeval = 1;
- //else if (headsym != LAMBDA)
- // lerror("apply: error: head must be lambda, macro, or label\n");- // build a calling environment for the lambda
- // the environment is the argument binds on top of the captured
- // environment
- while (iscons(v)) {- // bind args
- if (!iscons(*argsyms)) {- if (*argsyms == NIL)
- lerror("apply: error: too many arguments\n");- break;
- }
- asym = car_(*argsyms);
- if (asym==NIL || iscons(asym))
- lerror("apply: error: invalid formal argument\n");- v = car_(v);
- if (!noeval) {- v = eval(v);
- }
- PUSH(asym);
- PUSH(v);
- *argsyms = cdr_(*argsyms);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- if (*argsyms != NIL) {- if (issymbol(*argsyms)) {- PUSH(*argsyms);
- if (noeval) {- PUSH(Stack[saveSP]);
- }
- else {- // this version uses collective allocation. about 7-10%
- // faster for lists with > 2 elements, but uses more
- // stack space
- PUSH(NIL);
- i = SP;
- while (iscons(Stack[saveSP])) {- PUSH(eval(car_(Stack[saveSP])));
- Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- nargs = SP-i;
- if (nargs) {- Stack[i-1] = cons_reserve(nargs);
- c = (cons_t*)ptr(Stack[i-1]);
- for(; i < (int)SP; i++) {- c->car = Stack[i];
- c->cdr = tagptr(c+1, TAG_CONS);
- c++;
- }
- (c-1)->cdr = NIL;
- POPN(nargs);
- }
- }
- }
- else if (iscons(*argsyms)) {- lerror("apply: error: too few arguments\n");- }
- }
- noeval = 0;
- lenv = &Stack[saveSP+1];
- PUSH(cdr(*lenv)); // add cloenv to new environment
- e = car_(Stack[saveSP+1]);
- // macro: evaluate expansion in the calling environment
- if (headsym == MACRO) {- if (tag(e)<0x2) ;
- else e = eval_sexpr(e, argenv, 1, SP);
- SP = saveSP;
- if (tag(e)<0x2) return(e);
- goto eval_top;
- }
- else {- if (tag(e)<0x2) { SP=saveSP; return(e); }- if (tail) {- // ok to overwrite environment
- nargs = (int)(&Stack[SP] - argenv);
- for(i=0; i < nargs; i++)
- penv[i] = argenv[i];
- envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]);
- goto eval_top;
- }
- else {- v = eval_sexpr(e, argenv, 1, SP);
- SP = saveSP;
- return v;
- }
- }
- // not reached
- }
- type_error("apply", "function", f);- return NIL;
-}
-
-// repl -----------------------------------------------------------------------
-
-static char *infile = NULL;
-
-value_t toplevel_eval(value_t expr)
-{- value_t v;
- u_int32_t saveSP = SP;
- PUSH(NIL);
- v = topeval(expr, &Stack[SP-1]);
- SP = saveSP;
- return v;
-}
-
-value_t load_file(char *fname)
-{- value_t e, v=NIL;
- char *lastfile = infile;
- FILE *f = fopen(fname, "r");
- infile = fname;
- if (f == NULL) lerror("file not found\n");- while (1) {- e = read_sexpr(f);
- if (feof(f)) break;
- v = toplevel_eval(e);
- }
- infile = lastfile;
- fclose(f);
- return v;
-}
-
-int main(int argc, char* argv[])
-{- value_t v;
-
- stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
- lisp_init();
- if (setjmp(toplevel)) {- SP = 0;
- fprintf(stderr, "\n");
- if (infile) {- fprintf(stderr, "error loading file \"%s\"\n", infile);
- infile = NULL;
- }
- goto repl;
- }
- load_file("system.lsp");- if (argc > 1) { load_file(argv[1]); return 0; }- printf("; _ \n");- printf("; |_ _ _ |_ _ | . _ _ 2\n");- printf("; | (-||||_(_)|__|_)|_)\n");- printf(";-------------------|----------------------------------------------------------\n\n");- repl:
- while (1) {- printf("> ");- v = read_sexpr(stdin);
- if (feof(stdin)) break;
- print(stdout, v=toplevel_eval(v), 0);
- set(symbol("that"), v);- printf("\n\n");- }
- return 0;
-}
--- a/femtolisp/tiny/lisp2.c.bak
+++ /dev/null
@@ -1,1448 +1,0 @@
-/*
- femtoLisp
-
- a minimal interpreter for a minimal lisp dialect
-
- this lisp dialect uses lexical scope and self-evaluating lambda.
- it supports 30-bit integers, symbols, conses, and full macros.
- it is case-sensitive.
- it features a simple compacting copying garbage collector.
- it uses a Scheme-style evaluation rule where any expression may appear in
- head position as long as it evaluates to a function.
- it uses Scheme-style varargs (dotted formal argument lists)
- lambdas can have only 1 body expression; use (progn ...) for multiple
- expressions. this is due to the closure representation
- (lambda args body . env)
-
- This is a fork of femtoLisp with advanced reading and printing facilities:
- * circular structure can be printed and read
- * #. read macro for eval-when-read and correctly printing builtins
- * read macros for backquote
- * symbol character-escaping printer
-
- * new print algorithm
- 1. traverse & tag all conses to be printed. when you encounter a cons
- that is already tagged, add it to a table to give it a #n# index
- 2. untag a cons when printing it. if cons is in the table, print
- "#n=" before it in the car, " . #n=" in the cdr. if cons is in the
- table but already untagged, print #n# in car or " . #n#" in the cdr.
- * read macros for #n# and #n= using the same kind of table
- * also need a table of read labels to translate from input indexes to
- normalized indexes (0 for first label, 1 for next, etc.)
- * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq"
-
- The value of this extra complexity, and what makes this fork worthy of
- the femtoLisp brand, is that the interpreter is fully "closed" in the
- sense that all representable values can be read and printed.
-
- by Jeff Bezanson
- Public Domain
-*/
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <setjmp.h>
-#include <stdarg.h>
-#include <ctype.h>
-#include <sys/types.h>
-
-typedef u_int32_t value_t;
-typedef int32_t number_t;
-
-typedef struct {- value_t car;
- value_t cdr;
-} cons_t;
-
-typedef struct _symbol_t {- value_t binding; // global value binding
- value_t constant; // constant binding (used only for builtins)
- struct _symbol_t *left;
- struct _symbol_t *right;
- char name[1];
-} symbol_t;
-
-#define TAG_NUM 0x0
-#define TAG_BUILTIN 0x1
-#define TAG_SYM 0x2
-#define TAG_CONS 0x3
-#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
-#define tag(x) ((x)&0x3)
-#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
-#define tagptr(p,t) (((value_t)(p)) | (t))
-#define number(x) ((value_t)((x)<<2))
-#define numval(x) (((number_t)(x))>>2)
-#define intval(x) (((int)(x))>>2)
-#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
-#define iscons(x) (tag(x) == TAG_CONS)
-#define issymbol(x) (tag(x) == TAG_SYM)
-#define isnumber(x) (tag(x) == TAG_NUM)
-#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
-// functions ending in _ are unsafe, faster versions
-#define car_(v) (((cons_t*)ptr(v))->car)
-#define cdr_(v) (((cons_t*)ptr(v))->cdr)
-#define car(v) (tocons((v),"car")->car)
-#define cdr(v) (tocons((v),"cdr")->cdr)
-#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
-#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
-
-enum {- // special forms
- F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
- F_PROGN,
- // functions
- F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
- F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
- F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, F_ERROR, F_EXIT, F_PRINC, F_CONSP,
- F_ASSOC, N_BUILTINS
-};
-#define isspecial(v) (intval(v) <= (number_t)F_PROGN)
-
-static char *builtin_names[] =
- { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",- "progn",
- "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
- "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
- "prog1", "apply", "rplaca", "rplacd", "boundp", "error", "exit", "princ",
- "consp", "assoc" };
-
-static char *stack_bottom;
-#define PROCESS_STACK_SIZE (2*1024*1024)
-#define N_STACK 98304
-static value_t Stack[N_STACK];
-static u_int32_t SP = 0;
-#define PUSH(v) (Stack[SP++] = (v))
-#define POP() (Stack[--SP])
-#define POPN(n) (SP-=(n))
-
-value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
-value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
-
-value_t read_sexpr(FILE *f);
-void print(FILE *f, value_t v, int princ);
-value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend);
-value_t load_file(char *fname);
-value_t toplevel_eval(value_t expr);
-
-#include "flutils.c"
-
-typedef struct _readstate_t {- ltable_t labels;
- ltable_t exprs;
- struct _readstate_t *prev;
-} readstate_t;
-static readstate_t *readstate = NULL;
-
-// error utilities ------------------------------------------------------------
-
-jmp_buf toplevel;
-
-void lerror(char *format, ...)
-{- va_list args;
- va_start(args, format);
-
- while (readstate) {- free(readstate->labels.items);
- free(readstate->exprs.items);
- readstate = readstate->prev;
- }
-
- vfprintf(stderr, format, args);
- va_end(args);
- longjmp(toplevel, 1);
-}
-
-void type_error(char *fname, char *expected, value_t got)
-{- fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
- print(stderr, got, 0); lerror("\n");-}
-
-// safe cast operators --------------------------------------------------------
-
-#define SAFECAST_OP(type,ctype,cnvt) \
-ctype to##type(value_t v, char *fname) \
-{ \- if (is##type(v)) \
- return (ctype)cnvt(v); \
- type_error(fname, #type, v); \
- return (ctype)0; \
-}
-SAFECAST_OP(cons, cons_t*, ptr)
-SAFECAST_OP(symbol,symbol_t*,ptr)
-SAFECAST_OP(number,number_t, numval)
-
-// symbol table ---------------------------------------------------------------
-
-static symbol_t *symtab = NULL;
-
-static symbol_t *mk_symbol(char *str)
-{- symbol_t *sym;
-
- sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
- sym->left = sym->right = NULL;
- sym->constant = sym->binding = UNBOUND;
- strcpy(&sym->name[0], str);
- return sym;
-}
-
-static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
-{- int x;
-
- while(*ptree != NULL) {- x = strcmp(str, (*ptree)->name);
- if (x == 0)
- return ptree;
- if (x < 0)
- ptree = &(*ptree)->left;
- else
- ptree = &(*ptree)->right;
- }
- return ptree;
-}
-
-value_t symbol(char *str)
-{- symbol_t **pnode;
-
- pnode = symtab_lookup(&symtab, str);
- if (*pnode == NULL)
- *pnode = mk_symbol(str);
- return tagptr(*pnode, TAG_SYM);
-}
-
-// initialization -------------------------------------------------------------
-
-static unsigned char *fromspace;
-static unsigned char *tospace;
-static unsigned char *curheap;
-static unsigned char *lim;
-static u_int32_t heapsize = 128*1024;//bytes
-static u_int32_t *consflags;
-static ltable_t printconses;
-
-void lisp_init(void)
-{- int i;
-
- fromspace = malloc(heapsize);
- tospace = malloc(heapsize);
- curheap = fromspace;
- lim = curheap+heapsize-sizeof(cons_t);
- consflags = mk_bitvector(heapsize/sizeof(cons_t));
-
- ltable_init(&printconses, 32);
-
- NIL = symbol("nil"); setc(NIL, NIL);- T = symbol("t"); setc(T, T);- LAMBDA = symbol("lambda");- MACRO = symbol("macro");- LABEL = symbol("label");- QUOTE = symbol("quote");- BACKQUOTE = symbol("backquote");- COMMA = symbol("*comma*");- COMMAAT = symbol("*comma-at*");- COMMADOT = symbol("*comma-dot*");- for (i=0; i < (int)N_BUILTINS; i++)
- setc(symbol(builtin_names[i]), builtin(i));
-}
-
-// conses ---------------------------------------------------------------------
-
-void gc(int mustgrow);
-
-static value_t mk_cons(void)
-{- cons_t *c;
-
- if (curheap > lim)
- gc(0);
- c = (cons_t*)curheap;
- curheap += sizeof(cons_t);
- return tagptr(c, TAG_CONS);
-}
-
-// allocate and link n consecutive conses
-// warning: only cdrs are initialized
-static value_t cons_reserve(int n)
-{- cons_t *c, *first;
-
- n--;
- if ((cons_t*)curheap > ((cons_t*)lim)-n) {- gc(0);
- while ((cons_t*)curheap > ((cons_t*)lim)-n) {- gc(1);
- }
- }
- c = first = (cons_t*)curheap;
- for(; n > 0; n--) {- c->cdr = tagptr(c+1, TAG_CONS);
- c++;
- }
- c->cdr = NIL;
- curheap = (unsigned char*)(c+1);
- return tagptr(first, TAG_CONS);
-}
-
-value_t *cons(value_t *pcar, value_t *pcdr)
-{- value_t c = mk_cons();
- car_(c) = *pcar; cdr_(c) = *pcdr;
- PUSH(c);
- return &Stack[SP-1];
-}
-
-#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace))
-#define ismarked(c) bitvector_get(consflags, cons_index(c))
-#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
-#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
-
-// collector ------------------------------------------------------------------
-
-static value_t relocate(value_t v)
-{- value_t a, d, nc, first, *pcdr;
-
- if (!iscons(v))
- return v;
- // iterative implementation allows arbitrarily long cons chains
- pcdr = &first;
- do {- if ((a=car_(v)) == UNBOUND) {- *pcdr = cdr_(v);
- return first;
- }
- *pcdr = nc = mk_cons();
- d = cdr_(v);
- car_(v) = UNBOUND; cdr_(v) = nc;
- car_(nc) = relocate(a);
- pcdr = &cdr_(nc);
- v = d;
- } while (iscons(v));
- *pcdr = d;
-
- return first;
-}
-
-static void trace_globals(symbol_t *root)
-{- while (root != NULL) {- root->binding = relocate(root->binding);
- trace_globals(root->left);
- root = root->right;
- }
-}
-
-void gc(int mustgrow)
-{- static int grew = 0;
- unsigned char *temp;
- u_int32_t i;
- readstate_t *rs;
-
- curheap = tospace;
- lim = curheap+heapsize-sizeof(cons_t);
-
- for (i=0; i < SP; i++)
- Stack[i] = relocate(Stack[i]);
- trace_globals(symtab);
- rs = readstate;
- while (rs) {- for(i=0; i < rs->exprs.n; i++)
- rs->exprs.items[i] = relocate(rs->exprs.items[i]);
- rs = rs->prev;
- }
-#ifdef VERBOSEGC
- printf("gc found %d/%d live conses\n",- (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t));
-#endif
- temp = tospace;
- tospace = fromspace;
- fromspace = temp;
-
- // if we're using > 80% of the space, resize tospace so we have
- // more space to fill next time. if we grew tospace last time,
- // grow the other half of the heap this time to catch up.
- if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {- temp = realloc(tospace, grew ? heapsize : heapsize*2);
- if (temp == NULL)
- lerror("out of memory\n");- tospace = temp;
- if (!grew) {- heapsize*=2;
- }
- else {- temp = (char*)bitvector_resize(consflags, heapsize/sizeof(cons_t));
- if (temp == NULL)
- lerror("out of memory\n");- consflags = (u_int32_t*)temp;
- }
- grew = !grew;
- }
- if (curheap > lim) // all data was live
- gc(0);
-}
-
-// read -----------------------------------------------------------------------
-
-enum {- TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
- TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
- TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE
-};
-
-static int symchar(char c)
-{- static char *special = "()';`,\\|";
- return (!isspace(c) && !strchr(special, c));
-}
-
-static u_int32_t toktype = TOK_NONE;
-static value_t tokval;
-static char buf[256];
-
-static char nextchar(FILE *f)
-{- char c;
- int ch;
-
- do {- ch = fgetc(f);
- if (ch == EOF)
- return 0;
- c = (char)ch;
- if (c == ';') {- // single-line comment
- do {- ch = fgetc(f);
- if (ch == EOF)
- return 0;
- } while ((char)ch != '\n');
- c = (char)ch;
- }
- } while (isspace(c));
- return c;
-}
-
-static void take(void)
-{- toktype = TOK_NONE;
-}
-
-static void accumchar(char c, int *pi)
-{- buf[(*pi)++] = c;
- if (*pi >= (int)(sizeof(buf)-1))
- lerror("read: error: token too long\n");-}
-
-// return: 1 for dot token, 0 for symbol
-static int read_token(FILE *f, char c, int digits)
-{- int i=0, ch, escaped=0, dot=(c=='.'), totread=0;
-
- ungetc(c, f);
- while (1) {- ch = fgetc(f); totread++;
- if (ch == EOF)
- goto terminate;
- c = (char)ch;
- if (c == '|') {- escaped = !escaped;
- }
- else if (c == '\\') {- ch = fgetc(f);
- if (ch == EOF)
- goto terminate;
- accumchar((char)ch, &i);
- }
- else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {- break;
- }
- else {- accumchar(c, &i);
- }
- }
- ungetc(c, f);
- terminate:
- buf[i++] = '\0';
- return (dot && (totread==2));
-}
-
-static u_int32_t peek(FILE *f)
-{- char c, *end;
- number_t x;
- int ch;
-
- if (toktype != TOK_NONE)
- return toktype;
- c = nextchar(f);
- if (feof(f)) return TOK_NONE;
- if (c == '(') {- toktype = TOK_OPEN;
- }
- else if (c == ')') {- toktype = TOK_CLOSE;
- }
- else if (c == '\'') {- toktype = TOK_QUOTE;
- }
- else if (c == '`') {- toktype = TOK_BQ;
- }
- else if (c == '#') {- ch = fgetc(f);
- if (ch == EOF)
- lerror("read: error: invalid read macro\n");- if ((char)ch == '.') {- toktype = TOK_SHARPDOT;
- }
- else if ((char)ch == '\'') {- toktype = TOK_SHARPQUOTE;
- }
- else if (isdigit((char)ch)) {- read_token(f, (char)ch, 1);
- c = fgetc(f);
- if (c == '#')
- toktype = TOK_BACKREF;
- else if (c == '=')
- toktype = TOK_LABEL;
- else
- lerror("read: error: invalid label\n");- x = strtol(buf, &end, 10);
- tokval = number(x);
- }
- else {- lerror("read: error: unknown read macro\n");- }
- }
- else if (c == ',') {- toktype = TOK_COMMA;
- ch = fgetc(f);
- if (ch == EOF)
- return toktype;
- if ((char)ch == '@')
- toktype = TOK_COMMAAT;
- else if ((char)ch == '.')
- toktype = TOK_COMMADOT;
- else
- ungetc((char)ch, f);
- }
- else if (isdigit(c) || c=='-') {- read_token(f, c, 0);
- if (buf[0] == '-' && !isdigit(buf[1])) {- toktype = TOK_SYM;
- tokval = symbol(buf);
- }
- else {- x = strtol(buf, &end, 10);
- if (*end != '\0')
- lerror("read: error: invalid integer constant\n");- toktype = TOK_NUM;
- tokval = number(x);
- }
- }
- else {- if (read_token(f, c, 0)) {- toktype = TOK_DOT;
- }
- else {- toktype = TOK_SYM;
- tokval = symbol(buf);
- }
- }
- return toktype;
-}
-
-static value_t do_read_sexpr(FILE *f, int fixup);
-
-// build a list of conses. this is complicated by the fact that all conses
-// can move whenever a new cons is allocated. we have to refer to every cons
-// through a handle to a relocatable pointer (i.e. a pointer on the stack).
-static void read_list(FILE *f, value_t *pval, int fixup)
-{- value_t c, *pc;
- u_int32_t t;
-
- PUSH(NIL);
- pc = &Stack[SP-1]; // to keep track of current cons cell
- t = peek(f);
- while (t != TOK_CLOSE) {- if (feof(f))
- lerror("read: error: unexpected end of input\n");- c = mk_cons(); car_(c) = cdr_(c) = NIL;
- if (iscons(*pc)) {- cdr_(*pc) = c;
- }
- else {- *pval = c;
- if (fixup != -1)
- readstate->exprs.items[fixup] = c;
- }
- *pc = c;
- c = do_read_sexpr(f,-1); // must be on separate lines due to undefined
- car_(*pc) = c; // evaluation order
-
- t = peek(f);
- if (t == TOK_DOT) {- take();
- c = do_read_sexpr(f,-1);
- cdr_(*pc) = c;
- t = peek(f);
- if (feof(f))
- lerror("read: error: unexpected end of input\n");- if (t != TOK_CLOSE)
- lerror("read: error: expected ')'\n");- }
- }
- take();
- POP();
-}
-
-// fixup is the index of the label we'd like to fix up with this read
-static value_t do_read_sexpr(FILE *f, int fixup)
-{- value_t v, *head;
- u_int32_t t, l;
- int i;
-
- t = peek(f);
- take();
- switch (t) {- case TOK_CLOSE:
- lerror("read: error: unexpected ')'\n");- case TOK_DOT:
- lerror("read: error: unexpected '.'\n");- case TOK_SYM:
- case TOK_NUM:
- return tokval;
- case TOK_COMMA:
- head = &COMMA; goto listwith;
- case TOK_COMMAAT:
- head = &COMMAAT; goto listwith;
- case TOK_COMMADOT:
- head = &COMMADOT; goto listwith;
- case TOK_BQ:
- head = &BACKQUOTE; goto listwith;
- case TOK_QUOTE:
- head = "E;
- listwith:
- cons(head, cons(&NIL, &NIL));
- if (fixup != -1)
- readstate->exprs.items[fixup] = Stack[SP-1];
- v = do_read_sexpr(f,-1);
- car_(Stack[SP-2]) = v;
- v = Stack[SP-1];
- POPN(2);
- return v;
- case TOK_SHARPQUOTE:
- // femtoLisp doesn't need symbol-function, so #' does nothing
- return do_read_sexpr(f, fixup);
- case TOK_OPEN:
- PUSH(NIL);
- read_list(f, &Stack[SP-1], fixup);
- return POP();
- case TOK_SHARPDOT:
- // eval-when-read
- // evaluated expressions can refer to existing backreferences, but they
- // cannot see pending labels. in other words:
- // (... #2=#.#0# ... ) OK
- // (... #2=#.(#2#) ... ) DO NOT WANT
- v = do_read_sexpr(f,-1);
- return toplevel_eval(v);
- case TOK_LABEL:
- // create backreference label
- l = numval(tokval);
- if (ltable_lookup(&readstate->labels, l) != NOTFOUND)
- lerror("read: error: label %d redefined\n", l);- ltable_insert(&readstate->labels, l);
- i = readstate->exprs.n;
- ltable_insert(&readstate->exprs, UNBOUND);
- v = do_read_sexpr(f,i);
- readstate->exprs.items[i] = v;
- return v;
- case TOK_BACKREF:
- // look up backreference
- l = numval(tokval);
- i = ltable_lookup(&readstate->labels, l);
- if (i == NOTFOUND || i >= (int)readstate->exprs.n ||
- readstate->exprs.items[i] == UNBOUND)
- lerror("read: error: undefined label %d\n", l);- return readstate->exprs.items[i];
- }
- return NIL;
-}
-
-value_t read_sexpr(FILE *f)
-{- value_t v;
- readstate_t state;
- state.prev = readstate;
- ltable_init(&state.labels, 16);
- ltable_init(&state.exprs, 16);
- readstate = &state;
-
- v = do_read_sexpr(f, -1);
-
- readstate = state.prev;
- free(state.labels.items);
- free(state.exprs.items);
- return v;
-}
-
-// print ----------------------------------------------------------------------
-
-static void print_traverse(value_t v)
-{- while (iscons(v)) {- if (ismarked(v)) {- ltable_adjoin(&printconses, v);
- return;
- }
- mark_cons(v);
- print_traverse(car_(v));
- v = cdr_(v);
- }
-}
-
-static void print_symbol(FILE *f, char *name)
-{- int i, escape=0, charescape=0;
-
- if (name[0] == '\0') {- fprintf(f, "||");
- return;
- }
- if (name[0] == '.' && name[1] == '\0') {- fprintf(f, "|.|");
- return;
- }
- if (name[0] == '#')
- escape = 1;
- i=0;
- while (name[i]) {- if (!symchar(name[i])) {- escape = 1;
- if (name[i]=='|' || name[i]=='\\') {- charescape = 1;
- break;
- }
- }
- i++;
- }
- if (escape) {- if (charescape) {- fprintf(f, "|");
- i=0;
- while (name[i]) {- if (name[i]=='|' || name[i]=='\\')
- fprintf(f, "\\%c", name[i]);
- else
- fprintf(f, "%c", name[i]);
- i++;
- }
- fprintf(f, "|");
- }
- else {- fprintf(f, "|%s|", name);
- }
- }
- else {- fprintf(f, "%s", name);
- }
-}
-
-static void do_print(FILE *f, value_t v, int princ)
-{- value_t cd;
- int label;
- char *name;
-
- switch (tag(v)) {- case TAG_NUM: fprintf(f, "%d", numval(v)); break;
- case TAG_SYM:
- name = ((symbol_t*)ptr(v))->name;
- if (princ)
- fprintf(f, "%s", name);
- else
- print_symbol(f, name);
- break;
- case TAG_BUILTIN: fprintf(f, "#.%s", builtin_names[intval(v)]); break;
- case TAG_CONS:
- if ((label=ltable_lookup(&printconses,v)) != NOTFOUND) {- if (!ismarked(v)) {- fprintf(f, "#%d#", label);
- return;
- }
- fprintf(f, "#%d=", label);
- }
- fprintf(f, "(");- while (1) {- unmark_cons(v);
- do_print(f, car_(v), princ);
- cd = cdr_(v);
- if (!iscons(cd)) {- if (cd != NIL) {- fprintf(f, " . ");
- do_print(f, cd, princ);
- }
- fprintf(f, ")");
- break;
- }
- else {- if ((label=ltable_lookup(&printconses,cd)) != NOTFOUND) {- fprintf(f, " . ");
- do_print(f, cd, princ);
- fprintf(f, ")");
- break;
- }
- }
- fprintf(f, " ");
- v = cd;
- }
- break;
- }
-}
-
-void print(FILE *f, value_t v, int princ)
-{- ltable_clear(&printconses);
- print_traverse(v);
- do_print(f, v, princ);
-}
-
-// eval -----------------------------------------------------------------------
-
-static inline void argcount(char *fname, int nargs, int c)
-{- if (nargs != c)
- lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");-}
-
-// return a cons element of v whose car is item
-static value_t assoc(value_t item, value_t v)
-{- value_t bind;
-
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == item)
- return bind;
- v = cdr_(v);
- }
- return NIL;
-}
-
-#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0,envend))
-#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1,SP))
-#define tail_eval(xpr) do { SP = saveSP; \- if (tag(xpr)<0x2) { return (xpr); } \- else { e=(xpr); goto eval_top; } } while (0)-
-/* stack setup on entry:
- n n+1 ...
- +-----+-----+-----+-----+-----+-----+-----+-----+
- | SYM | VAL | SYM | VAL | CLO | | | |
- +-----+-----+-----+-----+-----+-----+-----+-----+
- ^ ^ ^
- | | |
- penv envend SP (who knows where)
-
- sym is an argument name and val is its binding. CLO is a closed-up
- environment list (which can be empty, i.e. NIL).
- CLO is always there, but there might be zero SYM/VAL pairs.
-
- if tail==1, you are allowed (indeed encouraged) to overwrite this
- environment, otherwise you have to put any new environment on the top
- of the stack.
-*/
-value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
-{- value_t f, v, headsym, asym, labl, *pv, *argsyms, *body, *lenv, *argenv;
- cons_t *c;
- symbol_t *sym;
- u_int32_t saveSP;
- int i, nargs, noeval=0;
- number_t s, n;
-
- eval_top:
- if (issymbol(e)) {- sym = (symbol_t*)ptr(e);
- if (sym->constant != UNBOUND) return sym->constant;
- while (issymbol(*penv)) { // 1. try lookup in argument env- if (*penv == NIL)
- goto get_global;
- if (*penv == e)
- return penv[1];
- penv+=2;
- }
- if ((v=assoc(e,*penv)) != NIL) // 2. closure env
- return cdr_(v);
- get_global:
- if ((v = sym->binding) == UNBOUND) // 3. global env
- lerror("eval: error: variable %s has no value\n", sym->name);- return v;
- }
- if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
- lerror("eval: error: stack overflow\n");- saveSP = SP;
- PUSH(e);
- v = car_(e);
- if (tag(v)<0x2) f = v;
- else if (issymbol(v) && (f=((symbol_t*)ptr(v))->constant)!=UNBOUND) ;
- else f = eval_sexpr(v, penv, 0, envend);
- if (isbuiltin(f)) {- // handle builtin function
- if (!isspecial(f)) {- // evaluate argument list, placing arguments on stack
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- while (iscons(v)) {- v = eval(car_(v));
- PUSH(v);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- }
- apply_builtin:
- nargs = SP - saveSP - 1;
- switch (intval(f)) {- // special forms
- case F_QUOTE:
- v = cdr_(Stack[saveSP]);
- if (!iscons(v)) lerror("quote: error: expected argument\n");- v = car_(v);
- break;
- case F_MACRO:
- case F_LAMBDA:
- if (*penv != NIL) {- // build a closure (lambda args body . env)
- if (issymbol(*penv)) {- // cons up and save temporary environment
- PUSH(Stack[envend-1]); // passed-in CLOENV
- // find out how many new conses we need
- nargs = ((int)(&Stack[envend] - penv - 1))>>1;
- if (nargs) {- lenv = penv;
- v = Stack[SP-1] = cons_reserve(nargs*2);
- while (1) {- e = cdr_(cdr_(v));
- car_(v) = cdr_(v);
- car_(cdr_(v)) = penv[0];
- cdr_(cdr_(v)) = penv[1];
- nargs--;
- if (nargs==0) break;
- penv+=2;
- cdr_(v) = e;
- v = e;
- }
- // final cdr points to existing cloenv
- cdr_(v) = Stack[envend-1];
- // environment representation changed; install
- // the new representation so everybody can see it
- *lenv = Stack[SP-1];
- }
- }
- else {- PUSH(*penv); // env has already been captured; recapture
- }
- v = cdr_(Stack[saveSP]);
- PUSH(car(v));
- PUSH(car(cdr_(v)));
- v = cons_reserve(3);
- car_(v) = (intval(f)==F_LAMBDA ? LAMBDA : MACRO); f = cdr_(v);
- car_(f) = Stack[SP-2]; f = cdr_(f); //argsyms
- car_(f) = Stack[SP-1]; //body
- cdr_(f) = Stack[SP-3]; //env
- }
- else {- v = Stack[saveSP];
- }
- break;
- case F_LABEL:
- v = Stack[saveSP];
- if (*penv != NIL) {- v = cdr_(v);
- PUSH(car(v));
- PUSH(car(cdr_(v)));
- body = &Stack[SP-1];
- *body = eval(*body); // evaluate lambda
- v = f = cons_reserve(3);
- car_(f) = LABEL; f = cdr_(f);
- car_(f) = Stack[SP-2]; f = cdr_(f); // name
- car_(f) = *body; // lambda expr
- }
- break;
- case F_IF:
- v = car(cdr_(Stack[saveSP]));
- if (eval(v) != NIL)
- v = car(cdr_(cdr_(Stack[saveSP])));
- else
- v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
- tail_eval(v);
- break;
- case F_COND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- c = tocons(car_(*pv), "cond");
- v = eval(c->car);
- if (v != NIL) {- *pv = cdr_(car_(*pv));
- // evaluate body forms
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- v = eval(car_(*pv));
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv));
- }
- break;
- }
- *pv = cdr_(*pv);
- }
- break;
- case F_AND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = T;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- if ((v=eval(car_(*pv))) == NIL) {- SP = saveSP; return NIL;
- }
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv));
- }
- break;
- case F_OR:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- if ((v=eval(car_(*pv))) != NIL) {- SP = saveSP; return v;
- }
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv));
- }
- break;
- case F_WHILE:
- PUSH(cdr(cdr_(Stack[saveSP])));
- body = &Stack[SP-1];
- PUSH(*body);
- Stack[saveSP] = car_(cdr_(Stack[saveSP]));
- value_t *cond = &Stack[saveSP];
- PUSH(NIL);
- pv = &Stack[SP-1];
- while (eval(*cond) != NIL) {- *body = Stack[SP-2];
- while (iscons(*body)) {- *pv = eval(car_(*body));
- *body = cdr_(*body);
- }
- }
- v = *pv;
- break;
- case F_PROGN:
- // return last arg
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- v = eval(car_(*pv));
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv));
- }
- break;
-
- // ordinary functions
- case F_SET:
- argcount("set", nargs, 2);- e = Stack[SP-2];
- while (issymbol(*penv)) {- if (*penv == NIL)
- goto set_global;
- if (*penv == e) {- penv[1] = Stack[SP-1];
- SP=saveSP; return penv[1];
- }
- penv+=2;
- }
- if ((v=assoc(e,*penv)) != NIL) {- cdr_(v) = (e=Stack[SP-1]);
- SP=saveSP; return e;
- }
- set_global:
- tosymbol(e, "set")->binding = (v=Stack[SP-1]);
- break;
- case F_BOUNDP:
- argcount("boundp", nargs, 1);- sym = tosymbol(Stack[SP-1], "boundp");
- if (sym->binding == UNBOUND && sym->constant == UNBOUND)
- v = NIL;
- else
- v = T;
- break;
- case F_EQ:
- argcount("eq", nargs, 2);- v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
- break;
- case F_CONS:
- argcount("cons", nargs, 2);- v = mk_cons();
- car_(v) = Stack[SP-2];
- cdr_(v) = Stack[SP-1];
- break;
- case F_CAR:
- argcount("car", nargs, 1);- v = car(Stack[SP-1]);
- break;
- case F_CDR:
- argcount("cdr", nargs, 1);- v = cdr(Stack[SP-1]);
- break;
- case F_RPLACA:
- argcount("rplaca", nargs, 2);- car(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_RPLACD:
- argcount("rplacd", nargs, 2);- cdr(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_ATOM:
- argcount("atom", nargs, 1);- v = ((!iscons(Stack[SP-1])) ? T : NIL);
- break;
- case F_CONSP:
- argcount("consp", nargs, 1);- v = (iscons(Stack[SP-1]) ? T : NIL);
- break;
- case F_SYMBOLP:
- argcount("symbolp", nargs, 1);- v = ((issymbol(Stack[SP-1])) ? T : NIL);
- break;
- case F_NUMBERP:
- argcount("numberp", nargs, 1);- v = ((isnumber(Stack[SP-1])) ? T : NIL);
- break;
- case F_ADD:
- s = 0;
- for (i=saveSP+1; i < (int)SP; i++) {- n = tonumber(Stack[i], "+");
- s += n;
- }
- v = number(s);
- break;
- case F_SUB:
- if (nargs < 1) lerror("-: error: too few arguments\n");- i = saveSP+1;
- s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "-");
- s -= n;
- }
- v = number(s);
- break;
- case F_MUL:
- s = 1;
- for (i=saveSP+1; i < (int)SP; i++) {- n = tonumber(Stack[i], "*");
- s *= n;
- }
- v = number(s);
- break;
- case F_DIV:
- if (nargs < 1) lerror("/: error: too few arguments\n");- i = saveSP+1;
- s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "/");
- if (n == 0) lerror("/: error: division by zero\n");- s /= n;
- }
- v = number(s);
- break;
- case F_LT:
- argcount("<", nargs, 2);- // this implements generic comparison for all atoms
- // strange comparisons (for example with builtins) are resolved
- // arbitrarily but consistently.
- // ordering: number < builtin < symbol < cons
- if (tag(Stack[SP-2]) != tag(Stack[SP-1])) {- v = (tag(Stack[SP-2]) < tag(Stack[SP-1]) ? T : NIL);
- }
- else {- switch (tag(Stack[SP-2])) {- case TAG_NUM:
- v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL;
- break;
- case TAG_SYM:
- v = (strcmp(((symbol_t*)ptr(Stack[SP-2]))->name,
- ((symbol_t*)ptr(Stack[SP-1]))->name) < 0) ?
- T : NIL;
- break;
- case TAG_BUILTIN:
- v = (intval(Stack[SP-2]) < intval(Stack[SP-1])) ? T : NIL;
- break;
- case TAG_CONS:
- lerror("<: error: expected atom\n");- }
- }
- break;
- case F_NOT:
- argcount("not", nargs, 1);- v = ((Stack[SP-1] == NIL) ? T : NIL);
- break;
- case F_EVAL:
- argcount("eval", nargs, 1);- v = Stack[SP-1];
- if (tag(v)<0x2) { SP=saveSP; return v; }- if (tail) {- *penv = NIL;
- envend = SP = (u_int32_t)(penv-&Stack[0]) + 1;
- e=v; goto eval_top;
- }
- else {- PUSH(NIL);
- v = eval_sexpr(v, &Stack[SP-1], 1, SP);
- }
- break;
- case F_PRINT:
- for (i=saveSP+1; i < (int)SP; i++)
- print(stdout, v=Stack[i], 0);
- fprintf(stdout, "\n");
- break;
- case F_PRINC:
- for (i=saveSP+1; i < (int)SP; i++)
- print(stdout, v=Stack[i], 1);
- break;
- case F_READ:
- argcount("read", nargs, 0);- v = read_sexpr(stdin);
- break;
- case F_LOAD:
- argcount("load", nargs, 1);- v = load_file(tosymbol(Stack[SP-1], "load")->name);
- break;
- case F_EXIT:
- exit(0);
- break;
- case F_ERROR:
- for (i=saveSP+1; i < (int)SP; i++)
- print(stderr, Stack[i], 1);
- lerror("\n");- break;
- case F_PROG1:
- // return first arg
- if (nargs < 1) lerror("prog1: error: too few arguments\n");- v = Stack[saveSP+1];
- break;
- case F_ASSOC:
- argcount("assoc", nargs, 2);- v = assoc(Stack[SP-2], Stack[SP-1]);
- break;
- case F_APPLY:
- argcount("apply", nargs, 2);- v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
- f = Stack[SP-2]; // first arg is new function
- POPN(2); // pop apply's args
- if (isbuiltin(f)) {- if (isspecial(f))
- lerror("apply: error: cannot apply special operator "- "%s\n", builtin_names[intval(f)]);
- // unpack arglist onto the stack
- while (iscons(v)) {- PUSH(car_(v));
- v = cdr_(v);
- }
- goto apply_builtin;
- }
- noeval = 1;
- goto apply_lambda;
- }
- SP = saveSP;
- return v;
- }
- else {- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- apply_lambda:
- if (iscons(f)) {- headsym = car_(f);
- if (headsym == LABEL) {- // (label name (lambda ...)) behaves the same as the lambda
- // alone, except with name bound to the whole label expression
- labl = f;
- f = car(cdr(cdr_(labl)));
- headsym = car(f);
- } else labl=0;
- // apply lambda or macro expression
- PUSH(cdr(cdr_(f)));
- PUSH(car_(cdr_(f)));
- argsyms = &Stack[SP-1];
- argenv = &Stack[SP]; // argument environment starts now
- if (labl) {- // add label binding to environment
- PUSH(car_(cdr_(labl)));
- PUSH(labl);
- }
- if (headsym == MACRO)
- noeval = 1;
- //else if (headsym != LAMBDA)
- // lerror("apply: error: head must be lambda, macro, or label\n");- // build a calling environment for the lambda
- // the environment is the argument binds on top of the captured
- // environment
- while (iscons(v)) {- // bind args
- if (!iscons(*argsyms)) {- if (*argsyms == NIL)
- lerror("apply: error: too many arguments\n");- break;
- }
- asym = car_(*argsyms);
- if (asym==NIL || iscons(asym))
- lerror("apply: error: invalid formal argument\n");- v = car_(v);
- if (!noeval) {- v = eval(v);
- }
- PUSH(asym);
- PUSH(v);
- *argsyms = cdr_(*argsyms);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- if (*argsyms != NIL) {- if (issymbol(*argsyms)) {- PUSH(*argsyms);
- if (noeval) {- PUSH(Stack[saveSP]);
- }
- else {- // this version uses collective allocation. about 7-10%
- // faster for lists with > 2 elements, but uses more
- // stack space
- PUSH(NIL);
- i = SP;
- while (iscons(Stack[saveSP])) {- PUSH(eval(car_(Stack[saveSP])));
- Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- nargs = SP-i;
- if (nargs) {- Stack[i-1] = v = cons_reserve(nargs);
- for(; i < (int)SP; i++) {- car_(v) = Stack[i];
- v = cdr_(v);
- }
- POPN(nargs);
- }
- }
- }
- else if (iscons(*argsyms)) {- lerror("apply: error: too few arguments\n");- }
- }
- noeval = 0;
- lenv = &Stack[saveSP+1];
- PUSH(cdr(*lenv)); // add cloenv to new environment
- e = car_(Stack[saveSP+1]);
- // macro: evaluate expansion in the calling environment
- if (headsym == MACRO) {- if (tag(e)<0x2) ;
- else e = eval_sexpr(e, argenv, 1, SP);
- SP = saveSP;
- if (tag(e)<0x2) return(e);
- goto eval_top;
- }
- else {- if (tag(e)<0x2) { SP=saveSP; return(e); }- if (tail) {- // ok to overwrite environment
- nargs = (int)(&Stack[SP] - argenv);
- for(i=0; i < nargs; i++)
- penv[i] = argenv[i];
- envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]);
- goto eval_top;
- }
- else {- v = eval_sexpr(e, argenv, 1, SP);
- SP = saveSP;
- return v;
- }
- }
- // not reached
- }
- type_error("apply", "function", f);- return NIL;
-}
-
-// repl -----------------------------------------------------------------------
-
-static char *infile = NULL;
-
-value_t toplevel_eval(value_t expr)
-{- value_t v;
- PUSH(NIL);
- v = topeval(expr, &Stack[SP-1]);
- POP();
- return v;
-}
-
-value_t load_file(char *fname)
-{- value_t e, v=NIL;
- char *lastfile = infile;
- FILE *f = fopen(fname, "r");
- infile = fname;
- if (f == NULL) lerror("file not found\n");- while (1) {- e = read_sexpr(f);
- if (feof(f)) break;
- v = toplevel_eval(e);
- }
- infile = lastfile;
- fclose(f);
- return v;
-}
-
-int main(int argc, char* argv[])
-{- value_t v;
-
- stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
- lisp_init();
- if (setjmp(toplevel)) {- SP = 0;
- fprintf(stderr, "\n");
- if (infile) {- fprintf(stderr, "error loading file \"%s\"\n", infile);
- infile = NULL;
- }
- goto repl;
- }
- load_file("system.lsp");- if (argc > 1) { load_file(argv[1]); return 0; }- printf("; _ \n");- printf("; |_ _ _ |_ _ | . _ _ 2\n");- printf("; | (-||||_(_)|__|_)|_)\n");- printf(";-------------------|----------------------------------------------------------\n\n");- repl:
- while (1) {- printf("> ");- v = read_sexpr(stdin);
- if (feof(stdin)) break;
- print(stdout, v=toplevel_eval(v), 0);
- set(symbol("that"), v);- printf("\n\n");- }
- return 0;
-}
--- a/femtolisp/tiny/lispf.c
+++ /dev/null
@@ -1,1043 +1,0 @@
-/*
- femtoLisp
-
- a minimal interpreter for a minimal lisp dialect
-
- this lisp dialect uses lexical scope and self-evaluating lambda.
- it supports 30-bit integers, symbols, conses, and full macros.
- it is case-sensitive.
- it features a simple compacting copying garbage collector.
- it uses a Scheme-style evaluation rule where any expression may appear in
- head position as long as it evaluates to a function.
- it uses Scheme-style varargs (dotted formal argument lists)
- lambdas can have only 1 body expression; use (progn ...) for multiple
- expressions. this is due to the closure representation
- (lambda args body . env)
-
- lispf is a fork that provides an #ifdef FLOAT option to use single-precision
- floating point numbers instead of integers, albeit with even less precision
- than usual---only 21 significant mantissa bits!
-
- it is now also being used to test a tail-recursive evaluator.
-
- by Jeff Bezanson
- Public Domain
-*/
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include <setjmp.h>
-#include <stdarg.h>
-#include <ctype.h>
-#include <sys/types.h>
-
-typedef u_int32_t value_t;
-#ifdef FLOAT
-typedef float number_t;
-#else
-typedef int32_t number_t;
-#endif
-
-typedef struct {- value_t car;
- value_t cdr;
-} cons_t;
-
-typedef struct _symbol_t {- value_t binding; // global value binding
- value_t constant; // constant binding (used only for builtins)
- struct _symbol_t *left;
- struct _symbol_t *right;
- char name[1];
-} symbol_t;
-
-#define TAG_NUM 0x0
-#define TAG_BUILTIN 0x1
-#define TAG_SYM 0x2
-#define TAG_CONS 0x3
-#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
-#define tag(x) ((x)&0x3)
-#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
-#define tagptr(p,t) (((value_t)(p)) | (t))
-#ifdef FLOAT
-#define number(x) ((*(value_t*)&(x))&~0x3)
-#define numval(x) (*(number_t*)&(x))
-#define NUM_FORMAT "%f"
-extern float strtof(const char *nptr, char **endptr);
-#define strtonum(s, e) strtof(s, e)
-#else
-#define number(x) ((value_t)((x)<<2))
-#define numval(x) (((number_t)(x))>>2)
-#define NUM_FORMAT "%d"
-#define strtonum(s, e) strtol(s, e, 10)
-#endif
-#define intval(x) (((int)(x))>>2)
-#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
-#define iscons(x) (tag(x) == TAG_CONS)
-#define issymbol(x) (tag(x) == TAG_SYM)
-#define isnumber(x) (tag(x) == TAG_NUM)
-#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
-// functions ending in _ are unsafe, faster versions
-#define car_(v) (((cons_t*)ptr(v))->car)
-#define cdr_(v) (((cons_t*)ptr(v))->cdr)
-#define car(v) (tocons((v),"car")->car)
-#define cdr(v) (tocons((v),"cdr")->cdr)
-#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
-#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
-
-enum {- // special forms
- F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
- F_PROGN,
- // functions
- F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
- F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
- F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
-};
-#define isspecial(v) (intval(v) <= (int)F_PROGN)
-
-static char *builtin_names[] =
- { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",- "progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
- "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
- "prog1", "apply", "rplaca", "rplacd", "boundp" };
-
-static char *stack_bottom;
-#define PROCESS_STACK_SIZE (2*1024*1024)
-#define N_STACK 49152
-static value_t Stack[N_STACK];
-static u_int32_t SP = 0;
-#define PUSH(v) (Stack[SP++] = (v))
-#define POP() (Stack[--SP])
-#define POPN(n) (SP-=(n))
-
-value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
-
-value_t read_sexpr(FILE *f);
-void print(FILE *f, value_t v);
-value_t eval_sexpr(value_t e, value_t *penv);
-value_t load_file(char *fname);
-
-// error utilities ------------------------------------------------------------
-
-jmp_buf toplevel;
-
-void lerror(char *format, ...)
-{- va_list args;
- va_start(args, format);
- vfprintf(stderr, format, args);
- va_end(args);
- longjmp(toplevel, 1);
-}
-
-void type_error(char *fname, char *expected, value_t got)
-{- fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
- print(stderr, got); lerror("\n");-}
-
-// safe cast operators --------------------------------------------------------
-
-#define SAFECAST_OP(type,ctype,cnvt) \
-ctype to##type(value_t v, char *fname) \
-{ \- if (is##type(v)) \
- return (ctype)cnvt(v); \
- type_error(fname, #type, v); \
- return (ctype)0; \
-}
-SAFECAST_OP(cons, cons_t*, ptr)
-SAFECAST_OP(symbol,symbol_t*,ptr)
-SAFECAST_OP(number,number_t, numval)
-
-// symbol table ---------------------------------------------------------------
-
-static symbol_t *symtab = NULL;
-
-static symbol_t *mk_symbol(char *str)
-{- symbol_t *sym;
-
- sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
- sym->left = sym->right = NULL;
- sym->constant = sym->binding = UNBOUND;
- strcpy(&sym->name[0], str);
- return sym;
-}
-
-static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
-{- int x;
-
- while(*ptree != NULL) {- x = strcmp(str, (*ptree)->name);
- if (x == 0)
- return ptree;
- if (x < 0)
- ptree = &(*ptree)->left;
- else
- ptree = &(*ptree)->right;
- }
- return ptree;
-}
-
-value_t symbol(char *str)
-{- symbol_t **pnode;
-
- pnode = symtab_lookup(&symtab, str);
- if (*pnode == NULL)
- *pnode = mk_symbol(str);
- return tagptr(*pnode, TAG_SYM);
-}
-
-// initialization -------------------------------------------------------------
-
-static unsigned char *fromspace;
-static unsigned char *tospace;
-static unsigned char *curheap;
-static unsigned char *lim;
-static u_int32_t heapsize = 64*1024;//bytes
-
-void lisp_init(void)
-{- int i;
-
- fromspace = malloc(heapsize);
- tospace = malloc(heapsize);
- curheap = fromspace;
- lim = curheap+heapsize-sizeof(cons_t);
-
- NIL = symbol("nil"); setc(NIL, NIL);- T = symbol("t"); setc(T, T);- LAMBDA = symbol("lambda");- MACRO = symbol("macro");- LABEL = symbol("label");- QUOTE = symbol("quote");- for (i=0; i < (int)N_BUILTINS; i++)
- setc(symbol(builtin_names[i]), builtin(i));
- setc(symbol("princ"), builtin(F_PRINT));-}
-
-// conses ---------------------------------------------------------------------
-
-void gc(void);
-
-static value_t mk_cons(void)
-{- cons_t *c;
-
- if (curheap > lim)
- gc();
- c = (cons_t*)curheap;
- curheap += sizeof(cons_t);
- return tagptr(c, TAG_CONS);
-}
-
-static value_t cons_(value_t *pcar, value_t *pcdr)
-{- value_t c = mk_cons();
- car_(c) = *pcar; cdr_(c) = *pcdr;
- return c;
-}
-
-value_t *cons(value_t *pcar, value_t *pcdr)
-{- value_t c = mk_cons();
- car_(c) = *pcar; cdr_(c) = *pcdr;
- PUSH(c);
- return &Stack[SP-1];
-}
-
-// collector ------------------------------------------------------------------
-
-static value_t relocate(value_t v)
-{- value_t a, d, nc;
-
- if (!iscons(v))
- return v;
- if (car_(v) == UNBOUND)
- return cdr_(v);
- nc = mk_cons(); car_(nc) = NIL;
- a = car_(v); d = cdr_(v);
- car_(v) = UNBOUND; cdr_(v) = nc;
- car_(nc) = relocate(a);
- cdr_(nc) = relocate(d);
- return nc;
-}
-
-static void trace_globals(symbol_t *root)
-{- while (root != NULL) {- root->binding = relocate(root->binding);
- trace_globals(root->left);
- root = root->right;
- }
-}
-
-void gc(void)
-{- static int grew = 0;
- unsigned char *temp;
- u_int32_t i;
-
- curheap = tospace;
- lim = curheap+heapsize-sizeof(cons_t);
-
- for (i=0; i < SP; i++)
- Stack[i] = relocate(Stack[i]);
- trace_globals(symtab);
-#ifdef VERBOSEGC
- printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);-#endif
- temp = tospace;
- tospace = fromspace;
- fromspace = temp;
-
- // if we're using > 80% of the space, resize tospace so we have
- // more space to fill next time. if we grew tospace last time,
- // grow the other half of the heap this time to catch up.
- if (grew || ((lim-curheap) < (int)(heapsize/5))) {- temp = realloc(tospace, grew ? heapsize : heapsize*2);
- if (temp == NULL)
- lerror("out of memory\n");- tospace = temp;
- if (!grew)
- heapsize*=2;
- grew = !grew;
- }
- if (curheap > lim) // all data was live
- gc();
-}
-
-// read -----------------------------------------------------------------------
-
-enum {- TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
-};
-
-static int symchar(char c)
-{- static char *special = "()';\\|";
- return (!isspace(c) && !strchr(special, c));
-}
-
-static u_int32_t toktype = TOK_NONE;
-static value_t tokval;
-static char buf[256];
-
-static char nextchar(FILE *f)
-{- char c;
- int ch;
-
- do {- ch = fgetc(f);
- if (ch == EOF)
- return 0;
- c = (char)ch;
- if (c == ';') {- // single-line comment
- do {- ch = fgetc(f);
- if (ch == EOF)
- return 0;
- } while ((char)ch != '\n');
- c = (char)ch;
- }
- } while (isspace(c));
- return c;
-}
-
-static void take(void)
-{- toktype = TOK_NONE;
-}
-
-static void accumchar(char c, int *pi)
-{- buf[(*pi)++] = c;
- if (*pi >= (int)(sizeof(buf)-1))
- lerror("read: error: token too long\n");-}
-
-static int read_token(FILE *f, char c)
-{- int i=0, ch, escaped=0;
-
- ungetc(c, f);
- while (1) {- ch = fgetc(f);
- if (ch == EOF)
- goto terminate;
- c = (char)ch;
- if (c == '|') {- escaped = !escaped;
- }
- else if (c == '\\') {- ch = fgetc(f);
- if (ch == EOF)
- goto terminate;
- accumchar((char)ch, &i);
- }
- else if (!escaped && !symchar(c)) {- break;
- }
- else {- accumchar(c, &i);
- }
- }
- ungetc(c, f);
- terminate:
- buf[i++] = '\0';
- return i;
-}
-
-static u_int32_t peek(FILE *f)
-{- char c, *end;
- number_t x;
-
- if (toktype != TOK_NONE)
- return toktype;
- c = nextchar(f);
- if (feof(f)) return TOK_NONE;
- if (c == '(') {- toktype = TOK_OPEN;
- }
- else if (c == ')') {- toktype = TOK_CLOSE;
- }
- else if (c == '\'') {- toktype = TOK_QUOTE;
- }
- else if (isdigit(c) || c=='-') {- read_token(f, c);
- if (buf[0] == '-' && !isdigit(buf[1])) {- toktype = TOK_SYM;
- tokval = symbol(buf);
- }
- else {- x = strtonum(buf, &end);
- if (*end != '\0')
- lerror("read: error: invalid constant\n");- toktype = TOK_NUM;
- tokval = number(x);
- }
- }
- else {- read_token(f, c);
- if (!strcmp(buf, ".")) {- toktype = TOK_DOT;
- }
- else {- toktype = TOK_SYM;
- tokval = symbol(buf);
- }
- }
- return toktype;
-}
-
-// build a list of conses. this is complicated by the fact that all conses
-// can move whenever a new cons is allocated. we have to refer to every cons
-// through a handle to a relocatable pointer (i.e. a pointer on the stack).
-static void read_list(FILE *f, value_t *pval)
-{- value_t c, *pc;
- u_int32_t t;
-
- PUSH(NIL);
- pc = &Stack[SP-1]; // to keep track of current cons cell
- t = peek(f);
- while (t != TOK_CLOSE) {- if (feof(f))
- lerror("read: error: unexpected end of input\n");- c = mk_cons(); car_(c) = cdr_(c) = NIL;
- if (iscons(*pc))
- cdr_(*pc) = c;
- else
- *pval = c;
- *pc = c;
- c = read_sexpr(f); // must be on separate lines due to undefined
- car_(*pc) = c; // evaluation order
-
- t = peek(f);
- if (t == TOK_DOT) {- take();
- c = read_sexpr(f);
- cdr_(*pc) = c;
- t = peek(f);
- if (feof(f))
- lerror("read: error: unexpected end of input\n");- if (t != TOK_CLOSE)
- lerror("read: error: expected ')'\n");- }
- }
- take();
- POP();
-}
-
-value_t read_sexpr(FILE *f)
-{- value_t v;
-
- switch (peek(f)) {- case TOK_CLOSE:
- take();
- lerror("read: error: unexpected ')'\n");- case TOK_DOT:
- take();
- lerror("read: error: unexpected '.'\n");- case TOK_SYM:
- case TOK_NUM:
- take();
- return tokval;
- case TOK_QUOTE:
- take();
- v = read_sexpr(f);
- PUSH(v);
- v = cons_("E, cons(&Stack[SP-1], &NIL));
- POPN(2);
- return v;
- case TOK_OPEN:
- take();
- PUSH(NIL);
- read_list(f, &Stack[SP-1]);
- return POP();
- }
- return NIL;
-}
-
-// print ----------------------------------------------------------------------
-
-void print(FILE *f, value_t v)
-{- value_t cd;
-
- switch (tag(v)) {- case TAG_NUM: fprintf(f, NUM_FORMAT, numval(v)); break;
- case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
- case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
- builtin_names[intval(v)]); break;
- case TAG_CONS:
- fprintf(f, "(");- while (1) {- print(f, car_(v));
- cd = cdr_(v);
- if (!iscons(cd)) {- if (cd != NIL) {- fprintf(f, " . ");
- print(f, cd);
- }
- fprintf(f, ")");
- break;
- }
- fprintf(f, " ");
- v = cd;
- }
- break;
- }
-}
-
-// eval -----------------------------------------------------------------------
-
-static inline void argcount(char *fname, int nargs, int c)
-{- if (nargs != c)
- lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");-}
-
-#define eval(e, penv) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv))
-#define tail_eval(xpr, env) do { SP = saveSP; \- if (tag(xpr)<0x2) { return (xpr); } \- else { e=(xpr); *penv=(env); goto eval_top; } } while (0)-
-value_t eval_sexpr(value_t e, value_t *penv)
-{- value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
- value_t *rest;
- cons_t *c;
- symbol_t *sym;
- u_int32_t saveSP;
- int i, nargs, noeval=0;
- number_t s, n;
-
- eval_top:
- if (issymbol(e)) {- sym = (symbol_t*)ptr(e);
- if (sym->constant != UNBOUND) return sym->constant;
- v = *penv;
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == e)
- return cdr_(bind);
- v = cdr_(v);
- }
- if ((v = sym->binding) == UNBOUND)
- lerror("eval: error: variable %s has no value\n", sym->name);- return v;
- }
- if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
- lerror("eval: error: stack overflow\n");- saveSP = SP;
- PUSH(e);
- PUSH(*penv);
- f = eval(car_(e), penv);
- *penv = Stack[saveSP+1];
- if (isbuiltin(f)) {- // handle builtin function
- if (!isspecial(f)) {- // evaluate argument list, placing arguments on stack
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- while (iscons(v)) {- v = eval(car_(v), penv);
- *penv = Stack[saveSP+1];
- PUSH(v);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- }
- apply_builtin:
- nargs = SP - saveSP - 2;
- switch (intval(f)) {- // special forms
- case F_QUOTE:
- v = cdr_(Stack[saveSP]);
- if (!iscons(v))
- lerror("quote: error: expected argument\n");- v = car_(v);
- break;
- case F_MACRO:
- case F_LAMBDA:
- v = Stack[saveSP];
- if (*penv != NIL) {- // build a closure (lambda args body . env)
- v = cdr_(v);
- PUSH(car(v));
- argsyms = &Stack[SP-1];
- PUSH(car(cdr_(v)));
- body = &Stack[SP-1];
- v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
- cons(argsyms, cons(body, penv)));
- }
- break;
- case F_LABEL:
- v = Stack[saveSP];
- if (*penv != NIL) {- v = cdr_(v);
- PUSH(car(v)); // name
- pv = &Stack[SP-1];
- PUSH(car(cdr_(v))); // function
- body = &Stack[SP-1];
- *body = eval(*body, penv); // evaluate lambda
- v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
- }
- break;
- case F_IF:
- v = car(cdr_(Stack[saveSP]));
- if (eval(v, penv) != NIL)
- v = car(cdr_(cdr_(Stack[saveSP])));
- else
- v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
- tail_eval(v, Stack[saveSP+1]);
- break;
- case F_COND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- while (iscons(*pv)) {- c = tocons(car_(*pv), "cond");
- v = eval(c->car, penv);
- *penv = Stack[saveSP+1];
- if (v != NIL) {- *pv = cdr_(car_(*pv));
- // evaluate body forms
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- v = eval(car_(*pv), penv);
- *penv = Stack[saveSP+1];
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv), *penv);
- }
- break;
- }
- *pv = cdr_(*pv);
- }
- break;
- case F_AND:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = T;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- if ((v=eval(car_(*pv), penv)) == NIL) {- SP = saveSP; return NIL;
- }
- *penv = Stack[saveSP+1];
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv), *penv);
- }
- break;
- case F_OR:
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- if ((v=eval(car_(*pv), penv)) != NIL) {- SP = saveSP; return v;
- }
- *penv = Stack[saveSP+1];
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv), *penv);
- }
- break;
- case F_WHILE:
- PUSH(car(cdr(cdr_(Stack[saveSP]))));
- body = &Stack[SP-1];
- Stack[saveSP] = car_(cdr_(Stack[saveSP]));
- value_t *cond = &Stack[saveSP];
- PUSH(NIL); pv = &Stack[SP-1];
- while (eval(*cond, penv) != NIL) {- *penv = Stack[saveSP+1];
- *pv = eval(*body, penv);
- *penv = Stack[saveSP+1];
- }
- v = *pv;
- break;
- case F_PROGN:
- // return last arg
- Stack[saveSP] = cdr_(Stack[saveSP]);
- pv = &Stack[saveSP]; v = NIL;
- if (iscons(*pv)) {- while (iscons(cdr_(*pv))) {- v = eval(car_(*pv), penv);
- *penv = Stack[saveSP+1];
- *pv = cdr_(*pv);
- }
- tail_eval(car_(*pv), *penv);
- }
- break;
-
- // ordinary functions
- case F_SET:
- argcount("set", nargs, 2);- e = Stack[SP-2];
- v = *penv;
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == e) {- cdr_(bind) = (v=Stack[SP-1]);
- SP=saveSP; return v;
- }
- v = cdr_(v);
- }
- tosymbol(e, "set")->binding = (v=Stack[SP-1]);
- break;
- case F_BOUNDP:
- argcount("boundp", nargs, 1);- if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
- v = NIL;
- else
- v = T;
- break;
- case F_EQ:
- argcount("eq", nargs, 2);- v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
- break;
- case F_CONS:
- argcount("cons", nargs, 2);- v = mk_cons();
- car_(v) = Stack[SP-2];
- cdr_(v) = Stack[SP-1];
- break;
- case F_CAR:
- argcount("car", nargs, 1);- v = car(Stack[SP-1]);
- break;
- case F_CDR:
- argcount("cdr", nargs, 1);- v = cdr(Stack[SP-1]);
- break;
- case F_RPLACA:
- argcount("rplaca", nargs, 2);- car(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_RPLACD:
- argcount("rplacd", nargs, 2);- cdr(v=Stack[SP-2]) = Stack[SP-1];
- break;
- case F_ATOM:
- argcount("atom", nargs, 1);- v = ((!iscons(Stack[SP-1])) ? T : NIL);
- break;
- case F_SYMBOLP:
- argcount("symbolp", nargs, 1);- v = ((issymbol(Stack[SP-1])) ? T : NIL);
- break;
- case F_NUMBERP:
- argcount("numberp", nargs, 1);- v = ((isnumber(Stack[SP-1])) ? T : NIL);
- break;
- case F_ADD:
- s = 0;
- for (i=saveSP+2; i < (int)SP; i++) {- n = tonumber(Stack[i], "+");
- s += n;
- }
- v = number(s);
- break;
- case F_SUB:
- if (nargs < 1)
- lerror("-: error: too few arguments\n");- i = saveSP+2;
- s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "-");
- s -= n;
- }
- v = number(s);
- break;
- case F_MUL:
- s = 1;
- for (i=saveSP+2; i < (int)SP; i++) {- n = tonumber(Stack[i], "*");
- s *= n;
- }
- v = number(s);
- break;
- case F_DIV:
- if (nargs < 1)
- lerror("/: error: too few arguments\n");- i = saveSP+2;
- s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
- for (; i < (int)SP; i++) {- n = tonumber(Stack[i], "/");
- if (n == 0)
- lerror("/: error: division by zero\n");- s /= n;
- }
- v = number(s);
- break;
- case F_LT:
- argcount("<", nargs, 2);- if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
- v = T;
- else
- v = NIL;
- break;
- case F_NOT:
- argcount("not", nargs, 1);- v = ((Stack[SP-1] == NIL) ? T : NIL);
- break;
- case F_EVAL:
- argcount("eval", nargs, 1);- v = Stack[SP-1];
- tail_eval(v, NIL);
- break;
- case F_PRINT:
- for (i=saveSP+2; i < (int)SP; i++)
- print(stdout, v=Stack[i]);
- break;
- case F_READ:
- argcount("read", nargs, 0);- v = read_sexpr(stdin);
- break;
- case F_LOAD:
- argcount("load", nargs, 1);- v = load_file(tosymbol(Stack[SP-1], "load")->name);
- break;
- case F_PROG1:
- // return first arg
- if (nargs < 1)
- lerror("prog1: error: too few arguments\n");- v = Stack[saveSP+2];
- break;
- case F_APPLY:
- argcount("apply", nargs, 2);- v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
- f = Stack[SP-2]; // first arg is new function
- POPN(2); // pop apply's args
- if (isbuiltin(f)) {- if (isspecial(f))
- lerror("apply: error: cannot apply special operator "- "%s\n", builtin_names[intval(f)]);
- // unpack arglist onto the stack
- while (iscons(v)) {- PUSH(car_(v));
- v = cdr_(v);
- }
- goto apply_builtin;
- }
- noeval = 1;
- goto apply_lambda;
- }
- SP = saveSP;
- return v;
- }
- else {- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- apply_lambda:
- if (iscons(f)) {- headsym = car_(f);
- if (headsym == LABEL) {- // (label name (lambda ...)) behaves the same as the lambda
- // alone, except with name bound to the whole label expression
- labl = f;
- f = car(cdr(cdr_(labl)));
- headsym = car(f);
- }
- // apply lambda or macro expression
- PUSH(cdr(cdr(cdr_(f))));
- lenv = &Stack[SP-1];
- PUSH(car_(cdr_(f)));
- argsyms = &Stack[SP-1];
- PUSH(car_(cdr_(cdr_(f))));
- body = &Stack[SP-1];
- if (labl) {- // add label binding to environment
- PUSH(labl);
- PUSH(car_(cdr_(labl)));
- *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
- POPN(3);
- v = Stack[saveSP]; // refetch arglist
- }
- if (headsym == MACRO)
- noeval = 1;
- else if (headsym != LAMBDA)
- lerror("apply: error: head must be lambda, macro, or label\n");- // build a calling environment for the lambda
- // the environment is the argument binds on top of the captured
- // environment
- while (iscons(v)) {- // bind args
- if (!iscons(*argsyms)) {- if (*argsyms == NIL)
- lerror("apply: error: too many arguments\n");- break;
- }
- asym = car_(*argsyms);
- if (!issymbol(asym))
- lerror("apply: error: formal argument not a symbol\n");- v = car_(v);
- if (!noeval) {- v = eval(v, penv);
- *penv = Stack[saveSP+1];
- }
- PUSH(v);
- *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
- POPN(2);
- *argsyms = cdr_(*argsyms);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- if (*argsyms != NIL) {- if (issymbol(*argsyms)) {- if (noeval) {- *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
- }
- else {- PUSH(NIL);
- PUSH(NIL);
- rest = &Stack[SP-1];
- // build list of rest arguments
- // we have to build it forwards, which is tricky
- while (iscons(v)) {- v = eval(car_(v), penv);
- *penv = Stack[saveSP+1];
- PUSH(v);
- v = cons_(&Stack[SP-1], &NIL);
- POP();
- if (iscons(*rest))
- cdr_(*rest) = v;
- else
- Stack[SP-2] = v;
- *rest = v;
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
- }
- }
- else if (iscons(*argsyms)) {- lerror("apply: error: too few arguments\n");- }
- }
- noeval = 0;
- // macro: evaluate expansion in the calling environment
- if (headsym == MACRO) {- SP = saveSP;
- PUSH(*lenv);
- lenv = &Stack[SP-1];
- v = eval(*body, lenv);
- tail_eval(v, *penv);
- }
- else {- tail_eval(*body, *lenv);
- }
- // not reached
- }
- type_error("apply", "function", f);- return NIL;
-}
-
-// repl -----------------------------------------------------------------------
-
-static char *infile = NULL;
-
-value_t toplevel_eval(value_t expr)
-{- value_t v;
- PUSH(NIL);
- v = eval(expr, &Stack[SP-1]);
- POP();
- return v;
-}
-
-value_t load_file(char *fname)
-{- value_t e, v=NIL;
- char *lastfile = infile;
- FILE *f = fopen(fname, "r");
- infile = fname;
- if (f == NULL) lerror("file not found\n");- while (1) {- e = read_sexpr(f);
- if (feof(f)) break;
- v = toplevel_eval(e);
- }
- infile = lastfile;
- fclose(f);
- return v;
-}
-
-int main(int argc, char* argv[])
-{- value_t v;
-
- stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
- lisp_init();
- if (setjmp(toplevel)) {- SP = 0;
- fprintf(stderr, "\n");
- if (infile) {- fprintf(stderr, "error loading file \"%s\"\n", infile);
- infile = NULL;
- }
- goto repl;
- }
- load_file("system.lsp");- if (argc > 1) { load_file(argv[1]); return 0; }- printf("Welcome to femtoLisp ----------------------------------------------------------\n");- repl:
- while (1) {- printf("> ");- v = read_sexpr(stdin);
- if (feof(stdin)) break;
- print(stdout, v=toplevel_eval(v));
- set(symbol("that"), v);- printf("\n\n");- }
- return 0;
-}
--- a/femtolisp/tiny/scrap.c
+++ /dev/null
@@ -1,107 +1,0 @@
-// code to relocate cons chains iteratively
- pcdr = &cdr_(nc);
- while (iscons(d)) {- if (car_(d) == FWD) {- *pcdr = cdr_(d);
- return first;
- }
- *pcdr = nc = mk_cons();
- a = car_(d); v = cdr_(d);
- car_(d) = FWD; cdr_(d) = nc;
- car_(nc) = relocate(a);
- pcdr = &cdr_(nc);
- d = v;
- }
- *pcdr = d;
-
-/*
- f = *rest;
- *rest = NIL;
- while (iscons(f)) { // nreverse!- v = cdr_(f);
- cdr_(f) = *rest;
- *rest = f;
- f = v;
- }*/
-
-int favailable(FILE *f)
-{- fd_set set;
- struct timeval tv = {0, 0};- int fd = fileno(f);
-
- FD_ZERO(&set);
- FD_SET(fd, &set);
- return (select(fd+1, &set, NULL, NULL, &tv)!=0);
-}
-
-static void print_env(value_t *penv)
-{- printf("<[ ");- while (issymbol(*penv) && *penv!=NIL) {- print(stdout, *penv, 0);
- printf(" ");- penv++;
- print(stdout, *penv, 0);
- printf(" ");- penv++;
- }
- printf("] ");- print(stdout, *penv, 0);
- printf(">\n");-}
-
-#else
- PUSH(NIL);
- PUSH(NIL);
- value_t *rest = &Stack[SP-1];
- // build list of rest arguments
- // we have to build it forwards, which is tricky
- while (iscons(v)) {- v = eval(car_(v));
- PUSH(v);
- v = cons_(&Stack[SP-1], &NIL);
- POP();
- if (iscons(*rest))
- cdr_(*rest) = v;
- else
- Stack[SP-2] = v;
- *rest = v;
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- POP();
-#endif
- // this version uses collective allocation. about 7-10%
- // faster for lists with > 2 elements, but uses more
- // stack space
- i = SP;
- while (iscons(v)) {- v = eval(car_(v));
- PUSH(v);
- v = Stack[saveSP] = cdr_(Stack[saveSP]);
- }
- if ((int)SP==i) {- PUSH(NIL);
- }
- else {- e = v = cons_reserve(nargs=(SP-i));
- for(; i < (int)SP; i++) {- car_(v) = Stack[i];
- v = cdr_(v);
- }
- POPN(nargs);
- PUSH(e);
- }
-
-value_t list_to_vector(value_t l)
-{- value_t v;
- size_t n = llength(l), i=0;
- v = alloc_vector(n, 0);
- while (iscons(l)) {- vector_elt(v,i) = car_(l);
- i++;
- l = cdr_(l);
- }
- return v;
-}
--- a/femtolisp/tiny/system.lsp
+++ /dev/null
@@ -1,426 +1,0 @@
-; femtoLisp standard library
-; by Jeff Bezanson
-; Public Domain
-
-(set 'list (lambda args args))
-
-(set 'setq (macro (name val)
- (list set (list quote name) val)))
-
-(setq sp '| |)
-(setq nl '|
-|)
-
-; convert a sequence of body statements to a single expression.
-; this allows define, defun, defmacro, let, etc. to contain multiple
-; body expressions as in Common Lisp.
-(setq f-body (lambda (e)
- (cond ((atom e) e)
- ((eq (cdr e) ()) (car e))
- (t (cons progn e)))))
-
-(setq defmacro
- (macro (name args . body)
- (list 'setq name (list 'macro args (f-body body)))))
-
-; support both CL defun and Scheme-style define
-(defmacro defun (name args . body)
- (list 'setq name (list 'lambda args (f-body body))))
-
-(defmacro define (name . body)
- (if (symbolp name)
- (list 'setq name (car body))
- (cons 'defun (cons (car name) (cons (cdr name) body)))))
-
-(defun identity (x) x)
-(setq null not)
-(defun consp (x) (not (atom x)))
-
-(defun map (f lst)
- (if (atom lst) lst
- (cons (f (car lst)) (map f (cdr lst)))))
-
-(defmacro let (binds . body)
- (cons (list 'lambda (map car binds) (f-body body))
- (map cadr binds)))
-
-(defun nconc lsts
- (cond ((null lsts) ())
- ((null (cdr lsts)) (car lsts))
- (t ((lambda (l d) (if (null l) d
- (prog1 l
- (while (consp (cdr l)) (set 'l (cdr l)))
- (rplacd l d))))
- (car lsts) (apply nconc (cdr lsts))))))
-
-(defun append lsts
- (cond ((null lsts) ())
- ((null (cdr lsts)) (car lsts))
- (t ((label append2 (lambda (l d)
- (if (null l) d
- (cons (car l)
- (append2 (cdr l) d)))))
- (car lsts) (apply append (cdr lsts))))))
-
-(defun member (item lst)
- (cond ((atom lst) ())
- ((eq (car lst) item) lst)
- (t (member item (cdr lst)))))
-
-(defun macrop (e) (and (consp e) (eq (car e) 'macro) e))
-(defun macrocallp (e) (and (symbolp (car e))
- (boundp (car e))
- (macrop (eval (car e)))))
-(defun macroapply (m args) (apply (cons 'lambda (cdr m)) args))
-
-(defun macroexpand-1 (e)
- (if (atom e) e
- (let ((f (macrocallp e)))
- (if f (macroapply f (cdr e))
- e))))
-
-; convert to proper list, i.e. remove "dots", and append
-(defun append.2 (l tail)
- (cond ((null l) tail)
- ((atom l) (cons l tail))
- (t (cons (car l) (append.2 (cdr l) tail)))))
-
-(defun macroexpand (e)
- ((label mexpand
- (lambda (e env f)
- (progn
- (while (and (consp e)
- (not (member (car e) env))
- (set 'f (macrocallp e)))
- (set 'e (macroapply f (cdr e))))
- (if (and (consp e)
- (not (or (eq (car e) 'quote)
- (eq (car e) quote))))
- (let ((newenv
- (if (and (or (eq (car e) 'lambda) (eq (car e) 'macro))
- (consp (cdr e)))
- (append.2 (cadr e) env)
- env)))
- (map (lambda (x) (mexpand x newenv nil)) e))
- e))))
- e nil nil))
-
-; uncomment this to macroexpand functions at definition time.
-; makes typical code ~25% faster, but only works for defun expressions
-; at the top level.
-;(defmacro defun (name args . body)
-; (list 'setq name (list 'lambda args (macroexpand (f-body body)))))
-
-; same thing for macros. enabled by default because macros are usually
-; defined at the top level.
-(defmacro defmacro (name args . body)
- (list 'setq name (list 'macro args (macroexpand (f-body body)))))
-
-(setq = eq)
-(setq eql eq)
-(define (/= a b) (not (eq a b)))
-(define != /=)
-(define (> a b) (< b a))
-(define (<= a b) (not (< b a)))
-(define (>= a b) (not (< a b)))
-(define (mod x y) (- x (* (/ x y) y)))
-(define (abs x) (if (< x 0) (- x) x))
-(define (truncate x) x)
-(setq K prog1) ; K combinator ;)
-(define (funcall f . args) (apply f args))
-(define (symbol-function sym) (eval sym))
-(define (symbol-value sym) (eval sym))
-
-(define (caar x) (car (car x)))
-(define (cadr x) (car (cdr x)))
-(define (cdar x) (cdr (car x)))
-(define (cddr x) (cdr (cdr x)))
-(define (caaar x) (car (car (car x))))
-(define (caadr x) (car (car (cdr x))))
-(define (cadar x) (car (cdr (car x))))
-(define (caddr x) (car (cdr (cdr x))))
-(define (cdaar x) (cdr (car (car x))))
-(define (cdadr x) (cdr (car (cdr x))))
-(define (cddar x) (cdr (cdr (car x))))
-(define (cdddr x) (cdr (cdr (cdr x))))
-
-(define (equal a b)
- (if (and (consp a) (consp b))
- (and (equal (car a) (car b))
- (equal (cdr a) (cdr b)))
- (eq a b)))
-
-; compare imposes an ordering on all values. yields -1 for a<b,
-; 0 for a==b, and 1 for a>b. lists are compared up to the first
-; point of difference.
-(defun compare (a b)
- (cond ((eq a b) 0)
- ((or (atom a) (atom b)) (if (< a b) -1 1))
- (t (let ((c (compare (car a) (car b))))
- (if (not (eq c 0))
- c
- (compare (cdr a) (cdr b)))))))
-
-(defun every (pred lst)
- (or (atom lst)
- (and (pred (car lst))
- (every pred (cdr lst)))))
-
-(defun any (pred lst)
- (and (consp lst)
- (or (pred (car lst))
- (any pred (cdr lst)))))
-
-(defun listp (a) (or (eq a ()) (consp a)))
-
-(defun length (l)
- (if (null l) 0
- (+ 1 (length (cdr l)))))
-
-(defun nthcdr (n lst)
- (if (<= n 0) lst
- (nthcdr (- n 1) (cdr lst))))
-
-(defun list-ref (lst n)
- (car (nthcdr n lst)))
-
-(defun list* l
- (if (atom (cdr l))
- (car l)
- (cons (car l) (apply list* (cdr l)))))
-
-(defun nlist* l
- (if (atom (cdr l))
- (car l)
- (rplacd l (apply nlist* (cdr l)))))
-
-(defun lastcdr (l)
- (if (atom l) l
- (lastcdr (cdr l))))
-
-(defun last (l)
- (cond ((atom l) l)
- ((atom (cdr l)) l)
- (t (last (cdr l)))))
-
-(defun map! (f lst)
- (prog1 lst
- (while (consp lst)
- (rplaca lst (f (car lst)))
- (set 'lst (cdr lst)))))
-
-(defun mapcar (f . lsts)
- ((label mapcar-
- (lambda (lsts)
- (cond ((null lsts) (f))
- ((atom (car lsts)) (car lsts))
- (t (cons (apply f (map car lsts))
- (mapcar- (map cdr lsts)))))))
- lsts))
-
-(defun transpose (M) (apply mapcar (cons list M)))
-
-(defun filter (pred lst)
- (cond ((null lst) ())
- ((not (pred (car lst))) (filter pred (cdr lst)))
- (t (cons (car lst) (filter pred (cdr lst))))))
-
-(define (foldr f zero lst)
- (if (null lst) zero
- (f (car lst) (foldr f zero (cdr lst)))))
-
-(define (foldl f zero lst)
- (if (null lst) zero
- (foldl f (f (car lst) zero) (cdr lst))))
-
-(define (reverse lst) (foldl cons nil lst))
-
-(define (reduce0 f zero lst)
- (if (null lst) zero
- (reduce0 f (f zero (car lst)) (cdr lst))))
-
-(defun reduce (f lst)
- (reduce0 f (car lst) (cdr lst)))
-
-(define (copy-list l) (map identity l))
-(define (copy-tree l)
- (if (atom l) l
- (cons (copy-tree (car l))
- (copy-tree (cdr l)))))
-
-(define (assoc item lst)
- (cond ((atom lst) ())
- ((eq (caar lst) item) (car lst))
- (t (assoc item (cdr lst)))))
-
-(define (nreverse l)
- (let ((prev nil))
- (while (consp l)
- (set 'l (prog1 (cdr l)
- (rplacd l (prog1 prev
- (set 'prev l))))))
- prev))
-
-(defmacro let* (binds . body)
- (cons (list 'lambda (map car binds)
- (cons progn
- (nconc (map (lambda (b) (cons 'setq b)) binds)
- body)))
- (map (lambda (x) nil) binds)))
-
-(defmacro labels (binds . body)
- (cons (list 'lambda (map car binds)
- (cons progn
- (nconc (map (lambda (b)
- (list 'setq (car b) (cons 'lambda (cdr b))))
- binds)
- body)))
- (map (lambda (x) nil) binds)))
-
-(defmacro when (c . body) (list if c (f-body body) nil))
-(defmacro unless (c . body) (list if c nil (f-body body)))
-
-(defmacro dotimes (var . body)
- (let ((v (car var))
- (cnt (cadr var)))
- (list 'let (list (list v 0))
- (list while (list < v cnt)
- (list prog1 (f-body body) (list 'setq v (list + v 1)))))))
-
-(defun map-int (f n)
- (let ((acc nil))
- (dotimes (i n)
- (setq acc (cons (f i) acc)))
- (nreverse acc)))
-
-; property lists
-(setq *plists* nil)
-
-(defun symbol-plist (sym)
- (cdr (or (assoc sym *plists*) '(()))))
-
-(defun set-symbol-plist (sym lst)
- (let ((p (assoc sym *plists*)))
- (if (null p) ; sym has no plist yet
- (setq *plists* (cons (cons sym lst) *plists*))
- (rplacd p lst))))
-
-(defun get (sym prop)
- (let ((pl (symbol-plist sym)))
- (if pl
- (let ((pr (member prop pl)))
- (if pr (cadr pr) nil))
- nil)))
-
-(defun put (sym prop val)
- (let ((p (assoc sym *plists*)))
- (if (null p) ; sym has no plist yet
- (setq *plists* (cons (list sym prop val) *plists*))
- (let ((pr (member prop p)))
- (if (null pr) ; sym doesn't have this property yet
- (rplacd p (cons prop (cons val (cdr p))))
- (rplaca (cdr pr) val)))))
- val)
-
-; setf
-; expands (setf (place x ...) v) to (mutator (f x ...) v)
-; (mutator (identity x ...) v) is interpreted as (mutator x ... v)
-(setq *setf-place-list*
- ; place mutator f
- '((car rplaca identity)
- (cdr rplacd identity)
- (caar rplaca car)
- (cadr rplaca cdr)
- (cdar rplacd car)
- (cddr rplacd cdr)
- (caaar rplaca caar)
- (caadr rplaca cadr)
- (cadar rplaca cdar)
- (caddr rplaca cddr)
- (cdaar rplacd caar)
- (cdadr rplacd cadr)
- (cddar rplacd cdar)
- (cdddr rplacd cddr)
- (get put identity)
- (aref aset identity)
- (symbol-function set identity)
- (symbol-value set identity)
- (symbol-plist set-symbol-plist identity)))
-
-(defun setf-place-mutator (place val)
- (if (symbolp place)
- (list 'setq place val)
- (let ((mutator (assoc (car place) *setf-place-list*)))
- (if (null mutator)
- (error '|setf: error: unknown place | (car place))
- (if (eq (caddr mutator) 'identity)
- (cons (cadr mutator) (append (cdr place) (list val)))
- (list (cadr mutator)
- (cons (caddr mutator) (cdr place))
- val))))))
-
-(defmacro setf args
- (f-body
- ((label setf-
- (lambda (args)
- (if (null args)
- nil
- (cons (setf-place-mutator (car args) (cadr args))
- (setf- (cddr args))))))
- args)))
-
-(defun revappend (l1 l2) (nconc (reverse l1) l2))
-(defun nreconc (l1 l2) (nconc (nreverse l1) l2))
-
-(defun builtinp (x)
- (and (atom x)
- (not (symbolp x))
- (not (numberp x))))
-
-(defun self-evaluating-p (x)
- (or (eq x nil)
- (eq x t)
- (and (atom x)
- (not (symbolp x)))))
-
-; backquote
-(defmacro backquote (x) (bq-process x))
-
-(defun splice-form-p (x)
- (or (and (consp x) (or (eq (car x) '*comma-at*)
- (eq (car x) '*comma-dot*)))
- (eq x '*comma*)))
-
-(defun bq-process (x)
- (cond ((self-evaluating-p x) x)
- ((atom x) (list quote x))
- ((eq (car x) 'backquote) (bq-process (bq-process (cadr x))))
- ((eq (car x) '*comma*) (cadr x))
- ((not (any splice-form-p x))
- (let ((lc (lastcdr x))
- (forms (map bq-bracket1 x)))
- (if (null lc)
- (cons 'list forms)
- (nconc (cons 'nlist* forms) (list (bq-process lc))))))
- (t (let ((p x) (q '()))
- (while (and (consp p)
- (not (eq (car p) '*comma*)))
- (setq q (cons (bq-bracket (car p)) q))
- (setq p (cdr p)))
- (cons 'nconc
- (cond ((consp p) (nreconc q (list (cadr p))))
- ((null p) (nreverse q))
- (t (nreconc q (list (bq-process p))))))))))
-
-(defun bq-bracket (x)
- (cond ((atom x) (list cons (bq-process x) nil))
- ((eq (car x) '*comma*) (list cons (cadr x) nil))
- ((eq (car x) '*comma-at*) (list 'copy-list (cadr x)))
- ((eq (car x) '*comma-dot*) (cadr x))
- (t (list cons (bq-process x) nil))))
-
-; bracket without splicing
-(defun bq-bracket1 (x)
- (if (and (consp x) (eq (car x) '*comma*))
- (cadr x)
- (bq-process x)))
--- a/femtolisp/todo
+++ /dev/null
@@ -1,1199 +1,0 @@
-* setf
-* plists
-* backquote
-* symbol< (make < generic), generic compare function
-? (cdr nil) should be nil
-* multiple-argument mapcar
-? multi-argument apply. for builtins, just push them. for lambdas, must
- cons together the evaluated arguments.
-? option *print-shared*. if nil, it still handles circular references
- but does not specially print non-circular shared structure
-? option *print-circle*
-* read support for #' for compatibility
-* #\c read character as code (including UTF-8 support!)
-* #| |# block comments
-? here-data for binary serialization. proposed syntax:
- #>size:data, e.g. #>6:000000
-? better read syntax for packed arrays, e.g. #double[3 1 4]
-* use syntax environment concept for user-defined macros to plug
- that hole in the semantics
-* make more builtins generic. if typecheck fails, call out to the
- generic version to try supporting more types.
- compare/equal
- +-*/< for all numeric types
- length for all sequences
- ? aref/aset for all sequences (vector, list, c-array)
- ? copy
-* fixnump, all numeric types should pass numberp
-- make sure all uses of symbols don't assume symbols are unmovable without
- checking ismanaged()
-* eliminate compiler warnings
-* fix printing nan and inf
-* move to "2.5-bit" type tags
-? builtin abs()
-* try adding optional arguments, (lambda (x (opt 0)) ...), see if performance
- is acceptable
-* (syntax-environment) to return it as an assoc list
-* (environment) for variables, constantp
-* prettier printing
-
-* readable gensyms and #:
- . #:n reads similar to #n=#.(gensym) the first time, and #n# after
-* circular equal
-* integer/truncate function
-? car-circularp, cdr-circularp, circularp
-- hashtable. plan as equal-hash, over three stages:
- 1. first support symbol and fixnum keys, use ptrhash. only values get
- relocated on GC.
- 2. create a version of ptrhash that uses equal() and hash(). if a key is
- inserted requiring this, switch vtable pointer to use these functions.
- both keys and values get relocated on GC.
- 3. write hash() for pairs and vectors. now everything works.
-- expose eq-hashtable to user
-- other backquote optimizations:
- * (nconc x) => x for any x
- . (copy-list (list|append|nconc ...)) => (list|append|nconc ...)
- * (apply vector (list ...)) => (vector ...)
- * (nconc (cons x nil) y) => (cons x y)
-* let form without initializers (let (a b) ...), defaults to nil
-* print (quote a) as 'a, same for ` etc.
-
-- template keyword arguments. you write
-(template (:test eq) (:key caar)
- (defun assoc (item lst)
- (cond ((atom lst) ())
- ((:test (:key lst) item) (car lst))
- (t (assoc item (cdr lst))))))
-
-This writes assoc as a macro that produces a call to a pre-specialized
-version of the function. For example
- (assoc x l :test equal)
-first tries to look up the variant '(equal caar) in the dictionary for assoc.
-If it doesn't exist it gets generated and stored. The result is a lambda
-expression.
-The macro returns ((lambda (item lst) <code for assoc>) x l).
-We might have to require different syntax for template invocations inside
-template definitions, such as
- ((t-instance assoc eq :key) item lst)
-which passes along the same key but always uses eq.
-Alternatively, we could use the keysyms without colons to name the values
-of the template arguments, so the keysyms are always used as markers and
-never appear to have values:
-(template (:test eq) (:key caar)
- (defun assoc? (item lst)
- (cond ((atom lst) ())
- ((test (key lst) item) ...
- ...
- (assoc x y :test test :key key)
-This would be even easier if the keyword syntax were something like
- (: test eq)
-
-
-possible optimizations:
-* delay environment creation. represent environment on the stack as
- alternating symbols/values, or if cons instead of symbol then traverse
- as assoc list. only explicitly cons the whole thing when making a closure
-* cons_reserve(n) interface, guarantees n conses available without gc.
- it could even link them together for you more efficiently
-* assoc builtin
-* special check for constant symbol when evaluating head since that's likely
-* remove the loop from cons_reserve. move all initialization to the loops
- that follow calls to cons_reserve.
-- case of lambda expression in head (as produced by let), can just modify
- env in-place in tail position
-- allocate memory by mmap'ing a large uncommitted block that we cut
- in half. then each half heap can be grown without moving addresses.
-* try making (list ...) a builtin by moving the list-building code to
- a static function, see if vararg call performance is affected.
-- try making foldl a builtin, implement table iterator as table.foldl
- . not great, since then it can't be CPS converted
-* represent lambda environment as a vector (in lispv)
-x setq builtin (didn't help)
-* list builtin, to use cons_reserve
-unconventional interpreter builtins that can be used as a compilation
-target without moving away from s-expressions:
-- (*global* . a) ; special form, don't look in local env first
-- (*local* . 2) ; direct stackframe access
-for internal use:
-* a special version of apply that takes arguments on the stack, to avoid
- consing when implementing "call-with" style primitives like trycatch,
- hashtable-foreach, or the fl_apply API
-- partial_apply, reapply interface so other iterators can use the same
- fast mechanism as for
-* try this environment representation:
- for all kinds of functions (except maybe builtin special forms) push
- all arguments on the stack, either evaluated or not.
- for lambdas, push the lambda list and next-env pointers.
- to capture, save the n+2 pointers to a vector
- . this uses n+2 heap or stack words per environment instead of 2n+1 words
- . argument handling is more uniform which could lead to simplifications,
- and a more efficient apply() entry point
- . disadvantage is looking through the lambda list on every lookup. maybe
- improve by making lambda lists vectors somehow?
-* fast builtin bounded iteration construct (for lo hi (lambda (x) ...))
-* represent guest function as a tagged function pointer; allocate nothing
-- when an instance of (array type n) is requested, use (array type)
- instead, unless the value is part of an aggregate (e.g. struct).
- . this avoids allocating a new type for every size.
- . and/or add function array.alloc
-x preallocate all byte,int8,uint8 values, and some wchars (up to 0x31B7?)
- . this made no difference in a string.map microbenchmark
-- use faster hash/compare in tables where the keys are eq-comparable
-- a way to do open-input-string without copying
-
-bugs:
-* with the fully recursive (simpler) relocate(), the size of cons chains
- is limited by the process stack size. with the iterative version we can
- have unlimited cdr-deep structures.
-* in #n='e, the case that makes the cons for 'e needs to use label fixup
-* symbol token |.| does not work
-* ltable realloc not multiplying by sizeof(unsigned long)
-* not relocating final cdr in iterative version if it is a vector
-- (setf (car x) y) doesn't return y
-* reader needs to check errno in isnumtok
-* prettyprint size measuring is not utf-8 correct
-* stack is too limited.
- . add extra heap-allocated stack segments as needed.
-* argument list length is too limited.
- need to fix it for: +,-,*,/,&,|,$,list,vector,apply,string,array
- . for builtins, make Nth argument list of rest args
- . write a function to evaluate directly from list to list, use it for
- Nth arg and for user function rest args
- . modify vararg builtins accordingly
-* filter should be stable. right now it reverses.
-
-
-femtoLisp3...with symbolic C interface
-
-c values are builtins with value > N_BUILTINS
-((u_int32_t*)cvalue)[0] & 0x3 must always be 2 to distinguish from vectors
-
-typedef struct _cvtable_t {- void (*relocate)(struct _cvalue_t *);
- void (*free)(struct _cvalue_t *);
- void (*print)(struct _cvalue_t *, FILE *);
-} cvtable_t;
-
-c type representations:
-symbols void, [u]int[8,16,32,64], float, double, [u]char, [u]short,
-[u]int, [u]long, lispvalue
-(c-function ret-type (argtype ...))
-(array type[ N])
-(struct ((name type) (name type) ...))
-(union ((name type) (name type) ...))
-(mlayout ((name type offset) (name type offset) ...))
-(enum (name1 name2 ...))
-(pointer type)
-
-constructors:
-([u]int[8,16] n)
-([u]int32 hi lo)
-([u]int64 b3 b2 b1 b0)
-(float hi lo) or (float "3.14")
-(double b3 b2 b1 b0) or (double "3.14")
-(array ctype val ...)
-(struct ((name type) ...) val ...)
-(pointer ctype) ; null pointer
-(pointer cvalue) ; constructs pointer to the given value
- ; same as (pointer (typeof x) x)
-(pointer ctype cvalue) ; pointer of given type, to given value
-(pointer ctype cvalue addr) ; (ctype*)((char*)cvalue + addr)
-(c-function ret-type (argtype ...) ld-symbol-name)
-
-? struct/enum tag:
- (struct 'tag <initializer>) or (pointer (struct tag))
- where tag is a global var with a value ((name type) ...)
-
-
-representing c data from lisp is the tricky part to make really elegant and
-efficient. the most elegant but too inefficient option is not to have opaque
-C values at all and always marshal to/from native lisp values like #int16[10].
-the next option is to have opaque values "sometimes", for example returning
-them from C functions but printing them using their lisp representations.
-the next option is to relax the idea that C values of a certain type have a
-specific lisp structure, and use a coercion system that "tries" to translate
-a lisp value to a specified C type. for example [0 1 2], (0 1 2),
-#string[0 1 2], etc. might all be accepted by a C function taking int8_t*.
-you could say (c-coerce <lispvalue> <typedesc>) and get a cvalue back or
-an error if the conversion fails.
-
-the final option is to have cvalues be the only officially-sanctioned
-representation of c data, and make them via constructors, like
-(int32 hi lo) returns an int32 cvalue
-(struct '((name type) (name type) ...) a b ...) makes a struct
-there is a constructor function for each primitive C type.
-you can print these by brute force as e.g. #.(int32 hi lo)
-then all checking just looks like functions checking their arguments
-
-this option seems almost ideal. what's wrong with it?
-. to construct cvalues from lisp you have to build code instead of data
-. it seems like it should take more explicit advantage of tagged vectors
-. should you accept multiple forms? for example
- (array 'int8 0 1 2) or (array 'int8 [0 1 2])
- if you're going to be that permissive, why not allow [0 1 2] to be passed
- directly to a function that expects int8_t* and do the conversion
- implicitly?
- . even if these c-primitive-constructor functions exist, you can still
- write things like c-coerce (in lisp, even) and hack in implicit
- conversion attempts when something other than a cvalue is passed.
-. the printing code is annoying, because it's not enough to print readably,
- you have to print evaluably.
- . solution: constructor notation, #int32(hi lo)
-
-in any case, "opaque" cvalues will not really be opaque because we want to
-know their types and be able to take them apart on the byte level from lisp.
-C code can get references to lisp values and manipulate them using lisp
-operations like car, so to be fair it should work vice-versa; give
-c references to lisp code and let it use c operations like * on them.
-you can write lisp in c and c in lisp, though of course you don't usually
-want to. however, c written in lisp can be generated by a macro, printed,
-and fed to TCC for compilation.
-
-
-for a struct the names and types are parameters of the type, not the
-constructor, so it seems more correct to do
-
-((struct (name type) (name type) ...) (val val ...))
-
-where struct returns a constructor. but this isn't practical because it
-can't be printed in constructor notation and the type is a lambda rather
-than a more sensible expression.
-
-
-notice constructor calls and type representations are "similar". they
-should be related formally:
-
-(define (new type)
- (if (symbolp type) (apply (eval type) ())
- (apply (eval (car type)) (cdr type))))
-
-NOTE: this relationship is no longer true. we don't want to have to
-construct 1 cvalue from 1 lisp value every time, since that could
-require allocating a totally redundant list or vector. it should be
-possible to make a cvalue from a series of lisp arguments. for
-example there are now 2 different ways to make an array:
-
-1) from series of arguments: (array type val0 val1 ...)
-2) from 1 (optional) value: (c-value '(array int8[ size])[ V])
-
-constructors will internally use the second form to initialize elements
-of aggregates. e.g. 'array' in the first case will conceptually call
- (c-value type val0)
- (c-value type val1)
- ...
-
-
-for aggregate types, you can keep a variable referring to the relevant
-piece:
-
-(setq point '((x int) (y int)))
-(struct point 2 3) ; looks like c declaration 'struct point x;'
-
-a type is a function, so something similar to typedef is achieved by:
-
-(define (point_t vals) (struct point vals))
-
-design points:
-. type constructors will all be able to take 1 or 0 arguments, so i could say
- (new (typeof val)) ; construct similar
- (define (new type)
- (if (symbolp type) (apply (eval type) ())
- (apply (eval (car type)) (cdr type))))
-. values can be marked as autorelease (1) if user says so, (2) if we can
- prove that it's ok (e.g. we only allocated the value using malloc because
- it is too large to move on every GC).
- in the future you should be able to specify an arbitrary finalization
- function, not just free().
-. when calling a C function, a value of type_t can be passed to something
- expecting a type_t* by taking the address of the representation. BUT
- this is dangerous if the C function might save a reference.
- a type_t* can be passed as a type_t by copying the representation.
-. you can use (pointer v) to switch v to "malloc'd representation", in
- which case the value is no longer autoreleased, but you can do whatever
- you want with the pointer. (other option is to COPY v when making a
- pointer to it, but this still doesn't prevent C from holding a reference
- too long)
-
-
-add a cfunction binding to symbols. you register in C simply by setting
-this binding to a function pointer, then
-
-(defun open (path flags)
- ; could insert type checks here
- (ccall 'int32 'open path flags))
-
-(setq fd (open "path" 0))
-
-using libdl you could even omit the registration step and extra binding
-
-this is possible:
-(defun malloc (size)
- (ccall `(array int8 ,size) 'malloc size))
- ;ret type ;f name ; . args
-
-
-vtable:
-we'd like to be able to define new lisp "types", like vectors
-and hash tables, using this. there needs to be a standard value interface
-you can implement in C and attach a vtable to some c values.
-interface: relocate, finalize, print(, copy)
-
-implementation plan:
-- write cvalue constructors
-- if a head evaluates to a cvalue, call the pointer directly with the arg array
- . this is the "guest function" interface, a C function written specifically
- to the femtolisp API. its type must be
- '(c-function lispvalue ((pointer lispvalue) uint32))
- which corresponds to
- value_t func(value_t *args, u_int32_t nargs);
- . this interface is useful for writing additional builtins, types,
- interpreter extensions, etc. more efficient.
- . one of these functions could also be called with
- (defun func args
- (ccall 'func 'lispvalue (array 'lispvalue args) (length args)))
- - these functions are effectively builtins and should have names so they
- can be printed as such.
- . have a registration function
- void guest_function(value_t (*f)(value_t*,u_int32_t), const char *name);
- so at least the function type can be checked from C
- . set a flags bit for functions registered this way so we can identify
- them quickly
-
-- ccall lisp builtin, (ccall rettype name . args). if name has no cfunc
- binding, looks it up lazily with dlsym and stores the result.
- this is a guest function that handles type checking, translation, and
- invocation of foreign c functions.
-
-- you could register builtins from lisp like this:
- (defun dlopen (name flags) (ccall '(pointer void) 'dlopen name flags))
- (defun dlsym (handle name type) (ccall type 'dlsym handle name))
- (define lisp-process (dlopen nil 0))
- (define vector-sym
- (dlsym lisp-process 'int_vector
- '(function lispvalue (pointer lispvalue) uint32)))
- (ccall 'void 'guest_function vector-sym 'vector)
-
-- write c extensions cref, cset, typeof, sizeof, cvaluep
-* read, print, vectorp methods for vectors
-- quoted string "" reading, produces #(c c c c ...)
-* get rid of primitive builtins read,print,princ,load,exit,
- implement using ccall
-
-
-other possible design:
-- just add two builtins, call and ccall.
- (call 'name arg arg arg) lisp guest function interface
- we can say e.g.
- (defmacro vector args `(call 'vector ,.args))
-- basically the question is whether to introduce a new kind of callable
- object or to do everything through the existing builtin mechanism
- . macros cannot be applied, so without a new kind of callable 'vector'
- would have to be a lisp function, entailing argument consing...
- (defun builtin (name)
- (guest-function name
- (dlsym lisp-process name '(function value (pointer value) uint32))))
- then you can print a guest function as e.g.
- #.(builtin 'vector)
-
-#name(x y z) reads as a tagged vector
-#(x y z) is the same as #vector(x y z)
-should be internally the same as well, so non-taggedness does not formally
-exist.
-
-
-then we can write the vector clause in backquote as e.g.
-
-(if (vectorp x)
- (let ((body (bq-process (vector-to-list x))))
- (if (eq (tag x) 'vector)
- (list 'list-to-vector body)
- (list 'apply 'tagged-vector
- (list cons (list quote (tag x)) body))))
- (list quote x))
-
-
-setup plan:
-* create source directory and svn repository, move llt sources into it
-* write femtolisp.h, definitions for extensions to #include
-- add fl_ prefix to all exported functions
-* port read and print to llt iostreams
-* get rid of flutils; use ptrhash instead
-* builtinp needs to be a builtin ;) to distinguish lisp builtins from cvalues
-* allocation and gc for cvalues
-- interface functions fl_list(...), fl_apply
- e.g. fl_apply(fl_eval(fl_symbol("+")), fl_list(fl_number(2),fl_number(3)))- and fl_symval("+"), fl_cons, etc.-
------------------------------------------------------------------------------
-
-vector todo:
-* compare for vectors
-- (aref v i j k) does (reduce aref v '(i j k)); therefore (aref v) => v
-- (aref v ... [1 2 3] ...) vectorized indexing
-- make (setf (aref v i j k) x) expand to (aset (aref v i j) k x)
-these should be done using the ccall interface:
-- concatenate
-- copy-vec
-- (range i j step) to make integer ranges
-- (rref v start stop), plus make it settable! (rset v start stop rhs)
-lower priority:
-- find (strstr)
-
-functions to be generic over vec/list:
-* compare, equal, length
-
-constructor notation:
-
-#func(a b c) does (apply func '(a b c))
-
------------------------------------------------------------------------------
-
-how we will allocate cvalues
-
-a vector's size will be a lisp-value number. we will set bit 0x2 to indicate
-a resize request, and bit 0x1 to indicate that it's actually a cvalue.
-
-every cvalue will have the following fields, followed by some number of
-words according to how much space is needed:
-
- value_t size; // | 0x2
- cvtable_t *vtable;
- struct {-#ifdef BITS64
- unsigned pad:32;
-#endif
- unsigned whatever:27;
- unsigned mark:1;
- unsigned hasparent:1;
- unsigned islispfunction:1;
- unsigned autorelease:1;
- unsigned inlined:1;
- } flags;
- value_t type;
- size_t len; // length of *data in bytes
- //void *data; // present if !inlined
- //value_t parent; // present if hasparent
-
-size/vtable have the same meaning as vector size/elt[0] for relocation
-obviously we only relocate parent and type. if vtable->relocate is present,
-we call it at the end of the relocate process, and it must touch every
-lisp value reachable from it.
-
-when a cvalue is created with a finalizer, its address is added to a special
-list. before GC, everything in that list has its mark bit set. when
-we relocate a cvalue, clear the bit. then go through the list to call
-finalizers on dead values. this is O(n+m) where n is amt of live data and m
-is # of values needing finalization. we expect m << heapsize.
-
------------------------------------------------------------------------------
-
-Goal: bootstrap a lisp system where we can do "anything" purely in lisp
-starting with the minimal builtins needed for successive levels of
-completeness:
-
-1. Turing completeness
-quote, if, lambda, eq, atom, cons, car, cdr
-
-2. Naming
-set
-
-3. Control flow
-progn, prog1, apply, eval
-call/cc needed for true completeness, but we'll have attempt, raise
-
-4. Predicate completeness
-symbolp, numberp, builtinp
-
-5. Syntax
-macro
-
-6. I/O completeness
-read, print
-
-7. Mutable state
-rplaca, rplacd
-
-8. Arithmetic completeness
-+, -, *, /, <
-
-9. The missing data structure(s): vector
-alloc, aref, aset, vectorp, length
-
-10. Real-world completeness (escape hatch)
-ccall
-
----
-11. Misc unnecessary
-while, label, cond, and, or, not, boundp, vector
-
------------------------------------------------------------------------------
-
-exception todo:
-
-* silence 'in file' errors when user frame active
-* add more useful data to builtin exception types:
- (UnboundError x)
- (BoundsError vec index)
- (TypeError fname expected got)
- (Error v1 v2 v3 ...)
-* attempt/raise, rewrite (error) in lisp
-* more intelligent exception printers in toplevel handler
-
------------------------------------------------------------------------------
-
-lisp variant ideas
-
-- get rid of separate predicates and give every value the same structure
- ala mathematica
- . (tag 'a) => symbol
- (tag '(a b)) => a
- (tag 'symbol 'a) => a
- (tag 'blah 3) => (blah 3)
-- have only vectors, not cons cells (sort of like julia)
- . could have a separate tag field as above
-
-- easiest way to add vectors:
- . allocate in same heap with conses, have a tag, size, then elements
- (each elt must be touched on GC for relocation anyway, so might as well
- copy collect it)
- . tag pointers as builtins, we identify them as builtins with big values
- . write (vector) in C, use it from read and eval
-
-8889314663 comcast net #
-
------------------------------------------------------------------------------
-
-cvalues reserves the following global symbols:
-
-int8, uint8, int16, uint16, int32, uint32, int64, uint64
-char, uchar, wchar, short, ushort, int, uint, long, ulong
-float, double
-struct, array, enum, union, function, void, pointer, lispvalue
-
-it defines (but doesn't reserve) the following:
-
-typeof, sizeof, autorelease, guestfunction, ccall
-
-
-user-defined types and typedefs:
-
-the rule is that a type should be viewed as a self-evaluating constant
-like a number. if i define a complex_t type of two doubles, then
-'complex_t is not a type any more than the symbol 'x could be added to
-something just because it happened to have the value 2.
-
-; typedefs from lisp
-(define wchar_t 'uint32)
-(define complex_t '(struct ((re double) (im double))))
-
-; use them
-(new complex_t)
-(new `(array ,complex_t 10))
-(array complex_t 10)
-
-BUT
-
-(array 'int32 10)
-
-because the primitive types *are* symbols. the fact that they have values is
-just a convenient coincidence that lets you do e.g. (int32 0)
-
-
-; size-annotate a pointer
-(setq p (ccall #c-function((pointer void) (ulong) malloc) n)
-(setq a (deref p `(array int8 ,n)))
-
-cvalues todo:
-
-* use uint32_t instead of wchar_t in C code
-- make sure empty arrays and 0-byte types really work
-* allow int constructors to accept other int cvalues
-* array constructor should accept any cvalue of the right size
-* make sure cvalues participate well in circular printing
-* float, double
-- struct, union (may want to start with more general layout type)
-- pointer type, function type
-* finalizers
-- functions autorelease, guestfunction
-- cref/cset/byteref/byteset
-* wchar type, wide character strings as (array wchar)
-* printing and reading strings
-- ccall
-- anonymous unions
-* fix princ for cvalues
-* make header size for primitives <= 8 bytes, even on 64-bit arch
-- more efficient read for #array(), so it doesn't need to build a pairlist
-? lispvalue type
- . keep track of whether a cvalue leads to any lispvalues, so they can
- be automatically relocated (?)
-
-* string constructor/concatenator:
-(string 'sym #char(65) #wchar(945) "blah" 23)
- ; gives "symA\u03B1blah23"
-"ccc" reads to (array char)
-
-low-level functions:
-; these are type/bounds-checked accesses
-- (cref cvalue key) ; key is field name or index. access by reference.
-- (aref cvalue key) ; access by value, returns fixnums where possible
-- (cset cvalue key value) ; key is field name, index, or struct offset
- . write&use conv_from_long to put fixnums into typed locations
- . aset is the same
-* (copy cv)
-- (offset type|cvalue field [field ...])
-- (eltype type field [field ...])
-- (memcpy dest-cv src-cv)
-- (memcpy dest doffs src soffs nbytes)
-- (bswap cvalue)
-- (c2lisp cvalue) ; convert to sexpr form
-* (typeof cvalue)
-* (sizeof cvalue|type)
-- (autorelease cvalue) ; mark cvalue as free-on-gc
-- (deref pointer[, type]) ; convert an arbitrary pointer to a cvalue
- ; this is the unsafe operation
-
-; (sizeof '(pointer type)) == sizeof(void*)
-; (sizeof '(array type N)) == N * sizeof(type)
-
-(define (reinterpret-cast cv type)
- (if (= (sizeof cv) (sizeof type))
- (deref (pointer 'void cv) type)
- (error "Invalid cast")))
-
-a[n].x looks like (cref (cref a n) 'x), (reduce cref head subs)
-
-things you can do with cvalues:
-
-. call native C functions from lisp code without wrappers
-. wrap C functions in pure lisp, automatically inheriting some degree
- of type safety
-. use lisp functions as callbacks from C code
-. use the lisp garbage collector to reclaim malloc'd storage
-. annotate C pointers with size information for bounds checking
-. attach symbolic type information to a C data structure, allowing it to
- inherit lisp services such as printing a readable representation
-. add datatypes like strings to lisp
-. use more efficient represenations for your lisp programs' data
-
-
-family of cvalue representations.
-relevant attributes:
- . large -- needs full size_t to represent size
- . inline -- allocated along with metadata
- . prim -- no stored type; uses primtype bits in flags
- . hasdeps -- depends on other values to stay alive
-
-these attributes have the following dependencies:
- . large -> !inline
- . prim -> !hasdeps && !large
-
-so we have the following possibilities:
-
-large inline prim hasdeps rep#
- 0 0 0 0 0
- 0 0 0 1 1
-
- 0 0 1 0 2
- 0 1 0 0 3
- 0 1 0 1 4
- 0 1 1 0 5
-
- 1 0 0 0 6
- 1 0 0 1 7
-
-we need to be able to un-inline data, so we need:
-change 3 -> 0 (easy; write pointer over data)
-change 4 -> 1
-change 5 -> 2 (also easy)
-
-
-rep#0&1: (!large && !inline && !prim)
-typedef struct {- cvflags_t flags;
- value_t type;
- value_t deps;
- void *data; /* points to malloc'd buffer */
-} cvalue_t;
-
-rep#3&4: (!large && inline && !prim)
-typedef struct {- cvflags_t flags;
- value_t type;
- value_t deps;
- /* data goes here inlined */
-} cvalue_t;
-
-
-rep#2: (prim && !inline)
-typedef struct {- cvflags_t flags;
- void *data; /* points to (tiny!) malloc'd buffer */
-} cvalue_t;
-
-rep#5: (prim && inline)
-typedef struct {- cvflags_t flags;
- /* data goes here inlined */
-} cvalue_t;
-
-
-rep#6&7: (large)
-typedef struct {- cvflags_t flags;
- value_t type;
- value_t deps;
- void *data; /* points to malloc'd buffer */
- size_t len;
-} cvalue_t;
-
------------------------------------------------------------------------------
-
-times for lispv:
-
-color 2.286s
-sort 0.181s
-fib34 5.205s
-mexpa 0.329s
-
------------------------------------------------------------------------------
-
-finalization algorithm that allows finalizers written in lisp:
-
-right after GC, go through finalization list (a weak list) and find objects
-that didn't move. relocate them (bring them back to life) and push them
-all onto the stack. remove all from finalization list.
-
-call finalizer for each value.
-
-optional: after calling a finalizer, make sure the object didn't get put
-back on the finalization list, remove if it did.
-if you don't do this, you can make an unkillable object by registering a
-finalizer that re-registers itself. this could be considered a feature though.
-
-pop dead values off stack.
-
-
------------------------------------------------------------------------------
-
-femtolisp semantics
-
-eval* is an internal procedure of 2 arguments, expr and env, invoked
-implicitly on input.
-The user-visible procedure eval performs eval* e Env ()
-
-eval* Symbol s E => lookup* s E
-eval* Atom a E => a
-... special forms ... quote arg, if a b c, other symbols from syntax env.
-eval* Cons f args E =>
-
-First the head expression, f, is evaluated, yielding f-.
-Then control is passed to #.apply f- args
- #.apply is the user-visible apply procedure.
- (here we imagine there is a user-invisible environment where f- is
- bound to the value of the car and args is bound to the cdr of the input)
-
-
-Now (apply b lst) where b is a procedure (i.e. satisfies functionp) is
-identical to
-(eval (map (lambda (e) `',e) (cons b lst)))
-
------------------------------------------------------------------------------
-
-design of new toplevel
-
-system.lsp contains definitions of (load) and (toplevel) and is loaded
-from *install-dir* by a bootstrap loader in C. at the end of system.lsp,
-we check whether (load) is builtin. if it is, we redefine it and reload
-system.lsp with the new loader. the C code then invokes (toplevel).
-
-(toplevel) either runs a script or a repl using (while T (trycatch ...))
-
-(load) reads and evaluates every form, keeping track of defined functions
-and macros (at the top level), and grabs a (main ...) form if it sees
-one. it applies optimizations to every definition, then invokes main.
-
-an error E during load should rethrow `(load-error ,filename ,E)
-such exceptions can be printed recursively
-
-lerror() should make a lisp string S from the result of sprintf, then
-raise `(,e ,S). first argument e should be a symbol.
-
-
-new expansion process:
-
-get rid of macroexpanding versions of define and define-macro
-macroexpand doesn't expand (define ...)
- macroexpand implements let-syntax
-add lambda-expand which applies f-body to the bodies of lambdas, then
- converts defines to set!
-call expand on every form before evaluating
- (define (expand x) (lambda-expand (macroexpand x)))
-(define (eval x) (%eval (expand x)))
-reload system.lsp with the new eval
-
------------------------------------------------------------------------------
-
-String API
-
-*string - append/construct
-*string.inc - (string.inc s i [nchars])
-*string.dec
-*string.count - # of chars between 2 byte offsets
-*string.char - char at byte offset
-*string.sub - substring between 2 byte offsets
-*string.split - (string.split s sep-chars)
-*string.trim - (string.trim s chars-at-start chars-at-end)
-*string.reverse
-*string.find - (string.find s str|char [offs]), or nil if not found
- string.rfind
-*string.encode - to utf8
-*string.decode - from utf8 to UCS
-*string.width - # columns
-*string.map - (string.map f s)
-
-
-IOStream API
-
-*read - (read[ stream]) ; get next sexpr from stream
-*princ
-*file
- iostream - (stream[ cvalue-as-bytestream])
-*buffer
- fifo
- socket
-*io.eof?
-*io.flush
-*io.close
-*io.discardbuffer
-*io.write - (io.write s cvalue [start [count]])
-*io.read - (io.read s ctype [len])
-*io.getc - get utf8 character
-*io.putc
- io.peekc
-*io.readline
-*io.readuntil
-*io.copy - (io.copy to from [nbytes])
-*io.copyuntil - (io.copy to from byte)
- io.pos - (io.pos s [set-pos])
- io.seek - (io.seek s offset)
- io.seekend - move to end of stream
- io.trunc
- io.read! - destructively take data
-*io.tostring!
-*io.readlines
-*io.readall
-*print-to-string
-*princ-to-string
-
-
-*path.exists?
- path.dir?
- path.combine
- path.parts
- path.absolute
- path.simplify
- path.tempdir
- path.tempname
- path.homedir
-*path.cwd
-
-
-*time.now
- time.parts
- time.fromparts
-*time.string
-*time.fromstring
-
-
-*os.name
-*os.getenv
-*os.setenv
- os.execv
-
-
-*rand
-*randn
-*rand.uint32
-*rand.uint64
-*rand.double
-*rand.float
-
------------------------------------------------------------------------------
-
- * new print algorithm
- 1. traverse & tag all conses to be printed. when you encounter a cons
- that is already tagged, add it to a table to give it a #n# index
- 2. untag a cons when printing it. if cons is in the table, print
- "#n=" before it in the car, " . #n=" in the cdr. if cons is in the
- table but already untagged, print #n# in car or " . #n#" in the cdr.
- * read macros for #n# and #n= using the same kind of table
- * also need a table of read labels to translate from input indexes to
- normalized indexes (0 for first label, 1 for next, etc.)
- * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq"
-
------------------------------------------------------------------------------
-
-prettyprint notes
-
-* if head of list causes VPOS to increase and HPOS is a bit large, then
-switch to miser mode, otherwise default is ok, for example:
-
-> '((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y))
-((lambda (x y)
- (if (< x y) x y)) (a b c)
- (d e f) 2 3
- (r t y))
-
-* (if a b c) should always put newlines before b and c
-
-* write try_predict_len that gives a length for easy cases like
- symbols, else -1. use it to avoid wrapping symbols around lines
-
-* print defun, defmacro, label, for more like lambda (2 spaces)
-
-* *print-pretty* to control it
-
-* if indent gets too large, dedent back to left edge
-
------------------------------------------------------------------------------
-
-consolidated todo list as of 7/8:
-* new cvalues, types representation
-* use the unused tag for TAG_PRIM, add smaller prim representation
-* finalizers in gc
-* hashtable
-* generic aref/aset
-* expose io stream object
-* new toplevel
-
-* make raising a memory error non-consing
-* eliminate string copy in lerror() when possible
-* fix printing lists of short strings
-
-* evaluator improvements, perf & debugging (below)
-* fix make-system-image to save aliases of builtins
-* reading named characters, e.g. #\newline etc.
-- #+, #- reader macros
-- printing improvements: *print-length*, keep track of horiz. position
- per-stream so indenting works across print calls
-- remaining c types
-- remaining cvalues functions
-- finish ios
-* optional arguments
-* keyword arguments
-- some kind of record, struct, or object system
-- improve test coverage
-
-expansion process bugs:
-* expand default expressions for opt/keyword args (as if lexically in body)
-* make bound identifiers (lambda and toplevel) shadow macro keywords
-* to expand a body:
- 1. splice begins
- 2. add defined vars to env
- 3. expand nondefinitions in the new env
- . if one expands to a definition, add the var to the env
- 4. expand RHSes of definitions
-- add different spellings for builtin versions of core forms, like
- $begin, $define, and $set!. they can be replaced when found during expansion,
- and used when the compiler needs to generate them with known meanings.
-
-- special efficient reader for #array
-- reimplement vectors as (array lispvalue)
-- implement fast subvectors and subarrays
-
------------------------------------------------------------------------------
-
-cvalues redesign
-
-goals:
-. allow custom types with vtables
-. use less space, share types more
-. simplify access to important metadata like length
-. unify vectors and arrays
-
-typedef struct {- fltype_t *type;
- void *data;
- size_t len; // length of *data in bytes
- union {- value_t parent; // optional
- char _space[1]; // variable size
- };
-} cvalue_t;
-
-#define owned(cv) ((cv)->type & 0x1)
-#define hasparent(cv) ((cv)->type & 0x2)
-#define isinlined(cv) ((cv)->data == &(cv)->_space[0])
-#define cv_class(cv) ((fltype_t*)(((uptrint_t)(cv)->type)&~3))
-#define cv_type(cv) (cv_class(cv)->type)
-#define cv_len(cv) ((cv)->len)
-#define cv_data(cv) ((cv)->data)
-#define cv_numtype(cv) (cv_class(cv)->numtype)
-
-typedef struct _fltype_t {- value_t type;
- int numtype;
- size_t sz;
- size_t elsz;
- cvtable_t *vtable;
- struct _fltype_t *eltype; // for arrays
- struct _fltype_t *artype; // (array this)
- int marked;
-} fltype_t;
-
------------------------------------------------------------------------------
-
-new evaluator todo:
-
-* need builtin = to handle nans properly, fix equal? on nans
-* builtin quasi-opaque function type
- fields: signature, maxstack, bcode, vals, cloenv
- function->vector
-* make (for ...) a special form
-* trycatch should require 2nd arg to be a lambda expression
-* immediate load int8 instruction
-* unlimited lambda lists
- . need 32-bit argument versions of loada, seta, loadc, setc
- . largs instruction to move args after MAX_ARGS from list to stack
-* maxstack calculation, make Stack growable
- * stack traces and better debugging support
-* improve internal define
-* try removing MAX_ARGS trickery
-? apply optimization, avoid redundant list copying calling vararg fns
-- let eversion
-- variable analysis - avoid holding references to values in frames
- captured by closures but not used inside them
-* lambda lifting
-* let optimization
-* fix equal? on functions
-* store function name
-* have macroexpand use its own global syntax table
-* be able to create/load an image file
-* fix trace and untrace
-* opcodes LOADA0, LOADA1, LOADC00, LOADC01
-- opcodes CAAR, CADR, CDAR, CDDR
-- EQTO N, compare directly to stored datum N
-- peephole opt
- done:
- not brf => brt
- eq brf => brne
- null brf => brnn
- null brt => brn
- null not brf => brn
- cdr car => cadr
-
- not yet:
- not brt => brf
- constant+pop => nothing, e.g. 2-arg 'if' in statement position
- loadt+brf => nothing
- loadf+brt => nothing
- loadt+brt => jmp
- loadf+brf => jmp
-
------------------------------------------------------------------------------
-
-new stack organization:
-
-func
-arg1
-...
-argn
-cloenv |
-prev |
-nargs |
-ip |
-captured |
-
-to call:
-push func and arguments
-args[nargs+3] = ip // save my state in my frame
-assign nargs
-goto top
-
-on entry:
-push cloenv
-push curr_frame (a global initialized to 0)
-push nargs
-SP += 1
-curr_frame = SP
-
-to return:
-v = POP();
-SP = curr_frame
-curr_frame = Stack[SP-4]
-if (args == top_args) return v;
-SP -= (5+nargs);
-move Stack[curr_frame-...] back into locals
-Stack[SP-1] = v
-goto next_op
-
-to relocate stack:
-for each segment {- curr_top = SP
- f = curr_frame
- while (1) {- for i=f, i<curr_top, i++
- relocate stack[i]
- if (f == 0) break;
- curr_top = f - 4
- f = stack[f - 4]
- }
-}
-
-typedef struct {- value_t *Stack;
- uint32_t size;
- uint32_t SP;
- uint32_t curr_frame;
-} stackseg_t;
-
------------------------------------------------------------------------------
-
-optional and keyword args:
-
-check nargs >= #required
-grow frame by ntotal-nargs ; ntotal = #req+#opt+#kw
-(sort keyword args into their places)
-branch if arg bound around initializer for each opt arg
-
-example: (lambda (a (b 0) (c b)))
-
-minargs 1
-framesize 3
-brbound 1 L1
-load0
-seta 0
-L1:
-brbound 2 L2
-loada 1
-seta 2
-L2:
-
------------------------------------------------------------------------------
-
-what needs more test coverage:
-
-- more error cases, lerrorf() cases
-- printing gensyms
-- gensyms with bindings
-- listn(), isnumber(), list*, boolean?, function?, add2+ovf, >2arg add,div
-- large functions, requiring long versions of branch opcodes
-- setal, loadvl, (long arglist and lots of vals cases)
-- aref/aset on c array
-- printing everything
-- reading floats, escaped symbols, multiline comment, octal chars in strs
-- equal? on functions
-- all cvalue ctors, string_from_cstrn()
-- typeof, copy, podp, builtin()
-- bitwise and logical ops
-- making a closure in a default value expression for an optional arg
-- gc during a catch block, then get stack trace
-
------------------------------------------------------------------------------
-
-5/4/10 todo:
-
-- flush and close open files on exit
-* make function versions of opcode builtins by wrapping in a lambda,
- stored in a table indexed by opcode. use in _applyn
--- a/femtolisp/todo-scrap
+++ /dev/null
@@ -1,41 +1,0 @@
-- readable gensyms. have uninterned symbols, but have all same-named
- gensyms read to the same (eq) symbol within an expression.
-- fat pointers, i.e. 64 bits on 32-bit platforms. we could have full 32-bit
- integers too. the mind boggles at the possibilities.
- (it would be great if everybody decided that pointer types should forever
- be wider than address spaces, with some bits reserved for application use)
-- any way at all to provide O(1) computed lookups (i.e. indexing).
- CL uses vectors for this. once you have it, it's sufficient to get
- efficient hash tables and everything else.
- - could be done just by generalizing cons cells to have more than
- car, cdr: c2r, c3r, etc. maybe (1 . 2 . 3 . 4 . ...)
- all you need is a tag+size on the front of the object so the collector
- knows how to deal with it.
- (car x) == (ref x 0), etc.
- (rplaca x v) == (rplac x 0 v), etc.
- (size (cons 1 2)) == 2, etc.
- - one possibility: if we see a cons whose CAR is tagptr(0x10,TAG_SYM),
- then the CDR is the size and the following words are the elements.
- . this approach is especially good if vectors are separate types from
- conses
- - another: add u_int32_t size to cons_t, making them all 50% bigger.
- access is simpler and more uniform, without fully doubling the size like
- we'd get with fat pointers.
-
-Notice that the size is one byte more than the number of characters in
-the string. This is because femtoLisp adds a NUL terminator to make its
-strings compatible with C. No effort is made to hide this fact.
-But since femtoLisp tracks the sizes of cvalues, it doesn't need the
-terminator itself. Therefore it treats zero bytes specially as rarely
-as possible. In particular, zeros are only special in values whose type
-is exactly <tt>(array char)</tt>, and are only interpreted in the
-following cases:
-<ul>
-<li>When printing strings, a final NUL is never printed. NULs in the
-middle of a string are printed though.
-<li>String constructors NUL-terminate their output.
-<li>Explicit string functions (like <tt>strlen</tt>) treat NULs the same
-way equivalent C functions would.
-</ul>
-Arrays of uchar, int8, etc. are treated as raw data and zero bytes are
-never special.
--- a/femtolisp/types.c
+++ /dev/null
@@ -1,99 +1,0 @@
-#include "equalhash.h"
-
-fltype_t *get_type(value_t t)
-{- fltype_t *ft;
- if (issymbol(t)) {- ft = ((symbol_t*)ptr(t))->type;
- if (ft != NULL)
- return ft;
- }
- void **bp = equalhash_bp(&TypeTable, (void*)t);
- if (*bp != HT_NOTFOUND)
- return *bp;
-
- int align, isarray=(iscons(t) && car_(t) == arraysym && iscons(cdr_(t)));
- size_t sz;
- if (isarray && !iscons(cdr_(cdr_(t)))) {- // special case: incomplete array type
- sz = 0;
- }
- else {- sz = ctype_sizeof(t, &align);
- }
-
- ft = (fltype_t*)malloc(sizeof(fltype_t));
- ft->type = t;
- if (issymbol(t)) {- ft->numtype = sym_to_numtype(t);
- ((symbol_t*)ptr(t))->type = ft;
- }
- else {- ft->numtype = N_NUMTYPES;
- }
- ft->size = sz;
- ft->vtable = NULL;
- ft->artype = NULL;
- ft->marked = 1;
- ft->elsz = 0;
- ft->eltype = NULL;
- ft->init = NULL;
- if (iscons(t)) {- if (isarray) {- fltype_t *eltype = get_type(car_(cdr_(t)));
- if (eltype->size == 0) {- free(ft);
- lerror(ArgError, "invalid array element type");
- }
- ft->elsz = eltype->size;
- ft->eltype = eltype;
- ft->init = &cvalue_array_init;
- eltype->artype = ft;
- }
- else if (car_(t) == enumsym) {- ft->numtype = T_INT32;
- ft->init = &cvalue_enum_init;
- }
- }
- *bp = ft;
- return ft;
-}
-
-fltype_t *get_array_type(value_t eltype)
-{- fltype_t *et = get_type(eltype);
- if (et->artype != NULL)
- return et->artype;
- return get_type(fl_list2(arraysym, eltype));
-}
-
-fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab,
- cvinitfunc_t init)
-{- fltype_t *ft = (fltype_t*)malloc(sizeof(fltype_t));
- ft->type = sym;
- ft->size = sz;
- ft->numtype = N_NUMTYPES;
- ft->vtable = vtab;
- ft->artype = NULL;
- ft->eltype = NULL;
- ft->elsz = 0;
- ft->marked = 1;
- ft->init = init;
- return ft;
-}
-
-void relocate_typetable()
-{- htable_t *h = &TypeTable;
- size_t i;
- void *nv;
- for(i=0; i < h->size; i+=2) {- if (h->table[i] != HT_NOTFOUND) {- nv = (void*)relocate((value_t)h->table[i]);
- h->table[i] = nv;
- if (h->table[i+1] != HT_NOTFOUND)
- ((fltype_t*)h->table[i+1])->type = (value_t)nv;
- }
- }
-}
--- /dev/null
+++ b/flisp.boot
@@ -1,0 +1,431 @@
+(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n"
+ *builtins* [0 0 0 0 0 0 0 0 0 0 0 0 #fn("7000r2|}<;" [])+ #fn("7000r2|}=;" [])+ #fn("7000r2|}>;" [])+ #fn("6000r1|?;" [])+ #fn("6000r1|@;" [])+ #fn("6000r1|A;" [])+ #fn("6000r1|B;" [])+ #fn("6000r1|C;" [])+ #fn("6000r1|D;" [])+ #fn("6000r1|E;" [])+ #fn("6000r1|F;" [])+ #fn("6000r1|G;" [])+ #fn("6000r1|H;" [])+ #fn("6000r1|I;" [])+ #fn("6000r1|J;" [])+ #fn("7000r2|}K;" [])+ #fn("9000s0c0|v2;" [#.list])+ #fn("6000r1|M;" [])+ #fn("6000r1|N;" [])+ #fn("7000r2|}O;" [])+ #fn("7000r2|}P;" [])+ #fn("9000s0c0|v2;" [#.apply])+ #fn("9000s0c0|v2;" [#.+])+ #fn("9000s0c0|v2;" [#.-])+ #fn("9000s0c0|v2;" [#.*])+ #fn("9000s0c0|v2;" [#./])+ #fn("9000s0c0|v2;" [#.div0])+ #fn("7000r2|}W;" [])+ #fn("7000r2|}X;" [])+ #fn("7000r2|}Y;" [])+ #fn("9000s0c0|v2;" [#.vector])+ #fn("7000r2|}[;" [])+ #fn("8000r3|}g2\\;" [])]+ *interactive* #f *syntax-environment*
+ #table(with-bindings #fn(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#fn("B000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6e0c7L1e4\x7f3132e0c7L1e4e2c8|g2333132L3L144;" [nconc+ let map #.list copy-list #fn("8000r2c0|}L3;" [set!]) unwind-protect begin #fn("8000r2c0|}L3;" [set!])])+ map #.car cadr #fn("6000r1e040;" [gensym])]) letrec #fn("?000s1e0e0c1L1e2c3|32L1e2c4|32e5}3134L1e2c6|3242;" [nconc+ lambda map #.car #fn("9000r1e0c1L1e2|3142;" [nconc set! copy-list]) copy-list+ #fn("6000r1e040;" [void])]) assert #fn("<000r1c0|]c1c2c3|L2L2L2L4;" [if+ raise quote assert-failed]) do #fn("A000s2c0qe130}Me2c3|32e2e4|32e2c5|3245;" [#fn("B000r5c0|c1g2c2}e3c4L1e5\x7fN3132e3c4L1e5i0231e3|L1g432L133L4L3L2L1e3|L1g332L3;" [letrec+ lambda if nconc begin copy-list]) gensym map #.car cadr #fn("7000r1e0|31F680e1|41;|M;" [cddr+ caddr])]) quasiquote #fn("8000r1e0|`42;" [bq-process]) when #fn("<000s1c0|c1}K^L4;" [if+ begin]) with-input-from #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc+ with-bindings
+ *input-stream*
+ copy-list]) unwind-protect #fn("8000r2c0qe130e13042;" [#fn("@000r2c0}c1_\x7fL3L2L1c2c3~c1|L1c4}L1c5|L2L3L3L3}L1L3L3;" [let+ lambda prog1 trycatch begin raise]) gensym]) dotimes #fn(";000s1c0q|M|\x8442;" [#fn("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for+ - nconc lambda copy-list])]) define-macro #fn("?000s1c0c1|ML2e2c3L1|NL1e4}3133L3;" [set-syntax!+ quote nconc lambda copy-list]) receive #fn("@000s2c0c1_}L3e2c1L1|L1e3g23133L3;" [call-with-values+ lambda nconc copy-list]) unless #fn("=000s1c0|^c1}KL4;" [if begin]) let #fn(":000s1c0q^41;" [#fn("<000r1~C6D0~m02\x7fMo002\x7fNo01530]2c0qe1c2L1e3c4~32L1e5\x7f3133e3c6~3242;" [#fn("8000r2~6@0c0~|L2L1~L3530|}K;" [letrec])+ nconc lambda map #fn("6000r1|F650|M;|;" []) copy-list #fn("6000r1|F650|\x84;e040;" [void])])]) cond #fn("9000s0c0q]41;" [#fn("7000r1c0qm02|~41;" [#fn("7000r1|?640^;c0q|M41;" [#fn(":000r1|Mc0<17702|M]<6@0|N\x8550|M;c1|NK;|N\x85@0c2|Mi10~N31L3;|\x84c3\x82W0e4e5|31316A0c6qe7e5|313141;c8qe93041;c:|Mc1|NKi10~N31L4;" [else+ begin or => 1arg-lambda? caddr #fn("=000r1c0|~ML2L1c1|c2e3e4~3131Ki20i10N31L4L3;" [let+ if begin cddr caddr]) caadr #fn("<000r1c0|~ML2L1c1|e2~31|L2i20i10N31L4L3;" [let+ if caddr]) gensym if])] cond-clauses->if)])]) throw #fn(":000r2c0c1c2c3L2|}L4L2;" [raise+ list quote thrown-value]) time #fn("7000r1c0qe13041;" [#fn(">000r1c0|c1L1L2L1c2~c3c4c5c1L1|L3c6L4L3L3;" [let+ time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #fn("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc+ lambda copy-list caar let* cadar]) case #fn(":000s1c0q]41;" [#fn("7000r1c0m02c1qe23041;" [#fn("9000r2}c0\x8250c0;}\x8540^;}C6=0c1|e2}31L3;}?6=0c3|e2}31L3;}N\x85>0c3|e2}M31L3;e4c5}326=0c6|c7}L2L3;c8|c7}L2L3;" [else+ eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond)
+ #fn("<000r1c0|i10L2L1e1c2L1e3c4qi113232L3;" [let nconc cond map #fn("8000r1i10~|M32|NK;" [])])+ gensym])]) with-output-to #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc+ with-bindings
+ *output-stream*
+ copy-list]) catch #fn("7000r2c0qe13041;" [#fn("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch+ lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym]))
+ *whitespace* "\t\n\v\f\r \u0085 \u2028\u2029 " 1+
+ #fn("7000r1|aw;" [] 1+) 1- #fn("7000r1|ax;" [] 1-) 1arg-lambda?+ #fn("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda+ length=] 1arg-lambda?)
+ <= #fn("7000r2|}X17602|}W;" [] <=) >+ #fn("7000r2}|X;" [] >) >= #fn("7000r2}|X17602|}W;" [] >=)+ Instructions #table(not 16 vargc 67 load1 49 = 39 setc.l 64 sub2 72 brne.l 83 largc 74 brnn 85 loadc.l 58 loadi8 50 < 40 nop 0 set-cdr! 32 loada 55 bound? 21 / 37 neg 73 brn.l 88 lvargc 75 brt 7 trycatch 68 null? 17 load0 48 jmp.l 8 loadv 51 seta 61 keyargs 91 * 36 function? 26 builtin? 23 aref 43 optargs 89 vector? 24 loadt 45 brf 6 symbol? 19 cdr 30 for 69 loadc00 78 pop 2 pair? 22 cadr 84 closure 65 loadf 46 compare 41 loadv.l 52 setg.l 60 brn 87 eqv? 13 aset! 44 eq? 12 atom? 15 boolean? 18 brt.l 10 tapply 70 dummy_nil 94 loada0 76 brbound 90 list 28 dup 1 apply 33 loadc 57 loadc01 79 dummy_t 92 setg 59 loada1 77 tcall.l 81 jmp 5 fixnum? 25 cons 27 loadg.l 54 tcall 4 call 3 - 35 brf.l 9 + 34 dummy_f 93 add2 71 seta.l 62 loadnil 47 brnn.l 86 setc 63 set-car! 31 vector 42 loadg 53 loada.l 56 argc 66 div0 38 ret 11 number? 20 equal? 14 car 29 call.l 80 brne 82)
+ __init_globals #fn("7000r0e0c1<17B02e0c2<17802e0c3<6>0c4k52c6k75;0c8k52c9k72e:k;2e<k=2e>k?;" [*os-name*+ win32 win64 windows "\\" *directory-separator* "\r\n" *linefeed* "/" "\n"
+ *stdout* *output-stream* *stdin* *input-stream* *stderr* *error-stream*] __init_globals)
+ __script #fn("7000r1c0qc1t;" [#fn("7000r0e0~41;" [load])+ #fn("7000r1e0|312e1a41;" [top-level-exception-handler+ exit])] __script)
+ __start #fn("8000r1e0302|NF6D0|Nk12^k22e3|\x84315E0|k12]k22e4e5312e6302e7`41;" [__init_globals+ *argv* *interactive* __script princ *banner* repl exit] __start)
+ abs #fn("7000r1|`X650|y;|;" [] abs) any+ #fn("8000r2}F16D02|}M3117:02e0|}N42;" [any] any) arg-counts #table(#.not 1 #.atom? 1 #.number? 1 #.cons 2 #.set-cdr! 2 #.equal? 2 #.fixnum? 1 #.bound? 1 #.eq? 2 #.symbol? 1 #.builtin? 1 #.< 2 #.aset! 3 #.div0 2 #.cdr 1 #.null? 1 #.eqv? 2 #.compare 2 #.aref 2 #.car 1 #.set-car! 2 #.pair? 1 #.= 2 #.vector? 1 #.boolean? 1)+ argc-error #fn("<000r2e0c1|c2}}aW670c3540c445;" [error "compile error: "+ " expects " " argument."
+ " arguments."] argc-error)
+ array? #fn("8000r1|H17<02c0e1|3141;" [#fn("7000r1|F16802|Mc0<;" [array])+ typeof] array?)
+ assoc #fn("8000r2}?640^;e0}31|>650}M;e1|}N42;" [caar assoc] assoc)+ assv #fn("8000r2}?640^;e0}31|=650}M;e1|}N42;" [caar assv] assv)+ bcode:cdepth #fn(":000r2|b3e0|b3[}32\\;" [min] bcode:cdepth)+ bcode:code #fn("7000r1|`[;" [] bcode:code) bcode:ctable+ #fn("7000r1|a[;" [] bcode:ctable) bcode:indexfor #fn("9000r2c0qe1|31e2|3142;" [#fn(":000r2e0|\x7f32690e1|\x7f42;e2|\x7f}332}~b2}aw\\2;" [has?+ get put!]) bcode:ctable bcode:nconst] bcode:indexfor)
+ bcode:nconst #fn("7000r1|b2[;" [] bcode:nconst) bq-bracket+ #fn("<000r2|?6=0c0e1|}32L2;|Mc2\x82R0}`W680c0|NK;c0c3c4e1|N}ax32L3L2;|Mc5\x82S0}`W690c6|\x84L2;c0c0c7e1|\x84}ax32L3L2;|Mc8\x82O0}`W650|\x84;c0c0c9e1|\x84}ax32L3L2;c0e1|}32L2;" [#.list+ bq-process unquote #.cons 'unquote unquote-splicing copy-list 'unquote-splicing
+ unquote-nsplicing 'unquote-nsplicing] bq-bracket)
+ bq-bracket1 #fn(";000r2|F16802|Mc0<6K0}`W650|\x84;c1c2e3|N}ax32L3;e3|}42;" [unquote+ #.cons 'unquote bq-process] bq-bracket1)
+ bq-process #fn(";000r2|C680c0|L2;|H6A0c1e2e3|31}3241;|?640|;|Mc4\x82B0c5c6e2|\x84}aw32L3;|Mc7\x82W0}`W16:02e8|b232650|\x84;c9c:e2|N}ax32L3;e;}`3217;02e<e=|32@6E0c>qe?|31e@cAq|3242;cBq]31|_42;" [quote+ #fn("8000r1|Mc0\x8280c1|NK;c2c1|L3;" [#.list #.vector #.apply]) bq-process+ vector->list quasiquote #.list 'quasiquote unquote length= #.cons 'unquote >
+ any splice-form? #fn(":000r2|\x8570c0}K;}N\x85?0c1}Me2|\x7f32L3;e3e4}Ke2|\x7f32L142;" [#.list+ #.cons bq-process nconc list*]) lastcdr map #fn("8000r1e0|\x7f42;" [bq-bracket1])+ #fn("6000r1c0qm02|;" [#fn(">000r2|\x85;0c0e1}31K;|F6s0|Mc2\x82[0c0e3}i11`W670|N5E0c4c5L2e6|Ni11ax32L232K;~|Ne7|Mi1132}K42;c0e1e6|i1132}K31K;" [nconc+ reverse! unquote nreconc #.list 'unquote bq-process bq-bracket])])] bq-process)
+ builtin->instruction #fn("9000r1e0~|^43;" [get] [#table(#.number? number? #.cons cons #.fixnum? fixnum? #.equal? equal? #.eq? eq? #.symbol? symbol? #.div0 div0 #.builtin? builtin? #.aset! aset! #.- - #.boolean? boolean? #.not not #.apply apply #.atom? atom? #.set-cdr! set-cdr! #./ / #.function? function? #.vector vector #.list list #.bound? bound? #.< < #.* * #.cdr cdr #.null? null? #.+ + #.eqv? eqv? #.compare compare #.aref aref #.set-car! set-car! #.car car #.pair? pair? #.= = #.vector? vector?)+ ()])
+ caaaar #fn("6000r1|MMMM;" [] caaaar) caaadr+ #fn("6000r1|\x84MM;" [] caaadr) caaar #fn("6000r1|MMM;" [] caaar)+ caadar #fn("6000r1|M\x84M;" [] caadar) caaddr+ #fn("6000r1|N\x84M;" [] caaddr) caadr #fn("6000r1|\x84M;" [] caadr)+ caar #fn("6000r1|MM;" [] caar) cadaar+ #fn("6000r1|MM\x84;" [] cadaar) cadadr #fn("6000r1|\x84\x84;" [] cadadr)+ cadar #fn("6000r1|M\x84;" [] cadar) caddar+ #fn("6000r1|MN\x84;" [] caddar) cadddr #fn("6000r1|NN\x84;" [] cadddr)+ caddr #fn("6000r1|N\x84;" [] caddr) cadr+ #fn("6000r1|\x84;" [] cadr) call-with-values #fn("7000r2c0q|3041;" [#fn("7000r1|F16902i10|M<680\x7f|Nv2;\x7f|41;" [])] #2=[(*values*)+ ()])
+ cdaaar #fn("6000r1|MMMN;" [] cdaaar) cdaadr+ #fn("6000r1|\x84MN;" [] cdaadr) cdaar #fn("6000r1|MMN;" [] cdaar)+ cdadar #fn("6000r1|M\x84N;" [] cdadar) cdaddr+ #fn("6000r1|N\x84N;" [] cdaddr) cdadr #fn("6000r1|\x84N;" [] cdadr)+ cdar #fn("6000r1|MN;" [] cdar) cddaar+ #fn("6000r1|MMNN;" [] cddaar) cddadr #fn("6000r1|\x84NN;" [] cddadr)+ cddar #fn("6000r1|MNN;" [] cddar) cdddar+ #fn("6000r1|MNNN;" [] cdddar) cddddr #fn("6000r1|NNNN;" [] cddddr)+ cdddr #fn("6000r1|NNN;" [] cdddr) cddr+ #fn("6000r1|NN;" [] cddr) char? #fn("7000r1e0|31c1<;" [typeof wchar] char?)+ closure? #fn("7000r1|J16602|G@;" [] closure?) compile+ #fn("8000r1e0_|42;" [compile-f] compile) compile-and #fn("<000r4e0|}g2g3]c146;" [compile-short-circuit+ brf] compile-and)
+ compile-app #fn("7000r4c0qg3M41;" [#fn("9000r1c0q|C16V02e1|\x7f32@16J02|E16C02e2|3116902e3|31G6:0e3|31530|41;" [#fn(":000r1e0i13Nc1326S0e2i10i11^|342c3qe4i10i11i13N3341;c5q|G16802e6|3141;" [length>+ 255 compile-in #fn(":000r1e0i20i22670c1540c2|43;" [emit tcall.l call.l])+ compile-arglist #fn(";000r1~c0<16X02e1~i2132@16J02e2c031e0>16<02e3i23b2326L0e4i20i21^i23\x84342e5i20c042;|7A0e4i20i21^~34530]2c6qe7i20i21i23N3341;" [cadr+ in-env? top-level-value length= compile-in emit #fn("=000r1~6H0e0i30i31i32i33i10~|47;e1i30i32670c2540c3|43;" [compile-builtin-call+ emit tcall call]) compile-arglist]) builtin->instruction]) in-env? constant?
+ top-level-value])] compile-app)
+ compile-arglist #fn("8000r3e0c1qg2322e2g241;" [for-each #fn(":000r1e0~\x7f^|44;" [compile-in])+ length] compile-arglist)
+ compile-begin #fn(":000r4g3?6?0e0|}g2e13044;g3N?6>0e0|}g2g3M44;e0|}^g3M342e2|c3322e4|}g2g3N44;" [compile-in+ void emit pop compile-begin] compile-begin)
+ compile-builtin-call #fn(":000r7c0qe1e2g5^3341;" [#fn("8000r1|16=02e0i03N|32@6=0e1i04|32530]2c2qi0541;" [length=+ argc-error #fn(":000r1|c0\x82R0i16`W6<0e1i10c242;e1i10i15i1643;|c3\x82e0i16`W6<0e1i10c442;i16b2W6<0e1i10c542;e1i10i15i1643;|c6\x82v0i16`W6;0e7i14a42;i16aW6<0e1i10c842;i16b2W6<0e1i10c942;e1i10i15i1643;|c:\x82R0i16`W6<0e1i10c;42;e1i10i15i1643;|c<\x82Q0i16`W6;0e7i14a42;e1i10i15i1643;|c=\x82T0i16`W6>0e1i10c>c?43;e1i10i15i1643;|c@\x82]0i16b2X6<0e7i14b242;e1i10i12670cA540c@i1643;e1i10i1542;" [list+ emit loadnil + load0 add2 - argc-error neg sub2 * load1 / vector loadv []
+ apply tapply])]) get arg-counts] compile-builtin-call)
+ compile-f #fn("8000r2e0c1qc242;" [call-with-values #fn("8000r0e0~\x7f42;" [compile-f-])+ #fn("6000r2|;" [])] compile-f)+ compile-f- #fn("8000r2c0q]]42;" [#fn(">000r2c0qm02c1qm12c2qe330\x7f\x84e4\x7f\x8431e5\x7f\x8431e6c7\x7f\x8432e4\x7f31i10\x8270c8570e4\x7f3146;" [#fn("9000r1c0qe1|31F6N0e2|31F6=0c3e1|31K570e4|31560e53041;" [#fn("8000r1c0qe1|3141;" [#fn(":000r1|\x8540~;e0c1|~i4034e2c3|32K;" [list*+ lambda map #fn("6000r1e040;" [void])]) get-defined-vars]) cddr cdddr begin+ caddr void] lambda-body) #fn("7000r1e0|31i20\x8280e1|41;~|41;" [lastcdr caddr] lam:body)+ #fn("9000r6c0q}?660`570e1}3141;" [#fn("9000r1c0q|e1i0431x41;" [#fn("9000r1c0qe1e2i143241;" [#fn("C000r1i24\x87\xa90|\x85O0e0i20c1~i22\x8580i10560i10y345s0e2i20e3e4c5e4c6|32e7e8|31313331322e0i20c9~e8|31i22\x8580i10560i10y352e:i20i40i24i23~35530]2e;i10c<326L0e0i20i22\x8570c=540c>i10335]0i22\x87A0e0i20c?i10335H0i24\x85A0e0i20c@i1033530^2eAi20i23i40K]i31i4131342e0i20cB322eCeDeEeFi203131eGi2031i2533i20b3[42;" [emit+ optargs bcode:indexfor make-perfect-hash-table map #.cons #.car iota length
+ keyargs emit-optional-arg-inits > 255 largc lvargc vargc argc compile-in ret
+ values function encode-byte-code bcode:code const-to-idx-vec]) filter
+ keyword-arg?]) length]) length]) make-code-emitter lastcdr lambda-vars filter
+ #.pair? lambda])] #0=[#:g709 ()])
+ compile-for #fn(":000r5e0g4316X0e1|}^g2342e1|}^g3342e1|}^g4342e2|c342;e4c541;" [1arg-lambda?+ compile-in emit for error "for: third form must be a 1-argument lambda"] compile-for)
+ compile-if #fn("<000r4c0qe1|31e1|31g3\x84e2g331e3g331F6;0e4g331560e53045;" [#fn(";000r5g2]\x82>0e0~\x7fi02g344;g2^\x82>0e0~\x7fi02g444;e0~\x7f^g2342e1~c2|332e0~\x7fi02g3342i026<0e1~c3325:0e1~c4}332e5~|322e0~\x7fi02g4342e5~}42;" [compile-in+ emit brf ret jmp mark-label]) make-label caddr cdddr cadddr void] compile-if)
+ compile-in #fn(";000r4g3C6=0e0|}g3c144;g3?6\xaf0g3`\x82:0e2|c342;g3a\x82:0e2|c442;g3]\x82:0e2|c542;g3^\x82:0e2|c642;g3_\x82:0e2|c742;e8g3316<0e2|c9g343;e:g3316C0e;|}g2e<c=31L144;e2|c>g343;g3MC@17D02g3ME17;02e?g3M}326=0e@|}g2g344;cAqg3M41;" [compile-sym+ [loada loadc loadg] emit load0 load1 loadt loadf loadnil fits-i8 loadi8
+ eof-object? compile-in top-level-value eof-object loadv in-env? compile-app
+ #fn("<000r1|c0\x82W0e1i03\x84316@0e2~\x7fi02i03\x8444;e3~c4i03\x8443;|c5\x82?0e6~\x7fi02i0344;|c7\x82@0e8~\x7fi02i03N44;|c9\x82<0e:~\x7fi0343;|c;\x82=0e<c=qc>q42;|c?\x82@0e@~\x7fi02i03N44;|cA\x82@0eB~\x7fi02i03N44;|cC\x82G0eD~\x7fi03\x84c7eEi0331K44;|cF\x82K0eG~\x7fi03\x84eHi0331eIi033145;|cJ\x82F0e2~\x7f]i03\x84342e3~cK42;|cL\x82N0e2~\x7f^eHi0331342eM~\x7fi03\x84cN44;|cO\x82C0e2~\x7fi02ePi033144;|cQ\x82s0e2~\x7f^c;_i03\x84L3342eReHi033131660^580eScT312e2~\x7f^eHi0331342e3~cQ42;eU~\x7fi02i0344;" [quote+ self-evaluating? compile-in emit loadv if compile-if begin compile-begin
+ prog1 compile-prog1 lambda call-with-values #fn("8000r0e0i11i1342;" [compile-f-])+ #fn("9000r2e0i10c1|332e2i10}322}e3i1131X6<0e0i10c442;];" [emit loadv+ bcode:cdepth nnn
+ closure]) and
+ compile-and or compile-or while compile-while cddr for compile-for caddr
+ cadddr return ret set! compile-sym [seta setc setg] define expand-define
+ trycatch 1arg-lambda? error "trycatch: second form must be a 1-argument lambda"
+ compile-app])] compile-in)
+ compile-or #fn("<000r4e0|}g2g3^c146;" [compile-short-circuit brt] compile-or)+ compile-prog1 #fn(";000r3e0|}^g2\x84342e1g231F6H0e2|}^e1g231342e3|c442;];" [compile-in+ cddr compile-begin emit pop] compile-prog1)
+ compile-short-circuit #fn(":000r6g3?6=0e0|}g2g444;g3N?6>0e0|}g2g3M44;c1qe2|3141;" [compile-in+ #fn("<000r1e0~\x7f^i03M342e1~c2322e1~i05|332e1~c3322e4~\x7fi02i03Ni04i05362e5~|42;" [compile-in+ emit dup pop compile-short-circuit mark-label]) make-label] compile-short-circuit)
+ compile-sym #fn(";000r4c0qe1g2}`]3441;" [#fn(":000r1|D6>0e0~i03`[|43;|MD6R0e0~i03a[|M|N342e1~e2\x7fN31a|MS342;e3i023116>02e4e5i0231316A0e0~c6e5i023143;e0~i03b2[i0243;" [emit+ bcode:cdepth nnn constant? printable? top-level-value loadv]) lookup-sym] compile-sym)
+ compile-thunk #fn(";000r1e0e1c2L1_L1|L1~3441;" [compile nconc lambda] #0#)+ compile-while #fn("9000r4c0qe1|31e1|3142;" [#fn(":000r2e0~\x7f^e130342e2~|322e0~\x7f^i02342e3~c4}332e3~c5322e0~\x7f^i03342e3~c6|332e2~}42;" [compile-in+ void mark-label emit brf pop jmp]) make-label] compile-while)
+ const-to-idx-vec #fn("9000r1c0qe1e2|313141;" [#fn("9000r1e0c1qe2~31322|;" [table.foreach+ #fn("8000r2~}|\\;" []) bcode:ctable]) vector.alloc bcode:nconst] const-to-idx-vec)+ copy-tree #fn("8000r1|?640|;e0|M31e0|N31K;" [copy-tree] copy-tree)+ count #fn("7000r2c0q]41;" [#fn("9000r1c0qm02|~\x7f`43;" [#fn(":000r3}\x8550g2;~|}N|}M31690g2aw540g243;" [] count-)])] count)+ delete-duplicates #fn("8000r1|?640|;c0|M|N42;" [#fn("8000r2e0|}32680e1}41;|e1}31K;" [member+ delete-duplicates])] delete-duplicates)
+ disassemble #fn("=000s1}\x85C0e0|`322e1302];530]2c2}Me3|31e4|3143;" [disassemble+ newline #fn("7000r3c0q]41;" [#fn(":000r1c0qm02`~axc1u2e2c3e4\x7f`32c5332c6qb4e7\x7f3142;" [#fn("9000r1|J16602|G@6D0e0c1312e2|i10aw42;e3|41;" [princ+ "\n" disassemble print] print-val) #fn("7000r1e0c141;" [princ "\t"]) princ "maxstack "+ ref-int32-LE "\n" #fn(":000r2]|}X6E02c0qe1c2q^e333315\x19/;" [#fn(";000r1e0~b432690e130530]2`i20axc2u2e3e4~b4x31c5e6|31c7342~awo002c8q|41;" [>+ newline #fn("7000r1e0c141;" [princ "\t"]) princ hex5 ": " string "\t" #fn("=000r1e0|c1326P0i20i32e2i31i1032[312i10b4wo10;e0|c3326L0i20i32i31i10[[312i10awo10;e0|c4326K0e5e6i31i10[31312i10awo10;e0|c7326O0e5e6e2i31i103231312i10b4wo10;e0|c8326f0e5e6i31i10[31c9322i10awo102e5e6i31i10[31312i10awo10;e0|c:326\x9c0e5e6e2i31i103231c9322i10b4wo102e5e6e2i31i103231312i10b4wo102~c;\x82X0e5c9312e5e6e2i31i103231c9322i10b4wo10;];|c<=6Q0e5e6e2i31i103231c9322i10b4wo10;e0|c=326X0e5c>e?i10b,e@i31i1032R331322i10b2wo10;e0|cA326X0e5c>e?i10b,e2i31i1032R331322i10b4wo10;^;" [memq+ (loadv.l loadg.l setg.l) ref-int32-LE (loadv loadg setg)
+ (loada seta call tcall list + - * / vector argc vargc loadi8 apply tapply)
+ princ number->string (loada.l seta.l largc lvargc call.l tcall.l) (loadc setc)
+ " " (loadc.l setc.l optargs keyargs) keyargs brbound (jmp brf brt brne brnn
+ brn) "@" hex5
+ ref-int16-LE (jmp.l brf.l brt.l brne.l brnn.l brn.l)])]) table.foldl #fn("8000r3g217@02}i21~[<16402|;" [])+ Instructions])
+ length])]) function:code function:vals] disassemble)
+ div #fn("8000r2|}V|`X16C02}`X16402a17502b/17402`w;" [] div) emit+ #fn("G000s2g2\x85b0}c0<16C02|`[F16:02|`[Mc1<6;0|`[c2O5:0|`}|`[K\\5\xe20e3}c4326A0e5|g2M32L1m2530]2c6qe7}c832312c9qe7}c:32312}c;\x82\\0g2c<>6=0c=m12_m25F0g2c>>6=0c?m12_m2530^530]2}c@\x82\\0g2cA>6=0cBm12_m25F0g2cC>6=0cDm12_m2530^530]2cEq|`[F690|`[M530_|`[322|;" [car+ cdr cadr memq (loadv loadg setg) bcode:indexfor #fn("8000r1|16=02e0i02Mc132680|\x84o01;];" [>+ 255]) assq ((loadv loadv.l) (loadg loadg.l) (setg setg.l) (loada loada.l) (seta
+ seta.l)) #fn("8000r1|16L02e0i02Mc13217=02e0i02\x84c132680|\x84o01;];" [> 255])+ ((loadc loadc.l) (setc setc.l)) loada (0) loada0 (1) loada1 loadc (0 0)
+ loadc00 (0 1) loadc01 #fn(">000r2\x7fc0<16\x9a02|c1<16802}\x84c2<6E0~`i02Mc3e4}31KK\\5u0|c1\x82B0~`i02Mc5}NKK\\5_0|c6\x82B0~`i02Mc7}NKK\\5I0|c2\x82B0~`i02Mc8}NKK\\530^17^02\x7fc5<16702|c2<6@0~`i02Mc3}NKK\\;~`e9\x7fi02K}32\\;" [brf+ not null? brn cddr brt eq? brne brnn nreconc])] emit)
+ emit-optional-arg-inits #fn("8000r5g2F6=0c0qe1|3141;];" [#fn("<000r1e0~c1i04332e0~c2|332e3~e4i03i0432\x7fK^e5i0231342e0~c6i04332e0~c7322e8~|322e9~\x7fi02Ni03i04aw45;" [emit+ brbound brt compile-in list-head cadar seta pop mark-label
+ emit-optional-arg-inits]) make-label] emit-optional-arg-inits)
+ encode-byte-code #fn("8000r1c0e1|3141;" [#fn("8000r1c0e1|3141;" [#fn(";000r1c0qe1e2|31b3e2|31b2VT2wc33241;" [#fn("=000r1c0qe1~31`e230e230e330^^47;" [#fn("?000r7e0g4c1322]}|X6\xff02i10}[m52g5c2\x82O0e3g2i10}aw[e4g431332}b2wm15\xcf0e0g4e5e6e7~6<0c8qg531540g53231322}awm12}|X6:0i10}[530^m62e9g5c:326^0e3g3e4g431g6332e0g4~670e;540e<`31322}awm15_0g5c=\x82G0e0g4e;g631322}awm15C0g6D6<0c>qg531530^5_/2e?c@qg3322eAg441;" [io.write+ #int32(0) label put! sizeof byte get Instructions #fn("7000r1|c0\x8250c1;|c2\x8250c3;|c4\x8250c5;|c6\x8250c7;|c8\x8250c9;|c:\x8250c;;i05;" [jmp+ jmp.l brt brt.l brf brf.l brne brne.l brnn brnn.l brn brn.l]) memq (jmp brf
+ brt brne brnn brn) int32 int16 brbound #fn(":000r1e0|c1326H0e2i04e3i0631322\x7fawo01;e0|c4326`0e2i04e5i0631322\x7fawo012e2i04e5i20\x7f[31322\x7fawo01;e0|c6326\x820e2i04e3i0631322\x7fawo012e2i04e3i20\x7f[31322\x7fawo012i05c7\x82J0e2i04e3i20\x7f[31322\x7fawo01;];e2i04e5i0631322\x7fawo01;" [memq+ (loadv.l loadg.l setg.l loada.l seta.l largc lvargc call.l tcall.l) io.write
+ int32 (loadc setc) uint8 (loadc.l setc.l optargs keyargs) keyargs])
+ table.foreach #fn("<000r2e0i04|322e1i04i10670e2540e3e4i02}32|x3142;" [io.seek+ io.write int32 int16 get]) io.tostring!]) length table buffer]) >= length 65536])
+ list->vector]) reverse!] encode-byte-code)
+ error #fn(":000s0e0c1|K41;" [raise error] error) eval+ #fn("8000r1e0e1|313140;" [compile-thunk expand] eval) even? #fn("8000r1e0|a32`W;" [logand] even?)+ every #fn("8000r2}?17D02|}M3116:02e0|}N42;" [every] every) expand+ #fn("A000r1c0q]]]]]]]]]]]4;;" [#fn("8000r;c0m02c1qm12c2L1m22c3qm32c4qm42c5qm52c6qm62c7qm72c8qm82c9m92c:qm:2g:~_42;" [#fn("8000r2|E17902e0|}32@;" [assq] top?)+ #fn("9000r1|?640|;|c0>640|;|MF16;02e1|31c2<6D0e3\x7fe4|3131\x7f|N3142;|M\x7f|N31K;" [((begin))+ caar begin append cdar] splice-begin) *expanded* #fn("9000r2|?640|;c0q~c1}32690\x7f|31530|41;" [#fn("9000r1c0qi10c1\x7f3241;" [#fn("8000r1c0q|6:0e1~31530_41;" [#fn(":000r1c0qe1e2c3|32i213241;" [#fn("8000r1i107=0e0c1qi2042;c2qc3q]31i203141;" [map+ #fn("8000r1i5:|~42;" []) #fn("7000r1c0q|41;" [#fn("9000r1]|F6]02i62e0|31<7A0|i6:|Mi1032O590|e1|31O2|Nm05\x02/2~;" [caar+ cdar])]) #fn("6000r1c0qm02|;" [#fn("9000r1|?640|;|MF16;02c0e1|31<6;0|M~|N31K;c2qi6:|Mi103241;" [define+ caar #fn(":000r1e0e1c2e3|3132i2032o202i72|Ki10~N31K;" [nconc map #.list+ get-defined-vars])])])])
+ nconc map #.list]) get-defined-vars]) define]) begin] expand-body)
+ #fn(":000r2|?640|;|MF16702|MNF6G0e0|31i0:e1|31}32L2540|Mi04|N}32K;" [caar+ cadar] expand-lambda-list) #fn("8000r1|?660|L1;|MF6@0e0|31i05|N31K;|Mi05|N31K;" [caar] l-vars)+ #fn(";000r2c0q|\x84e1|31e2|31i05|\x843144;" [#fn(":000r4c0qe1e2c3g332\x7f3241;" [#fn(";000r1e0c1L1i24~|32L1i23i02|32\x7f44;" [nconc+ lambda]) nconc map #.list]) lastcdr cddr] expand-lambda)
+ #fn("<000r2|NA17602|\x84?6N0e0|31\x8540|;c1|\x84i0:e2|31}32L3;c3qe4|31e5|31e0|31i05e4|313144;" [cddr+ define caddr #fn(":000r4c0qe1e2c3g332\x7f3241;" [#fn(";000r1e0c1L1\x7fi24~|32KL1i23i02|3243;" [nconc+ define]) nconc map #.list]) cdadr caadr] expand-define)
+ #fn("7000r2c0q|\x8441;" [#fn("<000r1c0i13e1~31e2e3c4q|32\x7f3232K;" [begin+ cddr nconc map #fn(":000r1|Me0i2:|\x84i11323130i11L3;" [compile-thunk])])] expand-let-syntax)+ #fn("6000r2|;" [] local-expansion-env) #fn("7000r2|?640|;c0q|M41;" [#fn("9000r1c0qe1|\x7f3241;" [#fn("7000r1c0qc1q41;" [#fn(":000r1~16602~NF6M0i3:~\x84i20NQ2i39e0~31i213242;~17A02i10C@17702i10E660|40;c1qe2i203141;" [caddr+ #fn("8000r1|6B0i4:|i30NQ2i3142;i20c0\x8260i30;i20c1\x82>0i46i30i3142;i20c2\x82>0i47i30i3142;i20c3\x82>0i48i30i3142;~40;" [quote+ lambda define let-syntax]) macrocall?])
+ #fn("7000r0c0q]31i2041;" [#fn("6000r1c0qm02|;" [#fn("9000r1|?640|;|M?670|M5<0i4:|Mi3132~|N31K;" [])])])])+ assq])] expand-in)])] expand)
+ expand-define #fn("=000r1c0|\x84e1|31F6:0e1|315L0|\x84C6;0e230L15=0e3c4e5|313242;" [#fn("<000r2|C6:0c0|}ML3;c0|Me1c2L1|NL1e3}31|M34L3;" [set!+ nconc lambda copy-list]) cddr void error "compile error: invalid syntax "
+ print-to-string] expand-define)
+ filter #fn("7000r2c0q]41;" [#fn("9000r1c0qm02|~\x7f_L143;" [#fn("9000r3g2]}F6S02i10}M316?0g2}M_KPNm2530]2}Nm15\f/2N;" [] filter-)])] filter)+ fits-i8 #fn("8000r1|I16F02e0|b\xb03216:02e1|b\xaf42;" [>= <=] fits-i8)+ foldl #fn(":000r3g2\x8540};e0||g2M}32g2N43;" [foldl] foldl) foldr+ #fn(";000r3g2\x8540};|g2Me0|}g2N3342;" [foldr] foldr) for-each #fn(";000s2c0q]41;" [#fn(":000r1c0qm02i02\x85J0]\x7fF6A02~\x7fM312\x7fNo015\x1e/5;0|~\x7fi02K322];" [#fn(":000r2}MF6I0|e0c1}32Q22~|e0c2}3242;];" [map+ #.car #.cdr] for-each-n)])] for-each)
+ get-defined-vars #fn("8000r1e0~|3141;" [delete-duplicates] #1=[#fn("9000r1|?640_;|Mc0<16602|NF6d0|\x84C16702|\x84L117S02|\x84F16E02e1|31C16:02e1|31L117402_;|Mc2\x82>0e3e4~|N32v2;_;" [define+ caadr begin nconc map] #1#) ()])
+ hex5 #fn("9000r1e0e1|b@32b5c243;" [string.lpad number->string #\0] hex5)+ identity #fn("6000r1|;" [] identity) in-env?+ #fn("8000r2}F16F02e0|}M3217:02e1|}N42;" [memq in-env?] in-env?)+ index-of #fn(":000r3}\x8540^;|}M\x8250g2;e0|}Ng2aw43;" [index-of] index-of)+ io.readall #fn("7000r1c0qe13041;" [#fn("8000r1e0|~322c1qe2|3141;" [io.copy+ #fn("7000r1|c0>16:02e1i1031670e240;|;" ["" io.eof? eof-object]) io.tostring!])+ buffer] io.readall)
+ io.readline #fn("8000r1e0|c142;" [io.readuntil #\linefeed] io.readline)+ io.readlines #fn("8000r1e0e1|42;" [read-all-of io.readline] io.readlines)+ iota #fn("8000r1e0e1|42;" [map-int identity] iota) keyword->symbol+ #fn("9000r1e0|316@0e1c2e3|313141;|;" [keyword? symbol #fn("<000r1e0|`e1|e2|313243;" [string.sub+ string.dec length]) string] keyword->symbol)
+ keyword-arg? #fn("7000r1|F16902e0|M41;" [keyword?] keyword-arg?)+ lambda-arg-names #fn("9000r1e0c1e2|3142;" [map! #fn("7000r1|F690e0|M41;|;" [keyword->symbol])+ to-proper] lambda-arg-names)
+ lambda-vars #fn("7000r1c0q]41;" [#fn(":000r1c0qm02|~~^^342e1~41;" [#fn(";000r4|A17502|C640];|F16602|MC6S0g217502g36<0e0c1}c243;~|N}g2g344;|F16602|MF6\x870e3|Mb23216902e4|31C660^5=0e0c5|Mc6}342e7e4|31316<0~|N}g2]44;g36<0e0c1}c843;~|N}]g344;|F6>0e0c9|Mc6}44;|}\x82:0e0c1}42;e0c9|c6}44;" [error+ "compile error: invalid argument list "
+ ". optional arguments must come after required." length= caar "compile error: invalid optional argument "
+ " in list " keyword? ". keyword arguments must come last."
+ "compile error: invalid formal argument "] check-formals) lambda-arg-names])] lambda-vars)
+ last-pair #fn("7000r1|N?640|;e0|N41;" [last-pair] last-pair) lastcdr+ #fn("7000r1|?640|;e0|31N;" [last-pair] lastcdr) length= #fn("9000r2}`X640^;}`W650|?;|?660}`W;e0|N}ax42;" [length=] length=)+ length> #fn("9000r2}`X640|;}`W6;0|F16402|;|?660}`X;e0|N}ax42;" [length>] length>)+ list->vector #fn("7000r1c0|v2;" [#.vector] list->vector) list-head+ #fn(":000r2e0}`32640_;|Me1|N}ax32K;" [<= list-head] list-head)+ list-ref #fn("8000r2e0|}32M;" [list-tail] list-ref) list-tail+ #fn("9000r2e0}`32640|;e1|N}ax42;" [<= list-tail] list-tail) list? #fn("7000r1|A17@02|F16902e0|N41;" [list?] list?)+ load #fn("9000r1c0qe1|c23241;" [#fn("7000r1c0qc1qt;" [#fn("9000r0c0q]31]]]43;" [#fn("6000r1c0qm02|;" [#fn(":000r3e0i10317C0~e1i1031|e2}3143;e3i10312e2}41;" [io.eof?+ read load-process io.close])])]) #fn("9000r1e0~312e1c2i10|L341;" [io.close+ raise
+ load-error])])
+ file :read] load)
+ load-process #fn("7000r1e0|41;" [eval] load-process) lookup-sym+ #fn("7000r4}\x8550c0;c1q}M41;" [(global)+ #fn(":000r1c0qe1~|`3341;" [#fn(";000r1|6@0i13640|;i12|K;e0i10i11Ni1317502~A680i12570i12aw^44;" [lookup-sym])+ index-of])] lookup-sym)
+ macrocall? #fn("7000r1|MC16902e0|M41;" [symbol-syntax] macrocall?)+ macroexpand-1 #fn("8000r1|?640|;c0qe1|3141;" [#fn("7000r1|680|~Nv2;~;" [])+ macrocall?] macroexpand-1)
+ make-code-emitter #fn("9000r0_e030`c1Z4;" [table +inf.0] make-code-emitter)+ make-label #fn("6000r1e040;" [gensym] make-label)+ make-perfect-hash-table #fn("7000r1c0q]41;" [#fn("8000r1c0m02c1q]31e2~3141;" [#fn("9000r2e0e1e2|3131}42;" [mod0+ abs hash] $hash-keyword) #fn("6000r1c0qm02|;" [#fn("9000r1c0qe1b2|T2^3241;" [#fn("7000r1c0q]31i3041;" [#fn("6000r1c0qm02|;" [#fn("8000r1|F6=0c0qe1|3141;i10;" [#fn(":000r1c0qb2i50|i3032T241;" [#fn("9000r1i30|[6=0i50i40aw41;i30|~\\2i30|awe0i1031\\2i20i10N41;" [cdar])])+ caar])])]) vector.alloc])]) length])] make-perfect-hash-table)
+ make-system-image #fn(";000r1c0e1|c2c3c434c542;" [#fn("8000r2c0qe1e242;" [#fn("7000r2]k02]k12c2qc3q41;" [*print-pretty*+ *print-readably* #fn("7000r1c0qc1qt|302;" [#fn(":000r0c0qe1c2qe3e4303132312e5i2041;" [#fn("=000r1e0e1e2c3|e2e4|3233Q2i20322e5i20e642;" [write+ nconc map #.list top-level-value io.write *linefeed*]) filter #fn("9000r1|E16w02e0|31@16l02e1|31G@17C02e2|31e2e1|3131>@16K02e3|i2132@16=02e4e1|3131@;" [constant?+ top-level-value string memq iostream?]) simple-sort environment io.close])
+ #fn("7000r1~302e0|41;" [raise])])+ #fn("6000r0~k02\x7fk1;" [*print-pretty* *print-readably*])]) *print-pretty*+ *print-readably*]) file :write :create :truncate (*linefeed*
+ *directory-separator*
+ *argv* that *print-pretty*
+ *print-width*
+ *print-readably*
+ *print-level*
+ *print-length* *os-name*)] make-system-image)
+ map! #fn("9000r2}]}F6B02}|}M31O2}Nm15\x1d/2;" [] map!) map-int+ #fn("8000r2e0}`32640_;c1q|`31_K_42;" [<= #fn(":000r2|m12a\x7faxc0qu2|;" [#fn("8000r1\x7fi10|31_KP2\x7fNo01;" [])])] map-int)+ mark-label #fn("9000r2e0|c1}43;" [emit label] mark-label) max+ #fn("<000s1}\x8540|;e0c1|}43;" [foldl #fn("7000r2|}X640};|;" [])] max)+ member #fn("8000r2}?640^;}M|>640};e0|}N42;" [member] member) memv+ #fn("8000r2}?640^;}M|=640};e0|}N42;" [memv] memv) min #fn("<000s1}\x8540|;e0c1|}43;" [foldl+ #fn("7000r2|}X640|;};" [])] min)+ mod #fn("9000r2|e0|}32}T2x;" [div] mod) mod0+ #fn("8000r2||}V}T2x;" [] mod0) negative? #fn("7000r1|`X;" [] negative?)+ nestlist #fn(";000r3e0g2`32640_;}e1||}31g2ax33K;" [<= nestlist] nestlist)+ newline #fn("9000\x8900001000\x8a0000770e0m02e1|e2322];" [*output-stream*+ io.write
+ *linefeed*] newline)
+ nnn #fn("8000r1e0c1|42;" [count #fn("6000r1|A@;" [])] nnn) nreconc+ #fn("8000r2e0}|42;" [reverse!-] nreconc) odd? #fn("7000r1e0|31@;" [even?] odd?)+ positive? #fn("8000r1e0|`42;" [>] positive?) princ+ #fn("9000s0c0qe141;" [#fn("7000r1^k02c1qc2q41;" [*print-readably* #fn("7000r1c0qc1qt|302;" [#fn("8000r0e0e1i2042;" [for-each+ write]) #fn("7000r1~302e0|41;" [raise])])+ #fn("6000r0~k0;" [*print-readably*])])+ *print-readably*] princ)
+ print #fn(":000s0e0e1|42;" [for-each write] print) print-exception+ #fn("=000r1|F16D02|Mc0<16:02e1|b4326P0e2c3|\x84c4e5|31c6352e7e8|31315\x070|F16D02|Mc9<16:02e1|b4326N0e2|\x84c:e8|31c;342e7e5|31315\xd00|F16@02|Mc<<16602|NF6?0e2c=|\x84c>335\xac0|F16802|Mc?<6B0e2c@312e2|NQ25\x8d0|F16802|McA<6G0eBe5|31312e2cC|\x84325i0eD|3116:02e1|b2326I0e7|M312e2cE312cF|\x84315>0e2cG312e7|312e2eH41;" [type-error+ length= princ "type error: " ": expected " caddr ", got " print cadddr
+ bounds-error ": index " " out of bounds for " unbound-error "eval: variable "
+ " has no value" error "error: " load-error print-exception "in file " list?
+ ": " #fn("8000r1e0|3117502|C670e1540e2|41;" [string? princ print])+ "*** Unhandled exception: " *linefeed*] print-exception)
+ print-stack-trace #fn("8000r1c0q]]42;" [#fn("=000r2c0qm02c1qm12c2qe3e4~e5670b5540b43231e6e7e8c9e:303232`43;" [#fn("8000r3c0qe1|31g2K41;" [#fn("9000r1e0~31e0\x7f31\x82>0e1c2c3|L341;c4qe5~3141;" [function:code+ raise thrown-value ffound #fn(":000r1`e0e1|3131c2qu;" [1- length #fn("9000r1e0~|[316A0i30~|[i21i1043;];" [closure?])])+ function:vals]) function:name] find-in-f)
+ #fn("8000r2c0c1qc2t41;" [#fn(";000r1|6H0e0e1e2e3e4|3132c53241;c6;" [symbol+ string.join map string reverse! "/" lambda])
+ #fn("8000r0e0c1q\x7f322^;" [for-each #fn("9000r1i10|~_43;" [])])+ #fn("7000r1|F16B02|Mc0<16802|\x84c1<680e2|41;e3|41;" [thrown-value+ ffound caddr raise])] fn-name) #fn("8000r3e0c1q|42;" [for-each #fn("9000r1e0c1i02c2332e3i11|`[\x7f32e4|31NK312e5302i02awo02;" [princ+ "#" " " print vector->list newline])]) reverse! list-tail *interactive*
+ filter closure? map #fn("7000r1|E16802e0|41;" [top-level-value]) environment])] print-stack-trace)+ print-to-string #fn("7000r1c0qe13041;" [#fn("8000r1e0~|322e1|41;" [write+ io.tostring!]) buffer] print-to-string)
+ printable? #fn("7000r1e0|3117802e1|31@;" [iostream? eof-object?] printable?)+ quote-value #fn("7000r1e0|31640|;c1|L2;" [self-evaluating? quote] quote-value)+ random #fn("8000r1e0|316<0e1e230|42;e330|T2;" [integer? mod rand+ rand.double] random)
+ read-all #fn("8000r1e0e1|42;" [read-all-of read] read-all)+ read-all-of #fn("9000r2c0q]31_|}3142;" [#fn("6000r1c0qm02|;" [#fn("9000r2e0i1131680e1|41;~}|Ki10i113142;" [io.eof?+ reverse!])])] read-all-of)
+ ref-int16-LE #fn(";000r2e0e1|}`w[`32e1|}aw[b832w41;" [int16 ash] ref-int16-LE)+ ref-int32-LE #fn("=000r2e0e1|}`w[`32e1|}aw[b832e1|}b2w[b@32e1|}b3w[bH32R441;" [int32+ ash] ref-int32-LE)
+ repl #fn("8000r0c0]]42;" [#fn("6000r2c0m02c1qm12}302e240;" [#fn("8000r0e0c1312e2e3312c4c5c6t41;" [princ+ "> " io.flush *output-stream* #fn("8000r1e0e131@16<02c2e3|3141;" [io.eof?+ *input-stream*
+ #fn("7000r1e0|312|k12];" [print+ that]) load-process]) #fn("6000r0e040;" [read])+ #fn("7000r1e0e1312e2|41;" [io.discardbuffer *input-stream* raise])] prompt)+ #fn("7000r0c0qc1t6;0e2302\x7f40;^;" [#fn("7000r0~3016702e040;" [newline])+ #fn("7000r1e0|312];" [top-level-exception-handler])+ newline] reploop) newline])] repl)
+ revappend #fn("8000r2e0}|42;" [reverse-] revappend) reverse+ #fn("8000r1e0_|42;" [reverse-] reverse) reverse! #fn("8000r1e0_|42;" [reverse!-] reverse!)+ reverse!- #fn("9000r2]}F6B02}N}|}m02P2m15\x1d/2|;" [] reverse!-)+ reverse- #fn("8000r2}\x8540|;e0}M|K}N42;" [reverse-] reverse-)+ self-evaluating? #fn("8000r1|?16602|C@17K02e0|3116A02|C16:02|e1|31<;" [constant?+ top-level-value] self-evaluating?)
+ separate #fn("7000r2c0q]41;" [#fn(":000r1c0m02|~\x7f_L1_L144;" [#fn(";000r4c0g2g3K]}F6Z02|}M316?0g2}M_KPNm25<0g3}M_KPNm32}Nm15\x05/241;" [#fn("8000r1e0|MN|NN42;" [values])] separate-)])] separate)+ set-syntax! #fn("9000r2e0e1|}43;" [put! *syntax-environment*] set-syntax!)+ simple-sort #fn("7000r1|A17602|NA640|;c0q|M41;" [#fn("8000r1e0c1qc2q42;" [call-with-values+ #fn("8000r0e0c1qi10N42;" [separate #fn("7000r1|~X;" [])])+ #fn(":000r2e0e1|31~L1e1}3143;" [nconc simple-sort])])] simple-sort)+ splice-form? #fn("8000r1|F16X02|Mc0<17N02|Mc1<17D02|Mc2<16:02e3|b23217702|c2<;" [unquote-splicing+ unquote-nsplicing unquote length>] splice-form?)
+ string.join #fn("7000r2|\x8550c0;c1qe23041;" ["" #fn("8000r1e0|~M322e1c2q~N322e3|41;" [io.write+ for-each #fn("8000r1e0~i11322e0~|42;" [io.write]) io.tostring!]) buffer] string.join)+ string.lpad #fn(";000r3e0e1g2}e2|31x32|42;" [string string.rep+ string.count] string.lpad)
+ string.map #fn("9000r2c0qe130e2}3142;" [#fn("7000r2c0q`312e1|41;" [#fn(";000r1]|\x7fX6S02e0~i10e1i11|3231322e2i11|32m05\v/;" [io.putc+ string.char string.inc]) io.tostring!]) buffer length] string.map)
+ string.rep #fn(";000r2}b4X6`0e0}`32650c1;}aW680e2|41;}b2W690e2||42;e2|||43;e3}316@0e2|e4|}ax3242;e4e2||32}b2U242;" [<=+ "" string odd? string.rep] string.rep)
+ string.rpad #fn("<000r3e0|e1g2}e2|31x3242;" [string string.rep+ string.count] string.rpad)
+ string.tail #fn(";000r2e0|e1|`}3342;" [string.sub string.inc] string.tail)+ string.trim #fn("8000r3c0q]]42;" [#fn("8000r2c0qm02c1qm12c2qe3~3141;" [#fn(";000r4g2g3X16?02e0}e1|g232326A0~|}e2|g232g344;g2;" [string.find+ string.char string.inc] trim-start) #fn("<000r3e0g2`3216D02e1}e2|e3|g23232326?0\x7f|}e3|g23243;g2;" [>+ string.find string.char string.dec] trim-end)
+ #fn("<000r1e0i10~i10i11`|34\x7fi10i12|3343;" [string.sub]) length])] string.trim)+ symbol-syntax #fn("9000r1e0e1|^43;" [get *syntax-environment*] symbol-syntax)+ table.clone #fn("7000r1c0qe13041;" [#fn("9000r1e0c1q_~332|;" [table.foldl+ #fn("9000r3e0~|}43;" [put!])]) table] table.clone)+ table.foreach #fn("9000r2e0c1q_}43;" [table.foldl #fn("8000r3~|}322];" [])] table.foreach)+ table.invert #fn("7000r1c0qe13041;" [#fn("9000r1e0c1q_~332|;" [table.foldl+ #fn("9000r3e0~}|43;" [put!])]) table] table.invert)+ table.keys #fn("9000r1e0c1_|43;" [table.foldl #fn("7000r3|g2K;" [])] table.keys)+ table.pairs #fn("9000r1e0c1_|43;" [table.foldl #fn("7000r3|}Kg2K;" [])] table.pairs)+ table.values #fn("9000r1e0c1_|43;" [table.foldl #fn("7000r3}g2K;" [])] table.values)+ to-proper #fn("8000r1|\x8540|;|?660|L1;|Me0|N31K;" [to-proper] to-proper)+ top-level-exception-handler #fn("7000r1c0qe141;" [#fn("7000r1e0k12c2qc3q41;" [*stderr*+ *output-stream* #fn("7000r1c0qc1qt|302;" [#fn("7000r0e0i20312e1e23041;" [print-exception+ print-stack-trace stacktrace]) #fn("7000r1~302e0|41;" [raise])])+ #fn("6000r0~k0;" [*output-stream*])]) *output-stream*] top-level-exception-handler)+ trace #fn("8000r1c0qe1|31312c2;" [#fn("7000r1c0qe13041;" [#fn("@000r1e0~317e0e1i10e2c3|c4c5c6c7i10L2|L3L2c8L1c9c7~L2|L3L4L33142;];" [traced?+ set-top-level-value! eval lambda begin write cons quote newline apply])
+ gensym])
+ top-level-value ok] trace)
+ traced? #fn("8000r1e0|3116>02e1|31e1~31>;" [closure? function:code] [#fn(":000s0e0c1|K312e2302c3|v2;" [write+ x newline #.apply]) ()])
+ untrace #fn("8000r1c0qe1|3141;" [#fn("9000r1e0|316@0e1~e2|31b2[42;];" [traced?+ set-top-level-value! function:vals]) top-level-value] untrace)
+ values #fn("9000s0|F16602|NA650|M;~|K;" [] #2#) vector->list+ #fn("8000r1c0qe1|31_42;" [#fn(":000r2a|c0qu2};" [#fn("8000r1i10~|x[\x7fKo01;" [])])+ length] vector->list)
+ vector.map #fn("8000r2c0qe1}3141;" [#fn("8000r1c0qe1|3141;" [#fn(":000r1`~axc0qu2|;" [#fn(":000r1~|i20i21|[31\\;" [])])+ vector.alloc]) length] vector.map)
+ void #fn("6000r0];" [] void) zero?+ #fn("7000r1|`W;" [] zero?))--- /dev/null
+++ b/flisp.c
@@ -1,0 +1,2382 @@
+/*
+ femtoLisp
+
+ a compact interpreter for a minimal lisp/scheme dialect
+
+ characteristics:
+ * lexical scope, lisp-1
+ * unrestricted macros
+ * data types: 30-bit integer, symbol, pair, vector, char, string, table
+ iostream, procedure, low-level data types
+ * case-sensitive
+ * simple compacting copying garbage collector
+ * Scheme-style varargs (dotted formal argument lists)
+ * "human-readable" bytecode with self-hosted compiler
+
+ extra features:
+ * circular structure can be printed and read
+ * #. read macro for eval-when-read and readably printing builtins
+ * read macros for backquote
+ * symbol character-escaping printer
+ * exceptions
+ * gensyms (can be usefully read back in, too)
+ * #| multiline comments |#, lots of other lexical syntax
+ * generic compare function, cyclic equal
+ * cvalues system providing C data types and a C FFI
+ * constructor notation for nicely printing arbitrary values
+
+ by Jeff Bezanson (C) 2009
+ Distributed under the BSD License
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <ctype.h>
+#include <wctype.h>
+#include <sys/types.h>
+#include <locale.h>
+#include <limits.h>
+#include <errno.h>
+#include <math.h>
+#include "llt.h"
+#include "flisp.h"
+#include "opcodes.h"
+
+static char *builtin_names[] =
+ { NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL,+ NULL, NULL, NULL, NULL,
+ // predicates
+ "eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
+ "number?", "bound?", "pair?", "builtin?", "vector?", "fixnum?",
+ "function?",
+
+ // lists
+ "cons", "list", "car", "cdr", "set-car!", "set-cdr!",
+
+ // execution
+ "apply",
+
+ // arithmetic
+ "+", "-", "*", "/", "div0", "=", "<", "compare",
+
+ // sequences
+ "vector", "aref", "aset!",
+ "", "", "" };
+
+#define ANYARGS -10000
+
+static short builtin_arg_counts[] =
+ { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,+ 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 2, ANYARGS, 1, 1, 2, 2,
+ -2,
+ ANYARGS, -1, ANYARGS, -1, 2, 2, 2, 2,
+ ANYARGS, 2, 3 };
+
+static uint32_t N_STACK;
+static value_t *Stack;
+static uint32_t SP = 0;
+static uint32_t curr_frame = 0;
+#define PUSH(v) (Stack[SP++] = (v))
+#define POP() (Stack[--SP])
+#define POPN(n) (SP-=(n))
+
+#define N_GC_HANDLES 1024
+static value_t *GCHandleStack[N_GC_HANDLES];
+static uint32_t N_GCHND = 0;
+
+value_t FL_NIL, FL_T, FL_F, FL_EOF, QUOTE;
+value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
+value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
+value_t printwidthsym, printreadablysym, printprettysym, printlengthsym;
+value_t printlevelsym, builtins_table_sym;
+
+static value_t NIL, LAMBDA, IF, TRYCATCH;
+static value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
+
+static value_t pairsym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym;
+static value_t definesym, defmacrosym, forsym, setqsym;
+static value_t tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym, fnsym;
+// for reading characters
+static value_t nulsym, alarmsym, backspacesym, tabsym, linefeedsym, newlinesym;
+static value_t vtabsym, pagesym, returnsym, escsym, spacesym, deletesym;
+
+static value_t apply_cl(uint32_t nargs);
+static value_t *alloc_words(int n);
+static value_t relocate(value_t v);
+
+static fl_readstate_t *readstate = NULL;
+
+static void free_readstate(fl_readstate_t *rs)
+{+ htable_free(&rs->backrefs);
+ htable_free(&rs->gensyms);
+}
+
+static unsigned char *fromspace;
+static unsigned char *tospace;
+static unsigned char *curheap;
+static unsigned char *lim;
+static uint32_t heapsize;//bytes
+static uint32_t *consflags;
+
+// error utilities ------------------------------------------------------------
+
+// saved execution state for an unwind target
+fl_exception_context_t *fl_ctx = NULL;
+uint32_t fl_throwing_frame=0; // active frame when exception was thrown
+value_t fl_lasterror;
+
+#define FL_TRY \
+ fl_exception_context_t _ctx; int l__tr, l__ca; \
+ _ctx.sp=SP; _ctx.frame=curr_frame; _ctx.rdst=readstate; _ctx.prev=fl_ctx; \
+ _ctx.ngchnd = N_GCHND; fl_ctx = &_ctx; \
+ if (!setjmp(_ctx.buf)) \
+ for (l__tr=1; l__tr; l__tr=0, (void)(fl_ctx=fl_ctx->prev))
+
+#define FL_CATCH \
+ else \
+ for(l__ca=1; l__ca; l__ca=0, \
+ fl_lasterror=FL_NIL,fl_throwing_frame=0,SP=_ctx.sp,curr_frame=_ctx.frame)
+
+void fl_savestate(fl_exception_context_t *_ctx)
+{+ _ctx->sp = SP;
+ _ctx->frame = curr_frame;
+ _ctx->rdst = readstate;
+ _ctx->prev = fl_ctx;
+ _ctx->ngchnd = N_GCHND;
+}
+
+void fl_restorestate(fl_exception_context_t *_ctx)
+{+ fl_lasterror = FL_NIL;
+ fl_throwing_frame = 0;
+ SP = _ctx->sp;
+ curr_frame = _ctx->frame;
+}
+
+void fl_raise(value_t e)
+{+ fl_lasterror = e;
+ // unwind read state
+ while (readstate != fl_ctx->rdst) {+ free_readstate(readstate);
+ readstate = readstate->prev;
+ }
+ if (fl_throwing_frame == 0)
+ fl_throwing_frame = curr_frame;
+ N_GCHND = fl_ctx->ngchnd;
+ fl_exception_context_t *thisctx = fl_ctx;
+ if (fl_ctx->prev) // don't throw past toplevel
+ fl_ctx = fl_ctx->prev;
+ longjmp(thisctx->buf, 1);
+}
+
+static value_t make_error_msg(char *format, va_list args)
+{+ char msgbuf[512];
+ vsnprintf(msgbuf, sizeof(msgbuf), format, args);
+ return string_from_cstr(msgbuf);
+}
+
+void lerrorf(value_t e, char *format, ...)
+{+ va_list args;
+ PUSH(e);
+ va_start(args, format);
+ value_t msg = make_error_msg(format, args);
+ va_end(args);
+
+ e = POP();
+ fl_raise(fl_list2(e, msg));
+}
+
+void lerror(value_t e, const char *msg)
+{+ PUSH(e);
+ value_t m = cvalue_static_cstring(msg);
+ e = POP();
+ fl_raise(fl_list2(e, m));
+}
+
+void type_error(char *fname, char *expected, value_t got)
+{+ fl_raise(fl_listn(4, TypeError, symbol(fname), symbol(expected), got));
+}
+
+void bounds_error(char *fname, value_t arr, value_t ind)
+{+ fl_raise(fl_listn(4, BoundsError, symbol(fname), arr, ind));
+}
+
+// safe cast operators --------------------------------------------------------
+
+#define isstring fl_isstring
+#define SAFECAST_OP(type,ctype,cnvt) \
+ctype to##type(value_t v, char *fname) \
+{ \+ if (is##type(v)) \
+ return (ctype)cnvt(v); \
+ type_error(fname, #type, v); \
+}
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol,symbol_t*,ptr)
+SAFECAST_OP(fixnum,fixnum_t, numval)
+SAFECAST_OP(cvalue,cvalue_t*,ptr)
+SAFECAST_OP(string,char*, cvalue_data)
+#undef isstring
+
+// symbol table ---------------------------------------------------------------
+
+symbol_t *symtab = NULL;
+
+int fl_is_keyword_name(char *str, size_t len)
+{+ return ((str[0] == ':' || str[len-1] == ':') && str[1] != '\0');
+}
+
+static symbol_t *mk_symbol(char *str)
+{+ symbol_t *sym;
+ size_t len = strlen(str);
+
+ sym = (symbol_t*)malloc(sizeof(symbol_t)-sizeof(void*) + len + 1);
+ assert(((uptrint_t)sym & 0x7) == 0); // make sure malloc aligns 8
+ sym->left = sym->right = NULL;
+ sym->flags = 0;
+ if (fl_is_keyword_name(str, len)) {+ value_t s = tagptr(sym, TAG_SYM);
+ setc(s, s);
+ sym->flags |= 0x2;
+ }
+ else {+ sym->binding = UNBOUND;
+ }
+ sym->type = sym->dlcache = NULL;
+ sym->hash = memhash32(str, len)^0xAAAAAAAA;
+ strcpy(&sym->name[0], str);
+ return sym;
+}
+
+static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
+{+ int x;
+
+ while(*ptree != NULL) {+ x = strcmp(str, (*ptree)->name);
+ if (x == 0)
+ return ptree;
+ if (x < 0)
+ ptree = &(*ptree)->left;
+ else
+ ptree = &(*ptree)->right;
+ }
+ return ptree;
+}
+
+value_t symbol(char *str)
+{+ symbol_t **pnode;
+
+ pnode = symtab_lookup(&symtab, str);
+ if (*pnode == NULL)
+ *pnode = mk_symbol(str);
+ return tagptr(*pnode, TAG_SYM);
+}
+
+static uint32_t _gensym_ctr=0;
+// two static buffers for gensym printing so there can be two
+// gensym names available at a time, mostly for compare()
+static char gsname[2][16];
+static int gsnameno=0;
+value_t fl_gensym(value_t *args, uint32_t nargs)
+{+ argcount("gensym", nargs, 0);+ (void)args;
+ gensym_t *gs = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
+ gs->id = _gensym_ctr++;
+ gs->binding = UNBOUND;
+ gs->isconst = 0;
+ gs->type = NULL;
+ return tagptr(gs, TAG_SYM);
+}
+
+int fl_isgensym(value_t v)
+{+ return isgensym(v);
+}
+
+static value_t fl_gensymp(value_t *args, u_int32_t nargs)
+{+ argcount("gensym?", nargs, 1);+ return isgensym(args[0]) ? FL_T : FL_F;
+}
+
+char *symbol_name(value_t v)
+{+ if (ismanaged(v)) {+ gensym_t *gs = (gensym_t*)ptr(v);
+ gsnameno = 1-gsnameno;
+ char *n = uint2str(gsname[gsnameno]+1, sizeof(gsname[0])-1, gs->id, 10);
+ *(--n) = 'g';
+ return n;
+ }
+ return ((symbol_t*)ptr(v))->name;
+}
+
+// conses ---------------------------------------------------------------------
+
+void gc(int mustgrow);
+
+static value_t mk_cons(void)
+{+ cons_t *c;
+
+ if (__unlikely(curheap > lim))
+ gc(0);
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+static value_t *alloc_words(int n)
+{+ value_t *first;
+
+ assert(n > 0);
+ n = LLT_ALIGN(n, 2); // only allocate multiples of 2 words
+ if (__unlikely((value_t*)curheap > ((value_t*)lim)+2-n)) {+ gc(0);
+ while ((value_t*)curheap > ((value_t*)lim)+2-n) {+ gc(1);
+ }
+ }
+ first = (value_t*)curheap;
+ curheap += (n*sizeof(value_t));
+ return first;
+}
+
+// allocate n consecutive conses
+#define cons_reserve(n) tagptr(alloc_words((n)*2), TAG_CONS)
+
+#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace))
+#define ismarked(c) bitvector_get(consflags, cons_index(c))
+#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
+#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
+
+static value_t the_empty_vector;
+
+value_t alloc_vector(size_t n, int init)
+{+ if (n == 0) return the_empty_vector;
+ value_t *c = alloc_words(n+1);
+ value_t v = tagptr(c, TAG_VECTOR);
+ vector_setsize(v, n);
+ if (init) {+ unsigned int i;
+ for(i=0; i < n; i++)
+ vector_elt(v, i) = FL_UNSPECIFIED;
+ }
+ return v;
+}
+
+// cvalues --------------------------------------------------------------------
+
+#include "cvalues.c"
+#include "types.c"
+
+// print ----------------------------------------------------------------------
+
+static int isnumtok(char *tok, value_t *pval);
+static inline int symchar(char c);
+
+#include "print.c"
+
+// collector ------------------------------------------------------------------
+
+void fl_gc_handle(value_t *pv)
+{+ if (N_GCHND >= N_GC_HANDLES)
+ lerror(MemoryError, "out of gc handles");
+ GCHandleStack[N_GCHND++] = pv;
+}
+
+void fl_free_gc_handles(uint32_t n)
+{+ assert(N_GCHND >= n);
+ N_GCHND -= n;
+}
+
+static value_t relocate(value_t v)
+{+ value_t a, d, nc, first, *pcdr;
+ uptrint_t t = tag(v);
+
+ if (t == TAG_CONS) {+ // iterative implementation allows arbitrarily long cons chains
+ pcdr = &first;
+ do {+ if ((a=car_(v)) == TAG_FWD) {+ *pcdr = cdr_(v);
+ return first;
+ }
+ *pcdr = nc = tagptr((cons_t*)curheap, TAG_CONS);
+ curheap += sizeof(cons_t);
+ d = cdr_(v);
+ car_(v) = TAG_FWD; cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ pcdr = &cdr_(nc);
+ v = d;
+ } while (iscons(v));
+ *pcdr = (d==NIL) ? NIL : relocate(d);
+ return first;
+ }
+
+ if ((t&3) == 0) return v;
+ if (!ismanaged(v)) return v;
+ if (isforwarded(v)) return forwardloc(v);
+
+ if (t == TAG_VECTOR) {+ // N.B.: 0-length vectors secretly have space for a first element
+ size_t i, sz = vector_size(v);
+ if (vector_elt(v,-1) & 0x1) {+ // grown vector
+ nc = relocate(vector_elt(v,0));
+ forward(v, nc);
+ }
+ else {+ nc = tagptr(alloc_words(sz+1), TAG_VECTOR);
+ vector_setsize(nc, sz);
+ a = vector_elt(v,0);
+ forward(v, nc);
+ if (sz > 0) {+ vector_elt(nc,0) = relocate(a);
+ for(i=1; i < sz; i++)
+ vector_elt(nc,i) = relocate(vector_elt(v,i));
+ }
+ }
+ return nc;
+ }
+ else if (t == TAG_CPRIM) {+ cprim_t *pcp = (cprim_t*)ptr(v);
+ size_t nw = CPRIM_NWORDS-1+NWORDS(cp_class(pcp)->size);
+ cprim_t *ncp = (cprim_t*)alloc_words(nw);
+ while (nw--)
+ ((value_t*)ncp)[nw] = ((value_t*)pcp)[nw];
+ nc = tagptr(ncp, TAG_CPRIM);
+ forward(v, nc);
+ return nc;
+ }
+ else if (t == TAG_CVALUE) {+ return cvalue_relocate(v);
+ }
+ else if (t == TAG_FUNCTION) {+ function_t *fn = (function_t*)ptr(v);
+ function_t *nfn = (function_t*)alloc_words(4);
+ nfn->bcode = fn->bcode;
+ nfn->vals = fn->vals;
+ nc = tagptr(nfn, TAG_FUNCTION);
+ forward(v, nc);
+ nfn->env = relocate(fn->env);
+ nfn->vals = relocate(nfn->vals);
+ nfn->bcode = relocate(nfn->bcode);
+ assert(!ismanaged(fn->name));
+ nfn->name = fn->name;
+ return nc;
+ }
+ else if (t == TAG_SYM) {+ gensym_t *gs = (gensym_t*)ptr(v);
+ gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
+ ng->id = gs->id;
+ ng->binding = gs->binding;
+ ng->isconst = 0;
+ nc = tagptr(ng, TAG_SYM);
+ forward(v, nc);
+ if (ng->binding != UNBOUND)
+ ng->binding = relocate(ng->binding);
+ return nc;
+ }
+ return v;
+}
+
+value_t relocate_lispvalue(value_t v)
+{+ return relocate(v);
+}
+
+static void trace_globals(symbol_t *root)
+{+ while (root != NULL) {+ if (root->binding != UNBOUND)
+ root->binding = relocate(root->binding);
+ trace_globals(root->left);
+ root = root->right;
+ }
+}
+
+static value_t memory_exception_value;
+
+void gc(int mustgrow)
+{+ static int grew = 0;
+ void *temp;
+ uint32_t i, f, top;
+ fl_readstate_t *rs;
+
+ curheap = tospace;
+ if (grew)
+ lim = curheap+heapsize*2-sizeof(cons_t);
+ else
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ if (fl_throwing_frame > curr_frame) {+ top = fl_throwing_frame - 4;
+ f = Stack[fl_throwing_frame-4];
+ }
+ else {+ top = SP;
+ f = curr_frame;
+ }
+ while (1) {+ for (i=f; i < top; i++)
+ Stack[i] = relocate(Stack[i]);
+ if (f == 0) break;
+ top = f - 4;
+ f = Stack[f-4];
+ }
+ for (i=0; i < N_GCHND; i++)
+ *GCHandleStack[i] = relocate(*GCHandleStack[i]);
+ trace_globals(symtab);
+ relocate_typetable();
+ rs = readstate;
+ while (rs) {+ value_t ent;
+ for(i=0; i < rs->backrefs.size; i++) {+ ent = (value_t)rs->backrefs.table[i];
+ if (ent != (value_t)HT_NOTFOUND)
+ rs->backrefs.table[i] = (void*)relocate(ent);
+ }
+ for(i=0; i < rs->gensyms.size; i++) {+ ent = (value_t)rs->gensyms.table[i];
+ if (ent != (value_t)HT_NOTFOUND)
+ rs->gensyms.table[i] = (void*)relocate(ent);
+ }
+ rs->source = relocate(rs->source);
+ rs = rs->prev;
+ }
+ fl_lasterror = relocate(fl_lasterror);
+ memory_exception_value = relocate(memory_exception_value);
+ the_empty_vector = relocate(the_empty_vector);
+
+ sweep_finalizers();
+
+#ifdef VERBOSEGC
+ printf("GC: found %d/%d live conses\n",+ (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t));
+#endif
+ temp = tospace;
+ tospace = fromspace;
+ fromspace = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {+ temp = LLT_REALLOC(tospace, heapsize*2);
+ if (temp == NULL)
+ fl_raise(memory_exception_value);
+ tospace = temp;
+ if (grew) {+ heapsize*=2;
+ temp = bitvector_resize(consflags, 0, heapsize/sizeof(cons_t), 1);
+ if (temp == NULL)
+ fl_raise(memory_exception_value);
+ consflags = (uint32_t*)temp;
+ }
+ grew = !grew;
+ }
+ if (curheap > lim) // all data was live
+ gc(0);
+}
+
+static void grow_stack()
+{+ size_t newsz = N_STACK + (N_STACK>>1);
+ value_t *ns = realloc(Stack, newsz*sizeof(value_t));
+ if (ns == NULL)
+ lerror(MemoryError, "stack overflow");
+ Stack = ns;
+ N_STACK = newsz;
+}
+
+// utils ----------------------------------------------------------------------
+
+// apply function with n args on the stack
+static value_t _applyn(uint32_t n)
+{+ value_t f = Stack[SP-n-1];
+ uint32_t saveSP = SP;
+ value_t v;
+ if (iscbuiltin(f)) {+ v = ((builtin_t*)ptr(f))[3](&Stack[SP-n], n);
+ }
+ else if (isfunction(f)) {+ v = apply_cl(n);
+ }
+ else if (isbuiltin(f)) {+ value_t tab = symbol_value(builtins_table_sym);
+ Stack[SP-n-1] = vector_elt(tab, uintval(f));
+ v = apply_cl(n);
+ }
+ else {+ type_error("apply", "function", f);+ }
+ SP = saveSP;
+ return v;
+}
+
+value_t fl_apply(value_t f, value_t l)
+{+ value_t v = l;
+ uint32_t n = SP;
+
+ PUSH(f);
+ while (iscons(v)) {+ if (SP >= N_STACK)
+ grow_stack();
+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ n = SP - n - 1;
+ v = _applyn(n);
+ POPN(n+1);
+ return v;
+}
+
+value_t fl_applyn(uint32_t n, value_t f, ...)
+{+ va_list ap;
+ va_start(ap, f);
+ size_t i;
+
+ PUSH(f);
+ while (SP+n > N_STACK)
+ grow_stack();
+ for(i=0; i < n; i++) {+ value_t a = va_arg(ap, value_t);
+ PUSH(a);
+ }
+ value_t v = _applyn(n);
+ POPN(n+1);
+ va_end(ap);
+ return v;
+}
+
+value_t fl_listn(size_t n, ...)
+{+ va_list ap;
+ va_start(ap, n);
+ uint32_t si = SP;
+ size_t i;
+
+ while (SP+n > N_STACK)
+ grow_stack();
+ for(i=0; i < n; i++) {+ value_t a = va_arg(ap, value_t);
+ PUSH(a);
+ }
+ cons_t *c = (cons_t*)alloc_words(n*2);
+ cons_t *l = c;
+ for(i=0; i < n; i++) {+ c->car = Stack[si++];
+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
+ }
+ (c-1)->cdr = NIL;
+
+ POPN(n);
+ va_end(ap);
+ return tagptr(l, TAG_CONS);
+}
+
+value_t fl_list2(value_t a, value_t b)
+{+ PUSH(a);
+ PUSH(b);
+ cons_t *c = (cons_t*)alloc_words(4);
+ b = POP();
+ a = POP();
+ c[0].car = a;
+ c[0].cdr = tagptr(c+1, TAG_CONS);
+ c[1].car = b;
+ c[1].cdr = NIL;
+ return tagptr(c, TAG_CONS);
+}
+
+value_t fl_cons(value_t a, value_t b)
+{+ PUSH(a);
+ PUSH(b);
+ value_t c = mk_cons();
+ cdr_(c) = POP();
+ car_(c) = POP();
+ return c;
+}
+
+int fl_isnumber(value_t v)
+{+ if (isfixnum(v)) return 1;
+ if (iscprim(v)) {+ cprim_t *c = (cprim_t*)ptr(v);
+ return c->type != wchartype;
+ }
+ return 0;
+}
+
+// read -----------------------------------------------------------------------
+
+#include "read.c"
+
+// equal ----------------------------------------------------------------------
+
+#include "equal.c"
+
+// eval -----------------------------------------------------------------------
+
+#define list(a,n) _list((a),(n),0)
+
+static value_t _list(value_t *args, uint32_t nargs, int star)
+{+ cons_t *c;
+ uint32_t i;
+ value_t v;
+ v = cons_reserve(nargs);
+ c = (cons_t*)ptr(v);
+ for(i=0; i < nargs; i++) {+ c->car = args[i];
+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
+ }
+ if (star)
+ (c-2)->cdr = (c-1)->car;
+ else
+ (c-1)->cdr = NIL;
+ return v;
+}
+
+static value_t copy_list(value_t L)
+{+ if (!iscons(L))
+ return NIL;
+ PUSH(NIL);
+ PUSH(L);
+ value_t *plcons = &Stack[SP-2];
+ value_t *pL = &Stack[SP-1];
+ value_t c;
+ c = mk_cons(); PUSH(c); // save first cons
+ car_(c) = car_(*pL);
+ cdr_(c) = NIL;
+ *plcons = c;
+ *pL = cdr_(*pL);
+ while (iscons(*pL)) {+ c = mk_cons();
+ car_(c) = car_(*pL);
+ cdr_(c) = NIL;
+ cdr_(*plcons) = c;
+ *plcons = c;
+ *pL = cdr_(*pL);
+ }
+ c = POP(); // first cons
+ POPN(2);
+ return c;
+}
+
+static value_t do_trycatch()
+{+ uint32_t saveSP = SP;
+ value_t v;
+ value_t thunk = Stack[SP-2];
+ Stack[SP-2] = Stack[SP-1];
+ Stack[SP-1] = thunk;
+
+ FL_TRY {+ v = apply_cl(0);
+ }
+ FL_CATCH {+ v = Stack[saveSP-2];
+ PUSH(v);
+ PUSH(fl_lasterror);
+ v = apply_cl(1);
+ }
+ SP = saveSP;
+ return v;
+}
+
+/*
+ argument layout on stack is
+ |--required args--|--opt args--|--kw args--|--rest args...
+*/
+static uint32_t process_keys(value_t kwtable,
+ uint32_t nreq, uint32_t nkw, uint32_t nopt,
+ uint32_t bp, uint32_t nargs, int va)
+{+ uint32_t extr = nopt+nkw;
+ uint32_t ntot = nreq+extr;
+ value_t args[extr], v;
+ uint32_t i, a = 0, nrestargs;
+ value_t s1 = Stack[SP-1];
+ value_t s2 = Stack[SP-2];
+ value_t s4 = Stack[SP-4];
+ value_t s5 = Stack[SP-5];
+ if (nargs < nreq)
+ lerror(ArgError, "apply: too few arguments");
+ for (i=0; i < extr; i++) args[i] = UNBOUND;
+ for (i=nreq; i < nargs; i++) {+ v = Stack[bp+i];
+ if (issymbol(v) && iskeyword((symbol_t*)ptr(v)))
+ break;
+ if (a >= nopt)
+ goto no_kw;
+ args[a++] = v;
+ }
+ if (i >= nargs) goto no_kw;
+ // now process keywords
+ uptrint_t n = vector_size(kwtable)/2;
+ do {+ i++;
+ if (i >= nargs)
+ lerrorf(ArgError, "keyword %s requires an argument",
+ symbol_name(v));
+ value_t hv = fixnum(((symbol_t*)ptr(v))->hash);
+ uptrint_t x = 2*(labs(numval(hv)) % n);
+ if (vector_elt(kwtable, x) == v) {+ uptrint_t idx = numval(vector_elt(kwtable, x+1));
+ assert(idx < nkw);
+ idx += nopt;
+ if (args[idx] == UNBOUND) {+ // if duplicate key, keep first value
+ args[idx] = Stack[bp+i];
+ }
+ }
+ else {+ lerrorf(ArgError, "unsupported keyword %s", symbol_name(v));
+ }
+ i++;
+ if (i >= nargs) break;
+ v = Stack[bp+i];
+ } while (issymbol(v) && iskeyword((symbol_t*)ptr(v)));
+ no_kw:
+ nrestargs = nargs - i;
+ if (!va && nrestargs > 0)
+ lerror(ArgError, "apply: too many arguments");
+ nargs = ntot + nrestargs;
+ if (nrestargs)
+ memmove(&Stack[bp+ntot], &Stack[bp+i], nrestargs*sizeof(value_t));
+ memcpy(&Stack[bp+nreq], args, extr*sizeof(value_t));
+ SP = bp + nargs;
+ assert(SP < N_STACK-5);
+ PUSH(s5);
+ PUSH(s4);
+ PUSH(nargs);
+ PUSH(s2);
+ PUSH(s1);
+ curr_frame = SP;
+ return nargs;
+}
+
+#if BYTE_ORDER == BIG_ENDIAN
+#define GET_INT32(a) \
+ ((int32_t) \
+ ((((int32_t)a[0])<<0) | \
+ (((int32_t)a[1])<<8) | \
+ (((int32_t)a[2])<<16) | \
+ (((int32_t)a[3])<<24)))
+#define GET_INT16(a) \
+ ((int16_t) \
+ ((((int16_t)a[0])<<0) | \
+ (((int16_t)a[1])<<8)))
+#define PUT_INT32(a,i) (*(int32_t*)(a) = bswap_32((int32_t)(i)))
+#else
+#define GET_INT32(a) (*(int32_t*)a)
+#define GET_INT16(a) (*(int16_t*)a)
+#define PUT_INT32(a,i) (*(int32_t*)(a) = (int32_t)(i))
+#endif
+#define SWAP_INT32(a) (*(int32_t*)(a) = bswap_32(*(int32_t*)(a)))
+#define SWAP_INT16(a) (*(int16_t*)(a) = bswap_16(*(int16_t*)(a)))
+
+#ifdef USE_COMPUTED_GOTO
+#define OP(x) L_##x:
+#define NEXT_OP goto *vm_labels[*ip++]
+#else
+#define OP(x) case x:
+#define NEXT_OP goto next_op
+#endif
+
+/*
+ stack on entry: <func> <nargs args...>
+ caller's responsibility:
+ - put the stack in this state
+ - provide arg count
+ - respect tail position
+ - restore SP
+
+ callee's responsibility:
+ - check arg counts
+ - allocate vararg array
+ - push closed env, set up new environment
+*/
+static value_t apply_cl(uint32_t nargs)
+{+ VM_LABELS;
+ VM_APPLY_LABELS;
+ uint32_t top_frame = curr_frame;
+ // frame variables
+ uint32_t n=0, captured;
+ uint32_t bp;
+ const uint8_t *ip;
+ fixnum_t s, hi;
+
+ // temporary variables (not necessary to preserve across calls)
+#ifndef USE_COMPUTED_GOTO
+ uint32_t op;
+#endif
+ uint32_t i;
+ symbol_t *sym;
+ static cons_t *c;
+ static value_t *pv;
+ static int64_t accum;
+ static value_t func, v, e;
+
+ apply_cl_top:
+ captured = 0;
+ func = Stack[SP-nargs-1];
+ ip = cv_data((cvalue_t*)ptr(fn_bcode(func)));
+ assert(!ismanaged((uptrint_t)ip));
+ while (SP+GET_INT32(ip) > N_STACK) {+ grow_stack();
+ }
+ ip += 4;
+
+ bp = SP-nargs;
+ PUSH(fn_env(func));
+ PUSH(curr_frame);
+ PUSH(nargs);
+ SP++;//PUSH(0); //ip
+ PUSH(0); //captured?
+ curr_frame = SP;
+
+ {+#ifdef USE_COMPUTED_GOTO
+ {+ NEXT_OP;
+#else
+ next_op:
+ op = *ip++;
+ dispatch:
+ switch (op) {+#endif
+ OP(OP_ARGC)
+ n = *ip++;
+ do_argc:
+ if (nargs != n) {+ if (nargs > n)
+ lerror(ArgError, "apply: too many arguments");
+ else
+ lerror(ArgError, "apply: too few arguments");
+ }
+ NEXT_OP;
+ OP(OP_VARGC)
+ i = *ip++;
+ do_vargc:
+ s = (fixnum_t)nargs - (fixnum_t)i;
+ if (s > 0) {+ v = list(&Stack[bp+i], s);
+ Stack[bp+i] = v;
+ if (s > 1) {+ Stack[bp+i+1] = Stack[bp+nargs+0];
+ Stack[bp+i+2] = Stack[bp+nargs+1];
+ Stack[bp+i+3] = i+1;
+ //Stack[bp+i+4] = 0;
+ Stack[bp+i+5] = 0;
+ SP = bp+i+6;
+ curr_frame = SP;
+ }
+ }
+ else if (s < 0) {+ lerror(ArgError, "apply: too few arguments");
+ }
+ else {+ PUSH(0);
+ Stack[SP-3] = i+1;
+ Stack[SP-4] = Stack[SP-5];
+ Stack[SP-5] = Stack[SP-6];
+ Stack[SP-6] = NIL;
+ curr_frame = SP;
+ }
+ nargs = i+1;
+ NEXT_OP;
+ OP(OP_LARGC)
+ n = GET_INT32(ip); ip+=4;
+ goto do_argc;
+ OP(OP_LVARGC)
+ i = GET_INT32(ip); ip+=4;
+ goto do_vargc;
+ OP(OP_BRBOUND)
+ i = GET_INT32(ip); ip+=4;
+ if (captured)
+ v = vector_elt(Stack[bp], i);
+ else
+ v = Stack[bp+i];
+ if (v != UNBOUND) PUSH(FL_T);
+ else PUSH(FL_F);
+ NEXT_OP;
+ OP(OP_DUP) SP++; Stack[SP-1] = Stack[SP-2]; NEXT_OP;
+ OP(OP_POP) POPN(1); NEXT_OP;
+ OP(OP_TCALL)
+ n = *ip++; // nargs
+ do_tcall:
+ func = Stack[SP-n-1];
+ if (tag(func) == TAG_FUNCTION) {+ if (func > (N_BUILTINS<<3)) {+ curr_frame = Stack[curr_frame-4];
+ for(s=-1; s < (fixnum_t)n; s++)
+ Stack[bp+s] = Stack[SP-n+s];
+ SP = bp+n;
+ nargs = n;
+ goto apply_cl_top;
+ }
+ else {+ i = uintval(func);
+ if (i <= OP_ASET) {+ s = builtin_arg_counts[i];
+ if (s >= 0)
+ argcount(builtin_names[i], n, s);
+ else if (s != ANYARGS && (signed)n < -s)
+ argcount(builtin_names[i], n, -s);
+ // remove function arg
+ for(s=SP-n-1; s < (int)SP-1; s++)
+ Stack[s] = Stack[s+1];
+ SP--;
+#ifdef USE_COMPUTED_GOTO
+ if (i == OP_APPLY)
+ goto apply_tapply;
+ goto *vm_apply_labels[i];
+#else
+ switch (i) {+ case OP_LIST: goto apply_list;
+ case OP_VECTOR: goto apply_vector;
+ case OP_APPLY: goto apply_tapply;
+ case OP_ADD: goto apply_add;
+ case OP_SUB: goto apply_sub;
+ case OP_MUL: goto apply_mul;
+ case OP_DIV: goto apply_div;
+ default:
+ op = (uint8_t)i;
+ goto dispatch;
+ }
+#endif
+ }
+ }
+ }
+ else if (iscbuiltin(func)) {+ s = SP;
+ v = ((builtin_t)(((void**)ptr(func))[3]))(&Stack[SP-n], n);
+ SP = s-n;
+ Stack[SP-1] = v;
+ NEXT_OP;
+ }
+ type_error("apply", "function", func);+ // WARNING: repeated code ahead
+ OP(OP_CALL)
+ n = *ip++; // nargs
+ do_call:
+ func = Stack[SP-n-1];
+ if (tag(func) == TAG_FUNCTION) {+ if (func > (N_BUILTINS<<3)) {+ Stack[curr_frame-2] = (uptrint_t)ip;
+ nargs = n;
+ goto apply_cl_top;
+ }
+ else {+ i = uintval(func);
+ if (i <= OP_ASET) {+ s = builtin_arg_counts[i];
+ if (s >= 0)
+ argcount(builtin_names[i], n, s);
+ else if (s != ANYARGS && (signed)n < -s)
+ argcount(builtin_names[i], n, -s);
+ // remove function arg
+ for(s=SP-n-1; s < (int)SP-1; s++)
+ Stack[s] = Stack[s+1];
+ SP--;
+#ifdef USE_COMPUTED_GOTO
+ goto *vm_apply_labels[i];
+#else
+ switch (i) {+ case OP_LIST: goto apply_list;
+ case OP_VECTOR: goto apply_vector;
+ case OP_APPLY: goto apply_apply;
+ case OP_ADD: goto apply_add;
+ case OP_SUB: goto apply_sub;
+ case OP_MUL: goto apply_mul;
+ case OP_DIV: goto apply_div;
+ default:
+ op = (uint8_t)i;
+ goto dispatch;
+ }
+#endif
+ }
+ }
+ }
+ else if (iscbuiltin(func)) {+ s = SP;
+ v = ((builtin_t)(((void**)ptr(func))[3]))(&Stack[SP-n], n);
+ SP = s-n;
+ Stack[SP-1] = v;
+ NEXT_OP;
+ }
+ type_error("apply", "function", func);+ OP(OP_TCALLL) n = GET_INT32(ip); ip+=4; goto do_tcall;
+ OP(OP_CALLL) n = GET_INT32(ip); ip+=4; goto do_call;
+ OP(OP_JMP) ip += (ptrint_t)GET_INT16(ip); NEXT_OP;
+ OP(OP_BRF)
+ v = POP();
+ if (v == FL_F) ip += (ptrint_t)GET_INT16(ip);
+ else ip += 2;
+ NEXT_OP;
+ OP(OP_BRT)
+ v = POP();
+ if (v != FL_F) ip += (ptrint_t)GET_INT16(ip);
+ else ip += 2;
+ NEXT_OP;
+ OP(OP_JMPL) ip += (ptrint_t)GET_INT32(ip); NEXT_OP;
+ OP(OP_BRFL)
+ v = POP();
+ if (v == FL_F) ip += (ptrint_t)GET_INT32(ip);
+ else ip += 4;
+ NEXT_OP;
+ OP(OP_BRTL)
+ v = POP();
+ if (v != FL_F) ip += (ptrint_t)GET_INT32(ip);
+ else ip += 4;
+ NEXT_OP;
+ OP(OP_BRNE)
+ if (Stack[SP-2] != Stack[SP-1]) ip += (ptrint_t)GET_INT16(ip);
+ else ip += 2;
+ POPN(2);
+ NEXT_OP;
+ OP(OP_BRNEL)
+ if (Stack[SP-2] != Stack[SP-1]) ip += (ptrint_t)GET_INT32(ip);
+ else ip += 4;
+ POPN(2);
+ NEXT_OP;
+ OP(OP_BRNN)
+ v = POP();
+ if (v != NIL) ip += (ptrint_t)GET_INT16(ip);
+ else ip += 2;
+ NEXT_OP;
+ OP(OP_BRNNL)
+ v = POP();
+ if (v != NIL) ip += (ptrint_t)GET_INT32(ip);
+ else ip += 4;
+ NEXT_OP;
+ OP(OP_BRN)
+ v = POP();
+ if (v == NIL) ip += (ptrint_t)GET_INT16(ip);
+ else ip += 2;
+ NEXT_OP;
+ OP(OP_BRNL)
+ v = POP();
+ if (v == NIL) ip += (ptrint_t)GET_INT32(ip);
+ else ip += 4;
+ NEXT_OP;
+ OP(OP_RET)
+ v = POP();
+ SP = curr_frame;
+ curr_frame = Stack[SP-4];
+ if (curr_frame == top_frame) return v;
+ SP -= (5+nargs);
+ captured = Stack[curr_frame-1];
+ ip = (uint8_t*)Stack[curr_frame-2];
+ nargs = Stack[curr_frame-3];
+ bp = curr_frame - 5 - nargs;
+ Stack[SP-1] = v;
+ NEXT_OP;
+
+ OP(OP_EQ)
+ Stack[SP-2] = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F);
+ POPN(1); NEXT_OP;
+ OP(OP_EQV)
+ if (Stack[SP-2] == Stack[SP-1]) {+ v = FL_T;
+ }
+ else if (!leafp(Stack[SP-2]) || !leafp(Stack[SP-1])) {+ v = FL_F;
+ }
+ else {+ v = (compare_(Stack[SP-2], Stack[SP-1], 1)==0 ? FL_T : FL_F);
+ }
+ Stack[SP-2] = v; POPN(1);
+ NEXT_OP;
+ OP(OP_EQUAL)
+ if (Stack[SP-2] == Stack[SP-1]) {+ v = FL_T;
+ }
+ else {+ v = (compare_(Stack[SP-2], Stack[SP-1], 1)==0 ? FL_T : FL_F);
+ }
+ Stack[SP-2] = v; POPN(1);
+ NEXT_OP;
+ OP(OP_PAIRP)
+ Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_T : FL_F); NEXT_OP;
+ OP(OP_ATOMP)
+ Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_F : FL_T); NEXT_OP;
+ OP(OP_NOT)
+ Stack[SP-1] = ((Stack[SP-1]==FL_F) ? FL_T : FL_F); NEXT_OP;
+ OP(OP_NULLP)
+ Stack[SP-1] = ((Stack[SP-1]==NIL) ? FL_T : FL_F); NEXT_OP;
+ OP(OP_BOOLEANP)
+ v = Stack[SP-1];
+ Stack[SP-1] = ((v == FL_T || v == FL_F) ? FL_T:FL_F); NEXT_OP;
+ OP(OP_SYMBOLP)
+ Stack[SP-1] = (issymbol(Stack[SP-1]) ? FL_T : FL_F); NEXT_OP;
+ OP(OP_NUMBERP)
+ v = Stack[SP-1];
+ Stack[SP-1] = (fl_isnumber(v) ? FL_T:FL_F); NEXT_OP;
+ OP(OP_FIXNUMP)
+ Stack[SP-1] = (isfixnum(Stack[SP-1]) ? FL_T : FL_F); NEXT_OP;
+ OP(OP_BOUNDP)
+ sym = tosymbol(Stack[SP-1], "bound?");
+ Stack[SP-1] = ((sym->binding == UNBOUND) ? FL_F : FL_T);
+ NEXT_OP;
+ OP(OP_BUILTINP)
+ v = Stack[SP-1];
+ Stack[SP-1] = (isbuiltin(v) || iscbuiltin(v)) ? FL_T : FL_F;
+ NEXT_OP;
+ OP(OP_FUNCTIONP)
+ v = Stack[SP-1];
+ Stack[SP-1] = ((tag(v)==TAG_FUNCTION &&
+ (uintval(v)<=OP_ASET || v>(N_BUILTINS<<3))) ||
+ iscbuiltin(v)) ? FL_T : FL_F;
+ NEXT_OP;
+ OP(OP_VECTORP)
+ Stack[SP-1] = (isvector(Stack[SP-1]) ? FL_T : FL_F); NEXT_OP;
+
+ OP(OP_CONS)
+ if (curheap > lim)
+ gc(0);
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ c->car = Stack[SP-2];
+ c->cdr = Stack[SP-1];
+ Stack[SP-2] = tagptr(c, TAG_CONS);
+ POPN(1); NEXT_OP;
+ OP(OP_CAR)
+ v = Stack[SP-1];
+ if (!iscons(v)) type_error("car", "cons", v);+ Stack[SP-1] = car_(v);
+ NEXT_OP;
+ OP(OP_CDR)
+ v = Stack[SP-1];
+ if (!iscons(v)) type_error("cdr", "cons", v);+ Stack[SP-1] = cdr_(v);
+ NEXT_OP;
+ OP(OP_CADR)
+ v = Stack[SP-1];
+ if (!iscons(v)) type_error("cdr", "cons", v);+ v = cdr_(v);
+ if (!iscons(v)) type_error("car", "cons", v);+ Stack[SP-1] = car_(v);
+ NEXT_OP;
+ OP(OP_SETCAR)
+ car(Stack[SP-2]) = Stack[SP-1];
+ POPN(1); NEXT_OP;
+ OP(OP_SETCDR)
+ cdr(Stack[SP-2]) = Stack[SP-1];
+ POPN(1); NEXT_OP;
+ OP(OP_LIST)
+ n = *ip++;
+ apply_list:
+ if (n > 0) {+ v = list(&Stack[SP-n], n);
+ POPN(n);
+ PUSH(v);
+ }
+ else {+ PUSH(NIL);
+ }
+ NEXT_OP;
+
+ OP(OP_TAPPLY)
+ n = *ip++;
+ apply_tapply:
+ v = POP(); // arglist
+ n = SP-(n-2); // n-2 == # leading arguments not in the list
+ while (iscons(v)) {+ if (SP >= N_STACK)
+ grow_stack();
+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ n = SP-n;
+ goto do_tcall;
+ OP(OP_APPLY)
+ n = *ip++;
+ apply_apply:
+ v = POP(); // arglist
+ n = SP-(n-2); // n-2 == # leading arguments not in the list
+ while (iscons(v)) {+ if (SP >= N_STACK)
+ grow_stack();
+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ n = SP-n;
+ goto do_call;
+
+ OP(OP_ADD)
+ n = *ip++;
+ apply_add:
+ s = 0;
+ i = SP-n;
+ for (; i < SP; i++) {+ if (isfixnum(Stack[i])) {+ s += numval(Stack[i]);
+ if (!fits_fixnum(s)) {+ i++;
+ goto add_ovf;
+ }
+ }
+ else {+ add_ovf:
+ v = fl_add_any(&Stack[i], SP-i, s);
+ break;
+ }
+ }
+ if (i==SP)
+ v = fixnum(s);
+ POPN(n);
+ PUSH(v);
+ NEXT_OP;
+ OP(OP_ADD2)
+ if (bothfixnums(Stack[SP-1], Stack[SP-2])) {+ s = numval(Stack[SP-1]) + numval(Stack[SP-2]);
+ if (fits_fixnum(s))
+ v = fixnum(s);
+ else
+ v = mk_long(s);
+ }
+ else {+ v = fl_add_any(&Stack[SP-2], 2, 0);
+ }
+ POPN(1);
+ Stack[SP-1] = v;
+ NEXT_OP;
+ OP(OP_SUB)
+ n = *ip++;
+ apply_sub:
+ if (n == 2) goto do_sub2;
+ if (n == 1) goto do_neg;
+ i = SP-n;
+ // we need to pass the full arglist on to fl_add_any
+ // so it can handle rest args properly
+ PUSH(Stack[i]);
+ Stack[i] = fixnum(0);
+ Stack[i+1] = fl_neg(fl_add_any(&Stack[i], n, 0));
+ Stack[i] = POP();
+ v = fl_add_any(&Stack[i], 2, 0);
+ POPN(n);
+ PUSH(v);
+ NEXT_OP;
+ OP(OP_NEG)
+ do_neg:
+ if (isfixnum(Stack[SP-1]))
+ Stack[SP-1] = fixnum(-numval(Stack[SP-1]));
+ else
+ Stack[SP-1] = fl_neg(Stack[SP-1]);
+ NEXT_OP;
+ OP(OP_SUB2)
+ do_sub2:
+ if (bothfixnums(Stack[SP-2], Stack[SP-1])) {+ s = numval(Stack[SP-2]) - numval(Stack[SP-1]);
+ if (fits_fixnum(s))
+ v = fixnum(s);
+ else
+ v = mk_long(s);
+ }
+ else {+ Stack[SP-1] = fl_neg(Stack[SP-1]);
+ v = fl_add_any(&Stack[SP-2], 2, 0);
+ }
+ POPN(1);
+ Stack[SP-1] = v;
+ NEXT_OP;
+ OP(OP_MUL)
+ n = *ip++;
+ apply_mul:
+ accum = 1;
+ i = SP-n;
+ for (; i < SP; i++) {+ if (isfixnum(Stack[i])) {+ accum *= numval(Stack[i]);
+ }
+ else {+ v = fl_mul_any(&Stack[i], SP-i, accum);
+ break;
+ }
+ }
+ if (i == SP) {+ if (fits_fixnum(accum))
+ v = fixnum(accum);
+ else
+ v = return_from_int64(accum);
+ }
+ POPN(n);
+ PUSH(v);
+ NEXT_OP;
+ OP(OP_DIV)
+ n = *ip++;
+ apply_div:
+ i = SP-n;
+ if (n == 1) {+ Stack[SP-1] = fl_div2(fixnum(1), Stack[i]);
+ }
+ else {+ if (n > 2) {+ PUSH(Stack[i]);
+ Stack[i] = fixnum(1);
+ Stack[i+1] = fl_mul_any(&Stack[i], n, 1);
+ Stack[i] = POP();
+ }
+ v = fl_div2(Stack[i], Stack[i+1]);
+ POPN(n);
+ PUSH(v);
+ }
+ NEXT_OP;
+ OP(OP_IDIV)
+ v = Stack[SP-2]; e = Stack[SP-1];
+ if (bothfixnums(v, e)) {+ if (e==0) DivideByZeroError();
+ v = fixnum(numval(v) / numval(e));
+ }
+ else
+ v = fl_idiv2(v, e);
+ POPN(1);
+ Stack[SP-1] = v;
+ NEXT_OP;
+ OP(OP_NUMEQ)
+ v = Stack[SP-2]; e = Stack[SP-1];
+ if (bothfixnums(v, e))
+ v = (v == e) ? FL_T : FL_F;
+ else
+ v = (!numeric_compare(v,e,1,0,"=")) ? FL_T : FL_F;
+ POPN(1);
+ Stack[SP-1] = v;
+ NEXT_OP;
+ OP(OP_LT)
+ if (bothfixnums(Stack[SP-2], Stack[SP-1])) {+ v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? FL_T : FL_F;
+ }
+ else {+ v = (numval(fl_compare(Stack[SP-2], Stack[SP-1])) < 0) ?
+ FL_T : FL_F;
+ }
+ POPN(1);
+ Stack[SP-1] = v;
+ NEXT_OP;
+ OP(OP_COMPARE)
+ Stack[SP-2] = compare_(Stack[SP-2], Stack[SP-1], 0);
+ POPN(1);
+ NEXT_OP;
+
+ OP(OP_VECTOR)
+ n = *ip++;
+ apply_vector:
+ v = alloc_vector(n, 0);
+ if (n) {+ memcpy(&vector_elt(v,0), &Stack[SP-n], n*sizeof(value_t));
+ POPN(n);
+ }
+ PUSH(v);
+ NEXT_OP;
+
+ OP(OP_AREF)
+ v = Stack[SP-2];
+ if (isvector(v)) {+ e = Stack[SP-1];
+ if (isfixnum(e))
+ i = numval(e);
+ else
+ i = (uint32_t)toulong(e, "aref");
+ if ((unsigned)i >= vector_size(v))
+ bounds_error("aref", v, e);+ v = vector_elt(v, i);
+ }
+ else if (isarray(v)) {+ v = cvalue_array_aref(&Stack[SP-2]);
+ }
+ else {+ type_error("aref", "sequence", v);+ }
+ POPN(1);
+ Stack[SP-1] = v;
+ NEXT_OP;
+ OP(OP_ASET)
+ e = Stack[SP-3];
+ if (isvector(e)) {+ i = tofixnum(Stack[SP-2], "aset!");
+ if ((unsigned)i >= vector_size(e))
+ bounds_error("aset!", v, Stack[SP-1]);+ vector_elt(e, i) = (v=Stack[SP-1]);
+ }
+ else if (isarray(e)) {+ v = cvalue_array_aset(&Stack[SP-3]);
+ }
+ else {+ type_error("aset!", "sequence", e);+ }
+ POPN(2);
+ Stack[SP-1] = v;
+ NEXT_OP;
+ OP(OP_FOR)
+ s = tofixnum(Stack[SP-3], "for");
+ hi = tofixnum(Stack[SP-2], "for");
+ //f = Stack[SP-1];
+ v = FL_UNSPECIFIED;
+ SP += 2;
+ n = SP;
+ for(; s <= hi; s++) {+ Stack[SP-2] = Stack[SP-3];
+ Stack[SP-1] = fixnum(s);
+ v = apply_cl(1);
+ SP = n;
+ }
+ POPN(4);
+ Stack[SP-1] = v;
+ NEXT_OP;
+
+ OP(OP_LOADT) PUSH(FL_T); NEXT_OP;
+ OP(OP_LOADF) PUSH(FL_F); NEXT_OP;
+ OP(OP_LOADNIL) PUSH(NIL); NEXT_OP;
+ OP(OP_LOAD0) PUSH(fixnum(0)); NEXT_OP;
+ OP(OP_LOAD1) PUSH(fixnum(1)); NEXT_OP;
+ OP(OP_LOADI8) s = (int8_t)*ip++; PUSH(fixnum(s)); NEXT_OP;
+ OP(OP_LOADV)
+ v = fn_vals(Stack[bp-1]);
+ assert(*ip < vector_size(v));
+ v = vector_elt(v, *ip); ip++;
+ PUSH(v);
+ NEXT_OP;
+ OP(OP_LOADVL)
+ v = fn_vals(Stack[bp-1]);
+ v = vector_elt(v, GET_INT32(ip)); ip+=4;
+ PUSH(v);
+ NEXT_OP;
+ OP(OP_LOADGL)
+ v = fn_vals(Stack[bp-1]);
+ v = vector_elt(v, GET_INT32(ip)); ip+=4;
+ goto do_loadg;
+ OP(OP_LOADG)
+ v = fn_vals(Stack[bp-1]);
+ assert(*ip < vector_size(v));
+ v = vector_elt(v, *ip); ip++;
+ do_loadg:
+ assert(issymbol(v));
+ sym = (symbol_t*)ptr(v);
+ if (sym->binding == UNBOUND)
+ fl_raise(fl_list2(UnboundError, v));
+ PUSH(sym->binding);
+ NEXT_OP;
+
+ OP(OP_SETGL)
+ v = fn_vals(Stack[bp-1]);
+ v = vector_elt(v, GET_INT32(ip)); ip+=4;
+ goto do_setg;
+ OP(OP_SETG)
+ v = fn_vals(Stack[bp-1]);
+ assert(*ip < vector_size(v));
+ v = vector_elt(v, *ip); ip++;
+ do_setg:
+ assert(issymbol(v));
+ sym = (symbol_t*)ptr(v);
+ v = Stack[SP-1];
+ if (!isconstant(sym))
+ sym->binding = v;
+ NEXT_OP;
+
+ OP(OP_LOADA)
+ assert(nargs > 0);
+ i = *ip++;
+ if (captured) {+ e = Stack[bp];
+ assert(isvector(e));
+ assert(i < vector_size(e));
+ v = vector_elt(e, i);
+ }
+ else {+ v = Stack[bp+i];
+ }
+ PUSH(v);
+ NEXT_OP;
+ OP(OP_LOADA0)
+ if (captured)
+ v = vector_elt(Stack[bp], 0);
+ else
+ v = Stack[bp];
+ PUSH(v);
+ NEXT_OP;
+ OP(OP_LOADA1)
+ if (captured)
+ v = vector_elt(Stack[bp], 1);
+ else
+ v = Stack[bp+1];
+ PUSH(v);
+ NEXT_OP;
+ OP(OP_LOADAL)
+ assert(nargs > 0);
+ i = GET_INT32(ip); ip+=4;
+ if (captured)
+ v = vector_elt(Stack[bp], i);
+ else
+ v = Stack[bp+i];
+ PUSH(v);
+ NEXT_OP;
+ OP(OP_SETA)
+ assert(nargs > 0);
+ v = Stack[SP-1];
+ i = *ip++;
+ if (captured) {+ e = Stack[bp];
+ assert(isvector(e));
+ assert(i < vector_size(e));
+ vector_elt(e, i) = v;
+ }
+ else {+ Stack[bp+i] = v;
+ }
+ NEXT_OP;
+ OP(OP_SETAL)
+ assert(nargs > 0);
+ v = Stack[SP-1];
+ i = GET_INT32(ip); ip+=4;
+ if (captured)
+ vector_elt(Stack[bp], i) = v;
+ else
+ Stack[bp+i] = v;
+ NEXT_OP;
+ OP(OP_LOADC)
+ s = *ip++;
+ i = *ip++;
+ v = Stack[bp+nargs];
+ while (s--)
+ v = vector_elt(v, vector_size(v)-1);
+ assert(isvector(v));
+ assert(i < vector_size(v));
+ PUSH(vector_elt(v, i));
+ NEXT_OP;
+ OP(OP_SETC)
+ s = *ip++;
+ i = *ip++;
+ v = Stack[bp+nargs];
+ while (s--)
+ v = vector_elt(v, vector_size(v)-1);
+ assert(isvector(v));
+ assert(i < vector_size(v));
+ vector_elt(v, i) = Stack[SP-1];
+ NEXT_OP;
+ OP(OP_LOADC00)
+ PUSH(vector_elt(Stack[bp+nargs], 0));
+ NEXT_OP;
+ OP(OP_LOADC01)
+ PUSH(vector_elt(Stack[bp+nargs], 1));
+ NEXT_OP;
+ OP(OP_LOADCL)
+ s = GET_INT32(ip); ip+=4;
+ i = GET_INT32(ip); ip+=4;
+ v = Stack[bp+nargs];
+ while (s--)
+ v = vector_elt(v, vector_size(v)-1);
+ PUSH(vector_elt(v, i));
+ NEXT_OP;
+ OP(OP_SETCL)
+ s = GET_INT32(ip); ip+=4;
+ i = GET_INT32(ip); ip+=4;
+ v = Stack[bp+nargs];
+ while (s--)
+ v = vector_elt(v, vector_size(v)-1);
+ assert(i < vector_size(v));
+ vector_elt(v, i) = Stack[SP-1];
+ NEXT_OP;
+
+ OP(OP_CLOSURE)
+ // build a closure (lambda args body . env)
+ if (nargs > 0 && !captured) {+ // save temporary environment to the heap
+ n = nargs;
+ pv = alloc_words(n + 2);
+ PUSH(tagptr(pv, TAG_VECTOR));
+ pv[0] = fixnum(n+1);
+ pv++;
+ do {+ pv[n] = Stack[bp+n];
+ } while (n--);
+ // environment representation changed; install
+ // the new representation so everybody can see it
+ captured = 1;
+ Stack[curr_frame-1] = 1;
+ Stack[bp] = Stack[SP-1];
+ }
+ else {+ PUSH(Stack[bp]); // env has already been captured; share
+ }
+ if (curheap > lim-2)
+ gc(0);
+ pv = (value_t*)curheap;
+ curheap += (4*sizeof(value_t));
+ e = Stack[SP-2]; // closure to copy
+ assert(isfunction(e));
+ pv[0] = ((value_t*)ptr(e))[0];
+ pv[1] = ((value_t*)ptr(e))[1];
+ pv[2] = Stack[SP-1]; // env
+ pv[3] = ((value_t*)ptr(e))[3];
+ POPN(1);
+ Stack[SP-1] = tagptr(pv, TAG_FUNCTION);
+ NEXT_OP;
+
+ OP(OP_TRYCATCH)
+ v = do_trycatch();
+ POPN(1);
+ Stack[SP-1] = v;
+ NEXT_OP;
+
+ OP(OP_OPTARGS)
+ i = GET_INT32(ip); ip+=4;
+ n = GET_INT32(ip); ip+=4;
+ if (nargs < i)
+ lerror(ArgError, "apply: too few arguments");
+ if ((int32_t)n > 0) {+ if (nargs > n)
+ lerror(ArgError, "apply: too many arguments");
+ }
+ else n = -n;
+ if (n > nargs) {+ n -= nargs;
+ SP += n;
+ Stack[SP-1] = Stack[SP-n-1];
+ Stack[SP-2] = Stack[SP-n-2];
+ Stack[SP-3] = nargs+n;
+ Stack[SP-4] = Stack[SP-n-4];
+ Stack[SP-5] = Stack[SP-n-5];
+ curr_frame = SP;
+ for(i=0; i < n; i++) {+ Stack[bp+nargs+i] = UNBOUND;
+ }
+ nargs += n;
+ }
+ NEXT_OP;
+ OP(OP_KEYARGS)
+ v = fn_vals(Stack[bp-1]);
+ v = vector_elt(v, 0);
+ i = GET_INT32(ip); ip+=4;
+ n = GET_INT32(ip); ip+=4;
+ s = GET_INT32(ip); ip+=4;
+ nargs = process_keys(v, i, n, abs(s)-(i+n), bp, nargs, s<0);
+ NEXT_OP;
+
+#ifndef USE_COMPUTED_GOTO
+ default:
+ goto dispatch;
+#endif
+ }
+ }
+#ifdef USE_COMPUTED_GOTO
+ return UNBOUND; // not reached
+#else
+ goto dispatch;
+#endif
+}
+
+static uint32_t compute_maxstack(uint8_t *code, size_t len, int bswap)
+{+ uint8_t *ip = code+4, *end = code+len;
+ uint8_t op;
+ uint32_t i, n, sp = 0, maxsp = 0;
+
+ while (1) {+ if ((int32_t)sp > (int32_t)maxsp) maxsp = sp;
+ if (ip >= end) break;
+ op = *ip++;
+ switch (op) {+ case OP_ARGC:
+ n = *ip++;
+ break;
+ case OP_VARGC:
+ n = *ip++;
+ sp += (n+2);
+ break;
+ case OP_LARGC:
+ if (bswap) SWAP_INT32(ip);
+ n = GET_INT32(ip); ip+=4;
+ break;
+ case OP_LVARGC:
+ if (bswap) SWAP_INT32(ip);
+ n = GET_INT32(ip); ip+=4;
+ sp += (n+2);
+ break;
+ case OP_OPTARGS:
+ if (bswap) SWAP_INT32(ip);
+ i = GET_INT32(ip); ip+=4;
+ if (bswap) SWAP_INT32(ip);
+ n = abs(GET_INT32(ip)); ip+=4;
+ sp += (n-i);
+ break;
+ case OP_KEYARGS:
+ if (bswap) SWAP_INT32(ip);
+ i = GET_INT32(ip); ip+=4;
+ if (bswap) SWAP_INT32(ip);
+ n = GET_INT32(ip); ip+=4;
+ if (bswap) SWAP_INT32(ip);
+ n = abs(GET_INT32(ip)); ip+=4;
+ sp += (n-i);
+ break;
+ case OP_BRBOUND:
+ if (bswap) SWAP_INT32(ip);
+ ip+=4;
+ sp++;
+ break;
+
+ case OP_TCALL: case OP_CALL:
+ n = *ip++; // nargs
+ sp -= n;
+ break;
+ case OP_TCALLL: case OP_CALLL:
+ if (bswap) SWAP_INT32(ip);
+ n = GET_INT32(ip); ip+=4;
+ sp -= n;
+ break;
+ case OP_JMP:
+ if (bswap) SWAP_INT16(ip);
+ ip += 2; break;
+ case OP_JMPL:
+ if (bswap) SWAP_INT32(ip);
+ ip += 4; break;
+ case OP_BRF: case OP_BRT:
+ if (bswap) SWAP_INT16(ip);
+ ip+=2;
+ sp--;
+ break;
+ case OP_BRFL: case OP_BRTL:
+ if (bswap) SWAP_INT32(ip);
+ ip += 4;
+ sp--;
+ break;
+ case OP_BRNE:
+ if (bswap) SWAP_INT16(ip);
+ ip += 2;
+ sp -= 2;
+ break;
+ case OP_BRNEL:
+ if (bswap) SWAP_INT32(ip);
+ ip += 4;
+ sp -= 2;
+ break;
+ case OP_BRNN: case OP_BRN:
+ if (bswap) SWAP_INT16(ip);
+ ip += 2;
+ sp--;
+ break;
+ case OP_BRNNL: case OP_BRNL:
+ if (bswap) SWAP_INT32(ip);
+ ip += 4;
+ sp--;
+ break;
+ case OP_RET: sp--; break;
+
+ case OP_CONS: case OP_SETCAR: case OP_SETCDR: case OP_POP:
+ case OP_EQ: case OP_EQV: case OP_EQUAL: case OP_ADD2: case OP_SUB2:
+ case OP_IDIV: case OP_NUMEQ: case OP_LT: case OP_COMPARE:
+ case OP_AREF: case OP_TRYCATCH:
+ sp--;
+ break;
+
+ case OP_PAIRP: case OP_ATOMP: case OP_NOT: case OP_NULLP:
+ case OP_BOOLEANP: case OP_SYMBOLP: case OP_NUMBERP: case OP_FIXNUMP:
+ case OP_BOUNDP: case OP_BUILTINP: case OP_FUNCTIONP: case OP_VECTORP:
+ case OP_NOP: case OP_CAR: case OP_CDR: case OP_NEG: case OP_CLOSURE:
+ break;
+
+ case OP_TAPPLY: case OP_APPLY:
+ n = *ip++;
+ sp -= (n-1);
+ break;
+
+ case OP_LIST: case OP_ADD: case OP_SUB: case OP_MUL: case OP_DIV:
+ case OP_VECTOR:
+ n = *ip++;
+ sp -= (n-1);
+ break;
+
+ case OP_ASET:
+ sp -= 2;
+ break;
+ case OP_FOR:
+ if (sp+2 > maxsp) maxsp = sp+2;
+ sp -=2;
+ break;
+
+ case OP_LOADT: case OP_LOADF: case OP_LOADNIL: case OP_LOAD0:
+ case OP_LOAD1: case OP_LOADA0: case OP_LOADA1: case OP_LOADC00:
+ case OP_LOADC01: case OP_DUP:
+ sp++;
+ break;
+
+ case OP_LOADI8: case OP_LOADV: case OP_LOADG: case OP_LOADA:
+ ip++;
+ sp++;
+ break;
+ case OP_LOADVL: case OP_LOADGL: case OP_LOADAL:
+ if (bswap) SWAP_INT32(ip);
+ ip+=4;
+ sp++;
+ break;
+
+ case OP_SETG: case OP_SETA:
+ ip++;
+ break;
+ case OP_SETGL: case OP_SETAL:
+ if (bswap) SWAP_INT32(ip);
+ ip+=4;
+ break;
+
+ case OP_LOADC: ip+=2; sp++; break;
+ case OP_SETC:
+ ip+=2;
+ break;
+ case OP_LOADCL:
+ if (bswap) SWAP_INT32(ip);
+ ip+=4;
+ if (bswap) SWAP_INT32(ip);
+ ip+=4;
+ sp++; break;
+ case OP_SETCL:
+ if (bswap) SWAP_INT32(ip);
+ ip+=4;
+ if (bswap) SWAP_INT32(ip);
+ ip+=4;
+ break;
+ }
+ }
+ return maxsp+5;
+}
+
+// top = top frame pointer to start at
+static value_t _stacktrace(uint32_t top)
+{+ uint32_t bp, sz;
+ value_t v, lst = NIL;
+ fl_gc_handle(&lst);
+ while (top > 0) {+ sz = Stack[top-3]+1;
+ bp = top-5-sz;
+ v = alloc_vector(sz, 0);
+ if (Stack[top-1] /*captured*/) {+ vector_elt(v, 0) = Stack[bp];
+ memcpy(&vector_elt(v, 1),
+ &vector_elt(Stack[bp+1],0), (sz-1)*sizeof(value_t));
+ }
+ else {+ memcpy(&vector_elt(v,0), &Stack[bp], sz*sizeof(value_t));
+ }
+ lst = fl_cons(v, lst);
+ top = Stack[top-4];
+ }
+ fl_free_gc_handles(1);
+ return lst;
+}
+
+// builtins -------------------------------------------------------------------
+
+void assign_global_builtins(builtinspec_t *b)
+{+ while (b->name != NULL) {+ set(symbol(b->name), cbuiltin(b->name, b->fptr));
+ b++;
+ }
+}
+
+static value_t fl_function(value_t *args, uint32_t nargs)
+{+ if (nargs == 1 && issymbol(args[0]))
+ return fl_builtin(args, nargs);
+ if (nargs < 2 || nargs > 4)
+ argcount("function", nargs, 2);+ if (!fl_isstring(args[0]))
+ type_error("function", "string", args[0]);+ if (!isvector(args[1]))
+ type_error("function", "vector", args[1]);+ cvalue_t *arr = (cvalue_t*)ptr(args[0]);
+ cv_pin(arr);
+ char *data = cv_data(arr);
+ int swap = 0;
+ if ((uint8_t)data[4] >= N_OPCODES) {+ // read syntax, shifted 48 for compact text representation
+ size_t i, sz = cv_len(arr);
+ for(i=0; i < sz; i++)
+ data[i] -= 48;
+ }
+ else {+#if BYTE_ORDER == BIG_ENDIAN
+ swap = 1;
+#endif
+ }
+ uint32_t ms = compute_maxstack((uint8_t*)data, cv_len(arr), swap);
+ PUT_INT32(data, ms);
+ function_t *fn = (function_t*)alloc_words(4);
+ value_t fv = tagptr(fn, TAG_FUNCTION);
+ fn->bcode = args[0];
+ fn->vals = args[1];
+ fn->env = NIL;
+ fn->name = LAMBDA;
+ if (nargs > 2) {+ if (issymbol(args[2])) {+ fn->name = args[2];
+ if (nargs > 3)
+ fn->env = args[3];
+ }
+ else {+ fn->env = args[2];
+ if (nargs > 3) {+ if (!issymbol(args[3]))
+ type_error("function", "symbol", args[3]);+ fn->name = args[3];
+ }
+ }
+ if (isgensym(fn->name))
+ lerror(ArgError, "function: name should not be a gensym");
+ }
+ return fv;
+}
+
+static value_t fl_function_code(value_t *args, uint32_t nargs)
+{+ argcount("function:code", nargs, 1);+ value_t v = args[0];
+ if (!isclosure(v)) type_error("function:code", "function", v);+ return fn_bcode(v);
+}
+static value_t fl_function_vals(value_t *args, uint32_t nargs)
+{+ argcount("function:vals", nargs, 1);+ value_t v = args[0];
+ if (!isclosure(v)) type_error("function:vals", "function", v);+ return fn_vals(v);
+}
+static value_t fl_function_env(value_t *args, uint32_t nargs)
+{+ argcount("function:env", nargs, 1);+ value_t v = args[0];
+ if (!isclosure(v)) type_error("function:env", "function", v);+ return fn_env(v);
+}
+static value_t fl_function_name(value_t *args, uint32_t nargs)
+{+ argcount("function:name", nargs, 1);+ value_t v = args[0];
+ if (!isclosure(v)) type_error("function:name", "function", v);+ return fn_name(v);
+}
+
+value_t fl_copylist(value_t *args, u_int32_t nargs)
+{+ argcount("copy-list", nargs, 1);+ return copy_list(args[0]);
+}
+
+value_t fl_append(value_t *args, u_int32_t nargs)
+{+ if (nargs == 0)
+ return NIL;
+ value_t first=NIL, lst, lastcons=NIL;
+ fl_gc_handle(&first);
+ fl_gc_handle(&lastcons);
+ uint32_t i=0;
+ while (1) {+ lst = args[i++];
+ if (i >= nargs) break;
+ if (iscons(lst)) {+ lst = copy_list(lst);
+ if (first == NIL)
+ first = lst;
+ else
+ cdr_(lastcons) = lst;
+ lastcons = tagptr((((cons_t*)curheap)-1), TAG_CONS);
+ }
+ else if (lst != NIL) {+ type_error("append", "cons", lst);+ }
+ }
+ if (first == NIL)
+ first = lst;
+ else
+ cdr_(lastcons) = lst;
+ fl_free_gc_handles(2);
+ return first;
+}
+
+value_t fl_liststar(value_t *args, u_int32_t nargs)
+{+ if (nargs == 1) return args[0];
+ else if (nargs == 0) argcount("list*", nargs, 1);+ return _list(args, nargs, 1);
+}
+
+value_t fl_stacktrace(value_t *args, u_int32_t nargs)
+{+ (void)args;
+ argcount("stacktrace", nargs, 0);+ return _stacktrace(fl_throwing_frame ? fl_throwing_frame : curr_frame);
+}
+
+value_t fl_map1(value_t *args, u_int32_t nargs)
+{+ if (nargs < 2)
+ lerror(ArgError, "map: too few arguments");
+ if (!iscons(args[1])) return NIL;
+ value_t first, last, v;
+ if (nargs == 2) {+ if (SP+3 > N_STACK) grow_stack();
+ PUSH(args[0]);
+ PUSH(car_(args[1]));
+ v = _applyn(1);
+ PUSH(v);
+ v = mk_cons();
+ car_(v) = POP(); cdr_(v) = NIL;
+ last = first = v;
+ args[1] = cdr_(args[1]);
+ fl_gc_handle(&first);
+ fl_gc_handle(&last);
+ while (iscons(args[1])) {+ Stack[SP-2] = args[0];
+ Stack[SP-1] = car_(args[1]);
+ v = _applyn(1);
+ PUSH(v);
+ v = mk_cons();
+ car_(v) = POP(); cdr_(v) = NIL;
+ cdr_(last) = v;
+ last = v;
+ args[1] = cdr_(args[1]);
+ }
+ POPN(2);
+ fl_free_gc_handles(2);
+ }
+ else {+ size_t i;
+ while (SP+nargs+1 > N_STACK) grow_stack();
+ PUSH(args[0]);
+ for(i=1; i < nargs; i++) {+ PUSH(car(args[i]));
+ args[i] = cdr_(args[i]);
+ }
+ v = _applyn(nargs-1);
+ PUSH(v);
+ v = mk_cons();
+ car_(v) = POP(); cdr_(v) = NIL;
+ last = first = v;
+ fl_gc_handle(&first);
+ fl_gc_handle(&last);
+ while (iscons(args[1])) {+ Stack[SP-nargs] = args[0];
+ for(i=1; i < nargs; i++) {+ Stack[SP-nargs+i] = car(args[i]);
+ args[i] = cdr_(args[i]);
+ }
+ v = _applyn(nargs-1);
+ PUSH(v);
+ v = mk_cons();
+ car_(v) = POP(); cdr_(v) = NIL;
+ cdr_(last) = v;
+ last = v;
+ }
+ POPN(nargs);
+ fl_free_gc_handles(2);
+ }
+ return first;
+}
+
+static builtinspec_t core_builtin_info[] = {+ { "function", fl_function },+ { "function:code", fl_function_code },+ { "function:vals", fl_function_vals },+ { "function:env", fl_function_env },+ { "function:name", fl_function_name },+ { "stacktrace", fl_stacktrace },+ { "gensym", fl_gensym },+ { "gensym?", fl_gensymp },+ { "hash", fl_hash },+ { "copy-list", fl_copylist },+ { "append", fl_append },+ { "list*", fl_liststar },+ { "map", fl_map1 },+ { NULL, NULL }+};
+
+// initialization -------------------------------------------------------------
+
+extern void builtins_init();
+extern void comparehash_init();
+
+static void lisp_init(size_t initial_heapsize)
+{+ int i;
+
+ llt_init();
+
+ heapsize = initial_heapsize;
+
+ fromspace = LLT_ALLOC(heapsize);
+ tospace = LLT_ALLOC(heapsize);
+ curheap = fromspace;
+ lim = curheap+heapsize-sizeof(cons_t);
+ consflags = bitvector_new(heapsize/sizeof(cons_t), 1);
+ htable_new(&printconses, 32);
+ comparehash_init();
+ N_STACK = 262144;
+ Stack = malloc(N_STACK*sizeof(value_t));
+
+ FL_NIL = NIL = builtin(OP_THE_EMPTY_LIST);
+ FL_T = builtin(OP_BOOL_CONST_T);
+ FL_F = builtin(OP_BOOL_CONST_F);
+ FL_EOF = builtin(OP_EOF_OBJECT);
+ LAMBDA = symbol("lambda"); FUNCTION = symbol("function");+ QUOTE = symbol("quote"); TRYCATCH = symbol("trycatch");+ BACKQUOTE = symbol("quasiquote"); COMMA = symbol("unquote");+ COMMAAT = symbol("unquote-splicing"); COMMADOT = symbol("unquote-nsplicing");+ IOError = symbol("io-error"); ParseError = symbol("parse-error");+ TypeError = symbol("type-error"); ArgError = symbol("arg-error");+ UnboundError = symbol("unbound-error");+ KeyError = symbol("key-error"); MemoryError = symbol("memory-error");+ BoundsError = symbol("bounds-error");+ DivideError = symbol("divide-error");+ EnumerationError = symbol("enumeration-error");+ Error = symbol("error"); pairsym = symbol("pair");+ symbolsym = symbol("symbol"); fixnumsym = symbol("fixnum");+ vectorsym = symbol("vector"); builtinsym = symbol("builtin");+ booleansym = symbol("boolean"); nullsym = symbol("null");+ definesym = symbol("define"); defmacrosym = symbol("define-macro");+ forsym = symbol("for");+ setqsym = symbol("set!"); evalsym = symbol("eval");+ vu8sym = symbol("vu8"); fnsym = symbol("fn");+ nulsym = symbol("nul"); alarmsym = symbol("alarm");+ backspacesym = symbol("backspace"); tabsym = symbol("tab");+ linefeedsym = symbol("linefeed"); vtabsym = symbol("vtab");+ pagesym = symbol("page"); returnsym = symbol("return");+ escsym = symbol("esc"); spacesym = symbol("space");+ deletesym = symbol("delete"); newlinesym = symbol("newline");+ tsym = symbol("t"); Tsym = symbol("T");+ fsym = symbol("f"); Fsym = symbol("F");+ set(printprettysym=symbol("*print-pretty*"), FL_T);+ set(printreadablysym=symbol("*print-readably*"), FL_T);+ set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));+ set(printlengthsym=symbol("*print-length*"), FL_F);+ set(printlevelsym=symbol("*print-level*"), FL_F);+ builtins_table_sym = symbol("*builtins*");+ fl_lasterror = NIL;
+ i = 0;
+ for (i=OP_EQ; i <= OP_ASET; i++) {+ setc(symbol(builtin_names[i]), builtin(i));
+ }
+ setc(symbol("eq"), builtin(OP_EQ));+ setc(symbol("procedure?"), builtin(OP_FUNCTIONP));+ setc(symbol("top-level-bound?"), builtin(OP_BOUNDP));+
+#ifdef LINUX
+ set(symbol("*os-name*"), symbol("linux"));+#elif defined(WIN32) || defined(WIN64)
+ set(symbol("*os-name*"), symbol("win32"));+#elif defined(MACOSX)
+ set(symbol("*os-name*"), symbol("macos"));+#else
+ set(symbol("*os-name*"), symbol("unknown"));+#endif
+
+ the_empty_vector = tagptr(alloc_words(1), TAG_VECTOR);
+ vector_setsize(the_empty_vector, 0);
+
+ cvalues_init();
+
+ char buf[1024];
+ char *exename = get_exename(buf, sizeof(buf));
+ if (exename != NULL) {+ path_to_dirname(exename);
+ setc(symbol("*install-dir*"), cvalue_static_cstring(strdup(exename)));+ }
+
+ memory_exception_value = fl_list2(MemoryError,
+ cvalue_static_cstring("out of memory"));+
+ assign_global_builtins(core_builtin_info);
+
+ builtins_init();
+}
+
+// top level ------------------------------------------------------------------
+
+value_t fl_toplevel_eval(value_t expr)
+{+ return fl_applyn(1, symbol_value(evalsym), expr);
+}
+
+void fl_init(size_t initial_heapsize)
+{+#ifdef BOEHM_GC
+ GC_init();
+#endif
+ lisp_init(initial_heapsize);
+}
+
+int fl_load_system_image(value_t sys_image_iostream)
+{+ value_t e;
+ int saveSP;
+ symbol_t *sym;
+
+ PUSH(sys_image_iostream);
+ saveSP = SP;
+ FL_TRY {+ while (1) {+ e = fl_read_sexpr(Stack[SP-1]);
+ if (ios_eof(value2c(ios_t*,Stack[SP-1]))) break;
+ if (isfunction(e)) {+ // stage 0 format: series of thunks
+ PUSH(e);
+ (void)_applyn(0);
+ SP = saveSP;
+ }
+ else {+ // stage 1 format: list alternating symbol/value
+ while (iscons(e)) {+ sym = tosymbol(car_(e), "bootstrap");
+ e = cdr_(e);
+ (void)tocons(e, "bootstrap");
+ sym->binding = car_(e);
+ e = cdr_(e);
+ }
+ break;
+ }
+ }
+ }
+ FL_CATCH {+ ios_puts("fatal error during bootstrap:\n", ios_stderr);+ fl_print(ios_stderr, fl_lasterror);
+ ios_putc('\n', ios_stderr);+ return 1;
+ }
+ ios_close(value2c(ios_t*,Stack[SP-1]));
+ POPN(1);
+ return 0;
+}
--- /dev/null
+++ b/flisp.h
@@ -1,0 +1,369 @@
+#ifndef _FLISP_H_
+#define _FLISP_H_
+
+typedef uptrint_t value_t;
+typedef int_t fixnum_t;
+#ifdef BITS64
+#define T_FIXNUM T_INT64
+#else
+#define T_FIXNUM T_INT32
+#endif
+
+typedef struct {+ value_t car;
+ value_t cdr;
+} cons_t;
+
+typedef struct _symbol_t {+ uptrint_t flags;
+ value_t binding; // global value binding
+ struct _fltype_t *type;
+ uint32_t hash;
+ void *dlcache; // dlsym address
+ // below fields are private
+ struct _symbol_t *left;
+ struct _symbol_t *right;
+ union {+ char name[1];
+ void *_pad; // ensure field aligned to pointer size
+ };
+} symbol_t;
+
+typedef struct {+ value_t isconst;
+ value_t binding; // global value binding
+ struct _fltype_t *type;
+ uint32_t id;
+} gensym_t;
+
+#define TAG_NUM 0x0
+#define TAG_CPRIM 0x1
+#define TAG_FUNCTION 0x2
+#define TAG_VECTOR 0x3
+#define TAG_NUM1 0x4
+#define TAG_CVALUE 0x5
+#define TAG_SYM 0x6
+#define TAG_CONS 0x7
+#define UNBOUND ((value_t)0x1) // an invalid value
+#define TAG_FWD UNBOUND
+#define tag(x) ((x)&0x7)
+#define ptr(x) ((void*)((x)&(~(value_t)0x7)))
+#define tagptr(p,t) (((value_t)(p)) | (t))
+#define fixnum(x) ((value_t)(((fixnum_t)(x))<<2))
+#define numval(x) (((fixnum_t)(x))>>2)
+#ifdef BITS64
+#define fits_fixnum(x) (((x)>>61) == 0 || (~((x)>>61)) == 0)
+#else
+#define fits_fixnum(x) (((x)>>29) == 0 || (~((x)>>29)) == 0)
+#endif
+#define fits_bits(x,b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
+#define uintval(x) (((unsigned int)(x))>>3)
+#define builtin(n) tagptr((((int)n)<<3), TAG_FUNCTION)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isfixnum(x) (((x)&3) == TAG_NUM)
+#define bothfixnums(x,y) ((((x)|(y))&3) == TAG_NUM)
+#define isbuiltin(x) ((tag(x) == TAG_FUNCTION) && uintval(x) <= OP_ASET)
+#define isvector(x) (tag(x) == TAG_VECTOR)
+#define iscvalue(x) (tag(x) == TAG_CVALUE)
+#define iscprim(x) (tag(x) == TAG_CPRIM)
+#define selfevaluating(x) (tag(x)<6)
+// comparable with ==
+#define eq_comparable(a,b) (!(((a)|(b))&1))
+#define eq_comparablep(a) (!((a)&1))
+// doesn't lead to other values
+#define leafp(a) (((a)&3) != 3)
+
+#define isforwarded(v) (((value_t*)ptr(v))[0] == TAG_FWD)
+#define forwardloc(v) (((value_t*)ptr(v))[1])
+#define forward(v,to) do { (((value_t*)ptr(v))[0] = TAG_FWD); \+ (((value_t*)ptr(v))[1] = to); } while (0)
+
+#define vector_size(v) (((size_t*)ptr(v))[0]>>2)
+#define vector_setsize(v,n) (((size_t*)ptr(v))[0] = ((n)<<2))
+#define vector_elt(v,i) (((value_t*)ptr(v))[1+(i)])
+#define vector_grow_amt(x) ((x)<8 ? 5 : 6*((x)>>3))
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v),"car")->car)
+#define cdr(v) (tocons((v),"cdr")->cdr)
+#define fn_bcode(f) (((value_t*)ptr(f))[0])
+#define fn_vals(f) (((value_t*)ptr(f))[1])
+#define fn_env(f) (((value_t*)ptr(f))[2])
+#define fn_name(f) (((value_t*)ptr(f))[3])
+
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) do { ((symbol_t*)ptr(s))->flags |= 1; \+ ((symbol_t*)ptr(s))->binding = (v); } while (0)
+#define isconstant(s) ((s)->flags&0x1)
+#define iskeyword(s) ((s)->flags&0x2)
+#define symbol_value(s) (((symbol_t*)ptr(s))->binding)
+#define ismanaged(v) ((((unsigned char*)ptr(v)) >= fromspace) && \
+ (((unsigned char*)ptr(v)) < fromspace+heapsize))
+#define isgensym(x) (issymbol(x) && ismanaged(x))
+
+#define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS<<3))
+#define isclosure(x) isfunction(x)
+#define iscbuiltin(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==builtintype))
+
+void fl_gc_handle(value_t *pv);
+void fl_free_gc_handles(uint32_t n);
+
+#include "opcodes.h"
+
+// utility for iterating over all arguments in a builtin
+// i=index, i0=start index, arg = var for each arg, args = arg array
+// assumes "nargs" is the argument count
+#define FOR_ARGS(i, i0, arg, args) \
+ for(i=i0; ((size_t)i)<nargs && ((arg=args[i]) || 1); i++)
+
+#define N_BUILTINS ((int)N_OPCODES)
+
+extern value_t FL_NIL, FL_T, FL_F, FL_EOF;
+
+#define FL_UNSPECIFIED FL_T
+
+/* read, eval, print main entry points */
+value_t fl_read_sexpr(value_t f);
+void fl_print(ios_t *f, value_t v);
+value_t fl_toplevel_eval(value_t expr);
+value_t fl_apply(value_t f, value_t l);
+value_t fl_applyn(uint32_t n, value_t f, ...);
+
+extern value_t printprettysym, printreadablysym, printwidthsym;
+
+/* object model manipulation */
+value_t fl_cons(value_t a, value_t b);
+value_t fl_list2(value_t a, value_t b);
+value_t fl_listn(size_t n, ...);
+value_t symbol(char *str);
+char *symbol_name(value_t v);
+int fl_is_keyword_name(char *str, size_t len);
+value_t alloc_vector(size_t n, int init);
+size_t llength(value_t v);
+value_t fl_compare(value_t a, value_t b); // -1, 0, or 1
+value_t fl_equal(value_t a, value_t b); // T or nil
+int equal_lispvalue(value_t a, value_t b);
+uptrint_t hash_lispvalue(value_t a);
+int isnumtok_base(char *tok, value_t *pval, int base);
+
+/* safe casts */
+cons_t *tocons(value_t v, char *fname);
+symbol_t *tosymbol(value_t v, char *fname);
+fixnum_t tofixnum(value_t v, char *fname);
+char *tostring(value_t v, char *fname);
+
+/* error handling */
+typedef struct _fl_readstate_t {+ htable_t backrefs;
+ htable_t gensyms;
+ value_t source;
+ struct _fl_readstate_t *prev;
+} fl_readstate_t;
+
+typedef struct _ectx_t {+ jmp_buf buf;
+ uint32_t sp;
+ uint32_t frame;
+ uint32_t ngchnd;
+ fl_readstate_t *rdst;
+ struct _ectx_t *prev;
+} fl_exception_context_t;
+
+extern fl_exception_context_t *fl_ctx;
+extern uint32_t fl_throwing_frame;
+extern value_t fl_lasterror;
+
+#define FL_TRY_EXTERN \
+ fl_exception_context_t _ctx; int l__tr, l__ca; \
+ fl_savestate(&_ctx); fl_ctx = &_ctx; \
+ if (!setjmp(_ctx.buf)) \
+ for (l__tr=1; l__tr; l__tr=0, (void)(fl_ctx=fl_ctx->prev))
+
+#define FL_CATCH_EXTERN \
+ else \
+ for(l__ca=1; l__ca; l__ca=0, fl_restorestate(&_ctx))
+
+void lerrorf(value_t e, char *format, ...) __attribute__ ((__noreturn__));
+void lerror(value_t e, const char *msg) __attribute__ ((__noreturn__));
+void fl_savestate(fl_exception_context_t *_ctx);
+void fl_restorestate(fl_exception_context_t *_ctx);
+void fl_raise(value_t e) __attribute__ ((__noreturn__));
+void type_error(char *fname, char *expected, value_t got) __attribute__ ((__noreturn__));
+void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noreturn__));
+extern value_t ArgError, IOError, KeyError, MemoryError, EnumerationError;
+extern value_t UnboundError;
+static inline void argcount(char *fname, uint32_t nargs, uint32_t c)
+{+ if (__unlikely(nargs != c))
+ lerrorf(ArgError,"%s: too %s arguments", fname, nargs<c ? "few":"many");
+}
+
+typedef struct {+ void (*print)(value_t self, ios_t *f);
+ void (*relocate)(value_t oldv, value_t newv);
+ void (*finalize)(value_t self);
+ void (*print_traverse)(value_t self);
+} cvtable_t;
+
+/* functions needed to implement the value interface (cvtable_t) */
+value_t relocate_lispvalue(value_t v);
+void print_traverse(value_t v);
+void fl_print_chr(char c, ios_t *f);
+void fl_print_str(char *s, ios_t *f);
+void fl_print_child(ios_t *f, value_t v);
+
+typedef int (*cvinitfunc_t)(struct _fltype_t*, value_t, void*);
+
+typedef struct _fltype_t {+ value_t type;
+ numerictype_t numtype;
+ size_t size;
+ size_t elsz;
+ cvtable_t *vtable;
+ struct _fltype_t *eltype; // for arrays
+ struct _fltype_t *artype; // (array this)
+ int marked;
+ cvinitfunc_t init;
+} fltype_t;
+
+typedef struct {+ fltype_t *type;
+ void *data;
+ size_t len; // length of *data in bytes
+ union {+ value_t parent; // optional
+ char _space[1]; // variable size
+ };
+} cvalue_t;
+
+#define CVALUE_NWORDS 4
+
+typedef struct {+ fltype_t *type;
+ char _space[1];
+} cprim_t;
+
+typedef struct {+ value_t bcode;
+ value_t vals;
+ value_t env;
+ value_t name;
+} function_t;
+
+#define CPRIM_NWORDS 2
+#define MAX_INL_SIZE 384
+
+#define CV_OWNED_BIT 0x1
+#define CV_PARENT_BIT 0x2
+#define owned(cv) ((uptrint_t)(cv)->type & CV_OWNED_BIT)
+#define hasparent(cv) ((uptrint_t)(cv)->type & CV_PARENT_BIT)
+#define isinlined(cv) ((cv)->data == &(cv)->_space[0])
+#define cv_class(cv) ((fltype_t*)(((uptrint_t)(cv)->type)&~3))
+#define cv_len(cv) ((cv)->len)
+#define cv_type(cv) (cv_class(cv)->type)
+#define cv_data(cv) ((cv)->data)
+#define cv_isstr(cv) (cv_class(cv)->eltype == bytetype)
+#define cv_isPOD(cv) (cv_class(cv)->init != NULL)
+
+#define cvalue_data(v) cv_data((cvalue_t*)ptr(v))
+#define cvalue_len(v) cv_len((cvalue_t*)ptr(v))
+#define value2c(type, v) ((type)cv_data((cvalue_t*)ptr(v)))
+
+#define valid_numtype(v) ((v) < N_NUMTYPES)
+#define cp_class(cp) ((cp)->type)
+#define cp_type(cp) (cp_class(cp)->type)
+#define cp_numtype(cp) (cp_class(cp)->numtype)
+#define cp_data(cp) (&(cp)->_space[0])
+
+// WARNING: multiple evaluation!
+#define cptr(v) \
+ (iscprim(v) ? cp_data((cprim_t*)ptr(v)) : cv_data((cvalue_t*)ptr(v)))
+
+/* C type names corresponding to cvalues type names */
+typedef int8_t fl_int8_t;
+typedef uint8_t fl_uint8_t;
+typedef int16_t fl_int16_t;
+typedef uint16_t fl_uint16_t;
+typedef int32_t fl_int32_t;
+typedef uint32_t fl_uint32_t;
+typedef int64_t fl_int64_t;
+typedef uint64_t fl_uint64_t;
+typedef char fl_char_t;
+typedef char char_t;
+typedef long fl_long_t;
+typedef long long_t;
+typedef unsigned long fl_ulong_t;
+typedef unsigned long ulong_t;
+typedef double fl_double_t;
+typedef float fl_float_t;
+
+typedef value_t (*builtin_t)(value_t*, uint32_t);
+
+extern value_t QUOTE;
+extern value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
+extern value_t int64sym, uint64sym;
+extern value_t longsym, ulongsym, bytesym, wcharsym;
+extern value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
+extern value_t stringtypesym, wcstringtypesym, emptystringsym;
+extern value_t unionsym, floatsym, doublesym;
+extern fltype_t *bytetype, *wchartype;
+extern fltype_t *stringtype, *wcstringtype;
+extern fltype_t *builtintype;
+
+value_t cvalue(fltype_t *type, size_t sz);
+void add_finalizer(cvalue_t *cv);
+void cv_autorelease(cvalue_t *cv);
+void cv_pin(cvalue_t *cv);
+size_t ctype_sizeof(value_t type, int *palign);
+value_t cvalue_copy(value_t v);
+value_t cvalue_from_data(fltype_t *type, void *data, size_t sz);
+value_t cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent);
+value_t cbuiltin(char *name, builtin_t f);
+size_t cvalue_arraylen(value_t v);
+value_t size_wrap(size_t sz);
+size_t toulong(value_t n, char *fname);
+value_t cvalue_string(size_t sz);
+value_t cvalue_static_cstring(const char *str);
+value_t string_from_cstr(char *str);
+value_t string_from_cstrn(char *str, size_t n);
+int fl_isstring(value_t v);
+int fl_isnumber(value_t v);
+int fl_isgensym(value_t v);
+int fl_isiostream(value_t v);
+ios_t *fl_toiostream(value_t v, char *fname);
+value_t cvalue_compare(value_t a, value_t b);
+int numeric_compare(value_t a, value_t b, int eq, int eqnans, char *fname);
+
+void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz);
+
+fltype_t *get_type(value_t t);
+fltype_t *get_array_type(value_t eltype);
+fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab,
+ cvinitfunc_t init);
+
+value_t mk_double(fl_double_t n);
+value_t mk_float(fl_float_t n);
+value_t mk_uint32(uint32_t n);
+value_t mk_uint64(uint64_t n);
+value_t mk_wchar(int32_t n);
+value_t return_from_uint64(uint64_t Uaccum);
+value_t return_from_int64(int64_t Saccum);
+
+typedef struct {+ char *name;
+ builtin_t fptr;
+} builtinspec_t;
+
+void assign_global_builtins(builtinspec_t *b);
+
+/* builtins */
+value_t fl_hash(value_t *args, u_int32_t nargs);
+value_t cvalue_byte(value_t *args, uint32_t nargs);
+value_t cvalue_wchar(value_t *args, uint32_t nargs);
+
+void fl_init(size_t initial_heapsize);
+int fl_load_system_image(value_t ios);
+
+#endif
--- /dev/null
+++ b/flmain.c
@@ -1,0 +1,71 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <ctype.h>
+#include <wctype.h>
+#include <sys/types.h>
+#include <locale.h>
+#include <limits.h>
+#include <errno.h>
+#include <math.h>
+#include "llt.h"
+#include "flisp.h"
+#include "opcodes.h"
+
+static value_t argv_list(int argc, char *argv[])
+{+ int i;
+ value_t lst=FL_NIL, temp;
+ fl_gc_handle(&lst);
+ fl_gc_handle(&temp);
+ for(i=argc-1; i >= 0; i--) {+ temp = cvalue_static_cstring(argv[i]);
+ lst = fl_cons(temp, lst);
+ }
+ fl_free_gc_handles(2);
+ return lst;
+}
+
+extern value_t fl_file(value_t *args, uint32_t nargs);
+
+int main(int argc, char *argv[])
+{+ char fname_buf[1024];
+
+ fl_init(512*1024);
+
+ fname_buf[0] = '\0';
+ value_t str = symbol_value(symbol("*install-dir*"));+ char *exedir = (str == UNBOUND ? NULL : cvalue_data(str));
+ if (exedir != NULL) {+ strcat(fname_buf, exedir);
+ strcat(fname_buf, PATHSEPSTRING);
+ }
+ strcat(fname_buf, "flisp.boot");
+
+ value_t args[2];
+ fl_gc_handle(&args[0]);
+ fl_gc_handle(&args[1]);
+ FL_TRY_EXTERN {+ args[0] = cvalue_static_cstring(fname_buf);
+ args[1] = symbol(":read");+ value_t f = fl_file(&args[0], 2);
+ fl_free_gc_handles(2);
+
+ if (fl_load_system_image(f))
+ return 1;
+
+ (void)fl_applyn(1, symbol_value(symbol("__start")),+ argv_list(argc, argv));
+ }
+ FL_CATCH_EXTERN {+ ios_puts("fatal error:\n", ios_stderr);+ fl_print(ios_stderr, fl_lasterror);
+ ios_putc('\n', ios_stderr);+ return 1;
+ }
+ return 0;
+}
--- /dev/null
+++ b/iostream.c
@@ -1,0 +1,451 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdarg.h>
+#include <string.h>
+#include <assert.h>
+#include <sys/types.h>
+#include <setjmp.h>
+#include "llt.h"
+#include "flisp.h"
+
+static value_t iostreamsym, rdsym, wrsym, apsym, crsym, truncsym;
+static value_t instrsym, outstrsym;
+fltype_t *iostreamtype;
+
+void print_iostream(value_t v, ios_t *f)
+{+ (void)v;
+ fl_print_str("#<io stream>", f);+}
+
+void free_iostream(value_t self)
+{+ ios_t *s = value2c(ios_t*, self);
+ ios_close(s);
+}
+
+void relocate_iostream(value_t oldv, value_t newv)
+{+ ios_t *olds = value2c(ios_t*, oldv);
+ ios_t *news = value2c(ios_t*, newv);
+ cvalue_t *cv = (cvalue_t*)ptr(oldv);
+ if (isinlined(cv)) {+ if (olds->buf == &olds->local[0]) {+ news->buf = &news->local[0];
+ }
+ }
+}
+
+cvtable_t iostream_vtable = { print_iostream, relocate_iostream,+ free_iostream, NULL };
+
+int fl_isiostream(value_t v)
+{+ return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == iostreamtype;
+}
+
+value_t fl_iostreamp(value_t *args, uint32_t nargs)
+{+ argcount("iostream?", nargs, 1);+ return fl_isiostream(args[0]) ? FL_T : FL_F;
+}
+
+value_t fl_eof_object(value_t *args, uint32_t nargs)
+{+ (void)args;
+ argcount("eof-object", nargs, 0);+ return FL_EOF;
+}
+
+value_t fl_eof_objectp(value_t *args, uint32_t nargs)
+{+ argcount("eof-object?", nargs, 1);+ return (FL_EOF == args[0]) ? FL_T : FL_F;
+}
+
+static ios_t *toiostream(value_t v, char *fname)
+{+ if (!fl_isiostream(v))
+ type_error(fname, "iostream", v);
+ return value2c(ios_t*, v);
+}
+
+ios_t *fl_toiostream(value_t v, char *fname)
+{+ return toiostream(v, fname);
+}
+
+value_t fl_file(value_t *args, uint32_t nargs)
+{+ if (nargs < 1)
+ argcount("file", nargs, 1);+ int i, r=0, w=0, c=0, t=0, a=0;
+ for(i=1; i < (int)nargs; i++) {+ if (args[i] == wrsym) w = 1;
+ else if (args[i] == apsym) { a = 1; w = 1; }+ else if (args[i] == crsym) { c = 1; w = 1; }+ else if (args[i] == truncsym) { t = 1; w = 1; }+ else if (args[i] == rdsym) r = 1;
+ }
+ if ((r|w|c|t|a) == 0) r = 1; // default to reading
+ value_t f = cvalue(iostreamtype, sizeof(ios_t));
+ char *fname = tostring(args[0], "file");
+ ios_t *s = value2c(ios_t*, f);
+ if (ios_file(s, fname, r, w, c, t) == NULL)
+ lerrorf(IOError, "file: could not open \"%s\"", fname);
+ if (a) ios_seek_end(s);
+ return f;
+}
+
+value_t fl_buffer(value_t *args, u_int32_t nargs)
+{+ argcount("buffer", nargs, 0);+ (void)args;
+ value_t f = cvalue(iostreamtype, sizeof(ios_t));
+ ios_t *s = value2c(ios_t*, f);
+ if (ios_mem(s, 0) == NULL)
+ lerror(MemoryError, "buffer: could not allocate stream");
+ return f;
+}
+
+value_t fl_read(value_t *args, u_int32_t nargs)
+{+ value_t arg;
+ if (nargs > 1) {+ argcount("read", nargs, 1);+ }
+ else if (nargs == 0) {+ arg = symbol_value(instrsym);
+ }
+ else {+ arg = args[0];
+ }
+ (void)toiostream(arg, "read");
+ fl_gc_handle(&arg);
+ value_t v = fl_read_sexpr(arg);
+ fl_free_gc_handles(1);
+ if (ios_eof(value2c(ios_t*,arg)))
+ return FL_EOF;
+ return v;
+}
+
+value_t fl_iogetc(value_t *args, u_int32_t nargs)
+{+ argcount("io.getc", nargs, 1);+ ios_t *s = toiostream(args[0], "io.getc");
+ uint32_t wc;
+ if (ios_getutf8(s, &wc) == IOS_EOF)
+ //lerror(IOError, "io.getc: end of file reached");
+ return FL_EOF;
+ return mk_wchar(wc);
+}
+
+value_t fl_iopeekc(value_t *args, u_int32_t nargs)
+{+ argcount("io.peekc", nargs, 1);+ ios_t *s = toiostream(args[0], "io.peekc");
+ uint32_t wc;
+ if (ios_peekutf8(s, &wc) == IOS_EOF)
+ return FL_EOF;
+ return mk_wchar(wc);
+}
+
+value_t fl_ioputc(value_t *args, u_int32_t nargs)
+{+ argcount("io.putc", nargs, 2);+ ios_t *s = toiostream(args[0], "io.putc");
+ if (!iscprim(args[1]) || ((cprim_t*)ptr(args[1]))->type != wchartype)
+ type_error("io.putc", "wchar", args[1]);+ uint32_t wc = *(uint32_t*)cp_data((cprim_t*)ptr(args[1]));
+ return fixnum(ios_pututf8(s, wc));
+}
+
+value_t fl_ioflush(value_t *args, u_int32_t nargs)
+{+ argcount("io.flush", nargs, 1);+ ios_t *s = toiostream(args[0], "io.flush");
+ if (ios_flush(s) != 0)
+ return FL_F;
+ return FL_T;
+}
+
+value_t fl_ioclose(value_t *args, u_int32_t nargs)
+{+ argcount("io.close", nargs, 1);+ ios_t *s = toiostream(args[0], "io.close");
+ ios_close(s);
+ return FL_T;
+}
+
+value_t fl_iopurge(value_t *args, u_int32_t nargs)
+{+ argcount("io.discardbuffer", nargs, 1);+ ios_t *s = toiostream(args[0], "io.discardbuffer");
+ ios_purge(s);
+ return FL_T;
+}
+
+value_t fl_ioeof(value_t *args, u_int32_t nargs)
+{+ argcount("io.eof?", nargs, 1);+ ios_t *s = toiostream(args[0], "io.eof?");
+ return (ios_eof(s) ? FL_T : FL_F);
+}
+
+value_t fl_ioseek(value_t *args, u_int32_t nargs)
+{+ argcount("io.seek", nargs, 2);+ ios_t *s = toiostream(args[0], "io.seek");
+ size_t pos = toulong(args[1], "io.seek");
+ off_t res = ios_seek(s, (off_t)pos);
+ if (res == -1)
+ return FL_F;
+ return FL_T;
+}
+
+value_t fl_iopos(value_t *args, u_int32_t nargs)
+{+ argcount("io.pos", nargs, 1);+ ios_t *s = toiostream(args[0], "io.pos");
+ off_t res = ios_pos(s);
+ if (res == -1)
+ return FL_F;
+ return size_wrap((size_t)res);
+}
+
+value_t fl_write(value_t *args, u_int32_t nargs)
+{+ if (nargs < 1 || nargs > 2)
+ argcount("write", nargs, 1);+ ios_t *s;
+ if (nargs == 2)
+ s = toiostream(args[1], "write");
+ else
+ s = toiostream(symbol_value(outstrsym), "write");
+ fl_print(s, args[0]);
+ return args[0];
+}
+
+value_t fl_ioread(value_t *args, u_int32_t nargs)
+{+ if (nargs != 3)
+ argcount("io.read", nargs, 2);+ (void)toiostream(args[0], "io.read");
+ size_t n;
+ fltype_t *ft;
+ if (nargs == 3) {+ // form (io.read s type count)
+ ft = get_array_type(args[1]);
+ n = toulong(args[2], "io.read") * ft->elsz;
+ }
+ else {+ ft = get_type(args[1]);
+ if (ft->eltype != NULL && !iscons(cdr_(cdr_(args[1]))))
+ lerror(ArgError, "io.read: incomplete type");
+ n = ft->size;
+ }
+ value_t cv = cvalue(ft, n);
+ char *data;
+ if (iscvalue(cv)) data = cv_data((cvalue_t*)ptr(cv));
+ else data = cp_data((cprim_t*)ptr(cv));
+ size_t got = ios_read(value2c(ios_t*,args[0]), data, n);
+ if (got < n)
+ //lerror(IOError, "io.read: end of input reached");
+ return FL_EOF;
+ return cv;
+}
+
+// args must contain data[, offset[, count]]
+static void get_start_count_args(value_t *args, uint32_t nargs, size_t sz,
+ size_t *offs, size_t *nb, char *fname)
+{+ if (nargs > 1) {+ *offs = toulong(args[1], fname);
+ if (nargs > 2)
+ *nb = toulong(args[2], fname);
+ else
+ *nb = sz - *offs;
+ if (*offs >= sz || *offs + *nb > sz)
+ bounds_error(fname, args[0], args[1]);
+ }
+}
+
+value_t fl_iowrite(value_t *args, u_int32_t nargs)
+{+ if (nargs < 2 || nargs > 4)
+ argcount("io.write", nargs, 2);+ ios_t *s = toiostream(args[0], "io.write");
+ if (iscprim(args[1]) && ((cprim_t*)ptr(args[1]))->type == wchartype) {+ if (nargs > 2)
+ lerror(ArgError,
+ "io.write: offset argument not supported for characters");
+ uint32_t wc = *(uint32_t*)cp_data((cprim_t*)ptr(args[1]));
+ return fixnum(ios_pututf8(s, wc));
+ }
+ char *data;
+ size_t sz, offs=0;
+ to_sized_ptr(args[1], "io.write", &data, &sz);
+ size_t nb = sz;
+ if (nargs > 2) {+ get_start_count_args(&args[1], nargs-1, sz, &offs, &nb, "io.write");
+ data += offs;
+ }
+ return size_wrap(ios_write(s, data, nb));
+}
+
+value_t fl_dump(value_t *args, u_int32_t nargs)
+{+ if (nargs < 1 || nargs > 3)
+ argcount("dump", nargs, 1);+ ios_t *s = toiostream(symbol_value(outstrsym), "dump");
+ char *data;
+ size_t sz, offs=0;
+ to_sized_ptr(args[0], "dump", &data, &sz);
+ size_t nb = sz;
+ if (nargs > 1) {+ get_start_count_args(args, nargs, sz, &offs, &nb, "dump");
+ data += offs;
+ }
+ hexdump(s, data, nb, offs);
+ return FL_T;
+}
+
+static char get_delim_arg(value_t arg, char *fname)
+{+ size_t uldelim = toulong(arg, fname);
+ if (uldelim > 0x7f) {+ // wchars > 0x7f, or anything else > 0xff, are out of range
+ if ((iscprim(arg) && cp_class((cprim_t*)ptr(arg))==wchartype) ||
+ uldelim > 0xff)
+ lerrorf(ArgError, "%s: delimiter out of range", fname);
+ }
+ return (char)uldelim;
+}
+
+value_t fl_ioreaduntil(value_t *args, u_int32_t nargs)
+{+ argcount("io.readuntil", nargs, 2);+ value_t str = cvalue_string(80);
+ cvalue_t *cv = (cvalue_t*)ptr(str);
+ char *data = cv_data(cv);
+ ios_t dest;
+ ios_mem(&dest, 0);
+ ios_setbuf(&dest, data, 80, 0);
+ char delim = get_delim_arg(args[1], "io.readuntil");
+ ios_t *src = toiostream(args[0], "io.readuntil");
+ size_t n = ios_copyuntil(&dest, src, delim);
+ cv->len = n;
+ if (dest.buf != data) {+ // outgrew initial space
+ cv->data = dest.buf;
+#ifndef BOEHM_GC
+ cv_autorelease(cv);
+#endif
+ }
+ ((char*)cv->data)[n] = '\0';
+ if (n == 0 && ios_eof(src))
+ return FL_EOF;
+ return str;
+}
+
+value_t fl_iocopyuntil(value_t *args, u_int32_t nargs)
+{+ argcount("io.copyuntil", nargs, 3);+ ios_t *dest = toiostream(args[0], "io.copyuntil");
+ ios_t *src = toiostream(args[1], "io.copyuntil");
+ char delim = get_delim_arg(args[2], "io.copyuntil");
+ return size_wrap(ios_copyuntil(dest, src, delim));
+}
+
+value_t fl_iocopy(value_t *args, u_int32_t nargs)
+{+ if (nargs < 2 || nargs > 3)
+ argcount("io.copy", nargs, 2);+ ios_t *dest = toiostream(args[0], "io.copy");
+ ios_t *src = toiostream(args[1], "io.copy");
+ if (nargs == 3) {+ size_t n = toulong(args[2], "io.copy");
+ return size_wrap(ios_copy(dest, src, n));
+ }
+ return size_wrap(ios_copyall(dest, src));
+}
+
+value_t stream_to_string(value_t *ps)
+{+ value_t str;
+ size_t n;
+ ios_t *st = value2c(ios_t*,*ps);
+ if (st->buf == &st->local[0]) {+ n = st->size;
+ str = cvalue_string(n);
+ memcpy(cvalue_data(str), value2c(ios_t*,*ps)->buf, n);
+ ios_trunc(st, 0);
+ }
+ else {+ char *b = ios_takebuf(st, &n); n--;
+ b[n] = '\0';
+ str = cvalue_from_ref(stringtype, b, n, FL_NIL);
+#ifndef BOEHM_GC
+ cv_autorelease((cvalue_t*)ptr(str));
+#endif
+ }
+ return str;
+}
+
+value_t fl_iotostring(value_t *args, u_int32_t nargs)
+{+ argcount("io.tostring!", nargs, 1);+ ios_t *src = toiostream(args[0], "io.tostring!");
+ if (src->bm != bm_mem)
+ lerror(ArgError, "io.tostring!: requires memory stream");
+ return stream_to_string(&args[0]);
+}
+
+static builtinspec_t iostreamfunc_info[] = {+ { "iostream?", fl_iostreamp },+ { "eof-object", fl_eof_object },+ { "eof-object?", fl_eof_objectp },+ { "dump", fl_dump },+ { "file", fl_file },+ { "buffer", fl_buffer },+ { "read", fl_read },+ { "write", fl_write },+ { "io.flush", fl_ioflush },+ { "io.close", fl_ioclose },+ { "io.eof?" , fl_ioeof },+ { "io.seek" , fl_ioseek },+ { "io.pos", fl_iopos },+ { "io.getc" , fl_iogetc },+ { "io.putc" , fl_ioputc },+ { "io.peekc" , fl_iopeekc },+ { "io.discardbuffer", fl_iopurge },+ { "io.read", fl_ioread },+ { "io.write", fl_iowrite },+ { "io.copy", fl_iocopy },+ { "io.readuntil", fl_ioreaduntil },+ { "io.copyuntil", fl_iocopyuntil },+ { "io.tostring!", fl_iotostring },+ { NULL, NULL }+};
+
+void iostream_init()
+{+ iostreamsym = symbol("iostream");+ rdsym = symbol(":read");+ wrsym = symbol(":write");+ apsym = symbol(":append");+ crsym = symbol(":create");+ truncsym = symbol(":truncate");+ instrsym = symbol("*input-stream*");+ outstrsym = symbol("*output-stream*");+ iostreamtype = define_opaque_type(iostreamsym, sizeof(ios_t),
+ &iostream_vtable, NULL);
+ assign_global_builtins(iostreamfunc_info);
+
+ setc(symbol("*stdout*"), cvalue_from_ref(iostreamtype, ios_stdout,+ sizeof(ios_t), FL_NIL));
+ setc(symbol("*stderr*"), cvalue_from_ref(iostreamtype, ios_stderr,+ sizeof(ios_t), FL_NIL));
+ setc(symbol("*stdin*" ), cvalue_from_ref(iostreamtype, ios_stdin,+ sizeof(ios_t), FL_NIL));
+}
--- /dev/null
+++ b/lib/lazy.scm
@@ -1,0 +1,47 @@
+; SRFI 45: Primitives for Expressing Iterative Lazy Algorithms
+; by André van Tonder
+;=========================================================================
+; Boxes
+
+(define (box x) (list x))
+(define unbox car)
+(define set-box! set-car!)
+
+;=========================================================================
+; Primitives for lazy evaluation:
+
+(define (eager x)
+ (box (cons 'eager x)))
+
+#|
+(define-syntax lazy
+ (syntax-rules ()
+ ((lazy exp)
+ (box (cons 'lazy (lambda () exp))))))
+
+(define-syntax delay
+ (syntax-rules ()
+ ((delay exp) (lazy (eager exp)))))
+|#
+
+(define-macro (lazy exp)
+ `(box (cons 'lazy (lambda () ,exp))))
+
+(define-macro (delay exp)
+ `(lazy (eager ,exp)))
+
+(define (force promise)
+ (let ((content (unbox promise)))
+ (case (car content)
+ ((eager) (cdr content))
+ ((lazy) (let* ((promise* ((cdr content)))
+ (content (unbox promise))) ; *
+ (if (not (eqv? (car content) 'eager)) ; *
+ (begin (set-car! content (car (unbox promise*)))
+ (set-cdr! content (cdr (unbox promise*)))
+ (set-box! promise* content)))
+ (force promise))))))
+
+; (*) These two lines re-fetch and check the original promise in case
+; the first line of the let* caused it to be forced. For an example
+; where this happens, see reentrancy test 3 below.
--- /dev/null
+++ b/lib/psyntax.pp
@@ -1,0 +1,10858 @@
+;;; psyntax.pp
+;;; automatically generated from psyntax.ss
+;;; Mon Feb 26 23:22:05 EST 2007
+;;; see copyright notice in psyntax.ss
+
+((lambda ()
+ (letrec ((noexpand62 '"noexpand")
+ (make-syntax-object63 (lambda (expression2530 wrap2529)
+ (vector
+ 'syntax-object
+ expression2530
+ wrap2529)))
+ (syntax-object?64 (lambda (x2528)
+ (if (vector? x2528)
+ (if (= (vector-length x2528) '3)
+ (eq? (vector-ref x2528 '0)
+ 'syntax-object)
+ '#f)
+ '#f)))
+ (syntax-object-expression65 (lambda (x2527)
+ (vector-ref x2527 '1)))
+ (syntax-object-wrap66 (lambda (x2526)
+ (vector-ref x2526 '2)))
+ (set-syntax-object-expression!67 (lambda (x2525 update2524)
+ (vector-set!
+ x2525
+ '1
+ update2524)))
+ (set-syntax-object-wrap!68 (lambda (x2523 update2522)
+ (vector-set!
+ x2523
+ '2
+ update2522)))
+ (annotation?132 (lambda (x2521) '#f))
+ (top-level-eval-hook133 (lambda (x2520)
+ (eval (list noexpand62 x2520))))
+ (local-eval-hook134 (lambda (x2519)
+ (eval (list noexpand62 x2519))))
+ (define-top-level-value-hook135 (lambda (sym2518 val2517)
+ (top-level-eval-hook133
+ (list
+ 'define
+ sym2518
+ (list 'quote val2517)))))
+ (error-hook136 (lambda (who2516 why2515 what2514)
+ (error who2516 '"~a ~s" why2515 what2514)))
+ (put-cte-hook137 (lambda (symbol2513 val2512)
+ ($sc-put-cte symbol2513 val2512 '*top*)))
+ (get-global-definition-hook138 (lambda (symbol2511)
+ (getprop
+ symbol2511
+ '*sc-expander*)))
+ (put-global-definition-hook139 (lambda (symbol2510 x2509)
+ (if (not x2509)
+ (remprop
+ symbol2510
+ '*sc-expander*)
+ (putprop
+ symbol2510
+ '*sc-expander*
+ x2509))))
+ (read-only-binding?140 (lambda (symbol2508) '#f))
+ (get-import-binding141 (lambda (symbol2507 token2506)
+ (getprop symbol2507 token2506)))
+ (update-import-binding!142 (lambda (symbol2504 token2503
+ p2502)
+ ((lambda (x2505)
+ (if (not x2505)
+ (remprop
+ symbol2504
+ token2503)
+ (putprop
+ symbol2504
+ token2503
+ x2505)))
+ (p2502
+ (get-import-binding141
+ symbol2504
+ token2503)))))
+ (generate-id143 ((lambda (digits2488)
+ ((lambda (base2490 session-key2489)
+ (letrec ((make-digit2491 (lambda (x2501)
+ (string-ref
+ digits2488
+ x2501)))
+ (fmt2492 (lambda (n2495)
+ ((letrec ((fmt2496 (lambda (n2498
+ a2497)
+ (if (< n2498
+ base2490)
+ (list->string
+ (cons
+ (make-digit2491
+ n2498)
+ a2497))
+ ((lambda (r2500
+ rest2499)
+ (fmt2496
+ rest2499
+ (cons
+ (make-digit2491
+ r2500)
+ a2497)))
+ (modulo
+ n2498
+ base2490)
+ (quotient
+ n2498
+ base2490))))))
+ fmt2496)
+ n2495
+ '()))))
+ ((lambda (n2493)
+ (lambda (name2494)
+ (begin
+ (set! n2493 (+ n2493 '1))
+ (string->symbol
+ (string-append
+ session-key2489
+ (fmt2492 n2493))))))
+ '-1)))
+ (string-length digits2488)
+ '"_"))
+ '"0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?~_^.+-"))
+ (built-lambda?217 (lambda (x2487)
+ (if (pair? x2487)
+ (eq? (car x2487) 'lambda)
+ '#f)))
+ (build-sequence235 (lambda (ae2484 exps2483)
+ ((letrec ((loop2485 (lambda (exps2486)
+ (if (null?
+ (cdr exps2486))
+ (car exps2486)
+ (if (equal?
+ (car exps2486)
+ '(void))
+ (loop2485
+ (cdr exps2486))
+ (cons
+ 'begin
+ exps2486))))))
+ loop2485)
+ exps2483)))
+ (build-letrec236 (lambda (ae2482 vars2481 val-exps2480
+ body-exp2479)
+ (if (null? vars2481)
+ body-exp2479
+ (list
+ 'letrec
+ (map list vars2481 val-exps2480)
+ body-exp2479))))
+ (build-body237 (lambda (ae2478 vars2477 val-exps2476
+ body-exp2475)
+ (build-letrec236
+ ae2478
+ vars2477
+ val-exps2476
+ body-exp2475)))
+ (build-top-module238 (lambda (ae2463 types2462 vars2461
+ val-exps2460 body-exp2459)
+ (call-with-values
+ (lambda ()
+ ((letrec ((f2467 (lambda (types2469
+ vars2468)
+ (if (null?
+ types2469)
+ (values
+ '()
+ '()
+ '())
+ ((lambda (var2470)
+ (call-with-values
+ (lambda ()
+ (f2467
+ (cdr types2469)
+ (cdr vars2468)))
+ (lambda (vars2473
+ defns2472
+ sets2471)
+ (if (eq? (car types2469)
+ 'global)
+ ((lambda (x2474)
+ (values
+ (cons
+ x2474
+ vars2473)
+ (cons
+ (list
+ 'define
+ var2470
+ (chi-void518))
+ defns2472)
+ (cons
+ (list
+ 'set!
+ var2470
+ x2474)
+ sets2471)))
+ (gensym))
+ (values
+ (cons
+ var2470
+ vars2473)
+ defns2472
+ sets2471)))))
+ (car vars2468))))))
+ f2467)
+ types2462
+ vars2461))
+ (lambda (vars2466 defns2465 sets2464)
+ (if (null? defns2465)
+ (build-letrec236
+ ae2463
+ vars2466
+ val-exps2460
+ body-exp2459)
+ (build-sequence235
+ '#f
+ (append
+ defns2465
+ (list
+ (build-letrec236
+ ae2463
+ vars2466
+ val-exps2460
+ (build-sequence235
+ '#f
+ (append
+ sets2464
+ (list
+ body-exp2459))))))))))))
+ (sanitize-binding271 (lambda (b2455)
+ (if (procedure? b2455)
+ (cons 'macro b2455)
+ (if (binding?285 b2455)
+ (if ((lambda (t2456)
+ (if (memv
+ t2456
+ '(core
+ macro
+ macro!
+ deferred))
+ (procedure?
+ (binding-value282
+ b2455))
+ (if (memv
+ t2456
+ '($module))
+ (interface?452
+ (binding-value282
+ b2455))
+ (if (memv
+ t2456
+ '(lexical))
+ '#f
+ (if (memv
+ t2456
+ '(global
+ meta-variable))
+ (symbol?
+ (binding-value282
+ b2455))
+ (if (memv
+ t2456
+ '(syntax))
+ ((lambda (x2457)
+ (if (pair?
+ x2457)
+ (if '#f
+ ((lambda (n2458)
+ (if (integer?
+ n2458)
+ (if (exact?
+ n2458)
+ (>= n2458
+ '0)
+ '#f)
+ '#f))
+ (cdr x2457))
+ '#f)
+ '#f))
+ (binding-value282
+ b2455))
+ (if (memv
+ t2456
+ '(begin
+ define
+ define-syntax
+ set!
+ $module-key
+ $import
+ eval-when
+ meta))
+ (null?
+ (binding-value282
+ b2455))
+ (if (memv
+ t2456
+ '(local-syntax))
+ (boolean?
+ (binding-value282
+ b2455))
+ (if (memv
+ t2456
+ '(displaced-lexical))
+ (eq? (binding-value282
+ b2455)
+ '#f)
+ '#t)))))))))
+ (binding-type281 b2455))
+ b2455
+ '#f)
+ '#f))))
+ (binding-type281 car)
+ (binding-value282 cdr)
+ (set-binding-type!283 set-car!)
+ (set-binding-value!284 set-cdr!)
+ (binding?285 (lambda (x2454)
+ (if (pair? x2454) (symbol? (car x2454)) '#f)))
+ (extend-env295 (lambda (label2453 binding2452 r2451)
+ (cons (cons label2453 binding2452) r2451)))
+ (extend-env*296 (lambda (labels2450 bindings2449 r2448)
+ (if (null? labels2450)
+ r2448
+ (extend-env*296
+ (cdr labels2450)
+ (cdr bindings2449)
+ (extend-env295
+ (car labels2450)
+ (car bindings2449)
+ r2448)))))
+ (extend-var-env*297 (lambda (labels2447 vars2446 r2445)
+ (if (null? labels2447)
+ r2445
+ (extend-var-env*297
+ (cdr labels2447)
+ (cdr vars2446)
+ (extend-env295
+ (car labels2447)
+ (cons 'lexical (car vars2446))
+ r2445)))))
+ (displaced-lexical?298 (lambda (id2442 r2441)
+ ((lambda (n2443)
+ (if n2443
+ ((lambda (b2444)
+ (eq? (binding-type281 b2444)
+ 'displaced-lexical))
+ (lookup301 n2443 r2441))
+ '#f))
+ (id-var-name434 id2442 '(())))))
+ (displaced-lexical-error299 (lambda (id2440)
+ (syntax-error
+ id2440
+ (if (id-var-name434
+ id2440
+ '(()))
+ '"identifier out of context"
+ '"identifier not visible"))))
+ (lookup*300 (lambda (x2437 r2436)
+ ((lambda (t2438)
+ (if t2438
+ (cdr t2438)
+ (if (symbol? x2437)
+ ((lambda (t2439)
+ (if t2439
+ t2439
+ (cons 'global x2437)))
+ (get-global-definition-hook138
+ x2437))
+ '(displaced-lexical . #f))))
+ (assq x2437 r2436))))
+ (lookup301 (lambda (x2431 r2430)
+ (letrec ((whack-binding!2432 (lambda (b2435
+ *b2434)
+ (begin
+ (set-binding-type!283
+ b2435
+ (binding-type281
+ *b2434))
+ (set-binding-value!284
+ b2435
+ (binding-value282
+ *b2434))))))
+ ((lambda (b2433)
+ (begin
+ (if (eq? (binding-type281 b2433) 'deferred)
+ (whack-binding!2432
+ b2433
+ (make-transformer-binding302
+ ((binding-value282 b2433))))
+ (void))
+ b2433))
+ (lookup*300 x2431 r2430)))))
+ (make-transformer-binding302 (lambda (b2428)
+ ((lambda (t2429)
+ (if t2429
+ t2429
+ (syntax-error
+ b2428
+ '"invalid transformer")))
+ (sanitize-binding271 b2428))))
+ (defer-or-eval-transformer303 (lambda (eval2427 x2426)
+ (if (built-lambda?217 x2426)
+ (cons
+ 'deferred
+ (lambda ()
+ (eval2427 x2426)))
+ (make-transformer-binding302
+ (eval2427 x2426)))))
+ (global-extend304 (lambda (type2425 sym2424 val2423)
+ (put-cte-hook137
+ sym2424
+ (cons type2425 val2423))))
+ (nonsymbol-id?305 (lambda (x2421)
+ (if (syntax-object?64 x2421)
+ (symbol?
+ ((lambda (e2422)
+ (if (annotation?132 e2422)
+ (annotation-expression e2422)
+ e2422))
+ (syntax-object-expression65
+ x2421)))
+ '#f)))
+ (id?306 (lambda (x2419)
+ (if (symbol? x2419)
+ '#t
+ (if (syntax-object?64 x2419)
+ (symbol?
+ ((lambda (e2420)
+ (if (annotation?132 e2420)
+ (annotation-expression e2420)
+ e2420))
+ (syntax-object-expression65 x2419)))
+ (if (annotation?132 x2419)
+ (symbol? (annotation-expression x2419))
+ '#f)))))
+ (id-marks312 (lambda (id2418)
+ (if (syntax-object?64 id2418)
+ (wrap-marks316
+ (syntax-object-wrap66 id2418))
+ (wrap-marks316 '((top))))))
+ (id-subst313 (lambda (id2417)
+ (if (syntax-object?64 id2417)
+ (wrap-subst317
+ (syntax-object-wrap66 id2417))
+ (wrap-marks316 '((top))))))
+ (id-sym-name&marks314 (lambda (x2414 w2413)
+ (if (syntax-object?64 x2414)
+ (values
+ ((lambda (e2415)
+ (if (annotation?132 e2415)
+ (annotation-expression
+ e2415)
+ e2415))
+ (syntax-object-expression65
+ x2414))
+ (join-marks423
+ (wrap-marks316 w2413)
+ (wrap-marks316
+ (syntax-object-wrap66
+ x2414))))
+ (values
+ ((lambda (e2416)
+ (if (annotation?132 e2416)
+ (annotation-expression
+ e2416)
+ e2416))
+ x2414)
+ (wrap-marks316 w2413)))))
+ (make-wrap315 cons)
+ (wrap-marks316 car)
+ (wrap-subst317 cdr)
+ (make-indirect-label355 (lambda (label2412)
+ (vector 'indirect-label label2412)))
+ (indirect-label?356 (lambda (x2411)
+ (if (vector? x2411)
+ (if (= (vector-length x2411) '2)
+ (eq? (vector-ref x2411 '0)
+ 'indirect-label)
+ '#f)
+ '#f)))
+ (indirect-label-label357 (lambda (x2410)
+ (vector-ref x2410 '1)))
+ (set-indirect-label-label!358 (lambda (x2409 update2408)
+ (vector-set!
+ x2409
+ '1
+ update2408)))
+ (gen-indirect-label359 (lambda ()
+ (make-indirect-label355
+ (gen-label362))))
+ (get-indirect-label360 (lambda (x2407)
+ (indirect-label-label357 x2407)))
+ (set-indirect-label!361 (lambda (x2406 v2405)
+ (set-indirect-label-label!358
+ x2406
+ v2405)))
+ (gen-label362 (lambda () (string '#\i)))
+ (label?363 (lambda (x2402)
+ ((lambda (t2403)
+ (if t2403
+ t2403
+ ((lambda (t2404)
+ (if t2404
+ t2404
+ (indirect-label?356 x2402)))
+ (symbol? x2402))))
+ (string? x2402))))
+ (gen-labels364 (lambda (ls2401)
+ (if (null? ls2401)
+ '()
+ (cons
+ (gen-label362)
+ (gen-labels364 (cdr ls2401))))))
+ (make-ribcage365 (lambda (symnames2400 marks2399 labels2398)
+ (vector
+ 'ribcage
+ symnames2400
+ marks2399
+ labels2398)))
+ (ribcage?366 (lambda (x2397)
+ (if (vector? x2397)
+ (if (= (vector-length x2397) '4)
+ (eq? (vector-ref x2397 '0) 'ribcage)
+ '#f)
+ '#f)))
+ (ribcage-symnames367 (lambda (x2396) (vector-ref x2396 '1)))
+ (ribcage-marks368 (lambda (x2395) (vector-ref x2395 '2)))
+ (ribcage-labels369 (lambda (x2394) (vector-ref x2394 '3)))
+ (set-ribcage-symnames!370 (lambda (x2393 update2392)
+ (vector-set! x2393 '1 update2392)))
+ (set-ribcage-marks!371 (lambda (x2391 update2390)
+ (vector-set! x2391 '2 update2390)))
+ (set-ribcage-labels!372 (lambda (x2389 update2388)
+ (vector-set! x2389 '3 update2388)))
+ (make-top-ribcage373 (lambda (key2387 mutable?2386)
+ (vector
+ 'top-ribcage
+ key2387
+ mutable?2386)))
+ (top-ribcage?374 (lambda (x2385)
+ (if (vector? x2385)
+ (if (= (vector-length x2385) '3)
+ (eq? (vector-ref x2385 '0)
+ 'top-ribcage)
+ '#f)
+ '#f)))
+ (top-ribcage-key375 (lambda (x2384) (vector-ref x2384 '1)))
+ (top-ribcage-mutable?376 (lambda (x2383)
+ (vector-ref x2383 '2)))
+ (set-top-ribcage-key!377 (lambda (x2382 update2381)
+ (vector-set! x2382 '1 update2381)))
+ (set-top-ribcage-mutable?!378 (lambda (x2380 update2379)
+ (vector-set!
+ x2380
+ '2
+ update2379)))
+ (make-import-interface379 (lambda (interface2378
+ new-marks2377)
+ (vector
+ 'import-interface
+ interface2378
+ new-marks2377)))
+ (import-interface?380 (lambda (x2376)
+ (if (vector? x2376)
+ (if (= (vector-length x2376) '3)
+ (eq? (vector-ref x2376 '0)
+ 'import-interface)
+ '#f)
+ '#f)))
+ (import-interface-interface381 (lambda (x2375)
+ (vector-ref x2375 '1)))
+ (import-interface-new-marks382 (lambda (x2374)
+ (vector-ref x2374 '2)))
+ (set-import-interface-interface!383 (lambda (x2373
+ update2372)
+ (vector-set!
+ x2373
+ '1
+ update2372)))
+ (set-import-interface-new-marks!384 (lambda (x2371
+ update2370)
+ (vector-set!
+ x2371
+ '2
+ update2370)))
+ (make-env385 (lambda (top-ribcage2369 wrap2368)
+ (vector 'env top-ribcage2369 wrap2368)))
+ (env?386 (lambda (x2367)
+ (if (vector? x2367)
+ (if (= (vector-length x2367) '3)
+ (eq? (vector-ref x2367 '0) 'env)
+ '#f)
+ '#f)))
+ (env-top-ribcage387 (lambda (x2366) (vector-ref x2366 '1)))
+ (env-wrap388 (lambda (x2365) (vector-ref x2365 '2)))
+ (set-env-top-ribcage!389 (lambda (x2364 update2363)
+ (vector-set! x2364 '1 update2363)))
+ (set-env-wrap!390 (lambda (x2362 update2361)
+ (vector-set! x2362 '2 update2361)))
+ (anti-mark400 (lambda (w2360)
+ (make-wrap315
+ (cons '#f (wrap-marks316 w2360))
+ (cons 'shift (wrap-subst317 w2360)))))
+ (barrier-marker405 '#f)
+ (extend-ribcage!410 (lambda (ribcage2358 id2357 label2356)
+ (begin
+ (set-ribcage-symnames!370
+ ribcage2358
+ (cons
+ ((lambda (e2359)
+ (if (annotation?132 e2359)
+ (annotation-expression
+ e2359)
+ e2359))
+ (syntax-object-expression65
+ id2357))
+ (ribcage-symnames367 ribcage2358)))
+ (set-ribcage-marks!371
+ ribcage2358
+ (cons
+ (wrap-marks316
+ (syntax-object-wrap66 id2357))
+ (ribcage-marks368 ribcage2358)))
+ (set-ribcage-labels!372
+ ribcage2358
+ (cons
+ label2356
+ (ribcage-labels369
+ ribcage2358))))))
+ (import-extend-ribcage!411 (lambda (ribcage2354
+ new-marks2353 id2352
+ label2351)
+ (begin
+ (set-ribcage-symnames!370
+ ribcage2354
+ (cons
+ ((lambda (e2355)
+ (if (annotation?132
+ e2355)
+ (annotation-expression
+ e2355)
+ e2355))
+ (syntax-object-expression65
+ id2352))
+ (ribcage-symnames367
+ ribcage2354)))
+ (set-ribcage-marks!371
+ ribcage2354
+ (cons
+ (join-marks423
+ new-marks2353
+ (wrap-marks316
+ (syntax-object-wrap66
+ id2352)))
+ (ribcage-marks368
+ ribcage2354)))
+ (set-ribcage-labels!372
+ ribcage2354
+ (cons
+ label2351
+ (ribcage-labels369
+ ribcage2354))))))
+ (extend-ribcage-barrier!412 (lambda (ribcage2350
+ killer-id2349)
+ (extend-ribcage-barrier-help!413
+ ribcage2350
+ (syntax-object-wrap66
+ killer-id2349))))
+ (extend-ribcage-barrier-help!413 (lambda (ribcage2348
+ wrap2347)
+ (begin
+ (set-ribcage-symnames!370
+ ribcage2348
+ (cons
+ barrier-marker405
+ (ribcage-symnames367
+ ribcage2348)))
+ (set-ribcage-marks!371
+ ribcage2348
+ (cons
+ (wrap-marks316
+ wrap2347)
+ (ribcage-marks368
+ ribcage2348))))))
+ (extend-ribcage-subst!414 (lambda (ribcage2346
+ import-iface2345)
+ (set-ribcage-symnames!370
+ ribcage2346
+ (cons
+ import-iface2345
+ (ribcage-symnames367
+ ribcage2346)))))
+ (lookup-import-binding-name415 (lambda (sym2340 marks2339
+ token2338
+ new-marks2337)
+ ((lambda (new2341)
+ (if new2341
+ ((letrec ((f2342 (lambda (new2343)
+ (if (pair?
+ new2343)
+ ((lambda (t2344)
+ (if t2344
+ t2344
+ (f2342
+ (cdr new2343))))
+ (f2342
+ (car new2343)))
+ (if (symbol?
+ new2343)
+ (if (same-marks?425
+ marks2339
+ (join-marks423
+ new-marks2337
+ (wrap-marks316
+ '((top)))))
+ new2343
+ '#f)
+ (if (same-marks?425
+ marks2339
+ (join-marks423
+ new-marks2337
+ (wrap-marks316
+ (syntax-object-wrap66
+ new2343))))
+ new2343
+ '#f))))))
+ f2342)
+ new2341)
+ '#f))
+ (get-import-binding141
+ sym2340
+ token2338))))
+ (store-import-binding416 (lambda (id2321 token2320
+ new-marks2319)
+ (letrec ((cons-id2322 (lambda (id2336
+ x2335)
+ (if (not x2335)
+ id2336
+ (cons
+ id2336
+ x2335))))
+ (weed2323 (lambda (marks2334
+ x2333)
+ (if (pair?
+ x2333)
+ (if (same-marks?425
+ (id-marks312
+ (car x2333))
+ marks2334)
+ (weed2323
+ marks2334
+ (cdr x2333))
+ (cons-id2322
+ (car x2333)
+ (weed2323
+ marks2334
+ (cdr x2333))))
+ (if x2333
+ (if (not (same-marks?425
+ (id-marks312
+ x2333)
+ marks2334))
+ x2333
+ '#f)
+ '#f)))))
+ ((lambda (id2324)
+ ((lambda (sym2325)
+ (if (not (eq? id2324
+ sym2325))
+ ((lambda (marks2326)
+ (update-import-binding!142
+ sym2325
+ token2320
+ (lambda (old-binding2327)
+ ((lambda (x2328)
+ (cons-id2322
+ (if (same-marks?425
+ marks2326
+ (wrap-marks316
+ '((top))))
+ (resolved-id-var-name420
+ id2324)
+ id2324)
+ x2328))
+ (weed2323
+ marks2326
+ old-binding2327)))))
+ (id-marks312 id2324))
+ (void)))
+ ((lambda (x2329)
+ ((lambda (e2330)
+ (if (annotation?132
+ e2330)
+ (annotation-expression
+ e2330)
+ e2330))
+ (if (syntax-object?64
+ x2329)
+ (syntax-object-expression65
+ x2329)
+ x2329)))
+ id2324)))
+ (if (null? new-marks2319)
+ id2321
+ (make-syntax-object63
+ ((lambda (x2331)
+ ((lambda (e2332)
+ (if (annotation?132
+ e2332)
+ (annotation-expression
+ e2332)
+ e2332))
+ (if (syntax-object?64
+ x2331)
+ (syntax-object-expression65
+ x2331)
+ x2331)))
+ id2321)
+ (make-wrap315
+ (join-marks423
+ new-marks2319
+ (id-marks312 id2321))
+ (id-subst313
+ id2321))))))))
+ (make-binding-wrap417 (lambda (ids2309 labels2308 w2307)
+ (if (null? ids2309)
+ w2307
+ (make-wrap315
+ (wrap-marks316 w2307)
+ (cons
+ ((lambda (labelvec2310)
+ ((lambda (n2311)
+ ((lambda (symnamevec2313
+ marksvec2312)
+ (begin
+ ((letrec ((f2314 (lambda (ids2316
+ i2315)
+ (if (not (null?
+ ids2316))
+ (call-with-values
+ (lambda ()
+ (id-sym-name&marks314
+ (car ids2316)
+ w2307))
+ (lambda (symname2318
+ marks2317)
+ (begin
+ (vector-set!
+ symnamevec2313
+ i2315
+ symname2318)
+ (vector-set!
+ marksvec2312
+ i2315
+ marks2317)
+ (f2314
+ (cdr ids2316)
+ (+ i2315
+ '1)))))
+ (void)))))
+ f2314)
+ ids2309
+ '0)
+ (make-ribcage365
+ symnamevec2313
+ marksvec2312
+ labelvec2310)))
+ (make-vector n2311)
+ (make-vector n2311)))
+ (vector-length
+ labelvec2310)))
+ (list->vector labels2308))
+ (wrap-subst317 w2307))))))
+ (make-resolved-id418 (lambda (fromsym2306 marks2305
+ tosym2304)
+ (make-syntax-object63
+ fromsym2306
+ (make-wrap315
+ marks2305
+ (list
+ (make-ribcage365
+ (vector fromsym2306)
+ (vector marks2305)
+ (vector tosym2304)))))))
+ (id->resolved-id419 (lambda (id2299)
+ (call-with-values
+ (lambda ()
+ (id-var-name&marks432 id2299 '(())))
+ (lambda (tosym2301 marks2300)
+ (begin
+ (if (not tosym2301)
+ (syntax-error
+ id2299
+ '"identifier not visible for export")
+ (void))
+ (make-resolved-id418
+ ((lambda (x2302)
+ ((lambda (e2303)
+ (if (annotation?132 e2303)
+ (annotation-expression
+ e2303)
+ e2303))
+ (if (syntax-object?64 x2302)
+ (syntax-object-expression65
+ x2302)
+ x2302)))
+ id2299)
+ marks2300
+ tosym2301))))))
+ (resolved-id-var-name420 (lambda (id2298)
+ (vector-ref
+ (ribcage-labels369
+ (car (wrap-subst317
+ (syntax-object-wrap66
+ id2298))))
+ '0)))
+ (smart-append421 (lambda (m12297 m22296)
+ (if (null? m22296)
+ m12297
+ (append m12297 m22296))))
+ (join-wraps422 (lambda (w12293 w22292)
+ ((lambda (m12295 s12294)
+ (if (null? m12295)
+ (if (null? s12294)
+ w22292
+ (make-wrap315
+ (wrap-marks316 w22292)
+ (join-subst424
+ s12294
+ (wrap-subst317 w22292))))
+ (make-wrap315
+ (join-marks423
+ m12295
+ (wrap-marks316 w22292))
+ (join-subst424
+ s12294
+ (wrap-subst317 w22292)))))
+ (wrap-marks316 w12293)
+ (wrap-subst317 w12293))))
+ (join-marks423 (lambda (m12291 m22290)
+ (smart-append421 m12291 m22290)))
+ (join-subst424 (lambda (s12289 s22288)
+ (smart-append421 s12289 s22288)))
+ (same-marks?425 (lambda (x2286 y2285)
+ ((lambda (t2287)
+ (if t2287
+ t2287
+ (if (not (null? x2286))
+ (if (not (null? y2285))
+ (if (eq? (car x2286)
+ (car y2285))
+ (same-marks?425
+ (cdr x2286)
+ (cdr y2285))
+ '#f)
+ '#f)
+ '#f)))
+ (eq? x2286 y2285))))
+ (diff-marks426 (lambda (m12279 m22278)
+ ((lambda (n12281 n22280)
+ ((letrec ((f2282 (lambda (n12284 m12283)
+ (if (> n12284 n22280)
+ (cons
+ (car m12283)
+ (f2282
+ (- n12284 '1)
+ (cdr m12283)))
+ (if (equal?
+ m12283
+ m22278)
+ '()
+ (error 'sc-expand
+ '"internal error in diff-marks: ~s is not a tail of ~s"
+ m12283
+ m22278))))))
+ f2282)
+ n12281
+ m12279))
+ (length m12279)
+ (length m22278))))
+ (leave-implicit?427 (lambda (token2277)
+ (eq? token2277 '*top*)))
+ (new-binding428 (lambda (sym2274 marks2273 token2272)
+ ((lambda (loc2275)
+ ((lambda (id2276)
+ (begin
+ (store-import-binding416
+ id2276
+ token2272
+ '())
+ (values loc2275 id2276)))
+ (make-resolved-id418
+ sym2274
+ marks2273
+ loc2275)))
+ (if (if (leave-implicit?427 token2272)
+ (same-marks?425
+ marks2273
+ (wrap-marks316 '((top))))
+ '#f)
+ sym2274
+ (generate-id143 sym2274)))))
+ (top-id-bound-var-name429 (lambda (sym2268 marks2267
+ top-ribcage2266)
+ ((lambda (token2269)
+ ((lambda (t2270)
+ (if t2270
+ ((lambda (id2271)
+ (if (symbol? id2271)
+ (if (read-only-binding?140
+ id2271)
+ (new-binding428
+ sym2268
+ marks2267
+ token2269)
+ (values
+ id2271
+ (make-resolved-id418
+ sym2268
+ marks2267
+ id2271)))
+ (values
+ (resolved-id-var-name420
+ id2271)
+ id2271)))
+ t2270)
+ (new-binding428
+ sym2268
+ marks2267
+ token2269)))
+ (lookup-import-binding-name415
+ sym2268
+ marks2267
+ token2269
+ '())))
+ (top-ribcage-key375
+ top-ribcage2266))))
+ (top-id-free-var-name430 (lambda (sym2260 marks2259
+ top-ribcage2258)
+ ((lambda (token2261)
+ ((lambda (t2262)
+ (if t2262
+ ((lambda (id2263)
+ (if (symbol? id2263)
+ id2263
+ (resolved-id-var-name420
+ id2263)))
+ t2262)
+ (if (if (top-ribcage-mutable?376
+ top-ribcage2258)
+ (same-marks?425
+ marks2259
+ (wrap-marks316
+ '((top))))
+ '#f)
+ (call-with-values
+ (lambda ()
+ (new-binding428
+ sym2260
+ (wrap-marks316
+ '((top)))
+ token2261))
+ (lambda (sym2265
+ id2264)
+ sym2265))
+ '#f)))
+ (lookup-import-binding-name415
+ sym2260
+ marks2259
+ token2261
+ '())))
+ (top-ribcage-key375
+ top-ribcage2258))))
+ (id-var-name-loc&marks431 (lambda (id2209 w2208)
+ (letrec ((search2210 (lambda (sym2253
+ subst2252
+ marks2251)
+ (if (null?
+ subst2252)
+ (values
+ '#f
+ marks2251)
+ ((lambda (fst2254)
+ (if (eq? fst2254
+ 'shift)
+ (search2210
+ sym2253
+ (cdr subst2252)
+ (cdr marks2251))
+ (if (ribcage?366
+ fst2254)
+ ((lambda (symnames2255)
+ (if (vector?
+ symnames2255)
+ (search-vector-rib2212
+ sym2253
+ subst2252
+ marks2251
+ symnames2255
+ fst2254)
+ (search-list-rib2211
+ sym2253
+ subst2252
+ marks2251
+ symnames2255
+ fst2254)))
+ (ribcage-symnames367
+ fst2254))
+ (if (top-ribcage?374
+ fst2254)
+ ((lambda (t2256)
+ (if t2256
+ ((lambda (var-name2257)
+ (values
+ var-name2257
+ marks2251))
+ t2256)
+ (search2210
+ sym2253
+ (cdr subst2252)
+ marks2251)))
+ (top-id-free-var-name430
+ sym2253
+ marks2251
+ fst2254))
+ (error 'sc-expand
+ '"internal error in id-var-name-loc&marks: improper subst ~s"
+ subst2252)))))
+ (car subst2252)))))
+ (search-list-rib2211 (lambda (sym2231
+ subst2230
+ marks2229
+ symnames2228
+ ribcage2227)
+ ((letrec ((f2232 (lambda (symnames2234
+ i2233)
+ (if (null?
+ symnames2234)
+ (search2210
+ sym2231
+ (cdr subst2230)
+ marks2229)
+ ((lambda (x2235)
+ (if (if (eq? x2235
+ sym2231)
+ (same-marks?425
+ marks2229
+ (list-ref
+ (ribcage-marks368
+ ribcage2227)
+ i2233))
+ '#f)
+ (values
+ (list-ref
+ (ribcage-labels369
+ ribcage2227)
+ i2233)
+ marks2229)
+ (if (import-interface?380
+ x2235)
+ ((lambda (iface2237
+ new-marks2236)
+ ((lambda (t2238)
+ (if t2238
+ ((lambda (token2239)
+ ((lambda (t2240)
+ (if t2240
+ ((lambda (id2241)
+ (values
+ (if (symbol?
+ id2241)
+ id2241
+ (resolved-id-var-name420
+ id2241))
+ marks2229))
+ t2240)
+ (f2232
+ (cdr symnames2234)
+ i2233)))
+ (lookup-import-binding-name415
+ sym2231
+ marks2229
+ token2239
+ new-marks2236)))
+ t2238)
+ ((lambda (ie2242)
+ ((lambda (n2243)
+ ((lambda ()
+ ((letrec ((g2244 (lambda (j2245)
+ (if (= j2245
+ n2243)
+ (f2232
+ (cdr symnames2234)
+ i2233)
+ ((lambda (id2246)
+ ((lambda (id.sym2248
+ id.marks2247)
+ (if (help-bound-id=?437
+ id.sym2248
+ id.marks2247
+ sym2231
+ marks2229)
+ (values
+ (lookup-import-label506
+ id2246)
+ marks2229)
+ (g2244
+ (+ j2245
+ '1))))
+ ((lambda (x2249)
+ ((lambda (e2250)
+ (if (annotation?132
+ e2250)
+ (annotation-expression
+ e2250)
+ e2250))
+ (if (syntax-object?64
+ x2249)
+ (syntax-object-expression65
+ x2249)
+ x2249)))
+ id2246)
+ (join-marks423
+ new-marks2236
+ (id-marks312
+ id2246))))
+ (vector-ref
+ ie2242
+ j2245))))))
+ g2244)
+ '0))))
+ (vector-length
+ ie2242)))
+ (interface-exports454
+ iface2237))))
+ (interface-token455
+ iface2237)))
+ (import-interface-interface381
+ x2235)
+ (import-interface-new-marks382
+ x2235))
+ (if (if (eq? x2235
+ barrier-marker405)
+ (same-marks?425
+ marks2229
+ (list-ref
+ (ribcage-marks368
+ ribcage2227)
+ i2233))
+ '#f)
+ (values
+ '#f
+ marks2229)
+ (f2232
+ (cdr symnames2234)
+ (+ i2233
+ '1))))))
+ (car symnames2234))))))
+ f2232)
+ symnames2228
+ '0)))
+ (search-vector-rib2212 (lambda (sym2223
+ subst2222
+ marks2221
+ symnames2220
+ ribcage2219)
+ ((lambda (n2224)
+ ((letrec ((f2225 (lambda (i2226)
+ (if (= i2226
+ n2224)
+ (search2210
+ sym2223
+ (cdr subst2222)
+ marks2221)
+ (if (if (eq? (vector-ref
+ symnames2220
+ i2226)
+ sym2223)
+ (same-marks?425
+ marks2221
+ (vector-ref
+ (ribcage-marks368
+ ribcage2219)
+ i2226))
+ '#f)
+ (values
+ (vector-ref
+ (ribcage-labels369
+ ribcage2219)
+ i2226)
+ marks2221)
+ (f2225
+ (+ i2226
+ '1)))))))
+ f2225)
+ '0))
+ (vector-length
+ symnames2220)))))
+ (if (symbol? id2209)
+ (search2210
+ id2209
+ (wrap-subst317 w2208)
+ (wrap-marks316 w2208))
+ (if (syntax-object?64 id2209)
+ ((lambda (sym2214 w12213)
+ (call-with-values
+ (lambda ()
+ (search2210
+ sym2214
+ (wrap-subst317
+ w2208)
+ (join-marks423
+ (wrap-marks316
+ w2208)
+ (wrap-marks316
+ w12213))))
+ (lambda (name2216
+ marks2215)
+ (if name2216
+ (values
+ name2216
+ marks2215)
+ (search2210
+ sym2214
+ (wrap-subst317
+ w12213)
+ marks2215)))))
+ ((lambda (e2217)
+ (if (annotation?132
+ e2217)
+ (annotation-expression
+ e2217)
+ e2217))
+ (syntax-object-expression65
+ id2209))
+ (syntax-object-wrap66
+ id2209))
+ (if (annotation?132
+ id2209)
+ (search2210
+ ((lambda (e2218)
+ (if (annotation?132
+ e2218)
+ (annotation-expression
+ e2218)
+ e2218))
+ id2209)
+ (wrap-subst317
+ w2208)
+ (wrap-marks316
+ w2208))
+ (error-hook136
+ 'id-var-name
+ '"invalid id"
+ id2209)))))))
+ (id-var-name&marks432 (lambda (id2205 w2204)
+ (call-with-values
+ (lambda ()
+ (id-var-name-loc&marks431
+ id2205
+ w2204))
+ (lambda (label2207 marks2206)
+ (values
+ (if (indirect-label?356
+ label2207)
+ (get-indirect-label360
+ label2207)
+ label2207)
+ marks2206)))))
+ (id-var-name-loc433 (lambda (id2201 w2200)
+ (call-with-values
+ (lambda ()
+ (id-var-name-loc&marks431
+ id2201
+ w2200))
+ (lambda (label2203 marks2202)
+ label2203))))
+ (id-var-name434 (lambda (id2197 w2196)
+ (call-with-values
+ (lambda ()
+ (id-var-name-loc&marks431 id2197 w2196))
+ (lambda (label2199 marks2198)
+ (if (indirect-label?356 label2199)
+ (get-indirect-label360 label2199)
+ label2199)))))
+ (free-id=?435 (lambda (i2191 j2190)
+ (if (eq? ((lambda (x2194)
+ ((lambda (e2195)
+ (if (annotation?132 e2195)
+ (annotation-expression
+ e2195)
+ e2195))
+ (if (syntax-object?64 x2194)
+ (syntax-object-expression65
+ x2194)
+ x2194)))
+ i2191)
+ ((lambda (x2192)
+ ((lambda (e2193)
+ (if (annotation?132 e2193)
+ (annotation-expression
+ e2193)
+ e2193))
+ (if (syntax-object?64 x2192)
+ (syntax-object-expression65
+ x2192)
+ x2192)))
+ j2190))
+ (eq? (id-var-name434 i2191 '(()))
+ (id-var-name434 j2190 '(())))
+ '#f)))
+ (literal-id=?436 (lambda (id2180 literal2179)
+ (if (eq? ((lambda (x2183)
+ ((lambda (e2184)
+ (if (annotation?132 e2184)
+ (annotation-expression
+ e2184)
+ e2184))
+ (if (syntax-object?64 x2183)
+ (syntax-object-expression65
+ x2183)
+ x2183)))
+ id2180)
+ ((lambda (x2181)
+ ((lambda (e2182)
+ (if (annotation?132 e2182)
+ (annotation-expression
+ e2182)
+ e2182))
+ (if (syntax-object?64 x2181)
+ (syntax-object-expression65
+ x2181)
+ x2181)))
+ literal2179))
+ ((lambda (n-id2186 n-literal2185)
+ ((lambda (t2187)
+ (if t2187
+ t2187
+ (if ((lambda (t2188)
+ (if t2188
+ t2188
+ (symbol?
+ n-id2186)))
+ (not n-id2186))
+ ((lambda (t2189)
+ (if t2189
+ t2189
+ (symbol?
+ n-literal2185)))
+ (not n-literal2185))
+ '#f)))
+ (eq? n-id2186 n-literal2185)))
+ (id-var-name434 id2180 '(()))
+ (id-var-name434 literal2179 '(())))
+ '#f)))
+ (help-bound-id=?437 (lambda (i.sym2178 i.marks2177 j.sym2176
+ j.marks2175)
+ (if (eq? i.sym2178 j.sym2176)
+ (same-marks?425
+ i.marks2177
+ j.marks2175)
+ '#f)))
+ (bound-id=?438 (lambda (i2170 j2169)
+ (help-bound-id=?437
+ ((lambda (x2173)
+ ((lambda (e2174)
+ (if (annotation?132 e2174)
+ (annotation-expression e2174)
+ e2174))
+ (if (syntax-object?64 x2173)
+ (syntax-object-expression65 x2173)
+ x2173)))
+ i2170)
+ (id-marks312 i2170)
+ ((lambda (x2171)
+ ((lambda (e2172)
+ (if (annotation?132 e2172)
+ (annotation-expression e2172)
+ e2172))
+ (if (syntax-object?64 x2171)
+ (syntax-object-expression65 x2171)
+ x2171)))
+ j2169)
+ (id-marks312 j2169))))
+ (valid-bound-ids?439 (lambda (ids2165)
+ (if ((letrec ((all-ids?2166 (lambda (ids2167)
+ ((lambda (t2168)
+ (if t2168
+ t2168
+ (if (id?306
+ (car ids2167))
+ (all-ids?2166
+ (cdr ids2167))
+ '#f)))
+ (null?
+ ids2167)))))
+ all-ids?2166)
+ ids2165)
+ (distinct-bound-ids?440 ids2165)
+ '#f)))
+ (distinct-bound-ids?440 (lambda (ids2161)
+ ((letrec ((distinct?2162 (lambda (ids2163)
+ ((lambda (t2164)
+ (if t2164
+ t2164
+ (if (not (bound-id-member?442
+ (car ids2163)
+ (cdr ids2163)))
+ (distinct?2162
+ (cdr ids2163))
+ '#f)))
+ (null?
+ ids2163)))))
+ distinct?2162)
+ ids2161)))
+ (invalid-ids-error441 (lambda (ids2157 exp2156 class2155)
+ ((letrec ((find2158 (lambda (ids2160
+ gooduns2159)
+ (if (null?
+ ids2160)
+ (syntax-error
+ exp2156)
+ (if (id?306
+ (car ids2160))
+ (if (bound-id-member?442
+ (car ids2160)
+ gooduns2159)
+ (syntax-error
+ (car ids2160)
+ '"duplicate "
+ class2155)
+ (find2158
+ (cdr ids2160)
+ (cons
+ (car ids2160)
+ gooduns2159)))
+ (syntax-error
+ (car ids2160)
+ '"invalid "
+ class2155))))))
+ find2158)
+ ids2157
+ '())))
+ (bound-id-member?442 (lambda (x2153 list2152)
+ (if (not (null? list2152))
+ ((lambda (t2154)
+ (if t2154
+ t2154
+ (bound-id-member?442
+ x2153
+ (cdr list2152))))
+ (bound-id=?438
+ x2153
+ (car list2152)))
+ '#f)))
+ (wrap443 (lambda (x2151 w2150)
+ (if (if (null? (wrap-marks316 w2150))
+ (null? (wrap-subst317 w2150))
+ '#f)
+ x2151
+ (if (syntax-object?64 x2151)
+ (make-syntax-object63
+ (syntax-object-expression65 x2151)
+ (join-wraps422
+ w2150
+ (syntax-object-wrap66 x2151)))
+ (if (null? x2151)
+ x2151
+ (make-syntax-object63 x2151 w2150))))))
+ (source-wrap444 (lambda (x2149 w2148 ae2147)
+ (wrap443
+ (if (annotation?132 ae2147)
+ (begin
+ (if (not (eq? (annotation-expression
+ ae2147)
+ x2149))
+ (error 'sc-expand
+ '"internal error in source-wrap: ae/x mismatch")
+ (void))
+ ae2147)
+ x2149)
+ w2148)))
+ (chi-when-list445 (lambda (when-list2145 w2144)
+ (map (lambda (x2146)
+ (if (literal-id=?436
+ x2146
+ '#(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(when-list w) #((top) (top)) #("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (to\ No newline at end of file
+ 'compile
+ (if (literal-id=?436
+ x2146
+ '#(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(when-list w) #((top) (top)) #("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (t\ No newline at end of file
+ 'load
+ (if (literal-id=?436
+ x2146
+ '#(syntax-object visit ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(when-list w) #((top) (top)) #("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (to\ No newline at end of file
+ 'visit
+ (if (literal-id=?436
+ x2146
+ '#(syntax-object revisit ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(when-list w) #((top) (top)) #("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (to\ No newline at end of file
+ 'revisit
+ (if (literal-id=?436
+ x2146
+ '#(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(when-list w) #((top) (top)) #("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (t\ No newline at end of file
+ 'eval
+ (syntax-error
+ (wrap443
+ x2146
+ w2144)
+ '"invalid eval-when situation")))))))
+ when-list2145)))
+ (syntax-type446 (lambda (e2129 r2128 w2127 ae2126 rib2125)
+ (if (symbol? e2129)
+ ((lambda (n2130)
+ ((lambda (b2131)
+ ((lambda (type2132)
+ ((lambda ()
+ ((lambda (t2133)
+ (if (memv
+ t2133
+ '(macro macro!))
+ (syntax-type446
+ (chi-macro502
+ (binding-value282
+ b2131)
+ e2129 r2128 w2127
+ ae2126 rib2125)
+ r2128 '(()) '#f
+ rib2125)
+ (values type2132
+ (binding-value282
+ b2131)
+ e2129 w2127
+ ae2126)))
+ type2132))))
+ (binding-type281 b2131)))
+ (lookup301 n2130 r2128)))
+ (id-var-name434 e2129 w2127))
+ (if (pair? e2129)
+ ((lambda (first2134)
+ (if (id?306 first2134)
+ ((lambda (n2135)
+ ((lambda (b2136)
+ ((lambda (type2137)
+ ((lambda ()
+ ((lambda (t2138)
+ (if (memv
+ t2138
+ '(lexical))
+ (values
+ 'lexical-call
+ (binding-value282
+ b2136)
+ e2129
+ w2127
+ ae2126)
+ (if (memv
+ t2138
+ '(macro
+ macro!))
+ (syntax-type446
+ (chi-macro502
+ (binding-value282
+ b2136)
+ e2129
+ r2128
+ w2127
+ ae2126
+ rib2125)
+ r2128
+ '(())
+ '#f
+ rib2125)
+ (if (memv
+ t2138
+ '(core))
+ (values
+ type2137
+ (binding-value282
+ b2136)
+ e2129
+ w2127
+ ae2126)
+ (if (memv
+ t2138
+ '(begin))
+ (values
+ 'begin-form
+ '#f
+ e2129
+ w2127
+ ae2126)
+ (if (memv
+ t2138
+ '(alias))
+ (values
+ 'alias-form
+ '#f
+ e2129
+ w2127
+ ae2126)
+ (if (memv
+ t2138
+ '(define))
+ (values
+ 'define-form
+ '#f
+ e2129
+ w2127
+ ae2126)
+ (if (memv
+ t2138
+ '(define-syntax))
+ (values
+ 'define-syntax-form
+ '#f
+ e2129
+ w2127
+ ae2126)
+ (if (memv
+ t2138
+ '(set!))
+ (chi-set!501
+ e2129
+ r2128
+ w2127
+ ae2126
+ rib2125)
+ (if (memv
+ t2138
+ '($module-key))
+ (values
+ '$module-form
+ '#f
+ e2129
+ w2127
+ ae2126)
+ (if (memv
+ t2138
+ '($import))
+ (values
+ '$import-form
+ '#f
+ e2129
+ w2127
+ ae2126)
+ (if (memv
+ t2138
+ '(eval-when))
+ (values
+ 'eval-when-form
+ '#f
+ e2129
+ w2127
+ ae2126)
+ (if (memv
+ t2138
+ '(meta))
+ (values
+ 'meta-form
+ '#f
+ e2129
+ w2127
+ ae2126)
+ (if (memv
+ t2138
+ '(local-syntax))
+ (values
+ 'local-syntax-form
+ (binding-value282
+ b2136)
+ e2129
+ w2127
+ ae2126)
+ (values
+ 'call
+ '#f
+ e2129
+ w2127
+ ae2126)))))))))))))))
+ type2137))))
+ (binding-type281
+ b2136)))
+ (lookup301 n2135 r2128)))
+ (id-var-name434
+ first2134
+ w2127))
+ (values 'call '#f e2129 w2127
+ ae2126)))
+ (car e2129))
+ (if (syntax-object?64 e2129)
+ (syntax-type446
+ (syntax-object-expression65
+ e2129)
+ r2128
+ (join-wraps422
+ w2127
+ (syntax-object-wrap66 e2129))
+ '#f rib2125)
+ (if (annotation?132 e2129)
+ (syntax-type446
+ (annotation-expression
+ e2129)
+ r2128 w2127 e2129 rib2125)
+ (if ((lambda (x2139)
+ ((lambda (t2140)
+ (if t2140
+ t2140
+ ((lambda (t2141)
+ (if t2141
+ t2141
+ ((lambda (t2142)
+ (if t2142
+ t2142
+ ((lambda (t2143)
+ (if t2143
+ t2143
+ (null?
+ x2139)))
+ (char?
+ x2139))))
+ (string?
+ x2139))))
+ (number?
+ x2139))))
+ (boolean? x2139)))
+ e2129)
+ (values 'constant '#f
+ e2129 w2127 ae2126)
+ (values 'other '#f e2129
+ w2127 ae2126))))))))
+ (chi-top*447 (lambda (e2120 r2119 w2118 ctem2117 rtem2116
+ meta?2115 top-ribcage2114)
+ ((lambda (meta-residuals2121)
+ (letrec ((meta-residualize!2122 (lambda (x2124)
+ (set! meta-residuals2121
+ (cons
+ x2124
+ meta-residuals2121)))))
+ ((lambda (e2123)
+ (build-sequence235
+ '#f
+ (reverse
+ (cons e2123 meta-residuals2121))))
+ (chi-top449 e2120 r2119 w2118 ctem2117
+ rtem2116 meta?2115 top-ribcage2114
+ meta-residualize!2122 '#f))))
+ '())))
+ (chi-top-sequence448 (lambda (body2110 r2109 w2108 ae2107
+ ctem2106 rtem2105 meta?2104
+ ribcage2103
+ meta-residualize!2102)
+ (build-sequence235
+ ae2107
+ ((letrec ((dobody2111 (lambda (body2112)
+ (if (null?
+ body2112)
+ '()
+ ((lambda (first2113)
+ (cons
+ first2113
+ (dobody2111
+ (cdr body2112))))
+ (chi-top449
+ (car body2112)
+ r2109
+ w2108
+ ctem2106
+ rtem2105
+ meta?2104
+ ribcage2103
+ meta-residualize!2102
+ '#f))))))
+ dobody2111)
+ body2110))))
+ (chi-top449 (lambda (e2047 r2046 w2045 ctem2044 rtem2043
+ meta?2042 top-ribcage2041
+ meta-residualize!2040 meta-seen?2039)
+ (call-with-values
+ (lambda ()
+ (syntax-type446 e2047 r2046 w2045 '#f
+ top-ribcage2041))
+ (lambda (type2052 value2051 e2050 w2049 ae2048)
+ ((lambda (t2053)
+ (if (memv t2053 '(begin-form))
+ ((lambda (forms2054)
+ (if (null? forms2054)
+ (chi-void518)
+ (chi-top-sequence448 forms2054
+ r2046 w2049 ae2048 ctem2044
+ rtem2043 meta?2042
+ top-ribcage2041
+ meta-residualize!2040)))
+ (parse-begin515
+ e2050
+ w2049
+ ae2048
+ '#t))
+ (if (memv t2053 '(local-syntax-form))
+ (call-with-values
+ (lambda ()
+ (chi-local-syntax517 value2051
+ e2050 r2046 r2046 w2049
+ ae2048))
+ (lambda (forms2059 r2058 mr2057
+ w2056 ae2055)
+ (chi-top-sequence448 forms2059
+ r2058 w2056 ae2055 ctem2044
+ rtem2043 meta?2042
+ top-ribcage2041
+ meta-residualize!2040)))
+ (if (memv t2053 '(eval-when-form))
+ (call-with-values
+ (lambda ()
+ (parse-eval-when513
+ e2050
+ w2049
+ ae2048))
+ (lambda (when-list2061
+ forms2060)
+ ((lambda (ctem2063
+ rtem2062)
+ (if (if (null?
+ ctem2063)
+ (null?
+ rtem2062)
+ '#f)
+ (chi-void518)
+ (chi-top-sequence448
+ forms2060 r2046
+ w2049 ae2048
+ ctem2063 rtem2062
+ meta?2042
+ top-ribcage2041
+ meta-residualize!2040)))
+ (update-mode-set490
+ when-list2061
+ ctem2044)
+ (update-mode-set490
+ when-list2061
+ rtem2043))))
+ (if (memv t2053 '(meta-form))
+ (chi-top449
+ (parse-meta512
+ e2050
+ w2049
+ ae2048)
+ r2046 w2049 ctem2044
+ rtem2043 '#t
+ top-ribcage2041
+ meta-residualize!2040
+ '#t)
+ (if (memv
+ t2053
+ '(define-syntax-form))
+ (call-with-values
+ (lambda ()
+ (parse-define-syntax511
+ e2050
+ w2049
+ ae2048))
+ (lambda (id2066
+ rhs2065
+ w2064)
+ ((lambda (id2067)
+ (begin
+ (if (displaced-lexical?298
+ id2067
+ r2046)
+ (displaced-lexical-error299
+ id2067)
+ (void))
+ (if (not (top-ribcage-mutable?376
+ top-ribcage2041))
+ (syntax-error
+ (source-wrap444
+ e2050
+ w2064
+ ae2048)
+ '"invalid definition in read-only environment")
+ (void))
+ ((lambda (sym2068)
+ (call-with-values
+ (lambda ()
+ (top-id-bound-var-name429
+ sym2068
+ (wrap-marks316
+ (syntax-object-wrap66
+ id2067))
+ top-ribcage2041))
+ (lambda (valsym2070
+ bound-id2069)
+ (begin
+ (if (not (eq? (id-var-name434
+ id2067
+ '(()))
+ valsym2070))
+ (syntax-error
+ (source-wrap444
+ e2050
+ w2064
+ ae2048)
+ '"definition not permitted")
+ (void))
+ (if (read-only-binding?140
+ valsym2070)
+ (syntax-error
+ (source-wrap444
+ e2050
+ w2064
+ ae2048)
+ '"invalid definition of read-only identifier")
+ (void))
+ (ct-eval/residualize2493
+ ctem2044
+ (lambda ()
+ (list
+ '$sc-put-cte
+ (list
+ 'quote
+ bound-id2069)
+ (chi498
+ rhs2065
+ r2046
+ r2046
+ w2064
+ '#t)
+ (list
+ 'quote
+ (top-ribcage-key375
+ top-ribcage2041)))))))))
+ ((lambda (x2071)
+ ((lambda (e2072)
+ (if (annotation?132
+ e2072)
+ (annotation-expression
+ e2072)
+ e2072))
+ (if (syntax-object?64
+ x2071)
+ (syntax-object-expression65
+ x2071)
+ x2071)))
+ id2067))))
+ (wrap443
+ id2066
+ w2064))))
+ (if (memv
+ t2053
+ '(define-form))
+ (call-with-values
+ (lambda ()
+ (parse-define510
+ e2050
+ w2049
+ ae2048))
+ (lambda (id2075
+ rhs2074
+ w2073)
+ ((lambda (id2076)
+ (begin
+ (if (displaced-lexical?298
+ id2076
+ r2046)
+ (displaced-lexical-error299
+ id2076)
+ (void))
+ (if (not (top-ribcage-mutable?376
+ top-ribcage2041))
+ (syntax-error
+ (source-wrap444
+ e2050
+ w2073
+ ae2048)
+ '"invalid definition in read-only environment")
+ (void))
+ ((lambda (sym2077)
+ (call-with-values
+ (lambda ()
+ (top-id-bound-var-name429
+ sym2077
+ (wrap-marks316
+ (syntax-object-wrap66
+ id2076))
+ top-ribcage2041))
+ (lambda (valsym2079
+ bound-id2078)
+ (begin
+ (if (not (eq? (id-var-name434
+ id2076
+ '(()))
+ valsym2079))
+ (syntax-error
+ (source-wrap444
+ e2050
+ w2073
+ ae2048)
+ '"definition not permitted")
+ (void))
+ (if (read-only-binding?140
+ valsym2079)
+ (syntax-error
+ (source-wrap444
+ e2050
+ w2073
+ ae2048)
+ '"invalid definition of read-only identifier")
+ (void))
+ (if meta?2042
+ (ct-eval/residualize2493
+ ctem2044
+ (lambda ()
+ (build-sequence235
+ '#f
+ (list
+ (list
+ '$sc-put-cte
+ (list
+ 'quote
+ bound-id2078)
+ (list
+ 'quote
+ (cons
+ 'meta-variable
+ valsym2079))
+ (list
+ 'quote
+ (top-ribcage-key375
+ top-ribcage2041)))
+ (list
+ 'define
+ valsym2079
+ (chi498
+ rhs2074
+ r2046
+ r2046
+ w2073
+ '#t))))))
+ ((lambda (x2080)
+ (build-sequence235
+ '#f
+ (list
+ x2080
+ (rt-eval/residualize492
+ rtem2043
+ (lambda ()
+ (list
+ 'define
+ valsym2079
+ (chi498
+ rhs2074
+ r2046
+ r2046
+ w2073
+ '#f)))))))
+ (ct-eval/residualize2493
+ ctem2044
+ (lambda ()
+ (list
+ '$sc-put-cte
+ (list
+ 'quote
+ bound-id2078)
+ (list
+ 'quote
+ (cons
+ 'global
+ valsym2079))
+ (list
+ 'quote
+ (top-ribcage-key375
+ top-ribcage2041)))))))))))
+ ((lambda (x2081)
+ ((lambda (e2082)
+ (if (annotation?132
+ e2082)
+ (annotation-expression
+ e2082)
+ e2082))
+ (if (syntax-object?64
+ x2081)
+ (syntax-object-expression65
+ x2081)
+ x2081)))
+ id2076))))
+ (wrap443
+ id2075
+ w2073))))
+ (if (memv
+ t2053
+ '($module-form))
+ ((lambda (ribcage2083)
+ (call-with-values
+ (lambda ()
+ (parse-module508
+ e2050
+ w2049
+ ae2048
+ (make-wrap315
+ (wrap-marks316
+ w2049)
+ (cons
+ ribcage2083
+ (wrap-subst317
+ w2049)))))
+ (lambda (orig2087
+ id2086
+ exports2085
+ forms2084)
+ (begin
+ (if (displaced-lexical?298
+ id2086
+ r2046)
+ (displaced-lexical-error299
+ (wrap443
+ id2086
+ w2049))
+ (void))
+ (if (not (top-ribcage-mutable?376
+ top-ribcage2041))
+ (syntax-error
+ orig2087
+ '"invalid definition in read-only environment")
+ (void))
+ (chi-top-module482
+ orig2087
+ r2046
+ r2046
+ top-ribcage2041
+ ribcage2083
+ ctem2044
+ rtem2043
+ meta?2042
+ id2086
+ exports2085
+ forms2084
+ meta-residualize!2040)))))
+ (make-ribcage365
+ '()
+ '()
+ '()))
+ (if (memv
+ t2053
+ '($import-form))
+ (call-with-values
+ (lambda ()
+ (parse-import509
+ e2050
+ w2049
+ ae2048))
+ (lambda (orig2090
+ only?2089
+ mid2088)
+ (begin
+ (if (not (top-ribcage-mutable?376
+ top-ribcage2041))
+ (syntax-error
+ orig2090
+ '"invalid definition in read-only environment")
+ (void))
+ (ct-eval/residualize2493
+ ctem2044
+ (lambda ()
+ ((lambda (binding2091)
+ ((lambda (t2092)
+ (if (memv
+ t2092
+ '($module))
+ (do-top-import489
+ only?2089
+ top-ribcage2041
+ mid2088
+ (interface-token455
+ (binding-value282
+ binding2091)))
+ (if (memv
+ t2092
+ '(displaced-lexical))
+ (displaced-lexical-error299
+ mid2088)
+ (syntax-error
+ mid2088
+ '"unknown module"))))
+ (binding-type281
+ binding2091)))
+ (lookup301
+ (id-var-name434
+ mid2088
+ '(()))
+ '())))))))
+ (if (memv
+ t2053
+ '(alias-form))
+ (call-with-values
+ (lambda ()
+ (parse-alias514
+ e2050
+ w2049
+ ae2048))
+ (lambda (new-id2094
+ old-id2093)
+ ((lambda (new-id2095)
+ (begin
+ (if (displaced-lexical?298
+ new-id2095
+ r2046)
+ (displaced-lexical-error299
+ new-id2095)
+ (void))
+ (if (not (top-ribcage-mutable?376
+ top-ribcage2041))
+ (syntax-error
+ (source-wrap444
+ e2050
+ w2049
+ ae2048)
+ '"invalid definition in read-only environment")
+ (void))
+ ((lambda (sym2096)
+ (call-with-values
+ (lambda ()
+ (top-id-bound-var-name429
+ sym2096
+ (wrap-marks316
+ (syntax-object-wrap66
+ new-id2095))
+ top-ribcage2041))
+ (lambda (valsym2098
+ bound-id2097)
+ (begin
+ (if (not (eq? (id-var-name434
+ new-id2095
+ '(()))
+ valsym2098))
+ (syntax-error
+ (source-wrap444
+ e2050
+ w2049
+ ae2048)
+ '"definition not permitted")
+ (void))
+ (if (read-only-binding?140
+ valsym2098)
+ (syntax-error
+ (source-wrap444
+ e2050
+ w2049
+ ae2048)
+ '"invalid definition of read-only identifier")
+ (void))
+ (ct-eval/residualize2493
+ ctem2044
+ (lambda ()
+ (list
+ '$sc-put-cte
+ (list
+ 'quote
+ (make-resolved-id418
+ sym2096
+ (wrap-marks316
+ (syntax-object-wrap66
+ new-id2095))
+ (id-var-name434
+ old-id2093
+ w2049)))
+ (list
+ 'quote
+ '(do-alias
+ .
+ #f))
+ (list
+ 'quote
+ (top-ribcage-key375
+ top-ribcage2041)))))))))
+ ((lambda (x2099)
+ ((lambda (e2100)
+ (if (annotation?132
+ e2100)
+ (annotation-expression
+ e2100)
+ e2100))
+ (if (syntax-object?64
+ x2099)
+ (syntax-object-expression65
+ x2099)
+ x2099)))
+ new-id2095))))
+ (wrap443
+ new-id2094
+ w2049))))
+ (begin
+ (if meta-seen?2039
+ (syntax-error
+ (source-wrap444
+ e2050
+ w2049
+ ae2048)
+ '"invalid meta definition")
+ (void))
+ (if meta?2042
+ ((lambda (x2101)
+ (begin
+ (top-level-eval-hook133
+ x2101)
+ (ct-eval/residualize3494
+ ctem2044
+ void
+ (lambda ()
+ x2101))))
+ (chi-expr499
+ type2052
+ value2051
+ e2050
+ r2046
+ r2046
+ w2049
+ ae2048
+ '#t))
+ (rt-eval/residualize492
+ rtem2043
+ (lambda ()
+ (chi-expr499
+ type2052
+ value2051
+ e2050
+ r2046
+ r2046
+ w2049
+ ae2048
+ '#f)))))))))))))))
+ type2052)))))
+ (flatten-exports450 (lambda (exports2035)
+ ((letrec ((loop2036 (lambda (exports2038
+ ls2037)
+ (if (null?
+ exports2038)
+ ls2037
+ (loop2036
+ (cdr exports2038)
+ (if (pair?
+ (car exports2038))
+ (loop2036
+ (car exports2038)
+ ls2037)
+ (cons
+ (car exports2038)
+ ls2037)))))))
+ loop2036)
+ exports2035
+ '())))
+ (make-interface451 (lambda (marks2034 exports2033 token2032)
+ (vector
+ 'interface
+ marks2034
+ exports2033
+ token2032)))
+ (interface?452 (lambda (x2031)
+ (if (vector? x2031)
+ (if (= (vector-length x2031) '4)
+ (eq? (vector-ref x2031 '0) 'interface)
+ '#f)
+ '#f)))
+ (interface-marks453 (lambda (x2030) (vector-ref x2030 '1)))
+ (interface-exports454 (lambda (x2029)
+ (vector-ref x2029 '2)))
+ (interface-token455 (lambda (x2028) (vector-ref x2028 '3)))
+ (set-interface-marks!456 (lambda (x2027 update2026)
+ (vector-set! x2027 '1 update2026)))
+ (set-interface-exports!457 (lambda (x2025 update2024)
+ (vector-set!
+ x2025
+ '2
+ update2024)))
+ (set-interface-token!458 (lambda (x2023 update2022)
+ (vector-set! x2023 '3 update2022)))
+ (make-unresolved-interface459 (lambda (mid2020 exports2019)
+ (make-interface451
+ (wrap-marks316
+ (syntax-object-wrap66
+ mid2020))
+ (list->vector
+ (map (lambda (x2021)
+ (if (pair? x2021)
+ (car x2021)
+ x2021))
+ exports2019))
+ '#f)))
+ (make-resolved-interface460 (lambda (mid2017 exports2016
+ token2015)
+ (make-interface451
+ (wrap-marks316
+ (syntax-object-wrap66
+ mid2017))
+ (list->vector
+ (map (lambda (x2018)
+ (id->resolved-id419
+ (if (pair? x2018)
+ (car x2018)
+ x2018)))
+ exports2016))
+ token2015)))
+ (make-module-binding461 (lambda (type2014 id2013 label2012
+ imps2011 val2010 exported2009)
+ (vector 'module-binding type2014
+ id2013 label2012 imps2011 val2010
+ exported2009)))
+ (module-binding?462 (lambda (x2008)
+ (if (vector? x2008)
+ (if (= (vector-length x2008) '7)
+ (eq? (vector-ref x2008 '0)
+ 'module-binding)
+ '#f)
+ '#f)))
+ (module-binding-type463 (lambda (x2007)
+ (vector-ref x2007 '1)))
+ (module-binding-id464 (lambda (x2006)
+ (vector-ref x2006 '2)))
+ (module-binding-label465 (lambda (x2005)
+ (vector-ref x2005 '3)))
+ (module-binding-imps466 (lambda (x2004)
+ (vector-ref x2004 '4)))
+ (module-binding-val467 (lambda (x2003)
+ (vector-ref x2003 '5)))
+ (module-binding-exported468 (lambda (x2002)
+ (vector-ref x2002 '6)))
+ (set-module-binding-type!469 (lambda (x2001 update2000)
+ (vector-set!
+ x2001
+ '1
+ update2000)))
+ (set-module-binding-id!470 (lambda (x1999 update1998)
+ (vector-set!
+ x1999
+ '2
+ update1998)))
+ (set-module-binding-label!471 (lambda (x1997 update1996)
+ (vector-set!
+ x1997
+ '3
+ update1996)))
+ (set-module-binding-imps!472 (lambda (x1995 update1994)
+ (vector-set!
+ x1995
+ '4
+ update1994)))
+ (set-module-binding-val!473 (lambda (x1993 update1992)
+ (vector-set!
+ x1993
+ '5
+ update1992)))
+ (set-module-binding-exported!474 (lambda (x1991 update1990)
+ (vector-set!
+ x1991
+ '6
+ update1990)))
+ (create-module-binding475 (lambda (type1989 id1988 label1987
+ imps1986 val1985)
+ (make-module-binding461 type1989
+ id1988 label1987 imps1986 val1985
+ '#f)))
+ (make-frob476 (lambda (e1984 meta?1983)
+ (vector 'frob e1984 meta?1983)))
+ (frob?477 (lambda (x1982)
+ (if (vector? x1982)
+ (if (= (vector-length x1982) '3)
+ (eq? (vector-ref x1982 '0) 'frob)
+ '#f)
+ '#f)))
+ (frob-e478 (lambda (x1981) (vector-ref x1981 '1)))
+ (frob-meta?479 (lambda (x1980) (vector-ref x1980 '2)))
+ (set-frob-e!480 (lambda (x1979 update1978)
+ (vector-set! x1979 '1 update1978)))
+ (set-frob-meta?!481 (lambda (x1977 update1976)
+ (vector-set! x1977 '2 update1976)))
+ (chi-top-module482 (lambda (orig1917 r1916 mr1915
+ top-ribcage1914 ribcage1913
+ ctem1912 rtem1911 meta?1910 id1909
+ exports1908 forms1907
+ meta-residualize!1906)
+ ((lambda (fexports1918)
+ (call-with-values
+ (lambda ()
+ (chi-external486 ribcage1913
+ orig1917
+ (map (lambda (d1975)
+ (make-frob476
+ d1975
+ meta?1910))
+ forms1907)
+ r1916 mr1915 ctem1912 exports1908
+ fexports1918
+ meta-residualize!1906))
+ (lambda (r1922 mr1921 bindings1920
+ inits1919)
+ ((letrec ((process-exports1923 (lambda (fexports1925
+ ctdefs1924)
+ (if (null?
+ fexports1925)
+ ((letrec ((process-locals1926 (lambda (bs1931
+ r1930
+ dts1929
+ dvs1928
+ des1927)
+ (if (null?
+ bs1931)
+ ((lambda (des1933
+ inits1932)
+ (build-sequence235
+ '#f
+ (append
+ (ctdefs1924)
+ (list
+ (ct-eval/residualize2493
+ ctem1912
+ (lambda ()
+ ((lambda (sym1934)
+ ((lambda (token1935)
+ ((lambda (b1936)
+ ((lambda ()
+ (call-with-values
+ (lambda ()
+ (top-id-bound-var-name429
+ sym1934
+ (wrap-marks316
+ (syntax-object-wrap66
+ id1909))
+ top-ribcage1914))
+ (lambda (valsym1938
+ bound-id1937)
+ (begin
+ (if (not (eq? (id-var-name434
+ id1909
+ '(()))
+ valsym1938))
+ (syntax-error
+ orig1917
+ '"definition not permitted")
+ (void))
+ (if (read-only-binding?140
+ valsym1938)
+ (syntax-error
+ orig1917
+ '"invalid definition of read-only identifier")
+ (void))
+ (list
+ '$sc-put-cte
+ (list
+ 'quote
+ bound-id1937)
+ b1936
+ (list
+ 'quote
+ (top-ribcage-key375
+ top-ribcage1914)))))))))
+ (list
+ 'quote
+ (cons
+ '$module
+ (make-resolved-interface460
+ id1909
+ exports1908
+ token1935)))))
+ (generate-id143
+ sym1934)))
+ ((lambda (x1939)
+ ((lambda (e1940)
+ (if (annotation?132
+ e1940)
+ (annotation-expression
+ e1940)
+ e1940))
+ (if (syntax-object?64
+ x1939)
+ (syntax-object-expression65
+ x1939)
+ x1939)))
+ id1909))))
+ (rt-eval/residualize492
+ rtem1911
+ (lambda ()
+ (build-top-module238
+ '#f
+ dts1929
+ dvs1928
+ des1933
+ (if (null?
+ inits1932)
+ (chi-void518)
+ (build-sequence235
+ '#f
+ (append
+ inits1932
+ (list
+ (chi-void518))))))))))))
+ (chi-frobs495
+ des1927
+ r1930
+ mr1921
+ '#f)
+ (chi-frobs495
+ inits1919
+ r1930
+ mr1921
+ '#f))
+ ((lambda (b1942
+ bs1941)
+ ((lambda (t1943)
+ ((lambda (t1944)
+ (if (memv
+ t1944
+ '(define-form))
+ ((lambda (label1945)
+ (if (module-binding-exported468
+ b1942)
+ ((lambda (var1946)
+ (process-locals1926
+ bs1941
+ r1930
+ (cons
+ 'global
+ dts1929)
+ (cons
+ label1945
+ dvs1928)
+ (cons
+ (module-binding-val467
+ b1942)
+ des1927)))
+ (module-binding-id464
+ b1942))
+ ((lambda (var1947)
+ (process-locals1926
+ bs1941
+ (extend-env295
+ label1945
+ (cons
+ 'lexical
+ var1947)
+ r1930)
+ (cons
+ 'local
+ dts1929)
+ (cons
+ var1947
+ dvs1928)
+ (cons
+ (module-binding-val467
+ b1942)
+ des1927)))
+ (gen-var523
+ (module-binding-id464
+ b1942)))))
+ (get-indirect-label360
+ (module-binding-label465
+ b1942)))
+ (if (memv
+ t1944
+ '(ctdefine-form
+ define-syntax-form
+ $module-form
+ alias-form))
+ (process-locals1926
+ bs1941
+ r1930
+ dts1929
+ dvs1928
+ des1927)
+ (error 'sc-expand-internal
+ '"unexpected module binding type ~s"
+ t1943))))
+ (module-binding-type463
+ b1942)))
+ (module-binding-type463
+ b1942)))
+ (car bs1931)
+ (cdr bs1931))))))
+ process-locals1926)
+ bindings1920
+ r1922
+ '()
+ '()
+ '())
+ ((lambda (id1949
+ fexports1948)
+ ((letrec ((loop1950 (lambda (bs1951)
+ (if (null?
+ bs1951)
+ (process-exports1923
+ fexports1948
+ ctdefs1924)
+ ((lambda (b1953
+ bs1952)
+ (if (free-id=?435
+ (module-binding-id464
+ b1953)
+ id1949)
+ (if (module-binding-exported468
+ b1953)
+ (process-exports1923
+ fexports1948
+ ctdefs1924)
+ ((lambda (t1954)
+ ((lambda (label1955)
+ ((lambda (imps1956)
+ ((lambda (fexports1957)
+ ((lambda ()
+ (begin
+ (set-module-binding-exported!474
+ b1953
+ '#t)
+ ((lambda (t1958)
+ (if (memv
+ t1958
+ '(define-form))
+ ((lambda (sym1959)
+ (begin
+ (set-indirect-label!361
+ label1955
+ sym1959)
+ (process-exports1923
+ fexports1957
+ ctdefs1924)))
+ (generate-id143
+ ((lambda (x1960)
+ ((lambda (e1961)
+ (if (annotation?132
+ e1961)
+ (annotation-expression
+ e1961)
+ e1961))
+ (if (syntax-object?64
+ x1960)
+ (syntax-object-expression65
+ x1960)
+ x1960)))
+ id1949)))
+ (if (memv
+ t1958
+ '(ctdefine-form))
+ ((lambda (b1962)
+ (process-exports1923
+ fexports1957
+ (lambda ()
+ ((lambda (sym1963)
+ (begin
+ (set-indirect-label!361
+ label1955
+ sym1963)
+ (cons
+ (ct-eval/residualize3494
+ ctem1912
+ (lambda ()
+ (put-cte-hook137
+ sym1963
+ b1962))
+ (lambda ()
+ (list
+ '$sc-put-cte
+ (list
+ 'quote
+ sym1963)
+ (list
+ 'quote
+ b1962)
+ (list
+ 'quote
+ '#f))))
+ (ctdefs1924))))
+ (binding-value282
+ b1962)))))
+ (module-binding-val467
+ b1953))
+ (if (memv
+ t1958
+ '(define-syntax-form))
+ ((lambda (sym1964)
+ (process-exports1923
+ fexports1957
+ (lambda ()
+ ((lambda (local-label1965)
+ (begin
+ (set-indirect-label!361
+ label1955
+ sym1964)
+ (cons
+ (ct-eval/residualize3494
+ ctem1912
+ (lambda ()
+ (put-cte-hook137
+ sym1964
+ (car (module-binding-val467
+ b1953))))
+ (lambda ()
+ (list
+ '$sc-put-cte
+ (list
+ 'quote
+ sym1964)
+ (cdr (module-binding-val467
+ b1953))
+ (list
+ 'quote
+ '#f))))
+ (ctdefs1924))))
+ (get-indirect-label360
+ label1955)))))
+ (generate-id143
+ ((lambda (x1966)
+ ((lambda (e1967)
+ (if (annotation?132
+ e1967)
+ (annotation-expression
+ e1967)
+ e1967))
+ (if (syntax-object?64
+ x1966)
+ (syntax-object-expression65
+ x1966)
+ x1966)))
+ id1949)))
+ (if (memv
+ t1958
+ '($module-form))
+ ((lambda (sym1969
+ exports1968)
+ (process-exports1923
+ (append
+ (flatten-exports450
+ exports1968)
+ fexports1957)
+ (lambda ()
+ (begin
+ (set-indirect-label!361
+ label1955
+ sym1969)
+ ((lambda (rest1970)
+ ((lambda (x1971)
+ (cons
+ (ct-eval/residualize3494
+ ctem1912
+ (lambda ()
+ (put-cte-hook137
+ sym1969
+ x1971))
+ (lambda ()
+ (list
+ '$sc-put-cte
+ (list
+ 'quote
+ sym1969)
+ (list
+ 'quote
+ x1971)
+ (list
+ 'quote
+ '#f))))
+ rest1970))
+ (cons
+ '$module
+ (make-resolved-interface460
+ id1949
+ exports1968
+ sym1969))))
+ (ctdefs1924))))))
+ (generate-id143
+ ((lambda (x1972)
+ ((lambda (e1973)
+ (if (annotation?132
+ e1973)
+ (annotation-expression
+ e1973)
+ e1973))
+ (if (syntax-object?64
+ x1972)
+ (syntax-object-expression65
+ x1972)
+ x1972)))
+ id1949))
+ (module-binding-val467
+ b1953))
+ (if (memv
+ t1958
+ '(alias-form))
+ (process-exports1923
+ fexports1957
+ (lambda ()
+ ((lambda (rest1974)
+ (begin
+ (if (indirect-label?356
+ label1955)
+ (if (not (symbol?
+ (get-indirect-label360
+ label1955)))
+ (syntax-error
+ (module-binding-id464
+ b1953)
+ '"unexported target of alias")
+ (void))
+ (void))
+ rest1974))
+ (ctdefs1924))))
+ (error 'sc-expand-internal
+ '"unexpected module binding type ~s"
+ t1954)))))))
+ t1954)))))
+ (append
+ imps1956
+ fexports1948)))
+ (module-binding-imps466
+ b1953)))
+ (module-binding-label465
+ b1953)))
+ (module-binding-type463
+ b1953)))
+ (loop1950
+ bs1952)))
+ (car bs1951)
+ (cdr bs1951))))))
+ loop1950)
+ bindings1920))
+ (car fexports1925)
+ (cdr fexports1925))))))
+ process-exports1923)
+ fexports1918
+ (lambda () '())))))
+ (flatten-exports450 exports1908))))
+ (id-set-diff483 (lambda (exports1905 defs1904)
+ (if (null? exports1905)
+ '()
+ (if (bound-id-member?442
+ (car exports1905)
+ defs1904)
+ (id-set-diff483
+ (cdr exports1905)
+ defs1904)
+ (cons
+ (car exports1905)
+ (id-set-diff483
+ (cdr exports1905)
+ defs1904))))))
+ (check-module-exports484 (lambda (source-exp1879
+ fexports1878 ids1877)
+ (letrec ((defined?1880 (lambda (e1887
+ ids1886)
+ (ormap
+ (lambda (x1888)
+ (if (import-interface?380
+ x1888)
+ ((lambda (x.iface1890
+ x.new-marks1889)
+ ((lambda (t1891)
+ (if t1891
+ ((lambda (token1892)
+ (lookup-import-binding-name415
+ ((lambda (x1893)
+ ((lambda (e1894)
+ (if (annotation?132
+ e1894)
+ (annotation-expression
+ e1894)
+ e1894))
+ (if (syntax-object?64
+ x1893)
+ (syntax-object-expression65
+ x1893)
+ x1893)))
+ e1887)
+ (id-marks312
+ e1887)
+ token1892
+ x.new-marks1889))
+ t1891)
+ ((lambda (v1895)
+ ((letrec ((lp1896 (lambda (i1897)
+ (if (>= i1897
+ '0)
+ ((lambda (t1898)
+ (if t1898
+ t1898
+ (lp1896
+ (- i1897
+ '1))))
+ ((lambda (id1899)
+ (help-bound-id=?437
+ ((lambda (x1902)
+ ((lambda (e1903)
+ (if (annotation?132
+ e1903)
+ (annotation-expression
+ e1903)
+ e1903))
+ (if (syntax-object?64
+ x1902)
+ (syntax-object-expression65
+ x1902)
+ x1902)))
+ id1899)
+ (join-marks423
+ x.new-marks1889
+ (id-marks312
+ id1899))
+ ((lambda (x1900)
+ ((lambda (e1901)
+ (if (annotation?132
+ e1901)
+ (annotation-expression
+ e1901)
+ e1901))
+ (if (syntax-object?64
+ x1900)
+ (syntax-object-expression65
+ x1900)
+ x1900)))
+ e1887)
+ (id-marks312
+ e1887)))
+ (vector-ref
+ v1895
+ i1897)))
+ '#f))))
+ lp1896)
+ (- (vector-length
+ v1895)
+ '1)))
+ (interface-exports454
+ x.iface1890))))
+ (interface-token455
+ x.iface1890)))
+ (import-interface-interface381
+ x1888)
+ (import-interface-new-marks382
+ x1888))
+ (bound-id=?438
+ e1887
+ x1888)))
+ ids1886))))
+ ((letrec ((loop1881 (lambda (fexports1883
+ missing1882)
+ (if (null?
+ fexports1883)
+ (if (not (null?
+ missing1882))
+ (syntax-error
+ (car missing1882)
+ (if (= (length
+ missing1882)
+ '1)
+ '"missing definition for export"
+ '"missing definition for multiple exports, including"))
+ (void))
+ ((lambda (e1885
+ fexports1884)
+ (if (defined?1880
+ e1885
+ ids1877)
+ (loop1881
+ fexports1884
+ missing1882)
+ (loop1881
+ fexports1884
+ (cons
+ e1885
+ missing1882))))
+ (car fexports1883)
+ (cdr fexports1883))))))
+ loop1881)
+ fexports1878
+ '()))))
+ (check-defined-ids485 (lambda (source-exp1826 ls1825)
+ (letrec ((vfold1827 (lambda (v1872
+ p1871
+ cls1870)
+ ((lambda (len1873)
+ ((letrec ((lp1874 (lambda (i1876
+ cls1875)
+ (if (= i1876
+ len1873)
+ cls1875
+ (lp1874
+ (+ i1876
+ '1)
+ (p1871
+ (vector-ref
+ v1872
+ i1876)
+ cls1875))))))
+ lp1874)
+ '0
+ cls1870))
+ (vector-length
+ v1872))))
+ (conflicts1828 (lambda (x1857
+ y1856
+ cls1855)
+ (if (import-interface?380
+ x1857)
+ ((lambda (x.iface1859
+ x.new-marks1858)
+ (if (import-interface?380
+ y1856)
+ ((lambda (y.iface1861
+ y.new-marks1860)
+ ((lambda (xe1863
+ ye1862)
+ (if (> (vector-length
+ xe1863)
+ (vector-length
+ ye1862))
+ (vfold1827
+ ye1862
+ (lambda (id1865
+ cls1864)
+ (id-iface-conflicts1829
+ id1865
+ y.new-marks1860
+ x.iface1859
+ x.new-marks1858
+ cls1864))
+ cls1855)
+ (vfold1827
+ xe1863
+ (lambda (id1867
+ cls1866)
+ (id-iface-conflicts1829
+ id1867
+ x.new-marks1858
+ y.iface1861
+ y.new-marks1860
+ cls1866))
+ cls1855)))
+ (interface-exports454
+ x.iface1859)
+ (interface-exports454
+ y.iface1861)))
+ (import-interface-interface381
+ y1856)
+ (import-interface-new-marks382
+ y1856))
+ (id-iface-conflicts1829
+ y1856
+ '()
+ x.iface1859
+ x.new-marks1858
+ cls1855)))
+ (import-interface-interface381
+ x1857)
+ (import-interface-new-marks382
+ x1857))
+ (if (import-interface?380
+ y1856)
+ ((lambda (y.iface1869
+ y.new-marks1868)
+ (id-iface-conflicts1829
+ x1857
+ '()
+ y.iface1869
+ y.new-marks1868
+ cls1855))
+ (import-interface-interface381
+ y1856)
+ (import-interface-new-marks382
+ y1856))
+ (if (bound-id=?438
+ x1857
+ y1856)
+ (cons
+ x1857
+ cls1855)
+ cls1855)))))
+ (id-iface-conflicts1829 (lambda (id1842
+ id.new-marks1841
+ iface1840
+ iface.new-marks1839
+ cls1838)
+ ((lambda (id.sym1844
+ id.marks1843)
+ ((lambda (t1845)
+ (if t1845
+ ((lambda (token1846)
+ (if (lookup-import-binding-name415
+ id.sym1844
+ id.marks1843
+ token1846
+ iface.new-marks1839)
+ (cons
+ id1842
+ cls1838)
+ cls1838))
+ t1845)
+ (vfold1827
+ (interface-exports454
+ iface1840)
+ (lambda (*id1848
+ cls1847)
+ ((lambda (*id.sym1850
+ *id.marks1849)
+ (if (help-bound-id=?437
+ *id.sym1850
+ *id.marks1849
+ id.sym1844
+ id.marks1843)
+ (cons
+ *id1848
+ cls1847)
+ cls1847))
+ ((lambda (x1851)
+ ((lambda (e1852)
+ (if (annotation?132
+ e1852)
+ (annotation-expression
+ e1852)
+ e1852))
+ (if (syntax-object?64
+ x1851)
+ (syntax-object-expression65
+ x1851)
+ x1851)))
+ *id1848)
+ (join-marks423
+ iface.new-marks1839
+ (id-marks312
+ *id1848))))
+ cls1838)))
+ (interface-token455
+ iface1840)))
+ ((lambda (x1853)
+ ((lambda (e1854)
+ (if (annotation?132
+ e1854)
+ (annotation-expression
+ e1854)
+ e1854))
+ (if (syntax-object?64
+ x1853)
+ (syntax-object-expression65
+ x1853)
+ x1853)))
+ id1842)
+ (join-marks423
+ id.new-marks1841
+ (id-marks312
+ id1842))))))
+ (if (not (null? ls1825))
+ ((letrec ((lp1830 (lambda (x1833
+ ls1832
+ cls1831)
+ (if (null?
+ ls1832)
+ (if (not (null?
+ cls1831))
+ ((lambda (cls1834)
+ (syntax-error
+ source-exp1826
+ '"duplicate definition for "
+ (symbol->string
+ (car cls1834))
+ '" in"))
+ (syntax-object->datum
+ cls1831))
+ (void))
+ ((letrec ((lp21835 (lambda (ls21837
+ cls1836)
+ (if (null?
+ ls21837)
+ (lp1830
+ (car ls1832)
+ (cdr ls1832)
+ cls1836)
+ (lp21835
+ (cdr ls21837)
+ (conflicts1828
+ x1833
+ (car ls21837)
+ cls1836))))))
+ lp21835)
+ ls1832
+ cls1831)))))
+ lp1830)
+ (car ls1825)
+ (cdr ls1825)
+ '())
+ (void)))))
+ (chi-external486 (lambda (ribcage1721 source-exp1720
+ body1719 r1718 mr1717 ctem1716
+ exports1715 fexports1714
+ meta-residualize!1713)
+ (letrec ((return1722 (lambda (r1824 mr1823
+ bindings1822
+ ids1821
+ inits1820)
+ (begin
+ (check-defined-ids485
+ source-exp1720
+ ids1821)
+ (check-module-exports484
+ source-exp1720
+ fexports1714
+ ids1821)
+ (values
+ r1824
+ mr1823
+ bindings1822
+ inits1820))))
+ (get-implicit-exports1723 (lambda (id1817)
+ ((letrec ((f1818 (lambda (exports1819)
+ (if (null?
+ exports1819)
+ '()
+ (if (if (pair?
+ (car exports1819))
+ (bound-id=?438
+ id1817
+ (caar
+ exports1819))
+ '#f)
+ (flatten-exports450
+ (cdar
+ exports1819))
+ (f1818
+ (cdr exports1819)))))))
+ f1818)
+ exports1715)))
+ (update-imp-exports1724 (lambda (bindings1812
+ exports1811)
+ ((lambda (exports1813)
+ (map (lambda (b1814)
+ ((lambda (id1815)
+ (if (not (bound-id-member?442
+ id1815
+ exports1813))
+ b1814
+ (create-module-binding475
+ (module-binding-type463
+ b1814)
+ id1815
+ (module-binding-label465
+ b1814)
+ (append
+ (get-implicit-exports1723
+ id1815)
+ (module-binding-imps466
+ b1814))
+ (module-binding-val467
+ b1814))))
+ (module-binding-id464
+ b1814)))
+ bindings1812))
+ (map (lambda (x1816)
+ (if (pair?
+ x1816)
+ (car x1816)
+ x1816))
+ exports1811)))))
+ ((letrec ((parse1725 (lambda (body1732
+ r1731 mr1730
+ ids1729
+ bindings1728
+ inits1727
+ meta-seen?1726)
+ (if (null?
+ body1732)
+ (return1722
+ r1731 mr1730
+ bindings1728
+ ids1729
+ inits1727)
+ ((lambda (fr1733)
+ ((lambda (e1734)
+ ((lambda (meta?1735)
+ ((lambda ()
+ (call-with-values
+ (lambda ()
+ (syntax-type446
+ e1734
+ r1731
+ '(())
+ '#f
+ ribcage1721))
+ (lambda (type1740
+ value1739
+ e1738
+ w1737
+ ae1736)
+ ((lambda (t1741)
+ (if (memv
+ t1741
+ '(define-form))
+ (call-with-values
+ (lambda ()
+ (parse-define510
+ e1738
+ w1737
+ ae1736))
+ (lambda (id1744
+ rhs1743
+ w1742)
+ ((lambda (id1745)
+ ((lambda (label1746)
+ ((lambda (imps1747)
+ ((lambda ()
+ (begin
+ (extend-ribcage!410
+ ribcage1721
+ id1745
+ label1746)
+ (if meta?1735
+ ((lambda (sym1748)
+ ((lambda (b1749)
+ ((lambda ()
+ ((lambda (mr1750)
+ ((lambda (exp1751)
+ (begin
+ (define-top-level-value-hook135
+ sym1748
+ (top-level-eval-hook133
+ exp1751))
+ (meta-residualize!1713
+ (ct-eval/residualize3494
+ ctem1716
+ void
+ (lambda ()
+ (list
+ 'define
+ sym1748
+ exp1751))))
+ (parse1725
+ (cdr body1732)
+ r1731
+ mr1750
+ (cons
+ id1745
+ ids1729)
+ (cons
+ (create-module-binding475
+ 'ctdefine-form
+ id1745
+ label1746
+ imps1747
+ b1749)
+ bindings1728)
+ inits1727
+ '#f)))
+ (chi498
+ rhs1743
+ mr1750
+ mr1750
+ w1742
+ '#t)))
+ (extend-env295
+ (get-indirect-label360
+ label1746)
+ b1749
+ mr1730)))))
+ (cons
+ 'meta-variable
+ sym1748)))
+ (generate-id143
+ ((lambda (x1752)
+ ((lambda (e1753)
+ (if (annotation?132
+ e1753)
+ (annotation-expression
+ e1753)
+ e1753))
+ (if (syntax-object?64
+ x1752)
+ (syntax-object-expression65
+ x1752)
+ x1752)))
+ id1745)))
+ (parse1725
+ (cdr body1732)
+ r1731
+ mr1730
+ (cons
+ id1745
+ ids1729)
+ (cons
+ (create-module-binding475
+ type1740
+ id1745
+ label1746
+ imps1747
+ (make-frob476
+ (wrap443
+ rhs1743
+ w1742)
+ meta?1735))
+ bindings1728)
+ inits1727
+ '#f))))))
+ (get-implicit-exports1723
+ id1745)))
+ (gen-indirect-label359)))
+ (wrap443
+ id1744
+ w1742))))
+ (if (memv
+ t1741
+ '(define-syntax-form))
+ (call-with-values
+ (lambda ()
+ (parse-define-syntax511
+ e1738
+ w1737
+ ae1736))
+ (lambda (id1756
+ rhs1755
+ w1754)
+ ((lambda (id1757)
+ ((lambda (label1758)
+ ((lambda (imps1759)
+ ((lambda (exp1760)
+ ((lambda ()
+ (begin
+ (extend-ribcage!410
+ ribcage1721
+ id1757
+ label1758)
+ ((lambda (l1762
+ b1761)
+ (parse1725
+ (cdr body1732)
+ (extend-env295
+ l1762
+ b1761
+ r1731)
+ (extend-env295
+ l1762
+ b1761
+ mr1730)
+ (cons
+ id1757
+ ids1729)
+ (cons
+ (create-module-binding475
+ type1740
+ id1757
+ label1758
+ imps1759
+ (cons
+ b1761
+ exp1760))
+ bindings1728)
+ inits1727
+ '#f))
+ (get-indirect-label360
+ label1758)
+ (defer-or-eval-transformer303
+ top-level-eval-hook133
+ exp1760))))))
+ (chi498
+ rhs1755
+ mr1730
+ mr1730
+ w1754
+ '#t)))
+ (get-implicit-exports1723
+ id1757)))
+ (gen-indirect-label359)))
+ (wrap443
+ id1756
+ w1754))))
+ (if (memv
+ t1741
+ '($module-form))
+ ((lambda (*ribcage1763)
+ ((lambda (*w1764)
+ ((lambda ()
+ (call-with-values
+ (lambda ()
+ (parse-module508
+ e1738
+ w1737
+ ae1736
+ *w1764))
+ (lambda (orig1768
+ id1767
+ *exports1766
+ forms1765)
+ (call-with-values
+ (lambda ()
+ (chi-external486
+ *ribcage1763
+ orig1768
+ (map (lambda (d1780)
+ (make-frob476
+ d1780
+ meta?1735))
+ forms1765)
+ r1731
+ mr1730
+ ctem1716
+ *exports1766
+ (flatten-exports450
+ *exports1766)
+ meta-residualize!1713))
+ (lambda (r1772
+ mr1771
+ *bindings1770
+ *inits1769)
+ ((lambda (iface1777
+ bindings1776
+ inits1775
+ label1774
+ imps1773)
+ (begin
+ (extend-ribcage!410
+ ribcage1721
+ id1767
+ label1774)
+ ((lambda (l1779
+ b1778)
+ (parse1725
+ (cdr body1732)
+ (extend-env295
+ l1779
+ b1778
+ r1772)
+ (extend-env295
+ l1779
+ b1778
+ mr1771)
+ (cons
+ id1767
+ ids1729)
+ (cons
+ (create-module-binding475
+ type1740
+ id1767
+ label1774
+ imps1773
+ *exports1766)
+ bindings1776)
+ inits1775
+ '#f))
+ (get-indirect-label360
+ label1774)
+ (cons
+ '$module
+ iface1777))))
+ (make-unresolved-interface459
+ id1767
+ *exports1766)
+ (append
+ *bindings1770
+ bindings1728)
+ (append
+ inits1727
+ *inits1769)
+ (gen-indirect-label359)
+ (get-implicit-exports1723
+ id1767)))))))))
+ (make-wrap315
+ (wrap-marks316
+ w1737)
+ (cons
+ *ribcage1763
+ (wrap-subst317
+ w1737)))))
+ (make-ribcage365
+ '()
+ '()
+ '()))
+ (if (memv
+ t1741
+ '($import-form))
+ (call-with-values
+ (lambda ()
+ (parse-import509
+ e1738
+ w1737
+ ae1736))
+ (lambda (orig1783
+ only?1782
+ mid1781)
+ ((lambda (mlabel1784)
+ ((lambda (binding1785)
+ ((lambda (t1786)
+ (if (memv
+ t1786
+ '($module))
+ ((lambda (iface1787)
+ ((lambda (import-iface1788)
+ ((lambda ()
+ (begin
+ (if only?1782
+ (extend-ribcage-barrier!412
+ ribcage1721
+ mid1781)
+ (void))
+ (do-import!507
+ import-iface1788
+ ribcage1721)
+ (parse1725
+ (cdr body1732)
+ r1731
+ mr1730
+ (cons
+ import-iface1788
+ ids1729)
+ (update-imp-exports1724
+ bindings1728
+ (vector->list
+ (interface-exports454
+ iface1787)))
+ inits1727
+ '#f)))))
+ (make-import-interface379
+ iface1787
+ (import-mark-delta505
+ mid1781
+ iface1787))))
+ (binding-value282
+ binding1785))
+ (if (memv
+ t1786
+ '(displaced-lexical))
+ (displaced-lexical-error299
+ mid1781)
+ (syntax-error
+ mid1781
+ '"unknown module"))))
+ (binding-type281
+ binding1785)))
+ (lookup301
+ mlabel1784
+ r1731)))
+ (id-var-name434
+ mid1781
+ '(())))))
+ (if (memv
+ t1741
+ '(alias-form))
+ (call-with-values
+ (lambda ()
+ (parse-alias514
+ e1738
+ w1737
+ ae1736))
+ (lambda (new-id1790
+ old-id1789)
+ ((lambda (new-id1791)
+ ((lambda (label1792)
+ ((lambda (imps1793)
+ ((lambda ()
+ (begin
+ (extend-ribcage!410
+ ribcage1721
+ new-id1791
+ label1792)
+ (parse1725
+ (cdr body1732)
+ r1731
+ mr1730
+ (cons
+ new-id1791
+ ids1729)
+ (cons
+ (create-module-binding475
+ type1740
+ new-id1791
+ label1792
+ imps1793
+ '#f)
+ bindings1728)
+ inits1727
+ '#f)))))
+ (get-implicit-exports1723
+ new-id1791)))
+ (id-var-name-loc433
+ old-id1789
+ w1737)))
+ (wrap443
+ new-id1790
+ w1737))))
+ (if (memv
+ t1741
+ '(begin-form))
+ (parse1725
+ ((letrec ((f1794 (lambda (forms1795)
+ (if (null?
+ forms1795)
+ (cdr body1732)
+ (cons
+ (make-frob476
+ (wrap443
+ (car forms1795)
+ w1737)
+ meta?1735)
+ (f1794
+ (cdr forms1795)))))))
+ f1794)
+ (parse-begin515
+ e1738
+ w1737
+ ae1736
+ '#t))
+ r1731
+ mr1730
+ ids1729
+ bindings1728
+ inits1727
+ '#f)
+ (if (memv
+ t1741
+ '(eval-when-form))
+ (call-with-values
+ (lambda ()
+ (parse-eval-when513
+ e1738
+ w1737
+ ae1736))
+ (lambda (when-list1797
+ forms1796)
+ (parse1725
+ (if (memq
+ 'eval
+ when-list1797)
+ ((letrec ((f1798 (lambda (forms1799)
+ (if (null?
+ forms1799)
+ (cdr body1732)
+ (cons
+ (make-frob476
+ (wrap443
+ (car forms1799)
+ w1737)
+ meta?1735)
+ (f1798
+ (cdr forms1799)))))))
+ f1798)
+ forms1796)
+ (cdr body1732))
+ r1731
+ mr1730
+ ids1729
+ bindings1728
+ inits1727
+ '#f)))
+ (if (memv
+ t1741
+ '(meta-form))
+ (parse1725
+ (cons
+ (make-frob476
+ (wrap443
+ (parse-meta512
+ e1738
+ w1737
+ ae1736)
+ w1737)
+ '#t)
+ (cdr body1732))
+ r1731
+ mr1730
+ ids1729
+ bindings1728
+ inits1727
+ '#t)
+ (if (memv
+ t1741
+ '(local-syntax-form))
+ (call-with-values
+ (lambda ()
+ (chi-local-syntax517
+ value1739
+ e1738
+ r1731
+ mr1730
+ w1737
+ ae1736))
+ (lambda (forms1804
+ r1803
+ mr1802
+ w1801
+ ae1800)
+ (parse1725
+ ((letrec ((f1805 (lambda (forms1806)
+ (if (null?
+ forms1806)
+ (cdr body1732)
+ (cons
+ (make-frob476
+ (wrap443
+ (car forms1806)
+ w1801)
+ meta?1735)
+ (f1805
+ (cdr forms1806)))))))
+ f1805)
+ forms1804)
+ r1803
+ mr1802
+ ids1729
+ bindings1728
+ inits1727
+ '#f)))
+ (begin
+ (if meta-seen?1726
+ (syntax-error
+ (source-wrap444
+ e1738
+ w1737
+ ae1736)
+ '"invalid meta definition")
+ (void))
+ ((letrec ((f1807 (lambda (body1808)
+ (if ((lambda (t1809)
+ (if t1809
+ t1809
+ (not (frob-meta?479
+ (car body1808)))))
+ (null?
+ body1808))
+ (return1722
+ r1731
+ mr1730
+ bindings1728
+ ids1729
+ (append
+ inits1727
+ body1808))
+ (begin
+ ((lambda (x1810)
+ (begin
+ (top-level-eval-hook133
+ x1810)
+ (meta-residualize!1713
+ (ct-eval/residualize3494
+ ctem1716
+ void
+ (lambda ()
+ x1810)))))
+ (chi-meta-frob496
+ (car body1808)
+ mr1730))
+ (f1807
+ (cdr body1808)))))))
+ f1807)
+ (cons
+ (make-frob476
+ (source-wrap444
+ e1738
+ w1737
+ ae1736)
+ meta?1735)
+ (cdr body1732))))))))))))))
+ type1740))))))
+ (frob-meta?479
+ fr1733)))
+ (frob-e478
+ fr1733)))
+ (car body1732))))))
+ parse1725) body1719 r1718 mr1717 '()
+ '() '() '#f))))
+ (vmap487 (lambda (fn1709 v1708)
+ ((letrec ((do1710 (lambda (i1712 ls1711)
+ (if (< i1712 '0)
+ ls1711
+ (do1710
+ (- i1712 '1)
+ (cons
+ (fn1709
+ (vector-ref
+ v1708
+ i1712))
+ ls1711))))))
+ do1710)
+ (- (vector-length v1708) '1)
+ '())))
+ (vfor-each488 (lambda (fn1704 v1703)
+ ((lambda (len1705)
+ ((letrec ((do1706 (lambda (i1707)
+ (if (not (= i1707
+ len1705))
+ (begin
+ (fn1704
+ (vector-ref
+ v1703
+ i1707))
+ (do1706
+ (+ i1707 '1)))
+ (void)))))
+ do1706)
+ '0))
+ (vector-length v1703))))
+ (do-top-import489 (lambda (import-only?1702 top-ribcage1701
+ mid1700 token1699)
+ (list
+ '$sc-put-cte
+ (list 'quote mid1700)
+ (list 'quote (cons 'do-import token1699))
+ (list
+ 'quote
+ (top-ribcage-key375
+ top-ribcage1701)))))
+ (update-mode-set490 ((lambda (table1690)
+ (lambda (when-list1692 mode-set1691)
+ (letrec ((remq1693 (lambda (x1698
+ ls1697)
+ (if (null?
+ ls1697)
+ '()
+ (if (eq? (car ls1697)
+ x1698)
+ (remq1693
+ x1698
+ (cdr ls1697))
+ (cons
+ (car ls1697)
+ (remq1693
+ x1698
+ (cdr ls1697))))))))
+ (remq1693
+ '-
+ (apply
+ append
+ (map (lambda (m1694)
+ ((lambda (row1695)
+ (map (lambda (s1696)
+ (cdr (assq
+ s1696
+ row1695)))
+ when-list1692))
+ (cdr (assq
+ m1694
+ table1690))))
+ mode-set1691))))))
+ '((l (load . l) (compile . c) (visit . v)
+ (revisit . r) (eval . -))
+ (c (load . -) (compile . -)
+ (visit . -) (revisit . -)
+ (eval . c))
+ (v (load . v) (compile . c)
+ (visit . v) (revisit . -)
+ (eval . -))
+ (r (load . r) (compile . c)
+ (visit . -) (revisit . r)
+ (eval . -))
+ (e (load . -) (compile . -)
+ (visit . -) (revisit . -)
+ (eval . e)))))
+ (initial-mode-set491 (lambda (when-list1686
+ compiling-a-file1685)
+ (apply
+ append
+ (map (lambda (s1687)
+ (if compiling-a-file1685
+ ((lambda (t1688)
+ (if (memv
+ t1688
+ '(compile))
+ '(c)
+ (if (memv
+ t1688
+ '(load))
+ '(l)
+ (if (memv
+ t1688
+ '(visit))
+ '(v)
+ (if (memv
+ t1688
+ '(revisit))
+ '(r)
+ '())))))
+ s1687)
+ ((lambda (t1689)
+ (if (memv t1689 '(eval))
+ '(e)
+ '()))
+ s1687)))
+ when-list1686))))
+ (rt-eval/residualize492 (lambda (rtem1680 thunk1679)
+ (if (memq 'e rtem1680)
+ (thunk1679)
+ ((lambda (thunk1681)
+ (if (memq 'v rtem1680)
+ (if ((lambda (t1682)
+ (if t1682
+ t1682
+ (memq
+ 'r
+ rtem1680)))
+ (memq 'l rtem1680))
+ (thunk1681)
+ (thunk1681))
+ (if ((lambda (t1683)
+ (if t1683
+ t1683
+ (memq
+ 'r
+ rtem1680)))
+ (memq 'l rtem1680))
+ (thunk1681)
+ (chi-void518))))
+ (if (memq 'c rtem1680)
+ ((lambda (x1684)
+ (begin
+ (top-level-eval-hook133
+ x1684)
+ (lambda () x1684)))
+ (thunk1679))
+ thunk1679)))))
+ (ct-eval/residualize2493 (lambda (ctem1676 thunk1675)
+ ((lambda (t1677)
+ (ct-eval/residualize3494
+ ctem1676
+ (lambda ()
+ (begin
+ (if (not t1677)
+ (set! t1677
+ (thunk1675))
+ (void))
+ (top-level-eval-hook133
+ t1677)))
+ (lambda ()
+ ((lambda (t1678)
+ (if t1678
+ t1678
+ (thunk1675)))
+ t1677))))
+ '#f)))
+ (ct-eval/residualize3494 (lambda (ctem1672 eval-thunk1671
+ residualize-thunk1670)
+ (if (memq 'e ctem1672)
+ (begin
+ (eval-thunk1671)
+ (chi-void518))
+ (begin
+ (if (memq 'c ctem1672)
+ (eval-thunk1671)
+ (void))
+ (if (memq 'r ctem1672)
+ (if ((lambda (t1673)
+ (if t1673
+ t1673
+ (memq
+ 'v
+ ctem1672)))
+ (memq 'l ctem1672))
+ (residualize-thunk1670)
+ (residualize-thunk1670))
+ (if ((lambda (t1674)
+ (if t1674
+ t1674
+ (memq
+ 'v
+ ctem1672)))
+ (memq 'l ctem1672))
+ (residualize-thunk1670)
+ (chi-void518)))))))
+ (chi-frobs495 (lambda (frob*1668 r1667 mr1666 m?1665)
+ (map (lambda (x1669)
+ (chi498 (frob-e478 x1669) r1667 mr1666
+ '(()) m?1665))
+ frob*1668)))
+ (chi-meta-frob496 (lambda (x1664 mr1663)
+ (chi498 (frob-e478 x1664) mr1663 mr1663
+ '(()) '#t)))
+ (chi-sequence497 (lambda (body1659 r1658 mr1657 w1656 ae1655
+ m?1654)
+ (build-sequence235
+ ae1655
+ ((letrec ((dobody1660 (lambda (body1661)
+ (if (null?
+ body1661)
+ '()
+ ((lambda (first1662)
+ (cons
+ first1662
+ (dobody1660
+ (cdr body1661))))
+ (chi498
+ (car body1661)
+ r1658
+ mr1657
+ w1656
+ m?1654))))))
+ dobody1660)
+ body1659))))
+ (chi498 (lambda (e1648 r1647 mr1646 w1645 m?1644)
+ (call-with-values
+ (lambda ()
+ (syntax-type446 e1648 r1647 w1645 '#f '#f))
+ (lambda (type1653 value1652 e1651 w1650 ae1649)
+ (chi-expr499 type1653 value1652 e1651 r1647
+ mr1646 w1650 ae1649 m?1644)))))
+ (chi-expr499 (lambda (type1628 value1627 e1626 r1625 mr1624
+ w1623 ae1622 m?1621)
+ ((lambda (t1629)
+ (if (memv t1629 '(lexical))
+ value1627
+ (if (memv t1629 '(core))
+ (value1627 e1626 r1625 mr1624 w1623
+ ae1622 m?1621)
+ (if (memv t1629 '(lexical-call))
+ (chi-application500 value1627
+ e1626 r1625 mr1624 w1623 ae1622
+ m?1621)
+ (if (memv t1629 '(constant))
+ (list
+ 'quote
+ (strip522
+ (source-wrap444
+ e1626
+ w1623
+ ae1622)
+ '(())))
+ (if (memv t1629 '(global))
+ value1627
+ (if (memv
+ t1629
+ '(meta-variable))
+ (if m?1621
+ value1627
+ (displaced-lexical-error299
+ (source-wrap444
+ e1626
+ w1623
+ ae1622)))
+ (if (memv
+ t1629
+ '(call))
+ (chi-application500
+ (chi498
+ (car e1626)
+ r1625 mr1624
+ w1623 m?1621)
+ e1626 r1625
+ mr1624 w1623
+ ae1622 m?1621)
+ (if (memv
+ t1629
+ '(begin-form))
+ (chi-sequence497
+ (parse-begin515
+ e1626
+ w1623
+ ae1622
+ '#f)
+ r1625
+ mr1624
+ w1623
+ ae1622
+ m?1621)
+ (if (memv
+ t1629
+ '(local-syntax-form))
+ (call-with-values
+ (lambda ()
+ (chi-local-syntax517
+ value1627
+ e1626
+ r1625
+ mr1624
+ w1623
+ ae1622))
+ (lambda (forms1634
+ r1633
+ mr1632
+ w1631
+ ae1630)
+ (chi-sequence497
+ forms1634
+ r1633
+ mr1632
+ w1631
+ ae1630
+ m?1621)))
+ (if (memv
+ t1629
+ '(eval-when-form))
+ (call-with-values
+ (lambda ()
+ (parse-eval-when513
+ e1626
+ w1623
+ ae1622))
+ (lambda (when-list1636
+ forms1635)
+ (if (memq
+ 'eval
+ when-list1636)
+ (chi-sequence497
+ forms1635
+ r1625
+ mr1624
+ w1623
+ ae1622
+ m?1621)
+ (chi-void518))))
+ (if (memv
+ t1629
+ '(meta-form))
+ (syntax-error
+ (source-wrap444
+ e1626
+ w1623
+ ae1622)
+ '"invalid context for meta definition")
+ (if (memv
+ t1629
+ '(define-form))
+ (begin
+ (parse-define510
+ e1626
+ w1623
+ ae1622)
+ (syntax-error
+ (source-wrap444
+ e1626
+ w1623
+ ae1622)
+ '"invalid context for definition"))
+ (if (memv
+ t1629
+ '(define-syntax-form))
+ (begin
+ (parse-define-syntax511
+ e1626
+ w1623
+ ae1622)
+ (syntax-error
+ (source-wrap444
+ e1626
+ w1623
+ ae1622)
+ '"invalid context for definition"))
+ (if (memv
+ t1629
+ '($module-form))
+ (call-with-values
+ (lambda ()
+ (parse-module508
+ e1626
+ w1623
+ ae1622
+ w1623))
+ (lambda (orig1640
+ id1639
+ exports1638
+ forms1637)
+ (syntax-error
+ orig1640
+ '"invalid context for definition")))
+ (if (memv
+ t1629
+ '($import-form))
+ (call-with-values
+ (lambda ()
+ (parse-import509
+ e1626
+ w1623
+ ae1622))
+ (lambda (orig1643
+ only?1642
+ mid1641)
+ (syntax-error
+ orig1643
+ '"invalid context for definition")))
+ (if (memv
+ t1629
+ '(alias-form))
+ (begin
+ (parse-alias514
+ e1626
+ w1623
+ ae1622)
+ (syntax-error
+ (source-wrap444
+ e1626
+ w1623
+ ae1622)
+ '"invalid context for definition"))
+ (if (memv
+ t1629
+ '(syntax))
+ (syntax-error
+ (source-wrap444
+ e1626
+ w1623
+ ae1622)
+ '"reference to pattern variable outside syntax form")
+ (if (memv
+ t1629
+ '(displaced-lexical))
+ (displaced-lexical-error299
+ (source-wrap444
+ e1626
+ w1623
+ ae1622))
+ (syntax-error
+ (source-wrap444
+ e1626
+ w1623
+ ae1622)))))))))))))))))))))
+ type1628)))
+ (chi-application500 (lambda (x1613 e1612 r1611 mr1610 w1609
+ ae1608 m?1607)
+ ((lambda (tmp1614)
+ ((lambda (tmp1615)
+ (if tmp1615
+ (apply
+ (lambda (e01617 e11616)
+ (cons
+ x1613
+ (map (lambda (e1619)
+ (chi498 e1619
+ r1611 mr1610
+ w1609 m?1607))
+ e11616)))
+ tmp1615)
+ ((lambda (_1620)
+ (syntax-error
+ (source-wrap444
+ e1612
+ w1609
+ ae1608)))
+ tmp1614)))
+ ($syntax-dispatch
+ tmp1614
+ '(any . each-any))))
+ e1612)))
+ (chi-set!501 (lambda (e1581 r1580 w1579 ae1578 rib1577)
+ ((lambda (tmp1582)
+ ((lambda (tmp1583)
+ (if (if tmp1583
+ (apply
+ (lambda (_1586 id1585 val1584)
+ (id?306 id1585))
+ tmp1583)
+ '#f)
+ (apply
+ (lambda (_1589 id1588 val1587)
+ ((lambda (n1590)
+ ((lambda (b1591)
+ ((lambda (t1592)
+ (if (memv
+ t1592
+ '(macro!))
+ ((lambda (id1594
+ val1593)
+ (syntax-type446
+ (chi-macro502
+ (binding-value282
+ b1591)
+ (list
+ '#(syntax-object set! ((top) #(ribcage () () ()) #(ribcage #(id val) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage #(_ id val) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w ae rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap s\ No newline at end of file
+ id1594
+ val1593)
+ r1580 '(())
+ '#f rib1577)
+ r1580 '(()) '#f
+ rib1577))
+ (wrap443
+ id1588
+ w1579)
+ (wrap443
+ val1587
+ w1579))
+ (values 'core
+ (lambda (e1600
+ r1599
+ mr1598
+ w1597
+ ae1596
+ m?1595)
+ ((lambda (val1602
+ n1601)
+ ((lambda (b1603)
+ ((lambda (t1604)
+ (if (memv
+ t1604
+ '(lexical))
+ (list
+ 'set!
+ (binding-value282
+ b1603)
+ val1602)
+ (if (memv
+ t1604
+ '(global))
+ ((lambda (sym1605)
+ (begin
+ (if (read-only-binding?140
+ n1601)
+ (syntax-error
+ (source-wrap444
+ e1600
+ w1597
+ ae1596)
+ '"invalid assignment to read-only variable")
+ (void))
+ (list
+ 'set!
+ sym1605
+ val1602)))
+ (binding-value282
+ b1603))
+ (if (memv
+ t1604
+ '(meta-variable))
+ (if m?1595
+ (list
+ 'set!
+ (binding-value282
+ b1603)
+ val1602)
+ (displaced-lexical-error299
+ (wrap443
+ id1588
+ w1597)))
+ (if (memv
+ t1604
+ '(displaced-lexical))
+ (displaced-lexical-error299
+ (wrap443
+ id1588
+ w1597))
+ (syntax-error
+ (source-wrap444
+ e1600
+ w1597
+ ae1596)))))))
+ (binding-type281
+ b1603)))
+ (lookup301
+ n1601
+ r1599)))
+ (chi498 val1587
+ r1599 mr1598
+ w1597 m?1595)
+ (id-var-name434
+ id1588
+ w1597)))
+ e1581 w1579
+ ae1578)))
+ (binding-type281 b1591)))
+ (lookup301 n1590 r1580)))
+ (id-var-name434 id1588 w1579)))
+ tmp1583)
+ ((lambda (_1606)
+ (syntax-error
+ (source-wrap444
+ e1581
+ w1579
+ ae1578)))
+ tmp1582)))
+ ($syntax-dispatch tmp1582 '(any any any))))
+ e1581)))
+ (chi-macro502 (lambda (p1564 e1563 r1562 w1561 ae1560
+ rib1559)
+ (letrec ((rebuild-macro-output1565 (lambda (x1569
+ m1568)
+ (if (pair?
+ x1569)
+ (cons
+ (rebuild-macro-output1565
+ (car x1569)
+ m1568)
+ (rebuild-macro-output1565
+ (cdr x1569)
+ m1568))
+ (if (syntax-object?64
+ x1569)
+ ((lambda (w1570)
+ ((lambda (ms1572
+ s1571)
+ (make-syntax-object63
+ (syntax-object-expression65
+ x1569)
+ (if (if (pair?
+ ms1572)
+ (eq? (car ms1572)
+ '#f)
+ '#f)
+ (make-wrap315
+ (cdr ms1572)
+ (cdr s1571))
+ (make-wrap315
+ (cons
+ m1568
+ ms1572)
+ (if rib1559
+ (cons
+ rib1559
+ (cons
+ 'shift
+ s1571))
+ (cons
+ 'shift
+ s1571))))))
+ (wrap-marks316
+ w1570)
+ (wrap-subst317
+ w1570)))
+ (syntax-object-wrap66
+ x1569))
+ (if (vector?
+ x1569)
+ ((lambda (n1573)
+ ((lambda (v1574)
+ ((lambda ()
+ ((letrec ((do1575 (lambda (i1576)
+ (if (= i1576
+ n1573)
+ v1574
+ (begin
+ (vector-set!
+ v1574
+ i1576
+ (rebuild-macro-output1565
+ (vector-ref
+ x1569
+ i1576)
+ m1568))
+ (do1575
+ (+ i1576
+ '1)))))))
+ do1575)
+ '0))))
+ (make-vector
+ n1573)))
+ (vector-length
+ x1569))
+ (if (symbol?
+ x1569)
+ (syntax-error
+ (source-wrap444
+ e1563
+ w1561
+ ae1560)
+ '"encountered raw symbol "
+ (symbol->string
+ x1569)
+ '" in output of macro")
+ x1569)))))))
+ (rebuild-macro-output1565
+ ((lambda (out1566)
+ (if (procedure? out1566)
+ (out1566
+ (lambda (id1567)
+ (begin
+ (if (not (identifier? id1567))
+ (syntax-error
+ id1567
+ '"environment argument is not an identifier")
+ (void))
+ (lookup301
+ (id-var-name434
+ id1567
+ '(()))
+ r1562))))
+ out1566))
+ (p1564
+ (source-wrap444
+ e1563
+ (anti-mark400 w1561)
+ ae1560)))
+ (string '#\m)))))
+ (chi-body503 (lambda (body1547 outer-form1546 r1545 mr1544
+ w1543 m?1542)
+ ((lambda (ribcage1548)
+ ((lambda (w1549)
+ ((lambda (body1550)
+ ((lambda ()
+ (call-with-values
+ (lambda ()
+ (chi-internal504 ribcage1548
+ outer-form1546 body1550 r1545
+ mr1544 m?1542))
+ (lambda (r1557 mr1556 exprs1555
+ ids1554 vars1553 vals1552
+ inits1551)
+ (begin
+ (if (null? exprs1555)
+ (syntax-error
+ outer-form1546
+ '"no expressions in body")
+ (void))
+ (build-body237
+ '#f
+ (reverse vars1553)
+ (chi-frobs495
+ (reverse vals1552)
+ r1557
+ mr1556
+ m?1542)
+ (build-sequence235
+ '#f
+ (chi-frobs495
+ (append
+ inits1551
+ exprs1555)
+ r1557
+ mr1556
+ m?1542)))))))))
+ (map (lambda (x1558)
+ (make-frob476
+ (wrap443 x1558 w1549)
+ '#f))
+ body1547)))
+ (make-wrap315
+ (wrap-marks316 w1543)
+ (cons
+ ribcage1548
+ (wrap-subst317 w1543)))))
+ (make-ribcage365 '() '() '()))))
+ (chi-internal504 (lambda (ribcage1451 source-exp1450
+ body1449 r1448 mr1447 m?1446)
+ (letrec ((return1452 (lambda (r1541 mr1540
+ exprs1539
+ ids1538
+ vars1537
+ vals1536
+ inits1535)
+ (begin
+ (check-defined-ids485
+ source-exp1450
+ ids1538)
+ (values r1541
+ mr1540 exprs1539
+ ids1538 vars1537
+ vals1536
+ inits1535)))))
+ ((letrec ((parse1453 (lambda (body1461
+ r1460 mr1459
+ ids1458
+ vars1457
+ vals1456
+ inits1455
+ meta-seen?1454)
+ (if (null?
+ body1461)
+ (return1452
+ r1460 mr1459
+ body1461
+ ids1458
+ vars1457
+ vals1456
+ inits1455)
+ ((lambda (fr1462)
+ ((lambda (e1463)
+ ((lambda (meta?1464)
+ ((lambda ()
+ (call-with-values
+ (lambda ()
+ (syntax-type446
+ e1463
+ r1460
+ '(())
+ '#f
+ ribcage1451))
+ (lambda (type1469
+ value1468
+ e1467
+ w1466
+ ae1465)
+ ((lambda (t1470)
+ (if (memv
+ t1470
+ '(define-form))
+ (call-with-values
+ (lambda ()
+ (parse-define510
+ e1467
+ w1466
+ ae1465))
+ (lambda (id1473
+ rhs1472
+ w1471)
+ ((lambda (id1475
+ label1474)
+ (if meta?1464
+ ((lambda (sym1476)
+ (begin
+ (extend-ribcage!410
+ ribcage1451
+ id1475
+ label1474)
+ ((lambda (mr1477)
+ (begin
+ (define-top-level-value-hook135
+ sym1476
+ (top-level-eval-hook133
+ (chi498
+ rhs1472
+ mr1477
+ mr1477
+ w1471
+ '#t)))
+ (parse1453
+ (cdr body1461)
+ r1460
+ mr1477
+ (cons
+ id1475
+ ids1458)
+ vars1457
+ vals1456
+ inits1455
+ '#f)))
+ (extend-env295
+ label1474
+ (cons
+ 'meta-variable
+ sym1476)
+ mr1459))))
+ (generate-id143
+ ((lambda (x1478)
+ ((lambda (e1479)
+ (if (annotation?132
+ e1479)
+ (annotation-expression
+ e1479)
+ e1479))
+ (if (syntax-object?64
+ x1478)
+ (syntax-object-expression65
+ x1478)
+ x1478)))
+ id1475)))
+ ((lambda (var1480)
+ (begin
+ (extend-ribcage!410
+ ribcage1451
+ id1475
+ label1474)
+ (parse1453
+ (cdr body1461)
+ (extend-env295
+ label1474
+ (cons
+ 'lexical
+ var1480)
+ r1460)
+ mr1459
+ (cons
+ id1475
+ ids1458)
+ (cons
+ var1480
+ vars1457)
+ (cons
+ (make-frob476
+ (wrap443
+ rhs1472
+ w1471)
+ meta?1464)
+ vals1456)
+ inits1455
+ '#f)))
+ (gen-var523
+ id1475))))
+ (wrap443
+ id1473
+ w1471)
+ (gen-label362))))
+ (if (memv
+ t1470
+ '(define-syntax-form))
+ (call-with-values
+ (lambda ()
+ (parse-define-syntax511
+ e1467
+ w1466
+ ae1465))
+ (lambda (id1483
+ rhs1482
+ w1481)
+ ((lambda (id1486
+ label1485
+ exp1484)
+ (begin
+ (extend-ribcage!410
+ ribcage1451
+ id1486
+ label1485)
+ ((lambda (b1487)
+ (parse1453
+ (cdr body1461)
+ (extend-env295
+ label1485
+ b1487
+ r1460)
+ (extend-env295
+ label1485
+ b1487
+ mr1459)
+ (cons
+ id1486
+ ids1458)
+ vars1457
+ vals1456
+ inits1455
+ '#f))
+ (defer-or-eval-transformer303
+ local-eval-hook134
+ exp1484))))
+ (wrap443
+ id1483
+ w1481)
+ (gen-label362)
+ (chi498
+ rhs1482
+ mr1459
+ mr1459
+ w1481
+ '#t))))
+ (if (memv
+ t1470
+ '($module-form))
+ ((lambda (*ribcage1488)
+ ((lambda (*w1489)
+ ((lambda ()
+ (call-with-values
+ (lambda ()
+ (parse-module508
+ e1467
+ w1466
+ ae1465
+ *w1489))
+ (lambda (orig1493
+ id1492
+ exports1491
+ forms1490)
+ (call-with-values
+ (lambda ()
+ (chi-internal504
+ *ribcage1488
+ orig1493
+ (map (lambda (d1507)
+ (make-frob476
+ d1507
+ meta?1464))
+ forms1490)
+ r1460
+ mr1459
+ m?1446))
+ (lambda (r1500
+ mr1499
+ *body1498
+ *ids1497
+ *vars1496
+ *vals1495
+ *inits1494)
+ (begin
+ (check-module-exports484
+ source-exp1450
+ (flatten-exports450
+ exports1491)
+ *ids1497)
+ ((lambda (iface1505
+ vars1504
+ vals1503
+ inits1502
+ label1501)
+ (begin
+ (extend-ribcage!410
+ ribcage1451
+ id1492
+ label1501)
+ ((lambda (b1506)
+ (parse1453
+ (cdr body1461)
+ (extend-env295
+ label1501
+ b1506
+ r1500)
+ (extend-env295
+ label1501
+ b1506
+ mr1499)
+ (cons
+ id1492
+ ids1458)
+ vars1504
+ vals1503
+ inits1502
+ '#f))
+ (cons
+ '$module
+ iface1505))))
+ (make-resolved-interface460
+ id1492
+ exports1491
+ '#f)
+ (append
+ *vars1496
+ vars1457)
+ (append
+ *vals1495
+ vals1456)
+ (append
+ inits1455
+ *inits1494
+ *body1498)
+ (gen-label362))))))))))
+ (make-wrap315
+ (wrap-marks316
+ w1466)
+ (cons
+ *ribcage1488
+ (wrap-subst317
+ w1466)))))
+ (make-ribcage365
+ '()
+ '()
+ '()))
+ (if (memv
+ t1470
+ '($import-form))
+ (call-with-values
+ (lambda ()
+ (parse-import509
+ e1467
+ w1466
+ ae1465))
+ (lambda (orig1510
+ only?1509
+ mid1508)
+ ((lambda (mlabel1511)
+ ((lambda (binding1512)
+ ((lambda (t1513)
+ (if (memv
+ t1513
+ '($module))
+ ((lambda (iface1514)
+ ((lambda (import-iface1515)
+ ((lambda ()
+ (begin
+ (if only?1509
+ (extend-ribcage-barrier!412
+ ribcage1451
+ mid1508)
+ (void))
+ (do-import!507
+ import-iface1515
+ ribcage1451)
+ (parse1453
+ (cdr body1461)
+ r1460
+ mr1459
+ (cons
+ import-iface1515
+ ids1458)
+ vars1457
+ vals1456
+ inits1455
+ '#f)))))
+ (make-import-interface379
+ iface1514
+ (import-mark-delta505
+ mid1508
+ iface1514))))
+ (binding-value282
+ binding1512))
+ (if (memv
+ t1513
+ '(displaced-lexical))
+ (displaced-lexical-error299
+ mid1508)
+ (syntax-error
+ mid1508
+ '"unknown module"))))
+ (binding-type281
+ binding1512)))
+ (lookup301
+ mlabel1511
+ r1460)))
+ (id-var-name434
+ mid1508
+ '(())))))
+ (if (memv
+ t1470
+ '(alias-form))
+ (call-with-values
+ (lambda ()
+ (parse-alias514
+ e1467
+ w1466
+ ae1465))
+ (lambda (new-id1517
+ old-id1516)
+ ((lambda (new-id1518)
+ (begin
+ (extend-ribcage!410
+ ribcage1451
+ new-id1518
+ (id-var-name-loc433
+ old-id1516
+ w1466))
+ (parse1453
+ (cdr body1461)
+ r1460
+ mr1459
+ (cons
+ new-id1518
+ ids1458)
+ vars1457
+ vals1456
+ inits1455
+ '#f)))
+ (wrap443
+ new-id1517
+ w1466))))
+ (if (memv
+ t1470
+ '(begin-form))
+ (parse1453
+ ((letrec ((f1519 (lambda (forms1520)
+ (if (null?
+ forms1520)
+ (cdr body1461)
+ (cons
+ (make-frob476
+ (wrap443
+ (car forms1520)
+ w1466)
+ meta?1464)
+ (f1519
+ (cdr forms1520)))))))
+ f1519)
+ (parse-begin515
+ e1467
+ w1466
+ ae1465
+ '#t))
+ r1460
+ mr1459
+ ids1458
+ vars1457
+ vals1456
+ inits1455
+ '#f)
+ (if (memv
+ t1470
+ '(eval-when-form))
+ (call-with-values
+ (lambda ()
+ (parse-eval-when513
+ e1467
+ w1466
+ ae1465))
+ (lambda (when-list1522
+ forms1521)
+ (parse1453
+ (if (memq
+ 'eval
+ when-list1522)
+ ((letrec ((f1523 (lambda (forms1524)
+ (if (null?
+ forms1524)
+ (cdr body1461)
+ (cons
+ (make-frob476
+ (wrap443
+ (car forms1524)
+ w1466)
+ meta?1464)
+ (f1523
+ (cdr forms1524)))))))
+ f1523)
+ forms1521)
+ (cdr body1461))
+ r1460
+ mr1459
+ ids1458
+ vars1457
+ vals1456
+ inits1455
+ '#f)))
+ (if (memv
+ t1470
+ '(meta-form))
+ (parse1453
+ (cons
+ (make-frob476
+ (wrap443
+ (parse-meta512
+ e1467
+ w1466
+ ae1465)
+ w1466)
+ '#t)
+ (cdr body1461))
+ r1460
+ mr1459
+ ids1458
+ vars1457
+ vals1456
+ inits1455
+ '#t)
+ (if (memv
+ t1470
+ '(local-syntax-form))
+ (call-with-values
+ (lambda ()
+ (chi-local-syntax517
+ value1468
+ e1467
+ r1460
+ mr1459
+ w1466
+ ae1465))
+ (lambda (forms1529
+ r1528
+ mr1527
+ w1526
+ ae1525)
+ (parse1453
+ ((letrec ((f1530 (lambda (forms1531)
+ (if (null?
+ forms1531)
+ (cdr body1461)
+ (cons
+ (make-frob476
+ (wrap443
+ (car forms1531)
+ w1526)
+ meta?1464)
+ (f1530
+ (cdr forms1531)))))))
+ f1530)
+ forms1529)
+ r1528
+ mr1527
+ ids1458
+ vars1457
+ vals1456
+ inits1455
+ '#f)))
+ (begin
+ (if meta-seen?1454
+ (syntax-error
+ (source-wrap444
+ e1467
+ w1466
+ ae1465)
+ '"invalid meta definition")
+ (void))
+ ((letrec ((f1532 (lambda (body1533)
+ (if ((lambda (t1534)
+ (if t1534
+ t1534
+ (not (frob-meta?479
+ (car body1533)))))
+ (null?
+ body1533))
+ (return1452
+ r1460
+ mr1459
+ body1533
+ ids1458
+ vars1457
+ vals1456
+ inits1455)
+ (begin
+ (top-level-eval-hook133
+ (chi-meta-frob496
+ (car body1533)
+ mr1459))
+ (f1532
+ (cdr body1533)))))))
+ f1532)
+ (cons
+ (make-frob476
+ (source-wrap444
+ e1467
+ w1466
+ ae1465)
+ meta?1464)
+ (cdr body1461))))))))))))))
+ type1469))))))
+ (frob-meta?479
+ fr1462)))
+ (frob-e478
+ fr1462)))
+ (car body1461))))))
+ parse1453) body1449 r1448 mr1447 '()
+ '() '() '() '#f))))
+ (import-mark-delta505 (lambda (mid1445 iface1444)
+ (diff-marks426
+ (id-marks312 mid1445)
+ (interface-marks453 iface1444))))
+ (lookup-import-label506 (lambda (id1442)
+ ((lambda (label1443)
+ (begin
+ (if (not label1443)
+ (syntax-error
+ id1442
+ '"exported identifier not visible")
+ (void))
+ label1443))
+ (id-var-name-loc433
+ id1442
+ '(())))))
+ (do-import!507 (lambda (import-iface1438 ribcage1437)
+ ((lambda (ie1439)
+ (if (<= (vector-length ie1439) '20)
+ ((lambda (new-marks1440)
+ (vfor-each488
+ (lambda (id1441)
+ (import-extend-ribcage!411
+ ribcage1437
+ new-marks1440
+ id1441
+ (lookup-import-label506
+ id1441)))
+ ie1439))
+ (import-interface-new-marks382
+ import-iface1438))
+ (extend-ribcage-subst!414
+ ribcage1437
+ import-iface1438)))
+ (interface-exports454
+ (import-interface-interface381
+ import-iface1438)))))
+ (parse-module508 (lambda (e1413 w1412 ae1411 *w1410)
+ (letrec ((listify1414 (lambda (exports1431)
+ (if (null?
+ exports1431)
+ '()
+ (cons
+ ((lambda (tmp1432)
+ ((lambda (tmp1433)
+ (if tmp1433
+ (apply
+ (lambda (ex1434)
+ (listify1414
+ ex1434))
+ tmp1433)
+ ((lambda (x1436)
+ (if (id?306
+ x1436)
+ (wrap443
+ x1436
+ *w1410)
+ (syntax-error
+ (source-wrap444
+ e1413
+ w1412
+ ae1411)
+ '"invalid exports list in")))
+ tmp1432)))
+ ($syntax-dispatch
+ tmp1432
+ 'each-any)))
+ (car exports1431))
+ (listify1414
+ (cdr exports1431)))))))
+ ((lambda (tmp1415)
+ ((lambda (tmp1416)
+ (if (if tmp1416
+ (apply
+ (lambda (_1421 orig1420
+ mid1419 ex1418
+ form1417)
+ (id?306 mid1419))
+ tmp1416)
+ '#f)
+ (apply
+ (lambda (_1426 orig1425
+ mid1424 ex1423
+ form1422)
+ (values
+ orig1425
+ (wrap443 mid1424 w1412)
+ (listify1414 ex1423)
+ (map (lambda (x1428)
+ (wrap443
+ x1428
+ *w1410))
+ form1422)))
+ tmp1416)
+ ((lambda (_1430)
+ (syntax-error
+ (source-wrap444
+ e1413
+ w1412
+ ae1411)))
+ tmp1415)))
+ ($syntax-dispatch
+ tmp1415
+ '(any any any each-any .
+ each-any))))
+ e1413))))
+ (parse-import509 (lambda (e1393 w1392 ae1391)
+ ((lambda (tmp1394)
+ ((lambda (tmp1395)
+ (if (if tmp1395
+ (apply
+ (lambda (_1398 orig1397
+ mid1396)
+ (id?306 mid1396))
+ tmp1395)
+ '#f)
+ (apply
+ (lambda (_1401 orig1400 mid1399)
+ (values
+ orig1400
+ '#t
+ (wrap443 mid1399 w1392)))
+ tmp1395)
+ ((lambda (tmp1402)
+ (if (if tmp1402
+ (apply
+ (lambda (_1405
+ orig1404
+ mid1403)
+ (id?306 mid1403))
+ tmp1402)
+ '#f)
+ (apply
+ (lambda (_1408 orig1407
+ mid1406)
+ (values
+ orig1407
+ '#f
+ (wrap443
+ mid1406
+ w1392)))
+ tmp1402)
+ ((lambda (_1409)
+ (syntax-error
+ (source-wrap444
+ e1393
+ w1392
+ ae1391)))
+ tmp1394)))
+ ($syntax-dispatch
+ tmp1394
+ '(any any #(atom #f) any)))))
+ ($syntax-dispatch
+ tmp1394
+ '(any any #(atom #t) any))))
+ e1393)))
+ (parse-define510 (lambda (e1364 w1363 ae1362)
+ ((lambda (tmp1365)
+ ((lambda (tmp1366)
+ (if (if tmp1366
+ (apply
+ (lambda (_1369 name1368
+ val1367)
+ (id?306 name1368))
+ tmp1366)
+ '#f)
+ (apply
+ (lambda (_1372 name1371 val1370)
+ (values
+ name1371
+ val1370
+ w1363))
+ tmp1366)
+ ((lambda (tmp1373)
+ (if (if tmp1373
+ (apply
+ (lambda (_1378
+ name1377
+ args1376
+ e11375
+ e21374)
+ (if (id?306
+ name1377)
+ (valid-bound-ids?439
+ (lambda-var-list524
+ args1376))
+ '#f))
+ tmp1373)
+ '#f)
+ (apply
+ (lambda (_1383 name1382
+ args1381 e11380
+ e21379)
+ (values
+ (wrap443
+ name1382
+ w1363)
+ (cons
+ '#(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e w ae) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) \ No newline at end of file
+ (wrap443
+ (cons
+ args1381
+ (cons
+ e11380
+ e21379))
+ w1363))
+ '(())))
+ tmp1373)
+ ((lambda (tmp1385)
+ (if (if tmp1385
+ (apply
+ (lambda (_1387
+ name1386)
+ (id?306
+ name1386))
+ tmp1385)
+ '#f)
+ (apply
+ (lambda (_1389
+ name1388)
+ (values
+ (wrap443
+ name1388
+ w1363)
+ '#(syntax-object (void) ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(e w ae) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) \ No newline at end of file
+ '(())))
+ tmp1385)
+ ((lambda (_1390)
+ (syntax-error
+ (source-wrap444
+ e1364
+ w1363
+ ae1362)))
+ tmp1365)))
+ ($syntax-dispatch
+ tmp1365
+ '(any any)))))
+ ($syntax-dispatch
+ tmp1365
+ '(any (any . any)
+ any
+ .
+ each-any)))))
+ ($syntax-dispatch
+ tmp1365
+ '(any any any))))
+ e1364)))
+ (parse-define-syntax511 (lambda (e1340 w1339 ae1338)
+ ((lambda (tmp1341)
+ ((lambda (tmp1342)
+ (if (if tmp1342
+ (apply
+ (lambda (_1347
+ name1346
+ id1345
+ e11344
+ e21343)
+ (if (id?306
+ name1346)
+ (id?306 id1345)
+ '#f))
+ tmp1342)
+ '#f)
+ (apply
+ (lambda (_1352 name1351
+ id1350 e11349
+ e21348)
+ (values
+ (wrap443
+ name1351
+ w1339)
+ (cons
+ '#(syntax-object lambda ((top) #(ribcage #(_ name id e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e w ae) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (t\ No newline at end of file
+ (cons
+ (wrap443
+ (list id1350)
+ w1339)
+ (wrap443
+ (cons
+ e11349
+ e21348)
+ w1339)))
+ '(())))
+ tmp1342)
+ ((lambda (tmp1354)
+ (if (if tmp1354
+ (apply
+ (lambda (_1357
+ name1356
+ val1355)
+ (id?306
+ name1356))
+ tmp1354)
+ '#f)
+ (apply
+ (lambda (_1360
+ name1359
+ val1358)
+ (values
+ name1359
+ val1358
+ w1339))
+ tmp1354)
+ ((lambda (_1361)
+ (syntax-error
+ (source-wrap444
+ e1340
+ w1339
+ ae1338)))
+ tmp1341)))
+ ($syntax-dispatch
+ tmp1341
+ '(any any any)))))
+ ($syntax-dispatch
+ tmp1341
+ '(any (any any)
+ any
+ .
+ each-any))))
+ e1340)))
+ (parse-meta512 (lambda (e1332 w1331 ae1330)
+ ((lambda (tmp1333)
+ ((lambda (tmp1334)
+ (if tmp1334
+ (apply
+ (lambda (_1336 form1335) form1335)
+ tmp1334)
+ ((lambda (_1337)
+ (syntax-error
+ (source-wrap444
+ e1332
+ w1331
+ ae1330)))
+ tmp1333)))
+ ($syntax-dispatch tmp1333 '(any . any))))
+ e1332)))
+ (parse-eval-when513 (lambda (e1320 w1319 ae1318)
+ ((lambda (tmp1321)
+ ((lambda (tmp1322)
+ (if tmp1322
+ (apply
+ (lambda (_1326 x1325 e11324
+ e21323)
+ (values
+ (chi-when-list445
+ x1325
+ w1319)
+ (cons e11324 e21323)))
+ tmp1322)
+ ((lambda (_1329)
+ (syntax-error
+ (source-wrap444
+ e1320
+ w1319
+ ae1318)))
+ tmp1321)))
+ ($syntax-dispatch
+ tmp1321
+ '(any each-any any . each-any))))
+ e1320)))
+ (parse-alias514 (lambda (e1308 w1307 ae1306)
+ ((lambda (tmp1309)
+ ((lambda (tmp1310)
+ (if (if tmp1310
+ (apply
+ (lambda (_1313 new-id1312
+ old-id1311)
+ (if (id?306 new-id1312)
+ (id?306 old-id1311)
+ '#f))
+ tmp1310)
+ '#f)
+ (apply
+ (lambda (_1316 new-id1315
+ old-id1314)
+ (values new-id1315 old-id1314))
+ tmp1310)
+ ((lambda (_1317)
+ (syntax-error
+ (source-wrap444
+ e1308
+ w1307
+ ae1306)))
+ tmp1309)))
+ ($syntax-dispatch
+ tmp1309
+ '(any any any))))
+ e1308)))
+ (parse-begin515 (lambda (e1295 w1294 ae1293 empty-okay?1292)
+ ((lambda (tmp1296)
+ ((lambda (tmp1297)
+ (if (if tmp1297
+ (apply
+ (lambda (_1298)
+ empty-okay?1292)
+ tmp1297)
+ '#f)
+ (apply
+ (lambda (_1299) '())
+ tmp1297)
+ ((lambda (tmp1300)
+ (if tmp1300
+ (apply
+ (lambda (_1303 e11302
+ e21301)
+ (cons e11302 e21301))
+ tmp1300)
+ ((lambda (_1305)
+ (syntax-error
+ (source-wrap444
+ e1295
+ w1294
+ ae1293)))
+ tmp1296)))
+ ($syntax-dispatch
+ tmp1296
+ '(any any . each-any)))))
+ ($syntax-dispatch tmp1296 '(any))))
+ e1295)))
+ (chi-lambda-clause516 (lambda (e1269 c1268 r1267 mr1266
+ w1265 m?1264)
+ ((lambda (tmp1270)
+ ((lambda (tmp1271)
+ (if tmp1271
+ (apply
+ (lambda (id1274 e11273
+ e21272)
+ ((lambda (ids1275)
+ (if (not (valid-bound-ids?439
+ ids1275))
+ (syntax-error
+ e1269
+ '"invalid parameter list in")
+ ((lambda (labels1277
+ new-vars1276)
+ (values
+ new-vars1276
+ (chi-body503
+ (cons
+ e11273
+ e21272)
+ e1269
+ (extend-var-env*297
+ labels1277
+ new-vars1276
+ r1267)
+ mr1266
+ (make-binding-wrap417
+ ids1275
+ labels1277
+ w1265)
+ m?1264)))
+ (gen-labels364
+ ids1275)
+ (map gen-var523
+ ids1275))))
+ id1274))
+ tmp1271)
+ ((lambda (tmp1280)
+ (if tmp1280
+ (apply
+ (lambda (ids1283
+ e11282
+ e21281)
+ ((lambda (old-ids1284)
+ (if (not (valid-bound-ids?439
+ old-ids1284))
+ (syntax-error
+ e1269
+ '"invalid parameter list in")
+ ((lambda (labels1286
+ new-vars1285)
+ (values
+ ((letrec ((f1288 (lambda (ls11290
+ ls21289)
+ (if (null?
+ ls11290)
+ ls21289
+ (f1288
+ (cdr ls11290)
+ (cons
+ (car ls11290)
+ ls21289))))))
+ f1288)
+ (cdr new-vars1285)
+ (car new-vars1285))
+ (chi-body503
+ (cons
+ e11282
+ e21281)
+ e1269
+ (extend-var-env*297
+ labels1286
+ new-vars1285
+ r1267)
+ mr1266
+ (make-binding-wrap417
+ old-ids1284
+ labels1286
+ w1265)
+ m?1264)))
+ (gen-labels364
+ old-ids1284)
+ (map gen-var523
+ old-ids1284))))
+ (lambda-var-list524
+ ids1283)))
+ tmp1280)
+ ((lambda (_1291)
+ (syntax-error
+ e1269))
+ tmp1270)))
+ ($syntax-dispatch
+ tmp1270
+ '(any any . each-any)))))
+ ($syntax-dispatch
+ tmp1270
+ '(each-any any . each-any))))
+ c1268)))
+ (chi-local-syntax517 (lambda (rec?1245 e1244 r1243 mr1242
+ w1241 ae1240)
+ ((lambda (tmp1246)
+ ((lambda (tmp1247)
+ (if tmp1247
+ (apply
+ (lambda (_1252 id1251
+ val1250 e11249
+ e21248)
+ ((lambda (ids1253)
+ (if (not (valid-bound-ids?439
+ ids1253))
+ (invalid-ids-error441
+ (map (lambda (x1254)
+ (wrap443
+ x1254
+ w1241))
+ ids1253)
+ (source-wrap444
+ e1244
+ w1241
+ ae1240)
+ '"keyword")
+ ((lambda (labels1255)
+ ((lambda (new-w1256)
+ ((lambda (b*1257)
+ (values
+ (cons
+ e11249
+ e21248)
+ (extend-env*296
+ labels1255
+ b*1257
+ r1243)
+ (extend-env*296
+ labels1255
+ b*1257
+ mr1242)
+ new-w1256
+ ae1240))
+ ((lambda (w1259)
+ (map (lambda (x1261)
+ (defer-or-eval-transformer303
+ local-eval-hook134
+ (chi498
+ x1261
+ mr1242
+ mr1242
+ w1259
+ '#t)))
+ val1250))
+ (if rec?1245
+ new-w1256
+ w1241))))
+ (make-binding-wrap417
+ ids1253
+ labels1255
+ w1241)))
+ (gen-labels364
+ ids1253))))
+ id1251))
+ tmp1247)
+ ((lambda (_1263)
+ (syntax-error
+ (source-wrap444
+ e1244
+ w1241
+ ae1240)))
+ tmp1246)))
+ ($syntax-dispatch
+ tmp1246
+ '(any #(each (any any))
+ any
+ .
+ each-any))))
+ e1244)))
+ (chi-void518 (lambda () (cons 'void '())))
+ (ellipsis?519 (lambda (x1239)
+ (if (nonsymbol-id?305 x1239)
+ (literal-id=?436
+ x1239
+ '#(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) \ No newline at end of file
+ '#f)))
+ (strip-annotation520 (lambda (x1238)
+ (if (pair? x1238)
+ (cons
+ (strip-annotation520 (car x1238))
+ (strip-annotation520 (cdr x1238)))
+ (if (annotation?132 x1238)
+ (annotation-stripped x1238)
+ x1238))))
+ (strip*521 (lambda (x1231 w1230 fn1229)
+ (if (memq 'top (wrap-marks316 w1230))
+ (fn1229 x1231)
+ ((letrec ((f1232 (lambda (x1233)
+ (if (syntax-object?64
+ x1233)
+ (strip*521
+ (syntax-object-expression65
+ x1233)
+ (syntax-object-wrap66
+ x1233)
+ fn1229)
+ (if (pair? x1233)
+ ((lambda (a1235
+ d1234)
+ (if (if (eq? a1235
+ (car x1233))
+ (eq? d1234
+ (cdr x1233))
+ '#f)
+ x1233
+ (cons
+ a1235
+ d1234)))
+ (f1232
+ (car x1233))
+ (f1232
+ (cdr x1233)))
+ (if (vector? x1233)
+ ((lambda (old1236)
+ ((lambda (new1237)
+ (if (andmap
+ eq?
+ old1236
+ new1237)
+ x1233
+ (list->vector
+ new1237)))
+ (map f1232
+ old1236)))
+ (vector->list
+ x1233))
+ x1233))))))
+ f1232)
+ x1231))))
+ (strip522 (lambda (x1226 w1225)
+ (strip*521
+ x1226
+ w1225
+ (lambda (x1227)
+ (if ((lambda (t1228)
+ (if t1228
+ t1228
+ (if (pair? x1227)
+ (annotation?132 (car x1227))
+ '#f)))
+ (annotation?132 x1227))
+ (strip-annotation520 x1227)
+ x1227)))))
+ (gen-var523 (lambda (id1223)
+ ((lambda (id1224)
+ (if (annotation?132 id1224)
+ (gensym)
+ (gensym)))
+ (if (syntax-object?64 id1223)
+ (syntax-object-expression65 id1223)
+ id1223))))
+ (lambda-var-list524 (lambda (vars1218)
+ ((letrec ((lvl1219 (lambda (vars1222
+ ls1221 w1220)
+ (if (pair? vars1222)
+ (lvl1219
+ (cdr vars1222)
+ (cons
+ (wrap443
+ (car vars1222)
+ w1220)
+ ls1221)
+ w1220)
+ (if (id?306
+ vars1222)
+ (cons
+ (wrap443
+ vars1222
+ w1220)
+ ls1221)
+ (if (null?
+ vars1222)
+ ls1221
+ (if (syntax-object?64
+ vars1222)
+ (lvl1219
+ (syntax-object-expression65
+ vars1222)
+ ls1221
+ (join-wraps422
+ w1220
+ (syntax-object-wrap66
+ vars1222)))
+ (if (annotation?132
+ vars1222)
+ (lvl1219
+ (annotation-expression
+ vars1222)
+ ls1221
+ w1220)
+ (cons
+ vars1222
+ ls1221)))))))))
+ lvl1219)
+ vars1218
+ '()
+ '(())))))
+ (begin
+ (set! $sc-put-cte
+ (lambda (id1199 b1198 top-token1197)
+ (letrec ((sc-put-module1200 (lambda (exports1216 token1215
+ new-marks1214)
+ (vfor-each488
+ (lambda (id1217)
+ (store-import-binding416
+ id1217
+ token1215
+ new-marks1214))
+ exports1216)))
+ (put-cte1201 (lambda (id1212 binding1211 token1210)
+ ((lambda (sym1213)
+ (begin
+ (store-import-binding416
+ id1212
+ token1210
+ '())
+ (put-global-definition-hook139
+ sym1213
+ (if (if (eq? (binding-type281
+ binding1211)
+ 'global)
+ (eq? (binding-value282
+ binding1211)
+ sym1213)
+ '#f)
+ '#f
+ binding1211))))
+ (if (symbol? id1212)
+ id1212
+ (id-var-name434 id1212 '(())))))))
+ ((lambda (binding1202)
+ ((lambda (t1203)
+ (if (memv t1203 '($module))
+ (begin
+ ((lambda (iface1204)
+ (sc-put-module1200
+ (interface-exports454 iface1204)
+ (interface-token455 iface1204)
+ '()))
+ (binding-value282 binding1202))
+ (put-cte1201 id1199 binding1202 top-token1197))
+ (if (memv t1203 '(do-alias))
+ (store-import-binding416
+ id1199
+ top-token1197
+ '())
+ (if (memv t1203 '(do-import))
+ ((lambda (token1205)
+ ((lambda (b1206)
+ ((lambda (t1207)
+ (if (memv t1207 '($module))
+ ((lambda (iface1208)
+ ((lambda (exports1209)
+ ((lambda ()
+ (begin
+ (if (not (eq? (interface-token455
+ iface1208)
+ token1205))
+ (syntax-error
+ id1199
+ '"import mismatch for module")
+ (void))
+ (sc-put-module1200
+ (interface-exports454
+ iface1208)
+ top-token1197
+ (import-mark-delta505
+ id1199
+ iface1208))))))
+ (interface-exports454
+ iface1208)))
+ (binding-value282 b1206))
+ (syntax-error
+ id1199
+ '"unknown module")))
+ (binding-type281 b1206)))
+ (lookup301
+ (id-var-name434 id1199 '(()))
+ '())))
+ (binding-value282 b1198))
+ (put-cte1201
+ id1199
+ binding1202
+ top-token1197)))))
+ (binding-type281 binding1202)))
+ (make-transformer-binding302 b1198)))))
+ (global-extend304 'local-syntax 'letrec-syntax '#t)
+ (global-extend304 'local-syntax 'let-syntax '#f)
+ (global-extend304
+ 'core
+ 'fluid-let-syntax
+ (lambda (e1171 r1170 mr1169 w1168 ae1167 m?1166)
+ ((lambda (tmp1172)
+ ((lambda (tmp1173)
+ (if (if tmp1173
+ (apply
+ (lambda (_1178 var1177 val1176 e11175 e21174)
+ (valid-bound-ids?439 var1177))
+ tmp1173)
+ '#f)
+ (apply
+ (lambda (_1184 var1183 val1182 e11181 e21180)
+ ((lambda (names1185)
+ (begin
+ (for-each
+ (lambda (id1192 n1191)
+ ((lambda (t1193)
+ (if (memv t1193 '(displaced-lexical))
+ (displaced-lexical-error299
+ (wrap443 id1192 w1168))
+ (void)))
+ (binding-type281
+ (lookup301 n1191 r1170))))
+ var1183
+ names1185)
+ ((lambda (b*1186)
+ (chi-body503 (cons e11181 e21180)
+ (source-wrap444 e1171 w1168 ae1167)
+ (extend-env*296 names1185 b*1186 r1170)
+ (extend-env*296 names1185 b*1186 mr1169)
+ w1168 m?1166))
+ (map (lambda (x1189)
+ (defer-or-eval-transformer303
+ local-eval-hook134
+ (chi498 x1189 mr1169 mr1169 w1168
+ '#t)))
+ val1182))))
+ (map (lambda (x1195)
+ (id-var-name434 x1195 w1168))
+ var1183)))
+ tmp1173)
+ ((lambda (_1196)
+ (syntax-error (source-wrap444 e1171 w1168 ae1167)))
+ tmp1172)))
+ ($syntax-dispatch
+ tmp1172
+ '(any #(each (any any)) any . each-any))))
+ e1171)))
+ (global-extend304
+ 'core
+ 'quote
+ (lambda (e1160 r1159 mr1158 w1157 ae1156 m?1155)
+ ((lambda (tmp1161)
+ ((lambda (tmp1162)
+ (if tmp1162
+ (apply
+ (lambda (_1164 e1163)
+ (list 'quote (strip522 e1163 w1157)))
+ tmp1162)
+ ((lambda (_1165)
+ (syntax-error (source-wrap444 e1160 w1157 ae1156)))
+ tmp1161)))
+ ($syntax-dispatch tmp1161 '(any any))))
+ e1160)))
+ (global-extend304
+ 'core
+ 'syntax
+ ((lambda ()
+ (letrec ((gen-syntax1039 (lambda (src1100 e1099 r1098
+ maps1097 ellipsis?1096
+ vec?1095)
+ (if (id?306 e1099)
+ ((lambda (label1101)
+ ((lambda (b1102)
+ (if (eq? (binding-type281
+ b1102)
+ 'syntax)
+ (call-with-values
+ (lambda ()
+ ((lambda (var.lev1105)
+ (gen-ref1040
+ src1100
+ (car var.lev1105)
+ (cdr var.lev1105)
+ maps1097))
+ (binding-value282
+ b1102)))
+ (lambda (var1104
+ maps1103)
+ (values
+ (list
+ 'ref
+ var1104)
+ maps1103)))
+ (if (ellipsis?1096
+ e1099)
+ (syntax-error
+ src1100
+ '"misplaced ellipsis in syntax form")
+ (values
+ (list
+ 'quote
+ e1099)
+ maps1097))))
+ (lookup301
+ label1101
+ r1098)))
+ (id-var-name434 e1099 '(())))
+ ((lambda (tmp1106)
+ ((lambda (tmp1107)
+ (if (if tmp1107
+ (apply
+ (lambda (dots1109
+ e1108)
+ (ellipsis?1096
+ dots1109))
+ tmp1107)
+ '#f)
+ (apply
+ (lambda (dots1111
+ e1110)
+ (if vec?1095
+ (syntax-error
+ src1100
+ '"misplaced ellipsis in syntax template")
+ (gen-syntax1039
+ src1100
+ e1110 r1098
+ maps1097
+ (lambda (x1112)
+ '#f)
+ '#f)))
+ tmp1107)
+ ((lambda (tmp1113)
+ (if (if tmp1113
+ (apply
+ (lambda (x1116
+ dots1115
+ y1114)
+ (ellipsis?1096
+ dots1115))
+ tmp1113)
+ '#f)
+ (apply
+ (lambda (x1119
+ dots1118
+ y1117)
+ ((letrec ((f1120 (lambda (y1122
+ k1121)
+ ((lambda (tmp1123)
+ ((lambda (tmp1124)
+ (if (if tmp1124
+ (apply
+ (lambda (dots1126
+ y1125)
+ (ellipsis?1096
+ dots1126))
+ tmp1124)
+ '#f)
+ (apply
+ (lambda (dots1128
+ y1127)
+ (f1120
+ y1127
+ (lambda (maps1129)
+ (call-with-values
+ (lambda ()
+ (k1121
+ (cons
+ '()
+ maps1129)))
+ (lambda (x1131
+ maps1130)
+ (if (null?
+ (car maps1130))
+ (syntax-error
+ src1100
+ '"extra ellipsis in syntax form")
+ (values
+ (gen-mappend1042
+ x1131
+ (car maps1130))
+ (cdr maps1130))))))))
+ tmp1124)
+ ((lambda (_1132)
+ (call-with-values
+ (lambda ()
+ (gen-syntax1039
+ src1100
+ y1122
+ r1098
+ maps1097
+ ellipsis?1096
+ vec?1095))
+ (lambda (y1134
+ maps1133)
+ (call-with-values
+ (lambda ()
+ (k1121
+ maps1133))
+ (lambda (x1136
+ maps1135)
+ (values
+ (gen-append1041
+ x1136
+ y1134)
+ maps1135))))))
+ tmp1123)))
+ ($syntax-dispatch
+ tmp1123
+ '(any .
+ any))))
+ y1122))))
+ f1120)
+ y1117
+ (lambda (maps1137)
+ (call-with-values
+ (lambda ()
+ (gen-syntax1039
+ src1100
+ x1119
+ r1098
+ (cons
+ '()
+ maps1137)
+ ellipsis?1096
+ '#f))
+ (lambda (x1139
+ maps1138)
+ (if (null?
+ (car maps1138))
+ (syntax-error
+ src1100
+ '"extra ellipsis in syntax form")
+ (values
+ (gen-map1043
+ x1139
+ (car maps1138))
+ (cdr maps1138))))))))
+ tmp1113)
+ ((lambda (tmp1140)
+ (if tmp1140
+ (apply
+ (lambda (x1142
+ y1141)
+ (call-with-values
+ (lambda ()
+ (gen-syntax1039
+ src1100
+ x1142
+ r1098
+ maps1097
+ ellipsis?1096
+ '#f))
+ (lambda (xnew1144
+ maps1143)
+ (call-with-values
+ (lambda ()
+ (gen-syntax1039
+ src1100
+ y1141
+ r1098
+ maps1143
+ ellipsis?1096
+ vec?1095))
+ (lambda (ynew1146
+ maps1145)
+ (values
+ (gen-cons1044
+ e1099
+ x1142
+ y1141
+ xnew1144
+ ynew1146)
+ maps1145))))))
+ tmp1140)
+ ((lambda (tmp1147)
+ (if tmp1147
+ (apply
+ (lambda (x11149
+ x21148)
+ ((lambda (ls1150)
+ (call-with-values
+ (lambda ()
+ (gen-syntax1039
+ src1100
+ ls1150
+ r1098
+ maps1097
+ ellipsis?1096
+ '#t))
+ (lambda (lsnew1152
+ maps1151)
+ (values
+ (gen-vector1045
+ e1099
+ ls1150
+ lsnew1152)
+ maps1151))))
+ (cons
+ x11149
+ x21148)))
+ tmp1147)
+ ((lambda (_1154)
+ (values
+ (list
+ 'quote
+ e1099)
+ maps1097))
+ tmp1106)))
+ ($syntax-dispatch
+ tmp1106
+ '#(vector
+ (any .
+ each-any))))))
+ ($syntax-dispatch
+ tmp1106
+ '(any .
+ any)))))
+ ($syntax-dispatch
+ tmp1106
+ '(any any
+ .
+ any)))))
+ ($syntax-dispatch
+ tmp1106
+ '(any any))))
+ e1099))))
+ (gen-ref1040 (lambda (src1090 var1089 level1088
+ maps1087)
+ (if (= level1088 '0)
+ (values var1089 maps1087)
+ (if (null? maps1087)
+ (syntax-error
+ src1090
+ '"missing ellipsis in syntax form")
+ (call-with-values
+ (lambda ()
+ (gen-ref1040
+ src1090
+ var1089
+ (- level1088 '1)
+ (cdr maps1087)))
+ (lambda (outer-var1092
+ outer-maps1091)
+ ((lambda (b1093)
+ (if b1093
+ (values
+ (cdr b1093)
+ maps1087)
+ ((lambda (inner-var1094)
+ (values
+ inner-var1094
+ (cons
+ (cons
+ (cons
+ outer-var1092
+ inner-var1094)
+ (car maps1087))
+ outer-maps1091)))
+ (gen-var523
+ 'tmp))))
+ (assq
+ outer-var1092
+ (car maps1087)))))))))
+ (gen-append1041 (lambda (x1086 y1085)
+ (if (equal? y1085 ''())
+ x1086
+ (list 'append x1086 y1085))))
+ (gen-mappend1042 (lambda (e1084 map-env1083)
+ (list
+ 'apply
+ '(primitive append)
+ (gen-map1043
+ e1084
+ map-env1083))))
+ (gen-map1043 (lambda (e1076 map-env1075)
+ ((lambda (formals1078 actuals1077)
+ (if (eq? (car e1076) 'ref)
+ (car actuals1077)
+ (if (andmap
+ (lambda (x1079)
+ (if (eq? (car x1079)
+ 'ref)
+ (memq
+ (cadr x1079)
+ formals1078)
+ '#f))
+ (cdr e1076))
+ (cons
+ 'map
+ (cons
+ (list
+ 'primitive
+ (car e1076))
+ (map ((lambda (r1080)
+ (lambda (x1081)
+ (cdr (assq
+ (cadr
+ x1081)
+ r1080))))
+ (map cons
+ formals1078
+ actuals1077))
+ (cdr e1076))))
+ (cons
+ 'map
+ (cons
+ (list
+ 'lambda
+ formals1078
+ e1076)
+ actuals1077)))))
+ (map cdr map-env1075)
+ (map (lambda (x1082)
+ (list 'ref (car x1082)))
+ map-env1075))))
+ (gen-cons1044 (lambda (e1071 x1070 y1069 xnew1068
+ ynew1067)
+ ((lambda (t1072)
+ (if (memv t1072 '(quote))
+ (if (eq? (car xnew1068) 'quote)
+ ((lambda (xnew1074
+ ynew1073)
+ (if (if (eq? xnew1074
+ x1070)
+ (eq? ynew1073
+ y1069)
+ '#f)
+ (list 'quote e1071)
+ (list
+ 'quote
+ (cons
+ xnew1074
+ ynew1073))))
+ (cadr xnew1068)
+ (cadr ynew1067))
+ (if (eq? (cadr ynew1067)
+ '())
+ (list 'list xnew1068)
+ (list
+ 'cons
+ xnew1068
+ ynew1067)))
+ (if (memv t1072 '(list))
+ (cons
+ 'list
+ (cons
+ xnew1068
+ (cdr ynew1067)))
+ (list
+ 'cons
+ xnew1068
+ ynew1067))))
+ (car ynew1067))))
+ (gen-vector1045 (lambda (e1066 ls1065 lsnew1064)
+ (if (eq? (car lsnew1064) 'quote)
+ (if (eq? (cadr lsnew1064)
+ ls1065)
+ (list 'quote e1066)
+ (list
+ 'quote
+ (list->vector
+ (cadr lsnew1064))))
+ (if (eq? (car lsnew1064) 'list)
+ (cons
+ 'vector
+ (cdr lsnew1064))
+ (list
+ 'list->vector
+ lsnew1064)))))
+ (regen1046 (lambda (x1061)
+ ((lambda (t1062)
+ (if (memv t1062 '(ref))
+ (cadr x1061)
+ (if (memv t1062 '(primitive))
+ (cadr x1061)
+ (if (memv t1062 '(quote))
+ (list 'quote (cadr x1061))
+ (if (memv t1062 '(lambda))
+ (list
+ 'lambda
+ (cadr x1061)
+ (regen1046
+ (caddr x1061)))
+ (if (memv
+ t1062
+ '(map))
+ ((lambda (ls1063)
+ (cons
+ (if (= (length
+ ls1063)
+ '2)
+ 'map
+ 'map)
+ ls1063))
+ (map regen1046
+ (cdr x1061)))
+ (cons
+ (car x1061)
+ (map regen1046
+ (cdr x1061)))))))))
+ (car x1061)))))
+ (lambda (e1052 r1051 mr1050 w1049 ae1048 m?1047)
+ ((lambda (e1053)
+ ((lambda (tmp1054)
+ ((lambda (tmp1055)
+ (if tmp1055
+ (apply
+ (lambda (_1057 x1056)
+ (call-with-values
+ (lambda ()
+ (gen-syntax1039 e1053 x1056 r1051 '()
+ ellipsis?519 '#f))
+ (lambda (e1059 maps1058)
+ (regen1046 e1059))))
+ tmp1055)
+ ((lambda (_1060) (syntax-error e1053))
+ tmp1054)))
+ ($syntax-dispatch tmp1054 '(any any))))
+ e1053))
+ (source-wrap444 e1052 w1049 ae1048)))))))
+ (global-extend304
+ 'core
+ 'lambda
+ (lambda (e1032 r1031 mr1030 w1029 ae1028 m?1027)
+ ((lambda (tmp1033)
+ ((lambda (tmp1034)
+ (if tmp1034
+ (apply
+ (lambda (_1036 c1035)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-clause516
+ (source-wrap444 e1032 w1029 ae1028) c1035
+ r1031 mr1030 w1029 m?1027))
+ (lambda (vars1038 body1037)
+ (list 'lambda vars1038 body1037))))
+ tmp1034)
+ (syntax-error tmp1033)))
+ ($syntax-dispatch tmp1033 '(any . any))))
+ e1032)))
+ (global-extend304
+ 'core
+ 'letrec
+ (lambda (e1008 r1007 mr1006 w1005 ae1004 m?1003)
+ ((lambda (tmp1009)
+ ((lambda (tmp1010)
+ (if tmp1010
+ (apply
+ (lambda (_1015 id1014 val1013 e11012 e21011)
+ ((lambda (ids1016)
+ (if (not (valid-bound-ids?439 ids1016))
+ (invalid-ids-error441
+ (map (lambda (x1017)
+ (wrap443 x1017 w1005))
+ ids1016)
+ (source-wrap444 e1008 w1005 ae1004)
+ '"bound variable")
+ ((lambda (labels1019 new-vars1018)
+ ((lambda (w1021 r1020)
+ (build-letrec236
+ ae1004
+ new-vars1018
+ (map (lambda (x1024)
+ (chi498 x1024 r1020 mr1006
+ w1021 m?1003))
+ val1013)
+ (chi-body503 (cons e11012 e21011)
+ (source-wrap444
+ e1008
+ w1021
+ ae1004)
+ r1020 mr1006 w1021 m?1003)))
+ (make-binding-wrap417
+ ids1016
+ labels1019
+ w1005)
+ (extend-var-env*297
+ labels1019
+ new-vars1018
+ r1007)))
+ (gen-labels364 ids1016)
+ (map gen-var523 ids1016))))
+ id1014))
+ tmp1010)
+ ((lambda (_1026)
+ (syntax-error (source-wrap444 e1008 w1005 ae1004)))
+ tmp1009)))
+ ($syntax-dispatch
+ tmp1009
+ '(any #(each (any any)) any . each-any))))
+ e1008)))
+ (global-extend304
+ 'core
+ 'if
+ (lambda (e991 r990 mr989 w988 ae987 m?986)
+ ((lambda (tmp992)
+ ((lambda (tmp993)
+ (if tmp993
+ (apply
+ (lambda (_996 test995 then994)
+ (list
+ 'if
+ (chi498 test995 r990 mr989 w988 m?986)
+ (chi498 then994 r990 mr989 w988 m?986)
+ (chi-void518)))
+ tmp993)
+ ((lambda (tmp997)
+ (if tmp997
+ (apply
+ (lambda (_1001 test1000 then999 else998)
+ (list
+ 'if
+ (chi498 test1000 r990 mr989 w988 m?986)
+ (chi498 then999 r990 mr989 w988 m?986)
+ (chi498 else998 r990 mr989 w988 m?986)))
+ tmp997)
+ ((lambda (_1002)
+ (syntax-error
+ (source-wrap444 e991 w988 ae987)))
+ tmp992)))
+ ($syntax-dispatch tmp992 '(any any any any)))))
+ ($syntax-dispatch tmp992 '(any any any))))
+ e991)))
+ (global-extend304 'set! 'set! '())
+ (global-extend304 'alias 'alias '())
+ (global-extend304 'begin 'begin '())
+ (global-extend304 '$module-key '$module '())
+ (global-extend304 '$import '$import '())
+ (global-extend304 'define 'define '())
+ (global-extend304 'define-syntax 'define-syntax '())
+ (global-extend304 'eval-when 'eval-when '())
+ (global-extend304 'meta 'meta '())
+ (global-extend304
+ 'core
+ 'syntax-case
+ ((lambda ()
+ (letrec ((convert-pattern858 (lambda (pattern935 keys934)
+ (letrec ((cvt*936 (lambda (p*981
+ n980
+ ids979)
+ (if (null?
+ p*981)
+ (values
+ '()
+ ids979)
+ (call-with-values
+ (lambda ()
+ (cvt*936
+ (cdr p*981)
+ n980
+ ids979))
+ (lambda (y983
+ ids982)
+ (call-with-values
+ (lambda ()
+ (cvt937
+ (car p*981)
+ n980
+ ids982))
+ (lambda (x985
+ ids984)
+ (values
+ (cons
+ x985
+ y983)
+ ids984))))))))
+ (cvt937 (lambda (p940
+ n939
+ ids938)
+ (if (id?306
+ p940)
+ (if (bound-id-member?442
+ p940
+ keys934)
+ (values
+ (vector
+ 'free-id
+ p940)
+ ids938)
+ (values
+ 'any
+ (cons
+ (cons
+ p940
+ n939)
+ ids938)))
+ ((lambda (tmp941)
+ ((lambda (tmp942)
+ (if (if tmp942
+ (apply
+ (lambda (x944
+ dots943)
+ (ellipsis?519
+ dots943))
+ tmp942)
+ '#f)
+ (apply
+ (lambda (x946
+ dots945)
+ (call-with-values
+ (lambda ()
+ (cvt937
+ x946
+ (+ n939
+ '1)
+ ids938))
+ (lambda (p948
+ ids947)
+ (values
+ (if (eq? p948
+ 'any)
+ 'each-any
+ (vector
+ 'each
+ p948))
+ ids947))))
+ tmp942)
+ ((lambda (tmp949)
+ (if (if tmp949
+ (apply
+ (lambda (x953
+ dots952
+ y951
+ z950)
+ (ellipsis?519
+ dots952))
+ tmp949)
+ '#f)
+ (apply
+ (lambda (x957
+ dots956
+ y955
+ z954)
+ (call-with-values
+ (lambda ()
+ (cvt937
+ z954
+ n939
+ ids938))
+ (lambda (z959
+ ids958)
+ (call-with-values
+ (lambda ()
+ (cvt*936
+ y955
+ n939
+ ids958))
+ (lambda (y961
+ ids960)
+ (call-with-values
+ (lambda ()
+ (cvt937
+ x957
+ (+ n939
+ '1)
+ ids960))
+ (lambda (x963
+ ids962)
+ (values
+ (vector
+ 'each+
+ x963
+ (reverse
+ y961)
+ z959)
+ ids962))))))))
+ tmp949)
+ ((lambda (tmp965)
+ (if tmp965
+ (apply
+ (lambda (x967
+ y966)
+ (call-with-values
+ (lambda ()
+ (cvt937
+ y966
+ n939
+ ids938))
+ (lambda (y969
+ ids968)
+ (call-with-values
+ (lambda ()
+ (cvt937
+ x967
+ n939
+ ids968))
+ (lambda (x971
+ ids970)
+ (values
+ (cons
+ x971
+ y969)
+ ids970))))))
+ tmp965)
+ ((lambda (tmp972)
+ (if tmp972
+ (apply
+ (lambda ()
+ (values
+ '()
+ ids938))
+ tmp972)
+ ((lambda (tmp973)
+ (if tmp973
+ (apply
+ (lambda (x974)
+ (call-with-values
+ (lambda ()
+ (cvt937
+ x974
+ n939
+ ids938))
+ (lambda (p976
+ ids975)
+ (values
+ (vector
+ 'vector
+ p976)
+ ids975))))
+ tmp973)
+ ((lambda (x978)
+ (values
+ (vector
+ 'atom
+ (strip522
+ p940
+ '(())))
+ ids938))
+ tmp941)))
+ ($syntax-dispatch
+ tmp941
+ '#(vector
+ each-any)))))
+ ($syntax-dispatch
+ tmp941
+ '()))))
+ ($syntax-dispatch
+ tmp941
+ '(any .
+ any)))))
+ ($syntax-dispatch
+ tmp941
+ '(any any
+ .
+ #(each+
+ any
+ ()
+ any))))))
+ ($syntax-dispatch
+ tmp941
+ '(any any))))
+ p940)))))
+ (cvt937 pattern935 '0 '()))))
+ (build-dispatch-call859 (lambda (pvars927 exp926 y925
+ r924 mr923 m?922)
+ ((lambda (ids929 levels928)
+ ((lambda (labels931
+ new-vars930)
+ (cons
+ 'apply
+ (list
+ (list
+ 'lambda
+ new-vars930
+ (chi498 exp926
+ (extend-env*296
+ labels931
+ (map (lambda (var933
+ level932)
+ (cons
+ 'syntax
+ (cons
+ var933
+ level932)))
+ new-vars930
+ (map cdr
+ pvars927))
+ r924)
+ mr923
+ (make-binding-wrap417
+ ids929
+ labels931
+ '(()))
+ m?922))
+ y925)))
+ (gen-labels364 ids929)
+ (map gen-var523
+ ids929)))
+ (map car pvars927)
+ (map cdr pvars927))))
+ (gen-clause860 (lambda (x905 keys904 clauses903 r902
+ mr901 m?900 pat899 fender898
+ exp897)
+ (call-with-values
+ (lambda ()
+ (convert-pattern858
+ pat899
+ keys904))
+ (lambda (p907 pvars906)
+ (if (not (distinct-bound-ids?440
+ (map car pvars906)))
+ (invalid-ids-error441
+ (map car pvars906)
+ pat899
+ '"pattern variable")
+ (if (not (andmap
+ (lambda (x908)
+ (not (ellipsis?519
+ (car x908))))
+ pvars906))
+ (syntax-error
+ pat899
+ '"misplaced ellipsis in syntax-case pattern")
+ ((lambda (y909)
+ (cons
+ (list
+ 'lambda
+ (list y909)
+ (list
+ 'if
+ ((lambda (tmp919)
+ ((lambda (tmp920)
+ (if tmp920
+ (apply
+ (lambda ()
+ y909)
+ tmp920)
+ ((lambda (_921)
+ (list
+ 'if
+ y909
+ (build-dispatch-call859
+ pvars906
+ fender898
+ y909
+ r902
+ mr901
+ m?900)
+ (list
+ 'quote
+ '#f)))
+ tmp919)))
+ ($syntax-dispatch
+ tmp919
+ '#(atom
+ #t))))
+ fender898)
+ (build-dispatch-call859
+ pvars906
+ exp897 y909
+ r902 mr901
+ m?900)
+ (gen-syntax-case861
+ x905 keys904
+ clauses903
+ r902 mr901
+ m?900)))
+ (list
+ (if (eq? p907
+ 'any)
+ (cons
+ 'list
+ (list x905))
+ (cons
+ '$syntax-dispatch
+ (list
+ x905
+ (list
+ 'quote
+ p907)))))))
+ (gen-var523
+ 'tmp))))))))
+ (gen-syntax-case861 (lambda (x885 keys884 clauses883
+ r882 mr881 m?880)
+ (if (null? clauses883)
+ (cons
+ 'syntax-error
+ (list x885))
+ ((lambda (tmp886)
+ ((lambda (tmp887)
+ (if tmp887
+ (apply
+ (lambda (pat889
+ exp888)
+ (if (if (id?306
+ pat889)
+ (if (not (bound-id-member?442
+ pat889
+ keys884))
+ (not (ellipsis?519
+ pat889))
+ '#f)
+ '#f)
+ ((lambda (label891
+ var890)
+ (cons
+ (list
+ 'lambda
+ (list
+ var890)
+ (chi498
+ exp888
+ (extend-env295
+ label891
+ (cons
+ 'syntax
+ (cons
+ var890
+ '0))
+ r882)
+ mr881
+ (make-binding-wrap417
+ (list
+ pat889)
+ (list
+ label891)
+ '(()))
+ m?880))
+ (list
+ x885)))
+ (gen-label362)
+ (gen-var523
+ pat889))
+ (gen-clause860
+ x885
+ keys884
+ (cdr clauses883)
+ r882
+ mr881
+ m?880
+ pat889
+ '#t
+ exp888)))
+ tmp887)
+ ((lambda (tmp892)
+ (if tmp892
+ (apply
+ (lambda (pat895
+ fender894
+ exp893)
+ (gen-clause860
+ x885
+ keys884
+ (cdr clauses883)
+ r882
+ mr881
+ m?880
+ pat895
+ fender894
+ exp893))
+ tmp892)
+ ((lambda (_896)
+ (syntax-error
+ (car clauses883)
+ '"invalid syntax-case clause"))
+ tmp886)))
+ ($syntax-dispatch
+ tmp886
+ '(any any
+ any)))))
+ ($syntax-dispatch
+ tmp886
+ '(any any))))
+ (car clauses883))))))
+ (lambda (e867 r866 mr865 w864 ae863 m?862)
+ ((lambda (e868)
+ ((lambda (tmp869)
+ ((lambda (tmp870)
+ (if tmp870
+ (apply
+ (lambda (_874 val873 key872 m871)
+ (if (andmap
+ (lambda (x876)
+ (if (id?306 x876)
+ (not (ellipsis?519 x876))
+ '#f))
+ key872)
+ ((lambda (x877)
+ (cons
+ (list
+ 'lambda
+ (list x877)
+ (gen-syntax-case861 x877 key872
+ m871 r866 mr865 m?862))
+ (list
+ (chi498 val873 r866 mr865 '(())
+ m?862))))
+ (gen-var523 'tmp))
+ (syntax-error
+ e868
+ '"invalid literals list in")))
+ tmp870)
+ (syntax-error tmp869)))
+ ($syntax-dispatch
+ tmp869
+ '(any any each-any . each-any))))
+ e868))
+ (source-wrap444 e867 w864 ae863)))))))
+ (put-cte-hook137
+ 'module
+ (lambda (x827)
+ (letrec ((proper-export?828 (lambda (e851)
+ ((lambda (tmp852)
+ ((lambda (tmp853)
+ (if tmp853
+ (apply
+ (lambda (id855 e854)
+ (if (identifier?
+ id855)
+ (andmap
+ proper-export?828
+ e854)
+ '#f))
+ tmp853)
+ ((lambda (id857)
+ (identifier? id857))
+ tmp852)))
+ ($syntax-dispatch
+ tmp852
+ '(any . each-any))))
+ e851))))
+ ((lambda (tmp829)
+ ((lambda (orig830)
+ ((lambda (tmp831)
+ ((lambda (tmp832)
+ (if tmp832
+ (apply
+ (lambda (_835 e834 d833)
+ (if (andmap proper-export?828 e834)
+ (list
+ '#(syntax-object begin ((top) #(ribcage #(_ e d) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) \ No newline at end of file
+ (cons
+ '#(syntax-object $module ((top) #(ribcage #(_ e d) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (t\ No newline at end of file
+ (cons
+ orig830
+ (cons
+ '#(syntax-object anon ((top) #(ribcage #(_ e d) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (\ No newline at end of file
+ (cons e834 d833))))
+ (cons
+ '#(syntax-object $import ((top) #(ribcage #(_ e d) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (t\ No newline at end of file
+ (cons
+ orig830
+ '#(syntax-object (#f anon) ((top) #(ribcage #(_ e d) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top\ No newline at end of file
+ (syntax-error
+ x827
+ '"invalid exports list in")))
+ tmp832)
+ ((lambda (tmp839)
+ (if (if tmp839
+ (apply
+ (lambda (_843 m842 e841 d840)
+ (identifier? m842))
+ tmp839)
+ '#f)
+ (apply
+ (lambda (_847 m846 e845 d844)
+ (if (andmap proper-export?828 e845)
+ (cons
+ '#(syntax-object $module ((top) #(ribcage #(_ m e d) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (to\ No newline at end of file
+ (cons
+ orig830
+ (cons
+ m846
+ (cons e845 d844))))
+ (syntax-error
+ x827
+ '"invalid exports list in")))
+ tmp839)
+ (syntax-error tmp831)))
+ ($syntax-dispatch
+ tmp831
+ '(any any each-any . each-any)))))
+ ($syntax-dispatch
+ tmp831
+ '(any each-any . each-any))))
+ x827))
+ tmp829))
+ x827))))
+ ((lambda ()
+ (letrec (($module-exports628 (lambda (m819 r818)
+ ((lambda (b820)
+ ((lambda (t821)
+ (if (memv t821 '($module))
+ ((lambda (interface822)
+ ((lambda (new-marks823)
+ ((lambda ()
+ (vmap487
+ (lambda (x824)
+ ((lambda (id825)
+ (make-syntax-object63
+ (syntax-object->datum
+ id825)
+ ((lambda (marks826)
+ (make-wrap315
+ marks826
+ (if (eq? (car marks826)
+ '#f)
+ (cons
+ 'shift
+ (wrap-subst317
+ '((top))))
+ (wrap-subst317
+ '((top))))))
+ (join-marks423
+ new-marks823
+ (wrap-marks316
+ (syntax-object-wrap66
+ id825))))))
+ (if (pair?
+ x824)
+ (car x824)
+ x824)))
+ (interface-exports454
+ interface822)))))
+ (import-mark-delta505
+ m819
+ interface822)))
+ (binding-value282
+ b820))
+ (if (memv
+ t821
+ '(displaced-lexical))
+ (displaced-lexical-error299
+ m819)
+ (syntax-error
+ m819
+ '"unknown module"))))
+ (binding-type281 b820)))
+ (r818 m819))))
+ ($import-help629 (lambda (orig633 import-only?632)
+ (lambda (r634)
+ (letrec ((difference635 (lambda (ls1817
+ ls2816)
+ (if (null?
+ ls1817)
+ ls1817
+ (if (bound-id-member?442
+ (car ls1817)
+ ls2816)
+ (difference635
+ (cdr ls1817)
+ ls2816)
+ (cons
+ (car ls1817)
+ (difference635
+ (cdr ls1817)
+ ls2816))))))
+ (prefix-add636 (lambda (prefix-id813)
+ ((lambda (prefix814)
+ (lambda (id815)
+ (datum->syntax-object
+ id815
+ (string->symbol
+ (string-append
+ prefix814
+ (symbol->string
+ (syntax-object->datum
+ id815)))))))
+ (symbol->string
+ (syntax-object->datum
+ prefix-id813)))))
+ (prefix-drop637 (lambda (prefix-id807)
+ ((lambda (prefix808)
+ (lambda (id809)
+ ((lambda (s810)
+ ((lambda (np812
+ ns811)
+ (begin
+ (if (not (if (>= ns811
+ np812)
+ (string=?
+ (substring
+ s810
+ '0
+ np812)
+ prefix808)
+ '#f))
+ (syntax-error
+ id809
+ (string-append
+ '"missing expected prefix "
+ prefix808))
+ (void))
+ (datum->syntax-object
+ id809
+ (string->symbol
+ (substring
+ s810
+ np812
+ ns811)))))
+ (string-length
+ prefix808)
+ (string-length
+ s810)))
+ (symbol->string
+ (syntax-object->datum
+ id809)))))
+ (symbol->string
+ (syntax-object->datum
+ prefix-id807)))))
+ (gen-mid638 (lambda (mid804)
+ (datum->syntax-object
+ mid804
+ (generate-id143
+ ((lambda (x805)
+ ((lambda (e806)
+ (if (annotation?132
+ e806)
+ (annotation-expression
+ e806)
+ e806))
+ (if (syntax-object?64
+ x805)
+ (syntax-object-expression65
+ x805)
+ x805)))
+ mid804)))))
+ (modspec639 (lambda (m655
+ exports?654)
+ ((lambda (tmp656)
+ ((lambda (tmp657)
+ (if tmp657
+ (apply
+ (lambda (orig659
+ import-only?658)
+ ((lambda (tmp660)
+ ((lambda (tmp661)
+ (if (if tmp661
+ (apply
+ (lambda (m663
+ id662)
+ (andmap
+ identifier?
+ id662))
+ tmp661)
+ '#f)
+ (apply
+ (lambda (m666
+ id665)
+ (call-with-values
+ (lambda ()
+ (modspec639
+ m666
+ '#f))
+ (lambda (mid669
+ d668
+ exports667)
+ ((lambda (tmp670)
+ ((lambda (tmp671)
+ (if tmp671
+ (apply
+ (lambda (d673
+ tmid672)
+ (values
+ mid669
+ (list
+ '#(syntax-object begin ((top) #(ribcage #(d tmid) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-bindin\ No newline at end of file
+ (list
+ '#(syntax-object $module ((top) #(ribcage #(d tmid) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-bi\ No newline at end of file
+ orig659
+ tmid672
+ id665
+ d673)
+ (list
+ '#(syntax-object $import ((top) #(ribcage #(d tmid) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-bi\ No newline at end of file
+ orig659
+ import-only?658
+ tmid672))
+ (if exports?654
+ id665
+ '#f)))
+ tmp671)
+ (syntax-error
+ tmp670)))
+ ($syntax-dispatch
+ tmp670
+ '(any any))))
+ (list
+ d668
+ (gen-mid638
+ mid669))))))
+ tmp661)
+ ((lambda (tmp676)
+ (if (if tmp676
+ (apply
+ (lambda (m678
+ id677)
+ (andmap
+ identifier?
+ id677))
+ tmp676)
+ '#f)
+ (apply
+ (lambda (m681
+ id680)
+ (call-with-values
+ (lambda ()
+ (modspec639
+ m681
+ '#t))
+ (lambda (mid684
+ d683
+ exports682)
+ ((lambda (tmp685)
+ ((lambda (tmp687)
+ (if tmp687
+ (apply
+ (lambda (d690
+ tmid689
+ id688)
+ (values
+ mid684
+ (list
+ '#(syntax-object begin ((top) #(ribcage #(d tmid id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-bindin\ No newline at end of file
+ (list
+ '#(syntax-object $module ((top) #(ribcage #(d tmid id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-bi\ No newline at end of file
+ orig659
+ tmid689
+ id688
+ d690)
+ (list
+ '#(syntax-object $import ((top) #(ribcage #(d tmid id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-bi\ No newline at end of file
+ orig659
+ import-only?658
+ tmid689))
+ (if exports?654
+ id688
+ '#f)))
+ tmp687)
+ (syntax-error
+ tmp685)))
+ ($syntax-dispatch
+ tmp685
+ '(any any
+ each-any))))
+ (list
+ d683
+ (gen-mid638
+ mid684)
+ (difference635
+ exports682
+ id680))))))
+ tmp676)
+ ((lambda (tmp693)
+ (if (if tmp693
+ (apply
+ (lambda (m695
+ prefix-id694)
+ (identifier?
+ prefix-id694))
+ tmp693)
+ '#f)
+ (apply
+ (lambda (m697
+ prefix-id696)
+ (call-with-values
+ (lambda ()
+ (modspec639
+ m697
+ '#t))
+ (lambda (mid700
+ d699
+ exports698)
+ ((lambda (tmp701)
+ ((lambda (tmp702)
+ (if tmp702
+ (apply
+ (lambda (d707
+ tmid706
+ old-id705
+ tmp704
+ id703)
+ (values
+ mid700
+ (list
+ '#(syntax-object begin ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build\ No newline at end of file
+ (cons
+ '#(syntax-object $module ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional b\ No newline at end of file
+ (cons
+ orig659
+ (cons
+ tmid706
+ (cons
+ (map list
+ id703
+ tmp704)
+ (cons
+ (cons
+ '#(syntax-object $module ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-con\ No newline at end of file
+ (cons
+ orig659
+ (cons
+ tmid706
+ (cons
+ (map list
+ tmp704
+ old-id705)
+ (cons
+ d707
+ (map (lambda (tmp714
+ tmp713)
+ (list
+ '#(syntax-object alias ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-refe\ No newline at end of file
+ tmp713
+ tmp714))
+ old-id705
+ tmp704))))))
+ (cons
+ (list
+ '#(syntax-object $import ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-c\ No newline at end of file
+ orig659
+ import-only?658
+ tmid706)
+ (map (lambda (tmp716
+ tmp715)
+ (list
+ '#(syntax-object alias ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference bu\ No newline at end of file
+ tmp715
+ tmp716))
+ tmp704
+ id703)))))))
+ (list
+ '#(syntax-object $import ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional b\ No newline at end of file
+ orig659
+ import-only?658
+ tmid706))
+ (if exports?654
+ id703
+ '#f)))
+ tmp702)
+ (syntax-error
+ tmp701)))
+ ($syntax-dispatch
+ tmp701
+ '(any any
+ each-any
+ each-any
+ each-any))))
+ (list
+ d699
+ (gen-mid638
+ mid700)
+ exports698
+ (generate-temporaries
+ exports698)
+ (map (prefix-add636
+ prefix-id696)
+ exports698))))))
+ tmp693)
+ ((lambda (tmp717)
+ (if (if tmp717
+ (apply
+ (lambda (m719
+ prefix-id718)
+ (identifier?
+ prefix-id718))
+ tmp717)
+ '#f)
+ (apply
+ (lambda (m721
+ prefix-id720)
+ (call-with-values
+ (lambda ()
+ (modspec639
+ m721
+ '#t))
+ (lambda (mid724
+ d723
+ exports722)
+ ((lambda (tmp725)
+ ((lambda (tmp726)
+ (if tmp726
+ (apply
+ (lambda (d731
+ tmid730
+ old-id729
+ tmp728
+ id727)
+ (values
+ mid724
+ (list
+ '#(syntax-object begin ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditiona\ No newline at end of file
+ (cons
+ '#(syntax-object $module ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-condit\ No newline at end of file
+ (cons
+ orig659
+ (cons
+ tmid730
+ (cons
+ (map list
+ id727
+ tmp728)
+ (cons
+ (cons
+ '#(syntax-object $module ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference bu\ No newline at end of file
+ (cons
+ orig659
+ (cons
+ tmid730
+ (cons
+ (map list
+ tmp728
+ old-id729)
+ (cons
+ d731
+ (map (lambda (tmp738
+ tmp737)
+ (list
+ '#(syntax-object alias ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexic\ No newline at end of file
+ tmp737
+ tmp738))
+ old-id729
+ tmp728))))))
+ (cons
+ (list
+ '#(syntax-object $import ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference \ No newline at end of file
+ orig659
+ import-only?658
+ tmid730)
+ (map (lambda (tmp740
+ tmp739)
+ (list
+ '#(syntax-object alias ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-refer\ No newline at end of file
+ tmp739
+ tmp740))
+ tmp728
+ id727)))))))
+ (list
+ '#(syntax-object $import ((top) #(ribcage #(d tmid old-id tmp id) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m prefix-id) #((top) (top)) #("i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-condit\ No newline at end of file
+ orig659
+ import-only?658
+ tmid730))
+ (if exports?654
+ id727
+ '#f)))
+ tmp726)
+ (syntax-error
+ tmp725)))
+ ($syntax-dispatch
+ tmp725
+ '(any any
+ each-any
+ each-any
+ each-any))))
+ (list
+ d723
+ (gen-mid638
+ mid724)
+ exports722
+ (generate-temporaries
+ exports722)
+ (map (prefix-drop637
+ prefix-id720)
+ exports722))))))
+ tmp717)
+ ((lambda (tmp741)
+ (if (if tmp741
+ (apply
+ (lambda (m744
+ new-id743
+ old-id742)
+ (if (andmap
+ identifier?
+ new-id743)
+ (andmap
+ identifier?
+ old-id742)
+ '#f))
+ tmp741)
+ '#f)
+ (apply
+ (lambda (m749
+ new-id748
+ old-id747)
+ (call-with-values
+ (lambda ()
+ (modspec639
+ m749
+ '#t))
+ (lambda (mid752
+ d751
+ exports750)
+ ((lambda (tmp753)
+ ((lambda (tmp756)
+ (if tmp756
+ (apply
+ (lambda (d760
+ tmid759
+ tmp758
+ other-id757)
+ (values
+ mid752
+ (list
+ '#(syntax-object begin ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-\ No newline at end of file
+ (cons
+ '#(syntax-object $module ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference bu\ No newline at end of file
+ (cons
+ orig659
+ (cons
+ tmid759
+ (cons
+ (append
+ (map list
+ new-id748
+ tmp758)
+ other-id757)
+ (cons
+ (cons
+ '#(syntax-object $module ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-re\ No newline at end of file
+ (cons
+ orig659
+ (cons
+ tmid759
+ (cons
+ (append
+ other-id757
+ (map list
+ tmp758
+ old-id747))
+ (cons
+ d760
+ (map (lambda (tmp770
+ tmp769)
+ (list
+ '#(syntax-object alias ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment b\ No newline at end of file
+ tmp769
+ tmp770))
+ old-id747
+ tmp758))))))
+ (cons
+ (list
+ '#(syntax-object $import ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-\ No newline at end of file
+ orig659
+ import-only?658
+ tmid759)
+ (map (lambda (tmp772
+ tmp771)
+ (list
+ '#(syntax-object alias ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lex\ No newline at end of file
+ tmp771
+ tmp772))
+ tmp758
+ new-id748)))))))
+ (list
+ '#(syntax-object $import ((top) #(ribcage #(d tmid tmp other-id) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference bu\ No newline at end of file
+ orig659
+ import-only?658
+ tmid759))
+ (if exports?654
+ (append
+ new-id748
+ other-id757)
+ '#f)))
+ tmp756)
+ (syntax-error
+ tmp753)))
+ ($syntax-dispatch
+ tmp753
+ '(any any
+ each-any
+ each-any))))
+ (list
+ d751
+ (gen-mid638
+ mid752)
+ (generate-temporaries
+ old-id747)
+ (difference635
+ exports750
+ old-id747))))))
+ tmp741)
+ ((lambda (tmp773)
+ (if (if tmp773
+ (apply
+ (lambda (m776
+ new-id775
+ old-id774)
+ (if (andmap
+ identifier?
+ new-id775)
+ (andmap
+ identifier?
+ old-id774)
+ '#f))
+ tmp773)
+ '#f)
+ (apply
+ (lambda (m781
+ new-id780
+ old-id779)
+ (call-with-values
+ (lambda ()
+ (modspec639
+ m781
+ '#t))
+ (lambda (mid784
+ d783
+ exports782)
+ ((lambda (tmp785)
+ ((lambda (tmp786)
+ (if tmp786
+ (apply
+ (lambda (d789
+ tmid788
+ other-id787)
+ (values
+ mid784
+ (list
+ '#(syntax-object begin ((top) #(ribcage #(d tmid other-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditi\ No newline at end of file
+ (cons
+ '#(syntax-object $module ((top) #(ribcage #(d tmid other-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-con\ No newline at end of file
+ (cons
+ orig659
+ (cons
+ tmid788
+ (cons
+ (append
+ (map list
+ new-id780
+ old-id779)
+ other-id787)
+ (cons
+ d789
+ (map (lambda (tmp796
+ tmp795)
+ (list
+ '#(syntax-object alias ((top) #(ribcage #(d tmid other-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-refe\ No newline at end of file
+ tmp795
+ tmp796))
+ old-id779
+ new-id780))))))
+ (list
+ '#(syntax-object $import ((top) #(ribcage #(d tmid other-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(mid d exports) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(m new-id old-id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-con\ No newline at end of file
+ orig659
+ import-only?658
+ tmid788))
+ (if exports?654
+ (append
+ new-id780
+ other-id787)
+ '#f)))
+ tmp786)
+ (syntax-error
+ tmp785)))
+ ($syntax-dispatch
+ tmp785
+ '(any any
+ each-any))))
+ (list
+ d783
+ (gen-mid638
+ mid784)
+ exports782)))))
+ tmp773)
+ ((lambda (tmp797)
+ (if (if tmp797
+ (apply
+ (lambda (mid798)
+ (identifier?
+ mid798))
+ tmp797)
+ '#f)
+ (apply
+ (lambda (mid799)
+ (values
+ mid799
+ (list
+ '#(syntax-object $import ((top) #(ribcage #(mid) #((top)) #("i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-\ No newline at end of file
+ orig659
+ import-only?658
+ mid799)
+ (if exports?654
+ ($module-exports628
+ mid799
+ r634)
+ '#f)))
+ tmp797)
+ ((lambda (tmp800)
+ (if (if tmp800
+ (apply
+ (lambda (mid801)
+ (identifier?
+ mid801))
+ tmp800)
+ '#f)
+ (apply
+ (lambda (mid802)
+ (values
+ mid802
+ (list
+ '#(syntax-object $import ((top) #(ribcage #(mid) #((top)) #("i")) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top\ No newline at end of file
+ orig659
+ import-only?658
+ mid802)
+ (if exports?654
+ ($module-exports628
+ mid802
+ r634)
+ '#f)))
+ tmp800)
+ ((lambda (_803)
+ (syntax-error
+ m655
+ '"invalid module specifier"))
+ tmp660)))
+ ($syntax-dispatch
+ tmp660
+ '(any)))))
+ (list
+ tmp660))))
+ ($syntax-dispatch
+ tmp660
+ '(#(free-id
+ #(syntax-object alias ((top) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook anno\ No newline at end of file
+ any
+ .
+ #(each
+ (any any)))))))
+ ($syntax-dispatch
+ tmp660
+ '(#(free-id
+ #(syntax-object rename ((top) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation\ No newline at end of file
+ any
+ .
+ #(each
+ (any any)))))))
+ ($syntax-dispatch
+ tmp660
+ '(#(free-id
+ #(syntax-object drop-prefix ((top) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? \ No newline at end of file
+ any
+ any)))))
+ ($syntax-dispatch
+ tmp660
+ '(#(free-id
+ #(syntax-object add-prefix ((top) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<\ No newline at end of file
+ any
+ any)))))
+ ($syntax-dispatch
+ tmp660
+ '(#(free-id
+ #(syntax-object except ((top) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< f\ No newline at end of file
+ any
+ .
+ each-any)))))
+ ($syntax-dispatch
+ tmp660
+ '(#(free-id
+ #(syntax-object only ((top) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(m exports?) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx\ No newline at end of file
+ any
+ .
+ each-any))))
+ m655))
+ tmp657)
+ (syntax-error
+ tmp656)))
+ ($syntax-dispatch
+ tmp656
+ '(any any))))
+ (list
+ orig633
+ import-only?632))))
+ (modspec*640 (lambda (m650)
+ (call-with-values
+ (lambda ()
+ (modspec639
+ m650
+ '#f))
+ (lambda (mid653
+ d652
+ exports651)
+ d652)))))
+ ((lambda (tmp641)
+ ((lambda (tmp642)
+ (if tmp642
+ (apply
+ (lambda (_644 m643)
+ ((lambda (tmp645)
+ ((lambda (tmp647)
+ (if tmp647
+ (apply
+ (lambda (d648)
+ (cons
+ '#(syntax-object begin ((top) #(ribcage #(d) #((top)) #("i")) #(ribcage #(_ m) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-obje\ No newline at end of file
+ d648))
+ tmp647)
+ (syntax-error
+ tmp645)))
+ ($syntax-dispatch
+ tmp645
+ 'each-any)))
+ (map modspec*640
+ m643)))
+ tmp642)
+ (syntax-error tmp641)))
+ ($syntax-dispatch
+ tmp641
+ '(any . each-any))))
+ orig633))))))
+ (begin
+ (put-cte-hook137
+ 'import
+ (lambda (orig631) ($import-help629 orig631 '#f)))
+ (put-cte-hook137
+ 'import-only
+ (lambda (orig630) ($import-help629 orig630 '#t)))))))
+ (set! sc-expand
+ ((lambda (ctem625 rtem624)
+ (lambda (x626)
+ ((lambda (env627)
+ (if (if (pair? x626) (equal? (car x626) noexpand62) '#f)
+ (cadr x626)
+ (chi-top*447 x626 '() (env-wrap388 env627) ctem625
+ rtem624 '#f (env-top-ribcage387 env627))))
+ (interaction-environment))))
+ '(e)
+ '(e)))
+ (set! $make-environment
+ (lambda (token622 mutable?621)
+ ((lambda (top-ribcage623)
+ (make-env385
+ top-ribcage623
+ (make-wrap315
+ (wrap-marks316 '((top)))
+ (cons top-ribcage623 (wrap-subst317 '((top)))))))
+ (make-top-ribcage373 token622 mutable?621))))
+ (set! environment? (lambda (x620) (env?386 x620)))
+ (set! interaction-environment
+ ((lambda (e619) (lambda () e619))
+ ($make-environment '*top* '#t)))
+ (set! identifier? (lambda (x618) (nonsymbol-id?305 x618)))
+ (set! datum->syntax-object
+ (lambda (id616 datum615)
+ (begin
+ ((lambda (x617)
+ (if (not (nonsymbol-id?305 x617))
+ (error-hook136
+ 'datum->syntax-object
+ '"invalid argument"
+ x617)
+ (void)))
+ id616)
+ (make-syntax-object63
+ datum615
+ (syntax-object-wrap66 id616)))))
+ (set! syntax->list
+ (lambda (orig-ls606)
+ ((letrec ((f607 (lambda (ls608)
+ ((lambda (tmp609)
+ ((lambda (tmp610)
+ (if tmp610
+ (apply (lambda () '()) tmp610)
+ ((lambda (tmp611)
+ (if tmp611
+ (apply
+ (lambda (x613 r612)
+ (cons x613 (f607 r612)))
+ tmp611)
+ ((lambda (_614)
+ (error 'syntax->list
+ '"invalid argument ~s"
+ orig-ls606))
+ tmp609)))
+ ($syntax-dispatch
+ tmp609
+ '(any . any)))))
+ ($syntax-dispatch tmp609 '())))
+ ls608))))
+ f607)
+ orig-ls606)))
+ (set! syntax->vector
+ (lambda (v600)
+ ((lambda (tmp601)
+ ((lambda (tmp602)
+ (if tmp602
+ (apply
+ (lambda (x603) (apply vector (syntax->list x603)))
+ tmp602)
+ ((lambda (_605)
+ (error 'syntax->vector
+ '"invalid argument ~s"
+ v600))
+ tmp601)))
+ ($syntax-dispatch tmp601 '#(vector each-any))))
+ v600)))
+ (set! syntax-object->datum
+ (lambda (x599) (strip522 x599 '(()))))
+ (set! generate-temporaries
+ ((lambda (n595)
+ (lambda (ls596)
+ (begin
+ ((lambda (x598)
+ (if (not (list? x598))
+ (error-hook136
+ 'generate-temporaries
+ '"invalid argument"
+ x598)
+ (void)))
+ ls596)
+ (map (lambda (x597)
+ (begin
+ (set! n595 (+ n595 '1))
+ (wrap443
+ (string->symbol
+ (string-append '"t" (number->string n595)))
+ '((tmp)))))
+ ls596))))
+ '0))
+ (set! free-identifier=?
+ (lambda (x592 y591)
+ (begin
+ ((lambda (x594)
+ (if (not (nonsymbol-id?305 x594))
+ (error-hook136
+ 'free-identifier=?
+ '"invalid argument"
+ x594)
+ (void)))
+ x592)
+ ((lambda (x593)
+ (if (not (nonsymbol-id?305 x593))
+ (error-hook136
+ 'free-identifier=?
+ '"invalid argument"
+ x593)
+ (void)))
+ y591)
+ (free-id=?435 x592 y591))))
+ (set! bound-identifier=?
+ (lambda (x588 y587)
+ (begin
+ ((lambda (x590)
+ (if (not (nonsymbol-id?305 x590))
+ (error-hook136
+ 'bound-identifier=?
+ '"invalid argument"
+ x590)
+ (void)))
+ x588)
+ ((lambda (x589)
+ (if (not (nonsymbol-id?305 x589))
+ (error-hook136
+ 'bound-identifier=?
+ '"invalid argument"
+ x589)
+ (void)))
+ y587)
+ (bound-id=?438 x588 y587))))
+ (set! literal-identifier=?
+ (lambda (x584 y583)
+ (begin
+ ((lambda (x586)
+ (if (not (nonsymbol-id?305 x586))
+ (error-hook136
+ 'literal-identifier=?
+ '"invalid argument"
+ x586)
+ (void)))
+ x584)
+ ((lambda (x585)
+ (if (not (nonsymbol-id?305 x585))
+ (error-hook136
+ 'literal-identifier=?
+ '"invalid argument"
+ x585)
+ (void)))
+ y583)
+ (literal-id=?436 x584 y583))))
+ (set! syntax-error
+ (lambda (object578 . messages579)
+ (begin
+ (for-each
+ (lambda (x581)
+ ((lambda (x582)
+ (if (not (string? x582))
+ (error-hook136
+ 'syntax-error
+ '"invalid argument"
+ x582)
+ (void)))
+ x581))
+ messages579)
+ ((lambda (message580)
+ (error-hook136 '#f message580 (strip522 object578 '(()))))
+ (if (null? messages579)
+ '"invalid syntax"
+ (apply string-append messages579))))))
+ ((lambda ()
+ (letrec ((match-each525 (lambda (e575 p574 w573)
+ (if (annotation?132 e575)
+ (match-each525
+ (annotation-expression e575)
+ p574
+ w573)
+ (if (pair? e575)
+ ((lambda (first576)
+ (if first576
+ ((lambda (rest577)
+ (if rest577
+ (cons
+ first576
+ rest577)
+ '#f))
+ (match-each525
+ (cdr e575)
+ p574
+ w573))
+ '#f))
+ (match531
+ (car e575)
+ p574
+ w573
+ '()))
+ (if (null? e575)
+ '()
+ (if (syntax-object?64 e575)
+ (match-each525
+ (syntax-object-expression65
+ e575)
+ p574
+ (join-wraps422
+ w573
+ (syntax-object-wrap66
+ e575)))
+ '#f))))))
+ (match-each+526 (lambda (e565 x-pat564 y-pat563 z-pat562
+ w561 r560)
+ ((letrec ((f566 (lambda (e568 w567)
+ (if (pair? e568)
+ (call-with-values
+ (lambda ()
+ (f566
+ (cdr e568)
+ w567))
+ (lambda (xr*571
+ y-pat570
+ r569)
+ (if r569
+ (if (null?
+ y-pat570)
+ ((lambda (xr572)
+ (if xr572
+ (values
+ (cons
+ xr572
+ xr*571)
+ y-pat570
+ r569)
+ (values
+ '#f
+ '#f
+ '#f)))
+ (match531
+ (car e568)
+ x-pat564
+ w567
+ '()))
+ (values
+ '()
+ (cdr y-pat570)
+ (match531
+ (car e568)
+ (car y-pat570)
+ w567
+ r569)))
+ (values
+ '#f
+ '#f
+ '#f))))
+ (if (annotation?132
+ e568)
+ (f566
+ (annotation-expression
+ e568)
+ w567)
+ (if (syntax-object?64
+ e568)
+ (f566
+ (syntax-object-expression65
+ e568)
+ (join-wraps422
+ w567
+ (syntax-object-wrap66
+ e568)))
+ (values
+ '()
+ y-pat563
+ (match531
+ e568
+ z-pat562
+ w567
+ r560))))))))
+ f566)
+ e565
+ w561)))
+ (match-each-any527 (lambda (e558 w557)
+ (if (annotation?132 e558)
+ (match-each-any527
+ (annotation-expression e558)
+ w557)
+ (if (pair? e558)
+ ((lambda (l559)
+ (if l559
+ (cons
+ (wrap443
+ (car e558)
+ w557)
+ l559)
+ '#f))
+ (match-each-any527
+ (cdr e558)
+ w557))
+ (if (null? e558)
+ '()
+ (if (syntax-object?64
+ e558)
+ (match-each-any527
+ (syntax-object-expression65
+ e558)
+ (join-wraps422
+ w557
+ (syntax-object-wrap66
+ e558)))
+ '#f))))))
+ (match-empty528 (lambda (p555 r554)
+ (if (null? p555)
+ r554
+ (if (eq? p555 'any)
+ (cons '() r554)
+ (if (pair? p555)
+ (match-empty528
+ (car p555)
+ (match-empty528
+ (cdr p555)
+ r554))
+ (if (eq? p555 'each-any)
+ (cons '() r554)
+ ((lambda (t556)
+ (if (memv
+ t556
+ '(each))
+ (match-empty528
+ (vector-ref
+ p555
+ '1)
+ r554)
+ (if (memv
+ t556
+ '(each+))
+ (match-empty528
+ (vector-ref
+ p555
+ '1)
+ (match-empty528
+ (reverse
+ (vector-ref
+ p555
+ '2))
+ (match-empty528
+ (vector-ref
+ p555
+ '3)
+ r554)))
+ (if (memv
+ t556
+ '(free-id
+ atom))
+ r554
+ (if (memv
+ t556
+ '(vector))
+ (match-empty528
+ (vector-ref
+ p555
+ '1)
+ r554)
+ (void))))))
+ (vector-ref
+ p555
+ '0))))))))
+ (combine529 (lambda (r*553 r552)
+ (if (null? (car r*553))
+ r552
+ (cons
+ (map car r*553)
+ (combine529
+ (map cdr r*553)
+ r552)))))
+ (match*530 (lambda (e545 p544 w543 r542)
+ (if (null? p544)
+ (if (null? e545) r542 '#f)
+ (if (pair? p544)
+ (if (pair? e545)
+ (match531
+ (car e545)
+ (car p544)
+ w543
+ (match531
+ (cdr e545)
+ (cdr p544)
+ w543
+ r542))
+ '#f)
+ (if (eq? p544 'each-any)
+ ((lambda (l546)
+ (if l546
+ (cons l546 r542)
+ '#f))
+ (match-each-any527
+ e545
+ w543))
+ ((lambda (t547)
+ (if (memv t547 '(each))
+ (if (null? e545)
+ (match-empty528
+ (vector-ref
+ p544
+ '1)
+ r542)
+ ((lambda (r*548)
+ (if r*548
+ (combine529
+ r*548
+ r542)
+ '#f))
+ (match-each525
+ e545
+ (vector-ref
+ p544
+ '1)
+ w543)))
+ (if (memv
+ t547
+ '(free-id))
+ (if (id?306 e545)
+ (if (literal-id=?436
+ (wrap443
+ e545
+ w543)
+ (vector-ref
+ p544
+ '1))
+ r542
+ '#f)
+ '#f)
+ (if (memv
+ t547
+ '(each+))
+ (call-with-values
+ (lambda ()
+ (match-each+526
+ e545
+ (vector-ref
+ p544
+ '1)
+ (vector-ref
+ p544
+ '2)
+ (vector-ref
+ p544
+ '3)
+ w543
+ r542))
+ (lambda (xr*551
+ y-pat550
+ r549)
+ (if r549
+ (if (null?
+ y-pat550)
+ (if (null?
+ xr*551)
+ (match-empty528
+ (vector-ref
+ p544
+ '1)
+ r549)
+ (combine529
+ xr*551
+ r549))
+ '#f)
+ '#f)))
+ (if (memv
+ t547
+ '(atom))
+ (if (equal?
+ (vector-ref
+ p544
+ '1)
+ (strip522
+ e545
+ w543))
+ r542
+ '#f)
+ (if (memv
+ t547
+ '(vector))
+ (if (vector?
+ e545)
+ (match531
+ (vector->list
+ e545)
+ (vector-ref
+ p544
+ '1)
+ w543
+ r542)
+ '#f)
+ (void)))))))
+ (vector-ref p544 '0)))))))
+ (match531 (lambda (e539 p538 w537 r536)
+ (if (not r536)
+ '#f
+ (if (eq? p538 'any)
+ (cons (wrap443 e539 w537) r536)
+ (if (syntax-object?64 e539)
+ (match*530
+ ((lambda (e540)
+ (if (annotation?132 e540)
+ (annotation-expression
+ e540)
+ e540))
+ (syntax-object-expression65
+ e539))
+ p538
+ (join-wraps422
+ w537
+ (syntax-object-wrap66 e539))
+ r536)
+ (match*530
+ ((lambda (e541)
+ (if (annotation?132 e541)
+ (annotation-expression
+ e541)
+ e541))
+ e539)
+ p538
+ w537
+ r536)))))))
+ (set! $syntax-dispatch
+ (lambda (e533 p532)
+ (if (eq? p532 'any)
+ (list e533)
+ (if (syntax-object?64 e533)
+ (match*530
+ ((lambda (e534)
+ (if (annotation?132 e534)
+ (annotation-expression e534)
+ e534))
+ (syntax-object-expression65 e533))
+ p532
+ (syntax-object-wrap66 e533)
+ '())
+ (match*530
+ ((lambda (e535)
+ (if (annotation?132 e535)
+ (annotation-expression e535)
+ e535))
+ e533)
+ p532
+ '(())
+ '()))))))))))))
+($sc-put-cte
+ '#(syntax-object with-syntax ((top) #(ribcage #(with-syntax) #((top)) #(with-syntax))))
+ (lambda (x2531)
+ ((lambda (tmp2532)
+ ((lambda (tmp2533)
+ (if tmp2533
+ (apply
+ (lambda (_2536 e12535 e22534)
+ (cons
+ '#(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons e12535 e22534)))
+ tmp2533)
+ ((lambda (tmp2538)
+ (if tmp2538
+ (apply
+ (lambda (_2543 out2542 in2541 e12540 e22539)
+ (list
+ '#(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")) #(top-ribcage *top* #t)))+ in2541
+ '()
+ (list
+ out2542
+ (cons
+ '#(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons e12540 e22539)))))
+ tmp2538)
+ ((lambda (tmp2545)
+ (if tmp2545
+ (apply
+ (lambda (_2550 out2549 in2548 e12547 e22546)
+ (list
+ '#(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")) #(top-ribcage *top* #t)))+ (cons
+ '#(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ in2548)
+ '()
+ (list
+ out2549
+ (cons
+ '#(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons e12547 e22546)))))
+ tmp2545)
+ (syntax-error tmp2532)))
+ ($syntax-dispatch
+ tmp2532
+ '(any #(each (any any)) any . each-any)))))
+ ($syntax-dispatch
+ tmp2532
+ '(any ((any any)) any . each-any)))))
+ ($syntax-dispatch tmp2532 '(any () any . each-any))))
+ x2531))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object with-implicit ((top) #(ribcage #(with-implicit) #((top)) #(with-implicit))))
+ (lambda (x2554)
+ ((lambda (tmp2555)
+ ((lambda (tmp2556)
+ (if (if tmp2556
+ (apply
+ (lambda (dummy2561 tid2560 id2559 e12558 e22557)
+ (andmap identifier? (cons tid2560 id2559)))
+ tmp2556)
+ '#f)
+ (apply
+ (lambda (dummy2567 tid2566 id2565 e12564 e22563)
+ (list
+ '#(syntax-object begin ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object unless ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object identifier? ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ tid2566))
+ (cons
+ '#(syntax-object syntax-error ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ tid2566)
+ '#(syntax-object ("non-identifier with-implicit template") ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t))))))+ (cons
+ '#(syntax-object with-syntax ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ (map (lambda (tmp2568)
+ (list
+ tmp2568
+ (list
+ '#(syntax-object datum->syntax-object ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ tid2566)
+ (list
+ '#(syntax-object quote ((top) #(ribcage #(dummy tid id e1 e2) #(("m" top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ tmp2568))))
+ id2565)
+ (cons e12564 e22563)))))
+ tmp2556)
+ (syntax-error tmp2555)))
+ ($syntax-dispatch
+ tmp2555
+ '(any (any . each-any) any . each-any))))
+ x2554))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object datum ((top) #(ribcage #(datum) #((top)) #(datum))))
+ (lambda (x2570)
+ ((lambda (tmp2571)
+ ((lambda (tmp2572)
+ (if tmp2572
+ (apply
+ (lambda (dummy2574 x2573)
+ (list
+ '#(syntax-object syntax-object->datum ((top) #(ribcage #(dummy x) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(dummy x) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ x2573)))
+ tmp2572)
+ (syntax-error tmp2571)))
+ ($syntax-dispatch tmp2571 '(any any))))
+ x2570))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object syntax-rules ((top) #(ribcage #(syntax-rules) #((top)) #(syntax-rules))))
+ (lambda (x2575)
+ (letrec ((clause2576 (lambda (y2592)
+ ((lambda (tmp2593)
+ ((lambda (tmp2594)
+ (if tmp2594
+ (apply
+ (lambda (keyword2597 pattern2596
+ template2595)
+ (list
+ (cons
+ '#(syntax-object dummy ((top) #(ribcage #(keyword pattern template) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(y) #((top)) #("i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ pattern2596)
+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(keyword pattern template) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(y) #((top)) #("i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ template2595)))
+ tmp2594)
+ ((lambda (tmp2598)
+ (if tmp2598
+ (apply
+ (lambda (keyword2602
+ pattern2601
+ fender2600
+ template2599)
+ (list
+ (cons
+ '#(syntax-object dummy ((top) #(ribcage #(keyword pattern fender template) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(y) #((top)) #("i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ pattern2601)
+ fender2600
+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(keyword pattern fender template) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(y) #((top)) #("i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ template2599)))
+ tmp2598)
+ ((lambda (_2603)
+ (syntax-error x2575))
+ tmp2593)))
+ ($syntax-dispatch
+ tmp2593
+ '((any . any) any any)))))
+ ($syntax-dispatch
+ tmp2593
+ '((any . any) any))))
+ y2592))))
+ ((lambda (tmp2577)
+ ((lambda (tmp2578)
+ (if (if tmp2578
+ (apply
+ (lambda (_2581 k2580 cl2579)
+ (andmap identifier? k2580))
+ tmp2578)
+ '#f)
+ (apply
+ (lambda (_2585 k2584 cl2583)
+ ((lambda (tmp2586)
+ ((lambda (tmp2588)
+ (if tmp2588
+ (apply
+ (lambda (cl2589)
+ (list
+ '#(syntax-object lambda ((top) #(ribcage #(cl) #((top)) #("i")) #(ribcage #(_ k cl) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object (x) ((top) #(ribcage #(cl) #((top)) #("i")) #(ribcage #(_ k cl) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ '#(syntax-object syntax-case ((top) #(ribcage #(cl) #((top)) #("i")) #(ribcage #(_ k cl) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ '#(syntax-object x ((top) #(ribcage #(cl) #((top)) #("i")) #(ribcage #(_ k cl) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons k2584 cl2589)))))
+ tmp2588)
+ (syntax-error tmp2586)))
+ ($syntax-dispatch tmp2586 'each-any)))
+ (map clause2576 cl2583)))
+ tmp2578)
+ (syntax-error tmp2577)))
+ ($syntax-dispatch tmp2577 '(any each-any . each-any))))
+ x2575)))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object or ((top) #(ribcage #(or) #((top)) #(or))))
+ (lambda (x2604)
+ ((lambda (tmp2605)
+ ((lambda (tmp2606)
+ (if tmp2606
+ (apply
+ (lambda (_2607)
+ '#(syntax-object #f ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ tmp2606)
+ ((lambda (tmp2608)
+ (if tmp2608
+ (apply (lambda (_2610 e2609) e2609) tmp2608)
+ ((lambda (tmp2611)
+ (if tmp2611
+ (apply
+ (lambda (_2615 e12614 e22613 e32612)
+ (list
+ '#(syntax-object let ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ (list
+ '#(syntax-object t ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ e12614))
+ (list
+ '#(syntax-object if ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object t ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object t ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ '#(syntax-object or ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons e22613 e32612)))))
+ tmp2611)
+ (syntax-error tmp2605)))
+ ($syntax-dispatch
+ tmp2605
+ '(any any any . each-any)))))
+ ($syntax-dispatch tmp2605 '(any any)))))
+ ($syntax-dispatch tmp2605 '(any))))
+ x2604))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object and ((top) #(ribcage #(and) #((top)) #(and))))
+ (lambda (x2617)
+ ((lambda (tmp2618)
+ ((lambda (tmp2619)
+ (if tmp2619
+ (apply
+ (lambda (_2623 e12622 e22621 e32620)
+ (cons
+ '#(syntax-object if ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ e12622
+ (cons
+ (cons
+ '#(syntax-object and ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons e22621 e32620))
+ '#(syntax-object (#f) ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))))))+ tmp2619)
+ ((lambda (tmp2625)
+ (if tmp2625
+ (apply (lambda (_2627 e2626) e2626) tmp2625)
+ ((lambda (tmp2628)
+ (if tmp2628
+ (apply
+ (lambda (_2629)
+ '#(syntax-object #t ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ tmp2628)
+ (syntax-error tmp2618)))
+ ($syntax-dispatch tmp2618 '(any)))))
+ ($syntax-dispatch tmp2618 '(any any)))))
+ ($syntax-dispatch tmp2618 '(any any any . each-any))))
+ x2617))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object let ((top) #(ribcage #(let) #((top)) #(let))))
+ (lambda (x2630)
+ ((lambda (tmp2631)
+ ((lambda (tmp2632)
+ (if (if tmp2632
+ (apply
+ (lambda (_2637 x2636 v2635 e12634 e22633)
+ (andmap identifier? x2636))
+ tmp2632)
+ '#f)
+ (apply
+ (lambda (_2643 x2642 v2641 e12640 e22639)
+ (cons
+ (cons
+ '#(syntax-object lambda ((top) #(ribcage #(_ x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons x2642 (cons e12640 e22639)))
+ v2641))
+ tmp2632)
+ ((lambda (tmp2647)
+ (if (if tmp2647
+ (apply
+ (lambda (_2653 f2652 x2651 v2650 e12649 e22648)
+ (andmap identifier? (cons f2652 x2651)))
+ tmp2647)
+ '#f)
+ (apply
+ (lambda (_2660 f2659 x2658 v2657 e12656 e22655)
+ (cons
+ (list
+ '#(syntax-object letrec ((top) #(ribcage #(_ f x v e1 e2) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ (list
+ f2659
+ (cons
+ '#(syntax-object lambda ((top) #(ribcage #(_ f x v e1 e2) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons x2658 (cons e12656 e22655)))))
+ f2659)
+ v2657))
+ tmp2647)
+ (syntax-error tmp2631)))
+ ($syntax-dispatch
+ tmp2631
+ '(any any #(each (any any)) any . each-any)))))
+ ($syntax-dispatch
+ tmp2631
+ '(any #(each (any any)) any . each-any))))
+ x2630))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object let* ((top) #(ribcage #(let*) #((top)) #(let*))))
+ (lambda (x2664)
+ ((lambda (tmp2665)
+ ((lambda (tmp2666)
+ (if (if tmp2666
+ (apply
+ (lambda (let*2671 x2670 v2669 e12668 e22667)
+ (andmap identifier? x2670))
+ tmp2666)
+ '#f)
+ (apply
+ (lambda (let*2677 x2676 v2675 e12674 e22673)
+ ((letrec ((f2678 (lambda (bindings2679)
+ (if (null? bindings2679)
+ (cons
+ '#(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(bindings) #((top)) #("i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons '() (cons e12674 e22673)))
+ ((lambda (tmp2681)
+ ((lambda (tmp2682)
+ (if tmp2682
+ (apply
+ (lambda (body2684
+ binding2683)
+ (list
+ '#(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(bindings) #((top)) #("i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (list binding2683)
+ body2684))
+ tmp2682)
+ (syntax-error tmp2681)))
+ ($syntax-dispatch
+ tmp2681
+ '(any any))))
+ (list
+ (f2678 (cdr bindings2679))
+ (car bindings2679)))))))
+ f2678)
+ (map list x2676 v2675)))
+ tmp2666)
+ (syntax-error tmp2665)))
+ ($syntax-dispatch
+ tmp2665
+ '(any #(each (any any)) any . each-any))))
+ x2664))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object cond ((top) #(ribcage #(cond) #((top)) #(cond))))
+ (lambda (x2687)
+ ((lambda (tmp2688)
+ ((lambda (tmp2689)
+ (if tmp2689
+ (apply
+ (lambda (_2692 m12691 m22690)
+ ((letrec ((f2693 (lambda (clause2695 clauses2694)
+ (if (null? clauses2694)
+ ((lambda (tmp2696)
+ ((lambda (tmp2697)
+ (if tmp2697
+ (apply
+ (lambda (e12699
+ e22698)
+ (cons
+ '#(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ e12699
+ e22698)))
+ tmp2697)
+ ((lambda (tmp2701)
+ (if tmp2701
+ (apply
+ (lambda (e02702)
+ (cons
+ '#(syntax-object let ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ (list
+ (list
+ '#(syntax-object t ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ e02702))
+ '#(syntax-object ((if t t)) ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))))+ tmp2701)
+ ((lambda (tmp2703)
+ (if tmp2703
+ (apply
+ (lambda (e02705
+ e12704)
+ (list
+ '#(syntax-object let ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ (list
+ '#(syntax-object t ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ e02705))
+ (list
+ '#(syntax-object if ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object t ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ e12704
+ '#(syntax-object (t) ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))))))+ tmp2703)
+ ((lambda (tmp2706)
+ (if tmp2706
+ (apply
+ (lambda (e02709
+ e12708
+ e22707)
+ (list
+ '#(syntax-object if ((top) #(ribcage #(e0 e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ e02709
+ (cons
+ '#(syntax-object begin ((top) #(ribcage #(e0 e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ e12708
+ e22707))))
+ tmp2706)
+ ((lambda (_2711)
+ (syntax-error
+ x2687))
+ tmp2696)))
+ ($syntax-dispatch
+ tmp2696
+ '(any any
+ .
+ each-any)))))
+ ($syntax-dispatch
+ tmp2696
+ '(any #(free-id
+ #(syntax-object => ((top) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ any)))))
+ ($syntax-dispatch
+ tmp2696
+ '(any)))))
+ ($syntax-dispatch
+ tmp2696
+ '(#(free-id
+ #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ any
+ .
+ each-any))))
+ clause2695)
+ ((lambda (tmp2712)
+ ((lambda (rest2713)
+ ((lambda (tmp2714)
+ ((lambda (tmp2715)
+ (if tmp2715
+ (apply
+ (lambda (e02716)
+ (list
+ '#(syntax-object let ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ (list
+ '#(syntax-object t ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ e02716))
+ (list
+ '#(syntax-object if ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object t ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object t ((top) #(ribcage #(e0) #((top)) #("i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ rest2713)))
+ tmp2715)
+ ((lambda (tmp2717)
+ (if tmp2717
+ (apply
+ (lambda (e02719
+ e12718)
+ (list
+ '#(syntax-object let ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ (list
+ '#(syntax-object t ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ e02719))
+ (list
+ '#(syntax-object if ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object t ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ e12718
+ '#(syntax-object (t) ((top) #(ribcage #(e0 e1) #((top) (top)) #("i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ rest2713)))
+ tmp2717)
+ ((lambda (tmp2720)
+ (if tmp2720
+ (apply
+ (lambda (e02723
+ e12722
+ e22721)
+ (list
+ '#(syntax-object if ((top) #(ribcage #(e0 e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ e02723
+ (cons
+ '#(syntax-object begin ((top) #(ribcage #(e0 e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ e12722
+ e22721))
+ rest2713))
+ tmp2720)
+ ((lambda (_2725)
+ (syntax-error
+ x2687))
+ tmp2714)))
+ ($syntax-dispatch
+ tmp2714
+ '(any any
+ .
+ each-any)))))
+ ($syntax-dispatch
+ tmp2714
+ '(any #(free-id
+ #(syntax-object => ((top) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ m1 m2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ any)))))
+ ($syntax-dispatch
+ tmp2714
+ '(any))))
+ clause2695))
+ tmp2712))
+ (f2693
+ (car clauses2694)
+ (cdr clauses2694)))))))
+ f2693)
+ m12691
+ m22690))
+ tmp2689)
+ (syntax-error tmp2688)))
+ ($syntax-dispatch tmp2688 '(any any . each-any))))
+ x2687))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object do ((top) #(ribcage #(do) #((top)) #(do))))
+ (lambda (orig-x2727)
+ ((lambda (tmp2728)
+ ((lambda (tmp2729)
+ (if tmp2729
+ (apply
+ (lambda (_2736 var2735 init2734 step2733 e02732 e12731
+ c2730)
+ ((lambda (tmp2737)
+ ((lambda (tmp2747)
+ (if tmp2747
+ (apply
+ (lambda (step2748)
+ ((lambda (tmp2749)
+ ((lambda (tmp2751)
+ (if tmp2751
+ (apply
+ (lambda ()
+ (list
+ '#(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")) #(top-ribcage *top* #t)))+ '#(syntax-object do ((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")) #(top-ribcage *top* #t)))+ (map list var2735 init2734)
+ (list
+ '#(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")) #(top-ribcage *top* #t)))+ (list
+ '#(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")) #(top-ribcage *top* #t)))+ e02732)
+ (cons
+ '#(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")) #(top-ribcage *top* #t)))+ (append
+ c2730
+ (list
+ (cons
+ '#(syntax-object do ((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")) #(top-ribcage *top* #t)))+ step2748)))))))
+ tmp2751)
+ ((lambda (tmp2756)
+ (if tmp2756
+ (apply
+ (lambda (e12758 e22757)
+ (list
+ '#(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")) #(top-ribcage *top* #t)))+ '#(syntax-object do ((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")) #(top-ribcage *top* #t)))+ (map list
+ var2735
+ init2734)
+ (list
+ '#(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")) #(top-ribcage *top* #t)))+ e02732
+ (cons
+ '#(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")) #(top-ribcage *top* #t)))+ (cons
+ e12758
+ e22757))
+ (cons
+ '#(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")) #(top-ribcage *top* #t)))+ (append
+ c2730
+ (list
+ (cons
+ '#(syntax-object do ((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")) #(top-ribcage *top* #t)))+ step2748)))))))
+ tmp2756)
+ (syntax-error tmp2749)))
+ ($syntax-dispatch
+ tmp2749
+ '(any . each-any)))))
+ ($syntax-dispatch tmp2749 '())))
+ e12731))
+ tmp2747)
+ (syntax-error tmp2737)))
+ ($syntax-dispatch tmp2737 'each-any)))
+ (map (lambda (v2741 s2740)
+ ((lambda (tmp2742)
+ ((lambda (tmp2743)
+ (if tmp2743
+ (apply (lambda () v2741) tmp2743)
+ ((lambda (tmp2744)
+ (if tmp2744
+ (apply
+ (lambda (e2745) e2745)
+ tmp2744)
+ ((lambda (_2746)
+ (syntax-error orig-x2727))
+ tmp2742)))
+ ($syntax-dispatch tmp2742 '(any)))))
+ ($syntax-dispatch tmp2742 '())))
+ s2740))
+ var2735
+ step2733)))
+ tmp2729)
+ (syntax-error tmp2728)))
+ ($syntax-dispatch
+ tmp2728
+ '(any #(each (any any . any))
+ (any . each-any)
+ .
+ each-any))))
+ orig-x2727))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object quasiquote ((top) #(ribcage #(quasiquote) #((top)) #(quasiquote))))
+ ((lambda ()
+ (letrec ((quasi2764 (lambda (p2900 lev2899)
+ ((lambda (tmp2901)
+ ((lambda (tmp2902)
+ (if tmp2902
+ (apply
+ (lambda (p2903)
+ (if (= lev2899 '0)
+ (list
+ '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ p2903)
+ (quasicons2766
+ '#(syntax-object ("quote" unquote) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ (quasi2764
+ (list p2903)
+ (- lev2899 '1)))))
+ tmp2902)
+ ((lambda (tmp2904)
+ (if tmp2904
+ (apply
+ (lambda (p2905)
+ (quasicons2766
+ '#(syntax-object ("quote" quasiquote) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ (quasi2764
+ (list p2905)
+ (+ lev2899 '1))))
+ tmp2904)
+ ((lambda (tmp2906)
+ (if tmp2906
+ (apply
+ (lambda (p2908 q2907)
+ ((lambda (tmp2909)
+ ((lambda (tmp2910)
+ (if tmp2910
+ (apply
+ (lambda (p2911)
+ (if (= lev2899
+ '0)
+ (quasilist*2768
+ (map (lambda (tmp2912)
+ (list
+ '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ tmp2912))
+ p2911)
+ (quasi2764
+ q2907
+ lev2899))
+ (quasicons2766
+ (quasicons2766
+ '#(syntax-object ("quote" unquote) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ (quasi2764
+ p2911
+ (- lev2899
+ '1)))
+ (quasi2764
+ q2907
+ lev2899))))
+ tmp2910)
+ ((lambda (tmp2914)
+ (if tmp2914
+ (apply
+ (lambda (p2915)
+ (if (= lev2899
+ '0)
+ (quasiappend2767
+ (map (lambda (tmp2916)
+ (list
+ '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ tmp2916))
+ p2915)
+ (quasi2764
+ q2907
+ lev2899))
+ (quasicons2766
+ (quasicons2766
+ '#(syntax-object ("quote" unquote-splicing) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ (quasi2764
+ p2915
+ (- lev2899
+ '1)))
+ (quasi2764
+ q2907
+ lev2899))))
+ tmp2914)
+ ((lambda (_2918)
+ (quasicons2766
+ (quasi2764
+ p2908
+ lev2899)
+ (quasi2764
+ q2907
+ lev2899)))
+ tmp2909)))
+ ($syntax-dispatch
+ tmp2909
+ '(#(free-id
+ #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))+ .
+ each-any)))))
+ ($syntax-dispatch
+ tmp2909
+ '(#(free-id
+ #(syntax-object unquote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))+ .
+ each-any))))
+ p2908))
+ tmp2906)
+ ((lambda (tmp2919)
+ (if tmp2919
+ (apply
+ (lambda (x2920)
+ (quasivector2769
+ (vquasi2765
+ x2920
+ lev2899)))
+ tmp2919)
+ ((lambda (p2922)
+ (list
+ '#(syntax-object "quote" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ p2922))
+ tmp2901)))
+ ($syntax-dispatch
+ tmp2901
+ '#(vector
+ each-any)))))
+ ($syntax-dispatch
+ tmp2901
+ '(any . any)))))
+ ($syntax-dispatch
+ tmp2901
+ '(#(free-id
+ #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))+ any)))))
+ ($syntax-dispatch
+ tmp2901
+ '(#(free-id
+ #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))+ any))))
+ p2900)))
+ (vquasi2765 (lambda (p2883 lev2882)
+ ((lambda (tmp2884)
+ ((lambda (tmp2885)
+ (if tmp2885
+ (apply
+ (lambda (p2887 q2886)
+ ((lambda (tmp2888)
+ ((lambda (tmp2889)
+ (if tmp2889
+ (apply
+ (lambda (p2890)
+ (if (= lev2882 '0)
+ (quasilist*2768
+ (map (lambda (tmp2891)
+ (list
+ '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ tmp2891))
+ p2890)
+ (vquasi2765
+ q2886
+ lev2882))
+ (quasicons2766
+ (quasicons2766
+ '#(syntax-object ("quote" unquote) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ (quasi2764
+ p2890
+ (- lev2882
+ '1)))
+ (vquasi2765
+ q2886
+ lev2882))))
+ tmp2889)
+ ((lambda (tmp2893)
+ (if tmp2893
+ (apply
+ (lambda (p2894)
+ (if (= lev2882
+ '0)
+ (quasiappend2767
+ (map (lambda (tmp2895)
+ (list
+ '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ tmp2895))
+ p2894)
+ (vquasi2765
+ q2886
+ lev2882))
+ (quasicons2766
+ (quasicons2766
+ '#(syntax-object ("quote" unquote-splicing) ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ (quasi2764
+ p2894
+ (- lev2882
+ '1)))
+ (vquasi2765
+ q2886
+ lev2882))))
+ tmp2893)
+ ((lambda (_2897)
+ (quasicons2766
+ (quasi2764
+ p2887
+ lev2882)
+ (vquasi2765
+ q2886
+ lev2882)))
+ tmp2888)))
+ ($syntax-dispatch
+ tmp2888
+ '(#(free-id
+ #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))+ .
+ each-any)))))
+ ($syntax-dispatch
+ tmp2888
+ '(#(free-id
+ #(syntax-object unquote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))+ .
+ each-any))))
+ p2887))
+ tmp2885)
+ ((lambda (tmp2898)
+ (if tmp2898
+ (apply
+ (lambda ()
+ '#(syntax-object ("quote" ()) ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))))+ tmp2898)
+ (syntax-error tmp2884)))
+ ($syntax-dispatch tmp2884 '()))))
+ ($syntax-dispatch tmp2884 '(any . any))))
+ p2883)))
+ (quasicons2766 (lambda (x2865 y2864)
+ ((lambda (tmp2866)
+ ((lambda (tmp2867)
+ (if tmp2867
+ (apply
+ (lambda (x2869 y2868)
+ ((lambda (tmp2870)
+ ((lambda (tmp2871)
+ (if tmp2871
+ (apply
+ (lambda (dy2872)
+ ((lambda (tmp2873)
+ ((lambda (tmp2874)
+ (if tmp2874
+ (apply
+ (lambda (dx2875)
+ (list
+ '#(syntax-object "quote" ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ (cons
+ dx2875
+ dy2872)))
+ tmp2874)
+ ((lambda (_2876)
+ (if (null?
+ dy2872)
+ (list
+ '#(syntax-object "list" ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ x2869)
+ (list
+ '#(syntax-object "list*" ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ x2869
+ y2868)))
+ tmp2873)))
+ ($syntax-dispatch
+ tmp2873
+ '(#(atom
+ "quote")
+ any))))
+ x2869))
+ tmp2871)
+ ((lambda (tmp2877)
+ (if tmp2877
+ (apply
+ (lambda (stuff2878)
+ (cons
+ '#(syntax-object "list" ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ (cons
+ x2869
+ stuff2878)))
+ tmp2877)
+ ((lambda (tmp2879)
+ (if tmp2879
+ (apply
+ (lambda (stuff2880)
+ (cons
+ '#(syntax-object "list*" ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ (cons
+ x2869
+ stuff2880)))
+ tmp2879)
+ ((lambda (_2881)
+ (list
+ '#(syntax-object "list*" ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ x2869
+ y2868))
+ tmp2870)))
+ ($syntax-dispatch
+ tmp2870
+ '(#(atom
+ "list*")
+ .
+ any)))))
+ ($syntax-dispatch
+ tmp2870
+ '(#(atom "list")
+ .
+ any)))))
+ ($syntax-dispatch
+ tmp2870
+ '(#(atom "quote")
+ any))))
+ y2868))
+ tmp2867)
+ (syntax-error tmp2866)))
+ ($syntax-dispatch tmp2866 '(any any))))
+ (list x2865 y2864))))
+ (quasiappend2767 (lambda (x2851 y2850)
+ ((lambda (tmp2852)
+ ((lambda (tmp2853)
+ (if tmp2853
+ (apply
+ (lambda ()
+ (if (null? x2851)
+ '#(syntax-object ("quote" ()) ((top) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ (if (null? (cdr x2851))
+ (car x2851)
+ ((lambda (tmp2854)
+ ((lambda (tmp2855)
+ (if tmp2855
+ (apply
+ (lambda (p2856)
+ (cons
+ '#(syntax-object "append" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ p2856))
+ tmp2855)
+ (syntax-error
+ tmp2854)))
+ ($syntax-dispatch
+ tmp2854
+ 'each-any)))
+ x2851))))
+ tmp2853)
+ ((lambda (_2858)
+ (if (null? x2851)
+ y2850
+ ((lambda (tmp2859)
+ ((lambda (tmp2860)
+ (if tmp2860
+ (apply
+ (lambda (p2862
+ y2861)
+ (cons
+ '#(syntax-object "append" ((top) #(ribcage #(p y) #((top) (top)) #("i" "i")) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ (append
+ p2862
+ (list
+ y2861))))
+ tmp2860)
+ (syntax-error
+ tmp2859)))
+ ($syntax-dispatch
+ tmp2859
+ '(each-any any))))
+ (list x2851 y2850))))
+ tmp2852)))
+ ($syntax-dispatch
+ tmp2852
+ '(#(atom "quote") ()))))
+ y2850)))
+ (quasilist*2768 (lambda (x2847 y2846)
+ ((letrec ((f2848 (lambda (x2849)
+ (if (null? x2849)
+ y2846
+ (quasicons2766
+ (car x2849)
+ (f2848
+ (cdr x2849)))))))
+ f2848)
+ x2847)))
+ (quasivector2769 (lambda (x2817)
+ ((lambda (tmp2818)
+ ((lambda (tmp2819)
+ (if tmp2819
+ (apply
+ (lambda (x2820)
+ (list
+ '#(syntax-object "quote" ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ (list->vector x2820)))
+ tmp2819)
+ ((lambda (_2822)
+ ((letrec ((f2823 (lambda (y2825
+ k2824)
+ ((lambda (tmp2826)
+ ((lambda (tmp2827)
+ (if tmp2827
+ (apply
+ (lambda (y2828)
+ (k2824
+ (map (lambda (tmp2829)
+ (list
+ '#(syntax-object "quote" ((top) #(ribcage #(y) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(y k) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ tmp2829))
+ y2828)))
+ tmp2827)
+ ((lambda (tmp2830)
+ (if tmp2830
+ (apply
+ (lambda (y2831)
+ (k2824
+ y2831))
+ tmp2830)
+ ((lambda (tmp2833)
+ (if tmp2833
+ (apply
+ (lambda (y2835
+ z2834)
+ (f2823
+ z2834
+ (lambda (ls2836)
+ (k2824
+ (append
+ y2835
+ ls2836)))))
+ tmp2833)
+ ((lambda (else2838)
+ ((lambda (tmp2839)
+ ((lambda (t72840)
+ (list
+ '#(syntax-object "list->vector" ((top) #(ribcage #(t7) #(("m" tmp)) #("i")) #(ribcage #(else) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(y k) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ t72840))
+ tmp2839))
+ x2817))
+ tmp2826)))
+ ($syntax-dispatch
+ tmp2826
+ '(#(atom
+ "list*")
+ .
+ #(each+
+ any
+ (any)
+ ()))))))
+ ($syntax-dispatch
+ tmp2826
+ '(#(atom
+ "list")
+ .
+ each-any)))))
+ ($syntax-dispatch
+ tmp2826
+ '(#(atom
+ "quote")
+ each-any))))
+ y2825))))
+ f2823)
+ x2817
+ (lambda (ls2841)
+ ((lambda (tmp2842)
+ ((lambda (tmp2843)
+ (if tmp2843
+ (apply
+ (lambda (t82844)
+ (cons
+ '#(syntax-object "vector" ((top) #(ribcage #(t8) #(("m" tmp)) #("i")) #(ribcage () () ()) #(ribcage #(ls) #((top)) #("i")) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ t82844))
+ tmp2843)
+ (syntax-error
+ tmp2842)))
+ ($syntax-dispatch
+ tmp2842
+ 'each-any)))
+ ls2841))))
+ tmp2818)))
+ ($syntax-dispatch
+ tmp2818
+ '(#(atom "quote") each-any))))
+ x2817)))
+ (emit2770 (lambda (x2776)
+ ((lambda (tmp2777)
+ ((lambda (tmp2778)
+ (if tmp2778
+ (apply
+ (lambda (x2779)
+ (list
+ '#(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ x2779))
+ tmp2778)
+ ((lambda (tmp2780)
+ (if tmp2780
+ (apply
+ (lambda (x2781)
+ ((lambda (tmp2782)
+ ((lambda (tmp2784)
+ (if tmp2784
+ (apply
+ (lambda (t12785)
+ (cons
+ '#(syntax-object list ((top) #(ribcage #(t1) #(("m" tmp)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ t12785))
+ tmp2784)
+ (syntax-error
+ tmp2782)))
+ ($syntax-dispatch
+ tmp2782
+ 'each-any)))
+ (map emit2770 x2781)))
+ tmp2780)
+ ((lambda (tmp2787)
+ (if tmp2787
+ (apply
+ (lambda (x2789 y2788)
+ ((letrec ((f2790 (lambda (x*2791)
+ (if (null?
+ x*2791)
+ (emit2770
+ y2788)
+ ((lambda (tmp2792)
+ ((lambda (tmp2793)
+ (if tmp2793
+ (apply
+ (lambda (t32795
+ t22794)
+ (list
+ '#(syntax-object cons ((top) #(ribcage #(t3 t2) #(("m" tmp) ("m" tmp)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x*) #((top)) #("i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ t32795
+ t22794))
+ tmp2793)
+ (syntax-error
+ tmp2792)))
+ ($syntax-dispatch
+ tmp2792
+ '(any any))))
+ (list
+ (emit2770
+ (car x*2791))
+ (f2790
+ (cdr x*2791))))))))
+ f2790)
+ x2789))
+ tmp2787)
+ ((lambda (tmp2797)
+ (if tmp2797
+ (apply
+ (lambda (x2798)
+ ((lambda (tmp2799)
+ ((lambda (tmp2801)
+ (if tmp2801
+ (apply
+ (lambda (t42802)
+ (cons
+ '#(syntax-object append ((top) #(ribcage #(t4) #(("m" tmp)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ t42802))
+ tmp2801)
+ (syntax-error
+ tmp2799)))
+ ($syntax-dispatch
+ tmp2799
+ 'each-any)))
+ (map emit2770
+ x2798)))
+ tmp2797)
+ ((lambda (tmp2804)
+ (if tmp2804
+ (apply
+ (lambda (x2805)
+ ((lambda (tmp2806)
+ ((lambda (tmp2808)
+ (if tmp2808
+ (apply
+ (lambda (t52809)
+ (cons
+ '#(syntax-object vector ((top) #(ribcage #(t5) #(("m" tmp)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ t52809))
+ tmp2808)
+ (syntax-error
+ tmp2806)))
+ ($syntax-dispatch
+ tmp2806
+ 'each-any)))
+ (map emit2770
+ x2805)))
+ tmp2804)
+ ((lambda (tmp2811)
+ (if tmp2811
+ (apply
+ (lambda (x2812)
+ ((lambda (tmp2813)
+ ((lambda (t62814)
+ (list
+ '#(syntax-object list->vector ((top) #(ribcage #(t6) #(("m" tmp)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))+ t62814))
+ tmp2813))
+ (emit2770
+ x2812)))
+ tmp2811)
+ ((lambda (tmp2815)
+ (if tmp2815
+ (apply
+ (lambda (x2816)
+ x2816)
+ tmp2815)
+ (syntax-error
+ tmp2777)))
+ ($syntax-dispatch
+ tmp2777
+ '(#(atom
+ "value")
+ any)))))
+ ($syntax-dispatch
+ tmp2777
+ '(#(atom
+ "list->vector")
+ any)))))
+ ($syntax-dispatch
+ tmp2777
+ '(#(atom
+ "vector")
+ .
+ each-any)))))
+ ($syntax-dispatch
+ tmp2777
+ '(#(atom "append")
+ .
+ each-any)))))
+ ($syntax-dispatch
+ tmp2777
+ '(#(atom "list*")
+ .
+ #(each+ any (any)
+ ()))))))
+ ($syntax-dispatch
+ tmp2777
+ '(#(atom "list") . each-any)))))
+ ($syntax-dispatch
+ tmp2777
+ '(#(atom "quote") any))))
+ x2776))))
+ (lambda (x2771)
+ ((lambda (tmp2772)
+ ((lambda (tmp2773)
+ (if tmp2773
+ (apply
+ (lambda (_2775 e2774) (emit2770 (quasi2764 e2774 '0)))
+ tmp2773)
+ (syntax-error tmp2772)))
+ ($syntax-dispatch tmp2772 '(any any))))
+ x2771)))))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object unquote ((top) #(ribcage #(unquote) #((top)) #(unquote))))
+ (lambda (x2923) (syntax-error x2923 '"misplaced"))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object unquote-splicing ((top) #(ribcage #(unquote-splicing) #((top)) #(unquote-splicing))))
+ (lambda (x2924) (syntax-error x2924 '"misplaced"))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object quasisyntax ((top) #(ribcage #(quasisyntax) #((top)) #(quasisyntax))))
+ (lambda (x2925)
+ (letrec ((qs2926 (lambda (q2977 n2976 b*2975 k2974)
+ ((lambda (tmp2978)
+ ((lambda (tmp2979)
+ (if tmp2979
+ (apply
+ (lambda (d2980)
+ (qs2926
+ d2980
+ (+ n2976 '1)
+ b*2975
+ (lambda (b*2982 dnew2981)
+ (k2974
+ b*2982
+ (if (eq? dnew2981 d2980)
+ q2977
+ ((lambda (tmp2983)
+ ((lambda (d2984)
+ (cons
+ '#(syntax-object quasisyntax ((top) #(ribcage #(d) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* dnew) #((top) (top)) #("i" "i")) #(ribcage #(d) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ d2984))
+ tmp2983))
+ dnew2981))))))
+ tmp2979)
+ ((lambda (tmp2985)
+ (if (if tmp2985
+ (apply
+ (lambda (d2986)
+ (not (= n2976 '0)))
+ tmp2985)
+ '#f)
+ (apply
+ (lambda (d2987)
+ (qs2926
+ d2987
+ (- n2976 '1)
+ b*2975
+ (lambda (b*2989 dnew2988)
+ (k2974
+ b*2989
+ (if (eq? dnew2988 d2987)
+ q2977
+ ((lambda (tmp2990)
+ ((lambda (d2991)
+ (cons
+ '#(syntax-object unsyntax ((top) #(ribcage #(d) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* dnew) #((top) (top)) #("i" "i")) #(ribcage #(d) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ d2991))
+ tmp2990))
+ dnew2988))))))
+ tmp2985)
+ ((lambda (tmp2992)
+ (if (if tmp2992
+ (apply
+ (lambda (d2993)
+ (not (= n2976 '0)))
+ tmp2992)
+ '#f)
+ (apply
+ (lambda (d2994)
+ (qs2926
+ d2994
+ (- n2976 '1)
+ b*2975
+ (lambda (b*2996
+ dnew2995)
+ (k2974
+ b*2996
+ (if (eq? dnew2995
+ d2994)
+ q2977
+ ((lambda (tmp2997)
+ ((lambda (d2998)
+ (cons
+ '#(syntax-object unsyntax-splicing ((top) #(ribcage #(d) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* dnew) #((top) (top)) #("i" "i")) #(ribcage #(d) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ d2998))
+ tmp2997))
+ dnew2995))))))
+ tmp2992)
+ ((lambda (tmp2999)
+ (if (if tmp2999
+ (apply
+ (lambda (q3000)
+ (= n2976 '0))
+ tmp2999)
+ '#f)
+ (apply
+ (lambda (q3001)
+ ((lambda (tmp3002)
+ ((lambda (tmp3003)
+ (if tmp3003
+ (apply
+ (lambda (t3004)
+ (k2974
+ (cons
+ (list
+ t3004
+ q3001)
+ b*2975)
+ t3004))
+ tmp3003)
+ (syntax-error
+ tmp3002)))
+ ($syntax-dispatch
+ tmp3002
+ '(any))))
+ (generate-temporaries
+ (list
+ q3001))))
+ tmp2999)
+ ((lambda (tmp3005)
+ (if (if tmp3005
+ (apply
+ (lambda (q3007
+ d3006)
+ (= n2976
+ '0))
+ tmp3005)
+ '#f)
+ (apply
+ (lambda (q3009
+ d3008)
+ (qs2926
+ d3008
+ n2976
+ b*2975
+ (lambda (b*3011
+ dnew3010)
+ ((lambda (tmp3012)
+ ((lambda (tmp3014)
+ (if tmp3014
+ (apply
+ (lambda (t3015)
+ (k2974
+ (append
+ (map list
+ t3015
+ q3009)
+ b*3011)
+ ((lambda (tmp3016)
+ ((lambda (d3017)
+ (append
+ t3015
+ d3017))
+ tmp3016))
+ dnew3010)))
+ tmp3014)
+ (syntax-error
+ tmp3012)))
+ ($syntax-dispatch
+ tmp3012
+ 'each-any)))
+ (generate-temporaries
+ q3009)))))
+ tmp3005)
+ ((lambda (tmp3021)
+ (if (if tmp3021
+ (apply
+ (lambda (q3023
+ d3022)
+ (= n2976
+ '0))
+ tmp3021)
+ '#f)
+ (apply
+ (lambda (q3025
+ d3024)
+ (qs2926
+ d3024
+ n2976
+ b*2975
+ (lambda (b*3027
+ dnew3026)
+ ((lambda (tmp3028)
+ ((lambda (tmp3030)
+ (if tmp3030
+ (apply
+ (lambda (t3031)
+ (k2974
+ (append
+ (map (lambda (tmp3041
+ tmp3040)
+ (list
+ (cons
+ tmp3040
+ '(#(syntax-object ... ((top) #(ribcage #(t) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* dnew) #((top) (top)) #("i" "i")) #(ribcage #(q d) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))))+ tmp3041))
+ q3025
+ t3031)
+ b*3027)
+ ((lambda (tmp3032)
+ ((lambda (tmp3034)
+ (if tmp3034
+ (apply
+ (lambda (m3035)
+ ((lambda (tmp3036)
+ ((lambda (d3037)
+ (append
+ (apply
+ append
+ m3035)
+ d3037))
+ tmp3036))
+ dnew3026))
+ tmp3034)
+ (syntax-error
+ tmp3032)))
+ ($syntax-dispatch
+ tmp3032
+ '#(each
+ each-any))))
+ (map (lambda (tmp3033)
+ (cons
+ tmp3033
+ '(#(syntax-object ... ((top) #(ribcage #(t) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* dnew) #((top) (top)) #("i" "i")) #(ribcage #(q d) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))))+ t3031))))
+ tmp3030)
+ (syntax-error
+ tmp3028)))
+ ($syntax-dispatch
+ tmp3028
+ 'each-any)))
+ (generate-temporaries
+ q3025)))))
+ tmp3021)
+ ((lambda (tmp3042)
+ (if tmp3042
+ (apply
+ (lambda (a3044
+ d3043)
+ (qs2926
+ a3044
+ n2976
+ b*2975
+ (lambda (b*3046
+ anew3045)
+ (qs2926
+ d3043
+ n2976
+ b*3046
+ (lambda (b*3048
+ dnew3047)
+ (k2974
+ b*3048
+ (if (if (eq? anew3045
+ a3044)
+ (eq? dnew3047
+ d3043)
+ '#f)
+ q2977
+ ((lambda (tmp3049)
+ ((lambda (tmp3050)
+ (if tmp3050
+ (apply
+ (lambda (a3052
+ d3051)
+ (cons
+ a3052
+ d3051))
+ tmp3050)
+ (syntax-error
+ tmp3049)))
+ ($syntax-dispatch
+ tmp3049
+ '(any any))))
+ (list
+ anew3045
+ dnew3047)))))))))
+ tmp3042)
+ ((lambda (tmp3053)
+ (if tmp3053
+ (apply
+ (lambda (x3054)
+ (vqs2927
+ x3054
+ n2976
+ b*2975
+ (lambda (b*3056
+ xnew*3055)
+ (k2974
+ b*3056
+ (if ((letrec ((same?3057 (lambda (x*3059
+ xnew*3058)
+ (if (null?
+ x*3059)
+ (null?
+ xnew*3058)
+ (if (not (null?
+ xnew*3058))
+ (if (eq? (car x*3059)
+ (car xnew*3058))
+ (same?3057
+ (cdr x*3059)
+ (cdr xnew*3058))
+ '#f)
+ '#f)))))
+ same?3057)
+ x3054
+ xnew*3055)
+ q2977
+ ((lambda (tmp3061)
+ ((lambda (tmp3062)
+ (if tmp3062
+ (apply
+ (lambda (x3063)
+ (list->vector
+ x3063))
+ tmp3062)
+ (syntax-error
+ tmp3061)))
+ ($syntax-dispatch
+ tmp3061
+ 'each-any)))
+ xnew*3055))))))
+ tmp3053)
+ ((lambda (_3066)
+ (k2974
+ b*2975
+ q2977))
+ tmp2978)))
+ ($syntax-dispatch
+ tmp2978
+ '#(vector
+ each-any)))))
+ ($syntax-dispatch
+ tmp2978
+ '(any .
+ any)))))
+ ($syntax-dispatch
+ tmp2978
+ '((#(free-id
+ #(syntax-object unsyntax-splicing ((top) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ .
+ each-any)
+ .
+ any)))))
+ ($syntax-dispatch
+ tmp2978
+ '((#(free-id
+ #(syntax-object unsyntax ((top) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ .
+ each-any)
+ .
+ any)))))
+ ($syntax-dispatch
+ tmp2978
+ '(#(free-id
+ #(syntax-object unsyntax ((top) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ any)))))
+ ($syntax-dispatch
+ tmp2978
+ '(#(free-id
+ #(syntax-object unsyntax-splicing ((top) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ .
+ any)))))
+ ($syntax-dispatch
+ tmp2978
+ '(#(free-id
+ #(syntax-object unsyntax ((top) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ .
+ any)))))
+ ($syntax-dispatch
+ tmp2978
+ '(#(free-id
+ #(syntax-object quasisyntax ((top) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ .
+ any))))
+ q2977)))
+ (vqs2927 (lambda (x*2942 n2941 b*2940 k2939)
+ (if (null? x*2942)
+ (k2939 b*2940 '())
+ (vqs2927
+ (cdr x*2942)
+ n2941
+ b*2940
+ (lambda (b*2944 xnew*2943)
+ ((lambda (tmp2945)
+ ((lambda (tmp2946)
+ (if (if tmp2946
+ (apply
+ (lambda (q2947)
+ (= n2941 '0))
+ tmp2946)
+ '#f)
+ (apply
+ (lambda (q2948)
+ ((lambda (tmp2949)
+ ((lambda (tmp2951)
+ (if tmp2951
+ (apply
+ (lambda (t2952)
+ (k2939
+ (append
+ (map list
+ t2952
+ q2948)
+ b*2944)
+ (append
+ t2952
+ xnew*2943)))
+ tmp2951)
+ (syntax-error
+ tmp2949)))
+ ($syntax-dispatch
+ tmp2949
+ 'each-any)))
+ (generate-temporaries
+ q2948)))
+ tmp2946)
+ ((lambda (tmp2956)
+ (if (if tmp2956
+ (apply
+ (lambda (q2957)
+ (= n2941 '0))
+ tmp2956)
+ '#f)
+ (apply
+ (lambda (q2958)
+ ((lambda (tmp2959)
+ ((lambda (tmp2961)
+ (if tmp2961
+ (apply
+ (lambda (t2962)
+ (k2939
+ (append
+ (map (lambda (tmp2970
+ tmp2969)
+ (list
+ (cons
+ tmp2969
+ '(#(syntax-object ... ((top) #(ribcage #(t) #((top)) #("i")) #(ribcage #(q) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* xnew*) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x* n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))))+ tmp2970))
+ q2958
+ t2962)
+ b*2944)
+ ((lambda (tmp2963)
+ ((lambda (tmp2965)
+ (if tmp2965
+ (apply
+ (lambda (m2966)
+ (append
+ (apply
+ append
+ m2966)
+ xnew*2943))
+ tmp2965)
+ (syntax-error
+ tmp2963)))
+ ($syntax-dispatch
+ tmp2963
+ '#(each
+ each-any))))
+ (map (lambda (tmp2964)
+ (cons
+ tmp2964
+ '(#(syntax-object ... ((top) #(ribcage #(t) #((top)) #("i")) #(ribcage #(q) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* xnew*) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x* n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))))+ t2962))))
+ tmp2961)
+ (syntax-error
+ tmp2959)))
+ ($syntax-dispatch
+ tmp2959
+ 'each-any)))
+ (generate-temporaries
+ q2958)))
+ tmp2956)
+ ((lambda (_2971)
+ (qs2926
+ (car x*2942)
+ n2941
+ b*2944
+ (lambda (b*2973
+ xnew2972)
+ (k2939
+ b*2973
+ (cons
+ xnew2972
+ xnew*2943)))))
+ tmp2945)))
+ ($syntax-dispatch
+ tmp2945
+ '(#(free-id
+ #(syntax-object unsyntax-splicing ((top) #(ribcage () () ()) #(ribcage #(b* xnew*) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x* n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ .
+ each-any)))))
+ ($syntax-dispatch
+ tmp2945
+ '(#(free-id
+ #(syntax-object unsyntax ((top) #(ribcage () () ()) #(ribcage #(b* xnew*) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x* n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ .
+ each-any))))
+ (car x*2942))))))))
+ ((lambda (tmp2928)
+ ((lambda (tmp2929)
+ (if tmp2929
+ (apply
+ (lambda (_2931 x2930)
+ (qs2926
+ x2930
+ '0
+ '()
+ (lambda (b*2933 xnew2932)
+ (if (eq? xnew2932 x2930)
+ (list
+ '#(syntax-object syntax ((top) #(ribcage () () ()) #(ribcage #(b* xnew) #((top) (top)) #("i" "i")) #(ribcage #(_ x) #((top) (top)) #("i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ x2930)
+ ((lambda (tmp2934)
+ ((lambda (tmp2935)
+ (if tmp2935
+ (apply
+ (lambda (b2937 x2936)
+ (list
+ '#(syntax-object with-syntax ((top) #(ribcage #(b x) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(b* xnew) #((top) (top)) #("i" "i")) #(ribcage #(_ x) #((top) (top)) #("i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ b2937
+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(b x) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(b* xnew) #((top) (top)) #("i" "i")) #(ribcage #(_ x) #((top) (top)) #("i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ x2936)))
+ tmp2935)
+ (syntax-error tmp2934)))
+ ($syntax-dispatch
+ tmp2934
+ '(each-any any))))
+ (list b*2933 xnew2932))))))
+ tmp2929)
+ (syntax-error tmp2928)))
+ ($syntax-dispatch tmp2928 '(any any))))
+ x2925)))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object unsyntax ((top) #(ribcage #(unsyntax) #((top)) #(unsyntax))))
+ (lambda (x3067) (syntax-error x3067 '"misplaced"))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object unsyntax-splicing ((top) #(ribcage #(unsyntax-splicing) #((top)) #(unsyntax-splicing))))
+ (lambda (x3068) (syntax-error x3068 '"misplaced"))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object include ((top) #(ribcage #(include) #((top)) #(include))))
+ (lambda (x3069)
+ (letrec ((read-file3070 (lambda (fn3081 k3080)
+ ((lambda (p3082)
+ ((letrec ((f3083 (lambda ()
+ ((lambda (x3084)
+ (if (eof-object?
+ x3084)
+ (begin
+ (close-input-port
+ p3082)
+ '())
+ (cons
+ (datum->syntax-object
+ k3080
+ x3084)
+ (f3083))))
+ (read p3082)))))
+ f3083)))
+ (open-input-file fn3081)))))
+ ((lambda (tmp3071)
+ ((lambda (tmp3072)
+ (if tmp3072
+ (apply
+ (lambda (k3074 filename3073)
+ ((lambda (fn3075)
+ ((lambda (tmp3076)
+ ((lambda (tmp3077)
+ (if tmp3077
+ (apply
+ (lambda (exp3078)
+ (cons
+ '#(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ exp3078))
+ tmp3077)
+ (syntax-error tmp3076)))
+ ($syntax-dispatch tmp3076 'each-any)))
+ (read-file3070 fn3075 k3074)))
+ (syntax-object->datum filename3073)))
+ tmp3072)
+ (syntax-error tmp3071)))
+ ($syntax-dispatch tmp3071 '(any any))))
+ x3069)))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object case ((top) #(ribcage #(case) #((top)) #(case))))
+ (lambda (x3085)
+ ((lambda (tmp3086)
+ ((lambda (tmp3087)
+ (if tmp3087
+ (apply
+ (lambda (_3091 e3090 m13089 m23088)
+ ((lambda (tmp3092)
+ ((lambda (body3119)
+ (list
+ '#(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")) #(top-ribcage *top* #t)))+ (list
+ (list
+ '#(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")) #(top-ribcage *top* #t)))+ e3090))
+ body3119))
+ tmp3092))
+ ((letrec ((f3093 (lambda (clause3095 clauses3094)
+ (if (null? clauses3094)
+ ((lambda (tmp3096)
+ ((lambda (tmp3097)
+ (if tmp3097
+ (apply
+ (lambda (e13099
+ e23098)
+ (cons
+ '#(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ e13099
+ e23098)))
+ tmp3097)
+ ((lambda (tmp3101)
+ (if tmp3101
+ (apply
+ (lambda (k3104
+ e13103
+ e23102)
+ (list
+ '#(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ k3104))
+ (cons
+ '#(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ e13103
+ e23102))))
+ tmp3101)
+ ((lambda (_3107)
+ (syntax-error
+ x3085))
+ tmp3096)))
+ ($syntax-dispatch
+ tmp3096
+ '(each-any
+ any
+ .
+ each-any)))))
+ ($syntax-dispatch
+ tmp3096
+ '(#(free-id
+ #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))))+ any
+ .
+ each-any))))
+ clause3095)
+ ((lambda (tmp3108)
+ ((lambda (rest3109)
+ ((lambda (tmp3110)
+ ((lambda (tmp3111)
+ (if tmp3111
+ (apply
+ (lambda (k3114
+ e13113
+ e23112)
+ (list
+ '#(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ k3114))
+ (cons
+ '#(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(clause clauses) #((top) (top)) #("i" "i")) #(ribcage #(f) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ e13113
+ e23112))
+ rest3109))
+ tmp3111)
+ ((lambda (_3117)
+ (syntax-error
+ x3085))
+ tmp3110)))
+ ($syntax-dispatch
+ tmp3110
+ '(each-any
+ any
+ .
+ each-any))))
+ clause3095))
+ tmp3108))
+ (f3093
+ (car clauses3094)
+ (cdr clauses3094)))))))
+ f3093)
+ m13089
+ m23088)))
+ tmp3087)
+ (syntax-error tmp3086)))
+ ($syntax-dispatch tmp3086 '(any any any . each-any))))
+ x3085))
+ '*top*)
+($sc-put-cte
+ '#(syntax-object identifier-syntax ((top) #(ribcage #(identifier-syntax) #((top)) #(identifier-syntax))))
+ (lambda (x3120)
+ ((lambda (tmp3121)
+ ((lambda (tmp3122)
+ (if tmp3122
+ (apply
+ (lambda (dummy3124 e3123)
+ (list
+ '#(syntax-object lambda ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object (x) ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object syntax-case ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object x ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ '()
+ (list
+ '#(syntax-object id ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object (identifier? (syntax id)) ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ e3123))
+ (list
+ '(#(syntax-object _ ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ #(syntax-object x ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ #(syntax-object ... ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t))))+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ e3123
+ '(#(syntax-object x ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ #(syntax-object ... ((top) #(ribcage #(dummy e) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t))))))))))+ tmp3122)
+ ((lambda (tmp3125)
+ (if (if tmp3125
+ (apply
+ (lambda (dummy3131 id3130 exp13129 var3128
+ val3127 exp23126)
+ (if (identifier? id3130)
+ (identifier? var3128)
+ '#f))
+ tmp3125)
+ '#f)
+ (apply
+ (lambda (dummy3137 id3136 exp13135 var3134 val3133
+ exp23132)
+ (list
+ '#(syntax-object cons ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object (quote macro!) ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object lambda ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object (x) ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object syntax-case ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object x ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ '#(syntax-object (set!) ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ (list
+ '#(syntax-object set! ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ var3134
+ val3133)
+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ exp23132))
+ (list
+ (cons
+ id3136
+ '(#(syntax-object x ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ #(syntax-object ... ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))))+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (cons
+ exp13135
+ '(#(syntax-object x ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ #(syntax-object ... ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))))))+ (list
+ id3136
+ (list
+ '#(syntax-object identifier? ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ id3136))
+ (list
+ '#(syntax-object syntax ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t)))+ exp13135))))))
+ tmp3125)
+ (syntax-error tmp3121)))
+ ($syntax-dispatch
+ tmp3121
+ '(any (any any)
+ ((#(free-id
+ #(syntax-object set! ((top) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t))))+ any
+ any)
+ any))))))
+ ($syntax-dispatch tmp3121 '(any any))))
+ x3120))
+ '*top*)
--- /dev/null
+++ b/lib/psyntax.ss
@@ -1,0 +1,4295 @@
+;;; Portable implementation of syntax-case
+;;; Extracted from Chez Scheme Version 7.3 (Feb 26, 2007)
+;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
+
+;;; Copyright (c) 1992-2002 Cadence Research Systems
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright notice in full. This software
+;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
+;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
+;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
+;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
+;;; NATURE WHATSOEVER.
+
+;;; Before attempting to port this code to a new implementation of
+;;; Scheme, please read the notes below carefully.
+
+;;; This file defines the syntax-case expander, sc-expand, and a set
+;;; of associated syntactic forms and procedures. Of these, the
+;;; following are documented in The Scheme Programming Language,
+;;; Third Edition (R. Kent Dybvig, MIT Press, 2003), which can be
+;;; found online at http://www.scheme.com/tspl3/. Most are also documented
+;;; in the R4RS and draft R5RS.
+;;;
+;;; bound-identifier=?
+;;; datum->syntax-object
+;;; define-syntax
+;;; fluid-let-syntax
+;;; free-identifier=?
+;;; generate-temporaries
+;;; identifier?
+;;; identifier-syntax
+;;; let-syntax
+;;; letrec-syntax
+;;; syntax
+;;; syntax-case
+;;; syntax-object->datum
+;;; syntax-rules
+;;; with-syntax
+;;;
+;;; All standard Scheme syntactic forms are supported by the expander
+;;; or syntactic abstractions defined in this file. Only the R4RS
+;;; delay is omitted, since its expansion is implementation-dependent.
+
+;;; Also defined are three forms that support modules: module, import,
+;;; and import-only. These are documented in the Chez Scheme User's
+;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
+;;; also be found online at http://www.scheme.com/csug/. They are
+;;; described briefly here as well.
+
+;;; All are definitions and may appear where and only where other
+;;; definitions may appear. modules may be named:
+;;;
+;;; (module id (ex ...) defn ... init ...)
+;;;
+;;; or anonymous:
+;;;
+;;; (module (ex ...) defn ... init ...)
+;;;
+;;; The latter form is semantically equivalent to:
+;;;
+;;; (module T (ex ...) defn ... init ...)
+;;; (import T)
+;;;
+;;; where T is a fresh identifier.
+;;;
+;;; In either form, each of the exports in (ex ...) is either an
+;;; identifier or of the form (id ex ...). In the former case, the
+;;; single identifier ex is exported. In the latter, the identifier
+;;; id is exported and the exports ex ... are "implicitly" exported.
+;;; This listing of implicit exports is useful only when id is a
+;;; keyword bound to a transformer that expands into references to
+;;; the listed implicit exports. In the present implementation,
+;;; listing of implicit exports is necessary only for top-level
+;;; modules and allows the implementation to avoid placing all
+;;; identifiers into the top-level environment where subsequent passes
+;;; of the compiler will be unable to deal effectively with them.
+;;;
+;;; Named modules may be referenced in import statements, which
+;;; always take one of the forms:
+;;;
+;;; (import id)
+;;; (import-only id)
+;;;
+;;; id must name a module. Each exported identifier becomes visible
+;;; within the scope of the import form. In the case of import-only,
+;;; all other identifiers become invisible in the scope of the
+;;; import-only form, except for those established by definitions
+;;; that appear textually after the import-only form.
+
+;;; import and import-only also support a variety of identifier
+;;; selection and renaming forms: only, except, add-prefix,
+;;; drop-prefix, rename, and alias.
+;;;
+;;; (import (only m x y))
+;;;
+;;; imports x and y (and nothing else) from m.
+;;;
+;;; (import (except m x y))
+;;;
+;;; imports all of m's imports except for x and y.
+;;;
+;;; (import (add-prefix (only m x y) m:))
+;;;
+;;; imports x and y as m:x and m:y.
+;;;
+;;; (import (drop-prefix m foo:))
+;;;
+;;; imports all of m's imports, dropping the common foo: prefix
+;;; (which must appear on all of m's exports).
+;;;
+;;; (import (rename (except m a b) (m-c c) (m-d d)))
+;;;
+;;; imports all of m's imports except for x and y, renaming c
+;;; m-c and d m-d.
+;;;
+;;; (import (alias (except m a b) (m-c c) (m-d d)))
+;;;
+;;; imports all of m's imports except for x and y, with additional
+;;; aliases m-c for c and m-d for d.
+;;;
+;;; multiple imports may be specified with one import form:
+;;;
+;;; (import (except m1 x) (only m2 x))
+;;;
+;;; imports all of m1's exports except for x plus x from m2.
+
+;;; Another form, meta, may be used as a prefix for any definition and
+;;; causes any resulting variable bindings to be created at expansion
+;;; time. Meta variables (variables defined using meta) are available
+;;; only at expansion time. Meta definitions are often used to create
+;;; data and helpers that can be shared by multiple macros, for example:
+
+;;; (module (alpha beta)
+;;; (meta define key-error
+;;; (lambda (key)
+;;; (syntax-error key "invalid key")))
+;;; (meta define parse-keys
+;;; (lambda (keys)
+;;; (let f ((keys keys) (c #'white) (s 10))
+;;; (syntax-case keys (color size)
+;;; (() (list c s))
+;;; (((color c) . keys) (f #'keys #'c s))
+;;; (((size s) . keys) (f #'keys c #'s))
+;;; ((k . keys) (key-error #'k))))))
+;;; (define-syntax alpha
+;;; (lambda (x)
+;;; (syntax-case x ()
+;;; ((_ (k ...) <other stuff>)
+;;; (with-syntax (((c s) (parse-keys (syntax (k ...)))))
+;;; ---)))))
+;;; (define-syntax beta
+;;; (lambda (x)
+;;; (syntax-case x ()
+;;; ((_ (k ...) <other stuff>)
+;;; (with-syntax (((c s) (parse-keys (syntax (k ...)))))
+;;; ---))))))
+
+;;; As with define-syntax rhs expressions, meta expressions can evaluate
+;;; references only to identifiers whose values are (already) available
+;;; in the compile-time environment, e.g., macros and meta variables.
+;;; They can, however, like define-syntax rhs expressions, build syntax
+;;; objects containing occurrences of any identifiers in their scope.
+
+;;; meta definitions propagate through macro expansion, so one can write,
+;;; for example:
+;;;
+;;; (module (a)
+;;; (meta define-structure (foo x))
+;;; (define-syntax a
+;;; (let ((q (make-foo (syntax 'q))))
+;;; (lambda (x)
+;;; (foo-x q)))))
+;;; a -> q
+;;;
+;;; where define-record is a macro that expands into a set of defines.
+;;;
+;;; It is also sometimes convenient to write
+;;;
+;;; (meta begin defn ...)
+;;;
+;;; or
+;;;
+;;; (meta module {exports} defn ...)+;;;
+;;; to create groups of meta bindings.
+
+;;; Another form, alias, is used to create aliases from one identifier
+;;; to another. This is used primarily to support the extended import
+;;; syntaxes (add-prefix, drop-prefix, rename, and alias).
+
+;;; (let ((x 3)) (alias y x) y) -> 3
+
+;;; The remaining exports are listed below. sc-expand, eval-when, and
+;;; syntax-error are described in the Chez Scheme User's Guide.
+;;;
+;;; (sc-expand datum)
+;;; if datum represents a valid expression, sc-expand returns an
+;;; expanded version of datum in a core language that includes no
+;;; syntactic abstractions. The core language includes begin,
+;;; define, if, lambda, letrec, quote, and set!.
+;;; (eval-when situations expr ...)
+;;; conditionally evaluates expr ... at compile-time or run-time
+;;; depending upon situations
+;;; (syntax-error object message)
+;;; used to report errors found during expansion
+;;; ($syntax-dispatch e p)
+;;; used by expanded code to handle syntax-case matching
+;;; ($sc-put-cte symbol val top-token)
+;;; used to establish top-level compile-time (expand-time) bindings.
+
+;;; The following nonstandard procedures must be provided by the
+;;; implementation for this code to run.
+;;;
+;;; (void)
+;;; returns the implementation's cannonical "unspecified value". The
+;;; following usually works:
+;;;
+;;; (define void (lambda () (if #f #f))).
+;;;
+;;; (andmap proc list1 list2 ...)
+;;; returns true if proc returns true when applied to each element of list1
+;;; along with the corresponding elements of list2 .... The following
+;;; definition works but does no error checking:
+;;;
+;;; (define andmap
+;;; (lambda (f first . rest)
+;;; (or (null? first)
+;;; (if (null? rest)
+;;; (let andmap ((first first))
+;;; (let ((x (car first)) (first (cdr first)))
+;;; (if (null? first)
+;;; (f x)
+;;; (and (f x) (andmap first)))))
+;;; (let andmap ((first first) (rest rest))
+;;; (let ((x (car first))
+;;; (xr (map car rest))
+;;; (first (cdr first))
+;;; (rest (map cdr rest)))
+;;; (if (null? first)
+;;; (apply f (cons x xr))
+;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
+;;;
+;;; (ormap proc list1)
+;;; returns the first non-false return result of proc applied to
+;;; the elements of list1 or false if none. The following definition
+;;; works but does no error checking:
+;;;
+;;; (define ormap
+;;; (lambda (proc list1)
+;;; (and (not (null? list1))
+;;; (or (proc (car list1)) (ormap proc (cdr list1))))))
+;;;
+;;; The following nonstandard procedures must also be provided by the
+;;; implementation for this code to run using the standard portable
+;;; hooks and output constructors. They are not used by expanded code,
+;;; and so need be present only at expansion time.
+;;;
+;;; (eval x)
+;;; where x is always in the form ("noexpand" expr).+;;; returns the value of expr. the "noexpand" flag is used to tell the
+;;; evaluator/expander that no expansion is necessary, since expr has
+;;; already been fully expanded to core forms.
+;;;
+;;; eval will not be invoked during the loading of psyntax.pp. After
+;;; psyntax.pp has been loaded, the expansion of any macro definition,
+;;; whether local or global, results in a call to eval. If, however,
+;;; sc-expand has already been registered as the expander to be used
+;;; by eval, and eval accepts one argument, nothing special must be done
+;;; to support the "noexpand" flag, since it is handled by sc-expand.
+;;;
+;;; (error who format-string why what)
+;;; where who is either a symbol or #f, format-string is always "~a ~s",
+;;; why is always a string, and what may be any object. error should
+;;; signal an error with a message something like
+;;;
+;;; "error in <who>: <why> <what>"
+;;;
+;;; (gensym)
+;;; returns a unique symbol each time it's called. In Chez Scheme, gensym
+;;; returns a symbol with a "globally" unique name so that gensyms that
+;;; end up in the object code of separately compiled files cannot conflict.
+;;; This is necessary only if you intend to support compiled files.
+;;;
+;;; (gensym? x)
+;;; returns #t if x is a gensym, otherwise false.
+;;;
+;;; (putprop symbol key value)
+;;; (getprop symbol key)
+;;; (remprop symbol key)
+;;; key is always a symbol; value may be any object. putprop should
+;;; associate the given value with the given symbol and key in some way
+;;; that it can be retrieved later with getprop. getprop should return
+;;; #f if no value is associated with the given symbol and key. remprop
+;;; should remove the association between the given symbol and key.
+
+;;; When porting to a new Scheme implementation, you should define the
+;;; procedures listed above, load the expanded version of psyntax.ss
+;;; (psyntax.pp, which should be available whereever you found
+;;; psyntax.ss), and register sc-expand as the current expander (how
+;;; you do this depends upon your implementation of Scheme). You may
+;;; change the hooks and constructors defined toward the beginning of
+;;; the code below, but to avoid bootstrapping problems, do so only
+;;; after you have a working version of the expander.
+
+;;; Chez Scheme allows the syntactic form (syntax <template>) to be
+;;; abbreviated to #'<template>, just as (quote <datum>) may be
+;;; abbreviated to '<datum>. The #' syntax makes programs written
+;;; using syntax-case shorter and more readable and draws out the
+;;; intuitive connection between syntax and quote. If you have access
+;;; to the source code of your Scheme system's reader, you might want
+;;; to implement this extension.
+
+;;; If you find that this code loads or runs slowly, consider
+;;; switching to faster hardware or a faster implementation of
+;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
+;;; compiling (with full optimization), and loading this file takes
+;;; between one and two seconds.
+
+;;; In the expander implementation, we sometimes use syntactic abstractions
+;;; when procedural abstractions would suffice. For example, we define
+;;; top-wrap and top-marked? as
+;;; (define-syntax top-wrap (identifier-syntax '((top))))
+;;; (define-syntax top-marked?
+;;; (syntax-rules ()
+;;; ((_ w) (memq 'top (wrap-marks w)))))
+;;; rather than
+;;; (define top-wrap '((top)))
+;;; (define top-marked?
+;;; (lambda (w) (memq 'top (wrap-marks w))))
+;;; On ther other hand, we don't do this consistently; we define make-wrap,
+;;; wrap-marks, and wrap-subst simply as
+;;; (define make-wrap cons)
+;;; (define wrap-marks car)
+;;; (define wrap-subst cdr)
+;;; In Chez Scheme, the syntactic and procedural forms of these
+;;; abstractions are equivalent, since the optimizer consistently
+;;; integrates constants and small procedures. Some Scheme
+;;; implementations, however, may benefit from more consistent use
+;;; of one form or the other.
+
+
+;;; Implementation notes:
+
+;;; "begin" is treated as a splicing construct at top level and at
+;;; the beginning of bodies. Any sequence of expressions that would
+;;; be allowed where the "begin" occurs is allowed.
+
+;;; "let-syntax" and "letrec-syntax" are also treated as splicing
+;;; constructs, in violation of the R5RS. A consequence is that let-syntax
+;;; and letrec-syntax do not create local contours, as do let and letrec.
+;;; Although the functionality is greater as it is presently implemented,
+;;; we will probably change it to conform to the R5RS. modules provide
+;;; similar functionality to nonsplicing letrec-syntax when the latter is
+;;; used as a definition.
+
+;;; Objects with no standard print syntax, including objects containing
+;;; cycles and syntax objects, are allowed in quoted data as long as they
+;;; are contained within a syntax form or produced by datum->syntax-object.
+;;; Such objects are never copied.
+
+;;; When the expander encounters a reference to an identifier that has
+;;; no global or lexical binding, it treats it as a global-variable
+;;; reference. This allows one to write mutually recursive top-level
+;;; definitions, e.g.:
+;;;
+;;; (define f (lambda (x) (g x)))
+;;; (define g (lambda (x) (f x)))
+;;;
+;;; but may not always yield the intended when the variable in question
+;;; is later defined as a keyword.
+
+;;; Top-level variable definitions of syntax keywords are permitted.
+;;; In order to make this work, top-level define not only produces a
+;;; top-level definition in the core language, but also modifies the
+;;; compile-time environment (using $sc-put-cte) to record the fact
+;;; that the identifier is a variable.
+
+;;; Top-level definitions of macro-introduced identifiers are visible
+;;; only in code produced by the macro. That is, a binding for a
+;;; hidden (generated) identifier is created instead, and subsequent
+;;; references within the macro output are renamed accordingly. For
+;;; example:
+;;;
+;;; (define-syntax a
+;;; (syntax-rules ()
+;;; ((_ var exp)
+;;; (begin
+;;; (define secret exp)
+;;; (define var
+;;; (lambda ()
+;;; (set! secret (+ secret 17))
+;;; secret))))))
+;;; (a x 0)
+;;; (x) => 17
+;;; (x) => 34
+;;; secret => Error: variable secret is not bound
+;;;
+;;; The definition above would fail if the definition for secret
+;;; were placed after the definition for var, since the expander would
+;;; encounter the references to secret before the definition that
+;;; establishes the compile-time map from the identifier secret to
+;;; the generated identifier.
+
+;;; Identifiers and syntax objects are implemented as vectors for
+;;; portability. As a result, it is possible to "forge" syntax
+;;; objects.
+
+;;; The input to sc-expand may contain "annotations" describing, e.g., the
+;;; source file and character position from where each object was read if
+;;; it was read from a file. These annotations are handled properly by
+;;; sc-expand only if the annotation? hook (see hooks below) is implemented
+;;; properly and the operators annotation-expression and annotation-stripped
+;;; are supplied. If annotations are supplied, the proper annotated
+;;; expression is passed to the various output constructors, allowing
+;;; implementations to accurately correlate source and expanded code.
+;;; Contact one of the authors for details if you wish to make use of
+;;; this feature.
+
+;;; Implementation of modules:
+;;;
+;;; The implementation of modules requires that implicit top-level exports
+;;; be listed with the exported macro at some level where both are visible,
+;;; e.g.,
+;;;
+;;; (module M (alpha (beta b))
+;;; (module ((alpha a) b)
+;;; (define-syntax alpha (identifier-syntax a))
+;;; (define a 'a)
+;;; (define b 'b))
+;;; (define-syntax beta (identifier-syntax b)))
+;;;
+;;; Listing of implicit imports is not needed for macros that do not make
+;;; it out to top level, including all macros that are local to a "body".
+;;; (They may be listed in this case, however.) We need this information
+;;; for top-level modules since a top-level module expands into a letrec
+;;; for non-top-level variables and top-level definitions (assignments) for
+;;; top-level variables. Because of the general nature of macro
+;;; transformers, we cannot determine the set of implicit exports from the
+;;; transformer code, so without the user's help, we'd have to put all
+;;; variables at top level.
+;;;
+;;; Each such top-level identifier is given a generated name (gensym).
+;;; When a top-level module is imported at top level, a compile-time
+;;; alias is established from the top-level name to the generated name.
+;;; The expander follows these aliases transparently. When any module is
+;;; imported anywhere other than at top level, the id-var-name of the
+;;; import identifier is set to the id-var-name of the export identifier.
+;;; Since we can't determine the actual labels for identifiers defined in
+;;; top-level modules until we determine which are placed in the letrec
+;;; and which make it to top level, we give each an "indirect" label---a
+;;; pair whose car will eventually contain the actual label. Import does
+;;; not follow the indirect, but id-var-name does.
+;;;
+;;; All identifiers defined within a local module are folded into the
+;;; letrec created for the enclosing body. Visibility is controlled in
+;;; this case and for nested top-level modules by introducing a new wrap
+;;; for each module.
+
+
+;;; Bootstrapping:
+
+;;; When changing syntax-object representations, it is necessary to support
+;;; both old and new syntax-object representations in id-var-name. It
+;;; should be sufficient to redefine syntax-object-expression to work for
+;;; both old and new representations and syntax-object-wrap to return the
+;;; empty-wrap for old representations.
+
+
+;;; The following set of definitions establishes bindings for the
+;;; top-level variables assigned values in the let expression below.
+;;; Uncomment them here and copy them to the front of psyntax.pp if
+;;; required by your system.
+
+; (define $sc-put-cte #f)
+; (define sc-expand #f)
+; (define $make-environment #f)
+; (define environment? #f)
+; (define interaction-environment #f)
+; (define identifier? #f)
+; (define syntax->list #f)
+; (define syntax-object->datum #f)
+; (define datum->syntax-object #f)
+; (define generate-temporaries #f)
+; (define free-identifier=? #f)
+; (define bound-identifier=? #f)
+; (define literal-identifier=? #f)
+; (define syntax-error #f)
+; (define $syntax-dispatch #f)
+
+(let ()
+
+(define-syntax when
+ (syntax-rules ()
+ ((_ test e1 e2 ...) (if test (begin e1 e2 ...)))))
+(define-syntax unless
+ (syntax-rules ()
+ ((_ test e1 e2 ...) (when (not test) (begin e1 e2 ...)))))
+(define-syntax define-structure
+ (lambda (x)
+ (define construct-name
+ (lambda (template-identifier . args)
+ (datum->syntax-object
+ template-identifier
+ (string->symbol
+ (apply string-append
+ (map (lambda (x)
+ (if (string? x)
+ x
+ (symbol->string (syntax-object->datum x))))
+ args))))))
+ (syntax-case x ()
+ ((_ (name id1 ...))
+ (andmap identifier? (syntax (name id1 ...)))
+ (with-syntax
+ ((constructor (construct-name (syntax name) "make-" (syntax name)))
+ (predicate (construct-name (syntax name) (syntax name) "?"))
+ ((access ...)
+ (map (lambda (x) (construct-name x (syntax name) "-" x))
+ (syntax (id1 ...))))
+ ((assign ...)
+ (map (lambda (x)
+ (construct-name x "set-" (syntax name) "-" x "!"))
+ (syntax (id1 ...))))
+ (structure-length
+ (+ (length (syntax (id1 ...))) 1))
+ ((index ...)
+ (let f ((i 1) (ids (syntax (id1 ...))))
+ (if (null? ids)
+ '()
+ (cons i (f (+ i 1) (cdr ids)))))))
+ (syntax (begin
+ (define constructor
+ (lambda (id1 ...)
+ (vector 'name id1 ... )))
+ (define predicate
+ (lambda (x)
+ (and (vector? x)
+ (= (vector-length x) structure-length)
+ (eq? (vector-ref x 0) 'name))))
+ (define access
+ (lambda (x)
+ (vector-ref x index)))
+ ...
+ (define assign
+ (lambda (x update)
+ (vector-set! x index update)))
+ ...)))))))
+
+(define-syntax let-values ; impoverished one-clause version
+ (syntax-rules ()
+ ((_ ((formals expr)) form1 form2 ...)
+ (call-with-values (lambda () expr) (lambda formals form1 form2 ...)))))
+
+(define noexpand "noexpand")
+
+(define-structure (syntax-object expression wrap))
+
+;;; hooks to nonportable run-time helpers
+(begin
+(define-syntax fx+ (identifier-syntax +))
+(define-syntax fx- (identifier-syntax -))
+(define-syntax fx= (identifier-syntax =))
+(define-syntax fx< (identifier-syntax <))
+(define-syntax fx> (identifier-syntax >))
+(define-syntax fx<= (identifier-syntax <=))
+(define-syntax fx>= (identifier-syntax >=))
+
+(define annotation? (lambda (x) #f))
+
+; top-level-eval-hook is used to create "permanent" code (e.g., top-level
+; transformers), so it might be a good idea to compile it
+(define top-level-eval-hook
+ (lambda (x)
+ (eval `(,noexpand ,x))))
+
+; local-eval-hook is used to create "temporary" code (e.g., local
+; transformers), so it might be a good idea to interpret it
+(define local-eval-hook
+ (lambda (x)
+ (eval `(,noexpand ,x))))
+
+(define define-top-level-value-hook
+ (lambda (sym val)
+ (top-level-eval-hook
+ (build-global-definition no-source sym
+ (build-data no-source val)))))
+
+(define error-hook
+ (lambda (who why what)
+ (error who "~a ~s" why what)))
+
+(define put-cte-hook
+ (lambda (symbol val)
+ ($sc-put-cte symbol val '*top*)))
+
+(define get-global-definition-hook
+ (lambda (symbol)
+ (getprop symbol '*sc-expander*)))
+
+(define put-global-definition-hook
+ (lambda (symbol x)
+ (if (not x)
+ (remprop symbol '*sc-expander*)
+ (putprop symbol '*sc-expander* x))))
+
+; if you treat certain bindings (say from environments like ieee or r5rs)
+; read-only, this should return #t for those bindings
+(define read-only-binding?
+ (lambda (symbol)
+ #f))
+
+; should return #f if symbol has no binding for token
+(define get-import-binding
+ (lambda (symbol token)
+ (getprop symbol token)))
+
+; remove binding if x is false
+(define update-import-binding!
+ (lambda (symbol token p)
+ (let ((x (p (get-import-binding symbol token))))
+ (if (not x)
+ (remprop symbol token)
+ (putprop symbol token x)))))
+
+;;; generate-id ideally produces globally unique symbols, i.e., symbols
+;;; unique across system runs, to support separate compilation/expansion.
+;;; Use gensyms if you do not need to support separate compilation/
+;;; expansion or if your system's gensym creates globally unique
+;;; symbols (as in Chez Scheme). Otherwise, use the following code
+;;; as a starting point. session-key should be a unique string for each
+;;; system run to support separate compilation; the default value given
+;;; is satisfactory during initial development only.
+(define generate-id
+ (let ((digits "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?~_^.+-"))
+ (let ((base (string-length digits)) (session-key "_"))
+ (define make-digit (lambda (x) (string-ref digits x)))
+ (define fmt
+ (lambda (n)
+ (let fmt ((n n) (a '()))
+ (if (< n base)
+ (list->string (cons (make-digit n) a))
+ (let ((r (modulo n base)) (rest (quotient n base)))
+ (fmt rest (cons (make-digit r) a)))))))
+ (let ((n -1))
+ (lambda (name) ; name is #f or a symbol
+ (set! n (+ n 1))
+ (string->symbol (string-append session-key (fmt n))))))))
+)
+
+
+
+;;; output constructors
+(begin
+(define-syntax build-application
+ (syntax-rules ()
+ ((_ ae fun-exp arg-exps)
+ `(,fun-exp . ,arg-exps))))
+
+(define-syntax build-conditional
+ (syntax-rules ()
+ ((_ ae test-exp then-exp else-exp)
+ `(if ,test-exp ,then-exp ,else-exp))))
+
+(define-syntax build-lexical-reference
+ (syntax-rules ()
+ ((_ type ae var)
+ var)))
+
+(define-syntax build-lexical-assignment
+ (syntax-rules ()
+ ((_ ae var exp)
+ `(set! ,var ,exp))))
+
+(define-syntax build-global-reference
+ (syntax-rules ()
+ ((_ ae var)
+ var)))
+
+(define-syntax build-global-assignment
+ (syntax-rules ()
+ ((_ ae var exp)
+ `(set! ,var ,exp))))
+
+(define-syntax build-global-definition
+ (syntax-rules ()
+ ((_ ae var exp)
+ `(define ,var ,exp))))
+
+(define-syntax build-cte-install
+ ; should build a call that has the same effect as calling put-cte-hook
+ (syntax-rules ()
+ ((_ sym exp token) `($sc-put-cte ',sym ,exp ',token))))
+
+(define-syntax build-visit-only
+ ; should mark the result as "visit only" for compile-file
+ ; in implementations that support visit/revisit
+ (syntax-rules ()
+ ((_ exp) exp)))
+
+(define-syntax build-revisit-only
+ ; should mark the result as "revisit only" for compile-file,
+ ; in implementations that support visit/revisit
+ (syntax-rules ()
+ ((_ exp) exp)))
+
+(define-syntax build-lambda
+ (syntax-rules ()
+ ((_ ae vars exp)
+ `(lambda ,vars ,exp))))
+
+(define built-lambda?
+ (lambda (x)
+ (and (pair? x) (eq? (car x) 'lambda))))
+
+(define-syntax build-primref
+ (syntax-rules ()
+ ((_ ae name) name)
+ ((_ ae level name) name)))
+
+(define-syntax build-data
+ (syntax-rules ()
+ ((_ ae exp) `',exp)))
+
+(define build-sequence
+ (lambda (ae exps)
+ (let loop ((exps exps))
+ (if (null? (cdr exps))
+ (car exps)
+ ; weed out leading void calls, assuming ordinary list representation
+ (if (equal? (car exps) '(void))
+ (loop (cdr exps))
+ `(begin ,@exps))))))
+
+(define build-letrec
+ (lambda (ae vars val-exps body-exp)
+ (if (null? vars)
+ body-exp
+ `(letrec ,(map list vars val-exps) ,body-exp))))
+
+(define build-body
+ (lambda (ae vars val-exps body-exp)
+ (build-letrec ae vars val-exps body-exp)))
+
+(define build-top-module
+ ; each type is either global (exported) or local (not exported)
+ ; we produce global definitions and assignments for globals and
+ ; letrec bindings for locals. if you don't need the definitions,
+ ; (just assignments) you can eliminate them. if you wish to
+ ; have your module definitions ordered from left-to-right (ala
+ ; letrec*), you can replace the global var-exps with dummy vars
+ ; and global val-exps with global assignments, and produce a letrec*
+ ; in place of a letrec.
+ (lambda (ae types vars val-exps body-exp)
+ (let-values (((vars defns sets)
+ (let f ((types types) (vars vars))
+ (if (null? types)
+ (values '() '() '())
+ (let ((var (car vars)))
+ (let-values (((vars defns sets) (f (cdr types) (cdr vars))))
+ (if (eq? (car types) 'global)
+ (let ((x (build-lexical-var no-source var)))
+ (values
+ (cons x vars)
+ (cons (build-global-definition no-source var (chi-void)) defns)
+ (cons (build-global-assignment no-source var (build-lexical-reference 'value no-source x)) sets)))
+ (values (cons var vars) defns sets))))))))
+ (if (null? defns)
+ (build-letrec ae vars val-exps body-exp)
+ (build-sequence no-source
+ (append defns
+ (list
+ (build-letrec ae vars val-exps
+ (build-sequence no-source (append sets (list body-exp)))))))))))
+
+(define-syntax build-lexical-var
+ (syntax-rules ()
+ ((_ ae id) (gensym))))
+
+(define-syntax lexical-var? gensym?)
+
+(define-syntax self-evaluating?
+ (syntax-rules ()
+ ((_ e)
+ (let ((x e))
+ (or (boolean? x) (number? x) (string? x) (char? x) (null? x))))))
+)
+
+(define-syntax unannotate
+ (syntax-rules ()
+ ((_ x)
+ (let ((e x))
+ (if (annotation? e)
+ (annotation-expression e)
+ e)))))
+
+(define-syntax no-source (identifier-syntax #f))
+
+(define-syntax arg-check
+ (syntax-rules ()
+ ((_ pred? e who)
+ (let ((x e))
+ (if (not (pred? x)) (error-hook who "invalid argument" x))))))
+
+;;; compile-time environments
+
+;;; wrap and environment comprise two level mapping.
+;;; wrap : id --> label
+;;; env : label --> <element>
+
+;;; environments are represented in two parts: a lexical part and a global
+;;; part. The lexical part is a simple list of associations from labels
+;;; to bindings. The global part is implemented by
+;;; {put,get}-global-definition-hook and associates symbols with+;;; bindings.
+
+;;; global (assumed global variable) and displaced-lexical (see below)
+;;; do not show up in any environment; instead, they are fabricated by
+;;; lookup when it finds no other bindings.
+
+;;; <environment> ::= ((<label> . <binding>)*)
+
+;;; identifier bindings include a type and a value
+
+;;; <binding> ::= <procedure> macro keyword
+;;; (macro . <procedure>) macro keyword
+;;; (deferred . <thunk>) macro keyword w/lazily evaluated transformer
+;;; (macro! . <procedure>) extended identifier macro keyword
+;;; (core . <procedure>) core keyword
+;;; (begin) begin keyword
+;;; (define) define keyword
+;;; (define-syntax) define-syntax keyword
+;;; (local-syntax . <boolean>) let-syntax (#f)/letrec-syntax (#t) keyword
+;;; (eval-when) eval-when keyword
+;;; (set!) set! keyword
+;;; (meta) meta keyword
+;;; ($module-key) $module keyword
+;;; ($import) $import keyword
+;;; ($module . <interface>) modules
+;;; (syntax . (<var> . <level>)) pattern variables
+;;; (global . <symbol>) assumed global variable
+;;; (meta-variable . <symbol>) meta variable
+;;; (lexical . <var>) lexical variables
+;;; (displaced-lexical . #f) id-var-name not found in store
+;;; <level> ::= <nonnegative integer>
+;;; <var> ::= variable returned by build-lexical-var
+
+;;; a macro is a user-defined syntactic-form. a core is a system-defined
+;;; syntactic form. begin, define, define-syntax, let-syntax, letrec-syntax,
+;;; eval-when, and meta are treated specially since they are sensitive to
+;;; whether the form is at top-level and can denote valid internal
+;;; definitions.
+
+;;; a pattern variable is a variable introduced by syntax-case and can
+;;; be referenced only within a syntax form.
+
+;;; any identifier for which no top-level syntax definition or local
+;;; binding of any kind has been seen is assumed to be a global
+;;; variable.
+
+;;; a lexical variable is a lambda- or letrec-bound variable.
+
+;;; a displaced-lexical identifier is a lexical identifier removed from
+;;; it's scope by the return of a syntax object containing the identifier.
+;;; a displaced lexical can also appear when a letrec-syntax-bound
+;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
+;;; a displaced lexical should never occur with properly written macros.
+
+(define sanitize-binding
+ (lambda (b)
+ (cond
+ ((procedure? b) (make-binding 'macro b))
+ ((binding? b)
+ (and (case (binding-type b)
+ ((core macro macro! deferred) (and (procedure? (binding-value b))))
+ (($module) (interface? (binding-value b)))
+ ((lexical) (lexical-var? (binding-value b)))
+ ((global meta-variable) (symbol? (binding-value b)))
+ ((syntax) (let ((x (binding-value b)))
+ (and (pair? x)
+ (lexical-var? (car x))
+ (let ((n (cdr x)))
+ (and (integer? n) (exact? n) (>= n 0))))))
+ ((begin define define-syntax set! $module-key $import eval-when meta) (null? (binding-value b)))
+ ((local-syntax) (boolean? (binding-value b)))
+ ((displaced-lexical) (eq? (binding-value b) #f))
+ (else #t))
+ b))
+ (else #f))))
+
+(define-syntax make-binding
+ (syntax-rules (quote)
+ ((_ 'type #f) '(type . #f))
+ ((_ type value) (cons type value))))
+(define binding-type car)
+(define binding-value cdr)
+(define set-binding-type! set-car!)
+(define set-binding-value! set-cdr!)
+(define binding? (lambda (x) (and (pair? x) (symbol? (car x)))))
+
+(define-syntax null-env (identifier-syntax '()))
+
+(define extend-env
+ (lambda (label binding r)
+ (cons (cons label binding) r)))
+
+(define extend-env*
+ (lambda (labels bindings r)
+ (if (null? labels)
+ r
+ (extend-env* (cdr labels) (cdr bindings)
+ (extend-env (car labels) (car bindings) r)))))
+
+(define extend-var-env*
+ ; variant of extend-env* that forms "lexical" binding
+ (lambda (labels vars r)
+ (if (null? labels)
+ r
+ (extend-var-env* (cdr labels) (cdr vars)
+ (extend-env (car labels) (make-binding 'lexical (car vars)) r)))))
+
+(define (displaced-lexical? id r)
+ (let ((n (id-var-name id empty-wrap)))
+ (and n
+ (let ((b (lookup n r)))
+ (eq? (binding-type b) 'displaced-lexical)))))
+
+(define displaced-lexical-error
+ (lambda (id)
+ (syntax-error id
+ (if (id-var-name id empty-wrap)
+ "identifier out of context"
+ "identifier not visible"))))
+
+(define lookup*
+ ; x may be a label or a symbol
+ ; although symbols are usually global, we check the environment first
+ ; anyway because a temporary binding may have been established by
+ ; fluid-let-syntax
+ (lambda (x r)
+ (cond
+ ((assq x r) => cdr)
+ ((symbol? x)
+ (or (get-global-definition-hook x) (make-binding 'global x)))
+ (else (make-binding 'displaced-lexical #f)))))
+
+(define lookup
+ (lambda (x r)
+ (define whack-binding!
+ (lambda (b *b)
+ (set-binding-type! b (binding-type *b))
+ (set-binding-value! b (binding-value *b))))
+ (let ((b (lookup* x r)))
+ (when (eq? (binding-type b) 'deferred)
+ (whack-binding! b (make-transformer-binding ((binding-value b)))))
+ b)))
+
+(define make-transformer-binding
+ (lambda (b)
+ (or (sanitize-binding b)
+ (syntax-error b "invalid transformer"))))
+
+(define defer-or-eval-transformer
+ (lambda (eval x)
+ (if (built-lambda? x)
+ (make-binding 'deferred (lambda () (eval x)))
+ (make-transformer-binding (eval x)))))
+
+(define global-extend
+ (lambda (type sym val)
+ (put-cte-hook sym (make-binding type val))))
+
+
+;;; Conceptually, identifiers are always syntax objects. Internally,
+;;; however, the wrap is sometimes maintained separately (a source of
+;;; efficiency and confusion), so that symbols are also considered
+;;; identifiers by id?. Externally, they are always wrapped.
+
+(define nonsymbol-id?
+ (lambda (x)
+ (and (syntax-object? x)
+ (symbol? (unannotate (syntax-object-expression x))))))
+
+(define id?
+ (lambda (x)
+ (cond
+ ((symbol? x) #t)
+ ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
+ ((annotation? x) (symbol? (annotation-expression x)))
+ (else #f))))
+
+(define-syntax id-sym-name
+ (syntax-rules ()
+ ((_ e)
+ (let ((x e))
+ (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
+
+(define id-marks
+ (lambda (id)
+ (if (syntax-object? id)
+ (wrap-marks (syntax-object-wrap id))
+ (wrap-marks top-wrap))))
+
+(define id-subst
+ (lambda (id)
+ (if (syntax-object? id)
+ (wrap-subst (syntax-object-wrap id))
+ (wrap-marks top-wrap))))
+
+(define id-sym-name&marks
+ (lambda (x w)
+ (if (syntax-object? x)
+ (values
+ (unannotate (syntax-object-expression x))
+ (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
+ (values (unannotate x) (wrap-marks w)))))
+
+;;; syntax object wraps
+
+;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
+;;; <subst> ::= <ribcage> | <shift>
+;;; <ribcage> ::= #((<ex-symname> ...) (<mark> ...) (<label> ...)) ; extensible, for chi-internal/external
+;;; | #(#(<symname> ...) #(<mark> ...) #(<label> ...)) ; nonextensible
+;;; <ex-symname> ::= <symname> | <import token> | <barrier>
+;;; <shift> ::= shift
+;;; <barrier> ::= #f ; inserted by import-only
+;;; <import interface> ::= #<import-interface interface new-marks>
+;;; <token> ::= <generated id>
+
+(define make-wrap cons)
+(define wrap-marks car)
+(define wrap-subst cdr)
+
+
+(define-syntax empty-wrap (identifier-syntax '(())))
+
+(define-syntax top-wrap (identifier-syntax '((top))))
+
+(define-syntax tmp-wrap (identifier-syntax '((tmp)))) ; for generate-temporaries
+
+(define-syntax top-marked?
+ (syntax-rules ()
+ ((_ w) (memq 'top (wrap-marks w)))))
+
+(define-syntax only-top-marked?
+ (syntax-rules ()
+ ((_ id) (same-marks? (wrap-marks (syntax-object-wrap id)) (wrap-marks top-wrap)))))
+
+;;; labels
+
+;;; simple labels must be comparable with "eq?" and distinct from symbols
+;;; and pairs.
+
+;;; indirect labels, which are implemented as pairs, are used to support
+;;; import aliasing for identifiers exported (explictly or implicitly) from
+;;; top-level modules. chi-external creates an indirect label for each
+;;; defined identifier, import causes the pair to be shared with aliases it
+;;; establishes, and chi-top-module whacks the pair to hold the top-level
+;;; identifier name (symbol) if the id is to be placed at top level, before
+;;; expanding the right-hand sides of the definitions in the module.
+
+(module (gen-indirect-label indirect-label? get-indirect-label set-indirect-label!)
+ (define-structure (indirect-label label))
+ (define gen-indirect-label
+ (lambda ()
+ (make-indirect-label (gen-label))))
+ (define get-indirect-label (lambda (x) (indirect-label-label x)))
+ (define set-indirect-label! (lambda (x v) (set-indirect-label-label! x v))))
+
+(define gen-label
+ (lambda () (string #\i)))
+(define label?
+ (lambda (x)
+ (or (string? x) ; normal lexical labels
+ (symbol? x) ; global labels (symbolic names)
+ (indirect-label? x))))
+
+(define gen-labels
+ (lambda (ls)
+ (if (null? ls)
+ '()
+ (cons (gen-label) (gen-labels (cdr ls))))))
+
+(define-structure (ribcage symnames marks labels))
+(define-structure (top-ribcage key mutable?))
+(define-structure (import-interface interface new-marks))
+(define-structure (env top-ribcage wrap))
+
+;;; Marks must be comparable with "eq?" and distinct from pairs and
+;;; the symbol top. We do not use integers so that marks will remain
+;;; unique even across file compiles.
+
+(define-syntax the-anti-mark (identifier-syntax #f))
+
+(define anti-mark
+ (lambda (w)
+ (make-wrap (cons the-anti-mark (wrap-marks w))
+ (cons 'shift (wrap-subst w)))))
+
+(define-syntax new-mark
+ (syntax-rules ()
+ ((_) (string #\m))))
+
+(define barrier-marker #f)
+
+;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
+;;; internal definitions, in which the ribcages are built incrementally
+(define-syntax make-empty-ribcage
+ (syntax-rules ()
+ ((_) (make-ribcage '() '() '()))))
+
+(define extend-ribcage!
+ ; must receive ids with complete wraps
+ ; ribcage guaranteed to be list-based
+ (lambda (ribcage id label)
+ (set-ribcage-symnames! ribcage
+ (cons (unannotate (syntax-object-expression id))
+ (ribcage-symnames ribcage)))
+ (set-ribcage-marks! ribcage
+ (cons (wrap-marks (syntax-object-wrap id))
+ (ribcage-marks ribcage)))
+ (set-ribcage-labels! ribcage
+ (cons label (ribcage-labels ribcage)))))
+
+(define import-extend-ribcage!
+ ; must receive ids with complete wraps
+ ; ribcage guaranteed to be list-based
+ (lambda (ribcage new-marks id label)
+ (set-ribcage-symnames! ribcage
+ (cons (unannotate (syntax-object-expression id))
+ (ribcage-symnames ribcage)))
+ (set-ribcage-marks! ribcage
+ (cons (join-marks new-marks (wrap-marks (syntax-object-wrap id)))
+ (ribcage-marks ribcage)))
+ (set-ribcage-labels! ribcage
+ (cons label (ribcage-labels ribcage)))))
+
+(define extend-ribcage-barrier!
+ ; must receive ids with complete wraps
+ ; ribcage guaranteed to be list-based
+ (lambda (ribcage killer-id)
+ (extend-ribcage-barrier-help! ribcage (syntax-object-wrap killer-id))))
+
+(define extend-ribcage-barrier-help!
+ (lambda (ribcage wrap)
+ (set-ribcage-symnames! ribcage
+ (cons barrier-marker (ribcage-symnames ribcage)))
+ (set-ribcage-marks! ribcage
+ (cons (wrap-marks wrap) (ribcage-marks ribcage)))))
+
+(define extend-ribcage-subst!
+ ; ribcage guaranteed to be list-based
+ (lambda (ribcage import-iface)
+ (set-ribcage-symnames! ribcage
+ (cons import-iface (ribcage-symnames ribcage)))))
+
+(define lookup-import-binding-name
+ (lambda (sym marks token new-marks)
+ (let ((new (get-import-binding sym token)))
+ (and new
+ (let f ((new new))
+ (cond
+ ((pair? new) (or (f (car new)) (f (cdr new))))
+ ((symbol? new)
+ (and (same-marks? marks (join-marks new-marks (wrap-marks top-wrap))) new))
+ ((same-marks? marks (join-marks new-marks (wrap-marks (syntax-object-wrap new)))) new)
+ (else #f)))))))
+
+(define store-import-binding
+ (lambda (id token new-marks)
+ (define cons-id
+ (lambda (id x)
+ (if (not x) id (cons id x))))
+ (define weed ; remove existing binding for id, if any
+ (lambda (marks x)
+ (if (pair? x)
+ (if (same-marks? (id-marks (car x)) marks)
+ (weed marks (cdr x))
+ (cons-id (car x) (weed marks (cdr x))))
+ (and x (not (same-marks? (id-marks x) marks)) x))))
+ (let ((id (if (null? new-marks)
+ id
+ (make-syntax-object (id-sym-name id)
+ (make-wrap
+ (join-marks new-marks (id-marks id))
+ (id-subst id))))))
+ (let ((sym (id-sym-name id)))
+ ; no need to record bindings mapping symbol to self, since this
+ ; assumed by default.
+ (unless (eq? id sym)
+ (let ((marks (id-marks id)))
+ (update-import-binding! sym token
+ (lambda (old-binding)
+ (let ((x (weed marks old-binding)))
+ (cons-id
+ (if (same-marks? marks (wrap-marks top-wrap))
+ ; need full id only if more than top-marked.
+ (resolved-id-var-name id)
+ id)
+ x))))))))))
+
+;;; make-binding-wrap creates vector-based ribcages
+(define make-binding-wrap
+ (lambda (ids labels w)
+ (if (null? ids)
+ w
+ (make-wrap
+ (wrap-marks w)
+ (cons
+ (let ((labelvec (list->vector labels)))
+ (let ((n (vector-length labelvec)))
+ (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
+ (let f ((ids ids) (i 0))
+ (unless (null? ids)
+ (let-values (((symname marks) (id-sym-name&marks (car ids) w)))
+ (vector-set! symnamevec i symname)
+ (vector-set! marksvec i marks)
+ (f (cdr ids) (fx+ i 1)))))
+ (make-ribcage symnamevec marksvec labelvec))))
+ (wrap-subst w))))))
+
+;;; resolved ids contain no unnecessary substitutions or marks. they are
+;;; used essentially as indirects or aliases in modules interfaces.
+(define make-resolved-id
+ (lambda (fromsym marks tosym)
+ (make-syntax-object fromsym
+ (make-wrap marks
+ (list (make-ribcage (vector fromsym) (vector marks) (vector tosym)))))))
+
+(define id->resolved-id
+ (lambda (id)
+ (let-values (((tosym marks) (id-var-name&marks id empty-wrap)))
+ (unless tosym
+ (syntax-error id "identifier not visible for export"))
+ (make-resolved-id (id-sym-name id) marks tosym))))
+
+(define resolved-id-var-name
+ (lambda (id)
+ (vector-ref
+ (ribcage-labels (car (wrap-subst (syntax-object-wrap id))))
+ 0)))
+
+;;; Scheme's append should not copy the first argument if the second is
+;;; nil, but it does, so we define a smart version here.
+(define smart-append
+ (lambda (m1 m2)
+ (if (null? m2)
+ m1
+ (append m1 m2))))
+
+(define join-wraps
+ (lambda (w1 w2)
+ (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
+ (if (null? m1)
+ (if (null? s1)
+ w2
+ (make-wrap
+ (wrap-marks w2)
+ (join-subst s1 (wrap-subst w2))))
+ (make-wrap
+ (join-marks m1 (wrap-marks w2))
+ (join-subst s1 (wrap-subst w2)))))))
+
+(define join-marks
+ (lambda (m1 m2)
+ (smart-append m1 m2)))
+
+(define join-subst
+ (lambda (s1 s2)
+ (smart-append s1 s2)))
+
+(define same-marks?
+ (lambda (x y)
+ (or (eq? x y)
+ (and (not (null? x))
+ (not (null? y))
+ (eq? (car x) (car y))
+ (same-marks? (cdr x) (cdr y))))))
+
+(define diff-marks
+ (lambda (m1 m2)
+ (let ((n1 (length m1)) (n2 (length m2)))
+ (let f ((n1 n1) (m1 m1))
+ (cond
+ ((> n1 n2) (cons (car m1) (f (- n1 1) (cdr m1))))
+ ((equal? m1 m2) '())
+ (else (error 'sc-expand
+ "internal error in diff-marks: ~s is not a tail of ~s"
+ m1 m2)))))))
+
+(module (top-id-bound-var-name top-id-free-var-name)
+ ;; top-id-bound-var-name is used to look up or establish new top-level
+ ;; substitutions, while top-id-free-var-name is used to look up existing
+ ;; (possibly implicit) substitutions. Implicit substitutions exist
+ ;; for top-marked names in all environments, but we represent them
+ ;; explicitly only on demand.
+ ;;
+ ;; In both cases, we first look for an existing substitution for sym
+ ;; and the given marks. If we find one, we return it. Otherwise, we
+ ;; extend the appropriate top-level environment
+ ;;
+ ;; For top-id-bound-var-name, we extend the environment with a substition
+ ;; keyed by the given marks, so that top-level definitions introduced by
+ ;; a macro are distinct from other top-level definitions for the same
+ ;; name. For example, if macros a and b both introduce definitions and
+ ;; bound references to identifier x, the two x's should be different,
+ ;; i.e., keyed by their own marks.
+ ;;
+ ;; For top-id-free-var-name, we extend the environment with a substition
+ ;; keyed by the top marks, since top-level free identifier references
+ ;; should refer to the existing implicit (top-marked) substitution. For
+ ;; example, if macros a and b both introduce free references to identifier
+ ;; x, they should both refer to the same (global, unmarked) x.
+ ;;
+ ;; If the environment is *top*, we map a symbol to itself
+
+ (define leave-implicit? (lambda (token) (eq? token '*top*)))
+
+ (define new-binding
+ (lambda (sym marks token)
+ (let ((loc (if (and (leave-implicit? token)
+ (same-marks? marks (wrap-marks top-wrap)))
+ sym
+ (generate-id sym))))
+ (let ((id (make-resolved-id sym marks loc)))
+ (store-import-binding id token '())
+ (values loc id)))))
+
+ (define top-id-bound-var-name
+ ; should be called only when top-ribcage is mutable
+ (lambda (sym marks top-ribcage)
+ (let ((token (top-ribcage-key top-ribcage)))
+ (cond
+ ((lookup-import-binding-name sym marks token '()) =>
+ (lambda (id)
+ (if (symbol? id) ; symbol iff marks == (wrap-marks top-wrap)
+ (if (read-only-binding? id)
+ (new-binding sym marks token)
+ (values id (make-resolved-id sym marks id)))
+ (values (resolved-id-var-name id) id))))
+ (else (new-binding sym marks token))))))
+
+ (define top-id-free-var-name
+ (lambda (sym marks top-ribcage)
+ (let ((token (top-ribcage-key top-ribcage)))
+ (cond
+ ((lookup-import-binding-name sym marks token '()) =>
+ (lambda (id) (if (symbol? id) id (resolved-id-var-name id))))
+ ((and (top-ribcage-mutable? top-ribcage)
+ (same-marks? marks (wrap-marks top-wrap)))
+ (let-values (((sym id) (new-binding sym (wrap-marks top-wrap) token)))
+ sym))
+ (else #f))))))
+
+(define id-var-name-loc&marks
+ (lambda (id w)
+ (define search
+ (lambda (sym subst marks)
+ (if (null? subst)
+ (values #f marks)
+ (let ((fst (car subst)))
+ (cond
+ ((eq? fst 'shift) (search sym (cdr subst) (cdr marks)))
+ ((ribcage? fst)
+ (let ((symnames (ribcage-symnames fst)))
+ (if (vector? symnames)
+ (search-vector-rib sym subst marks symnames fst)
+ (search-list-rib sym subst marks symnames fst))))
+ ((top-ribcage? fst)
+ (cond
+ ((top-id-free-var-name sym marks fst) =>
+ (lambda (var-name) (values var-name marks)))
+ (else (search sym (cdr subst) marks))))
+ (else
+ (error 'sc-expand
+ "internal error in id-var-name-loc&marks: improper subst ~s"
+ subst)))))))
+ (define search-list-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let f ((symnames symnames) (i 0))
+ (if (null? symnames)
+ (search sym (cdr subst) marks)
+ (let ((x (car symnames)))
+ (cond
+ ((and (eq? x sym)
+ (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+ (values (list-ref (ribcage-labels ribcage) i) marks))
+ ((import-interface? x)
+ (let ((iface (import-interface-interface x))
+ (new-marks (import-interface-new-marks x)))
+ (cond
+ ((interface-token iface) =>
+ (lambda (token)
+ (cond
+ ((lookup-import-binding-name sym marks token new-marks) =>
+ (lambda (id)
+ (values
+ (if (symbol? id) id (resolved-id-var-name id))
+ marks)))
+ (else (f (cdr symnames) i)))))
+ (else
+ (let* ((ie (interface-exports iface))
+ (n (vector-length ie)))
+ (let g ((j 0))
+ (if (fx= j n)
+ (f (cdr symnames) i)
+ (let ((id (vector-ref ie j)))
+ (let ((id.sym (id-sym-name id))
+ (id.marks (join-marks new-marks (id-marks id))))
+ (if (help-bound-id=? id.sym id.marks sym marks)
+ (values (lookup-import-label id) marks)
+ (g (fx+ j 1))))))))))))
+ ((and (eq? x barrier-marker)
+ (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+ (values #f marks))
+ (else (f (cdr symnames) (fx+ i 1)))))))))
+ (define search-vector-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let ((n (vector-length symnames)))
+ (let f ((i 0))
+ (cond
+ ((fx= i n) (search sym (cdr subst) marks))
+ ((and (eq? (vector-ref symnames i) sym)
+ (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
+ (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (else (f (fx+ i 1))))))))
+ (cond
+ ((symbol? id) (search id (wrap-subst w) (wrap-marks w)))
+ ((syntax-object? id)
+ (let ((sym (unannotate (syntax-object-expression id)))
+ (w1 (syntax-object-wrap id)))
+ (let-values (((name marks) (search sym (wrap-subst w)
+ (join-marks
+ (wrap-marks w)
+ (wrap-marks w1)))))
+ (if name
+ (values name marks)
+ (search sym (wrap-subst w1) marks)))))
+ ((annotation? id) (search (unannotate id) (wrap-subst w) (wrap-marks w)))
+ (else (error-hook 'id-var-name "invalid id" id)))))
+
+(define id-var-name&marks
+ ; this version follows indirect labels
+ (lambda (id w)
+ (let-values (((label marks) (id-var-name-loc&marks id w)))
+ (values (if (indirect-label? label) (get-indirect-label label) label) marks))))
+
+(define id-var-name-loc
+ ; this version doesn't follow indirect labels
+ (lambda (id w)
+ (let-values (((label marks) (id-var-name-loc&marks id w)))
+ label)))
+
+(define id-var-name
+ ; this version follows indirect labels
+ (lambda (id w)
+ (let-values (((label marks) (id-var-name-loc&marks id w)))
+ (if (indirect-label? label) (get-indirect-label label) label))))
+
+;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
+;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
+
+(define free-id=?
+ (lambda (i j)
+ (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
+ (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
+
+(define literal-id=?
+ (lambda (id literal)
+ (and (eq? (id-sym-name id) (id-sym-name literal))
+ (let ((n-id (id-var-name id empty-wrap))
+ (n-literal (id-var-name literal empty-wrap)))
+ (or (eq? n-id n-literal)
+ (and (or (not n-id) (symbol? n-id))
+ (or (not n-literal) (symbol? n-literal))))))))
+
+;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
+;;; long as the missing portion of the wrap is common to both of the ids
+;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
+
+(define help-bound-id=?
+ (lambda (i.sym i.marks j.sym j.marks)
+ (and (eq? i.sym j.sym)
+ (same-marks? i.marks j.marks))))
+
+(define bound-id=?
+ (lambda (i j)
+ (help-bound-id=? (id-sym-name i) (id-marks i) (id-sym-name j) (id-marks j))))
+
+;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
+;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
+;;; as long as the missing portion of the wrap is common to all of the
+;;; ids.
+
+(define valid-bound-ids?
+ (lambda (ids)
+ (and (let all-ids? ((ids ids))
+ (or (null? ids)
+ (and (id? (car ids))
+ (all-ids? (cdr ids)))))
+ (distinct-bound-ids? ids))))
+
+;;; distinct-bound-ids? expects a list of ids and returns #t if there are
+;;; no duplicates. It is quadratic on the length of the id list; long
+;;; lists could be sorted to make it more efficient. distinct-bound-ids?
+;;; may be passed unwrapped (or partially wrapped) ids as long as the
+;;; missing portion of the wrap is common to all of the ids.
+
+(define distinct-bound-ids?
+ (lambda (ids)
+ (let distinct? ((ids ids))
+ (or (null? ids)
+ (and (not (bound-id-member? (car ids) (cdr ids)))
+ (distinct? (cdr ids)))))))
+
+(define invalid-ids-error
+ ; find first bad one and complain about it
+ (lambda (ids exp class)
+ (let find ((ids ids) (gooduns '()))
+ (if (null? ids)
+ (syntax-error exp) ; shouldn't happen
+ (if (id? (car ids))
+ (if (bound-id-member? (car ids) gooduns)
+ (syntax-error (car ids) "duplicate " class)
+ (find (cdr ids) (cons (car ids) gooduns)))
+ (syntax-error (car ids) "invalid " class))))))
+
+(define bound-id-member?
+ (lambda (x list)
+ (and (not (null? list))
+ (or (bound-id=? x (car list))
+ (bound-id-member? x (cdr list))))))
+
+;;; wrapping expressions and identifiers
+
+(define wrap
+ (lambda (x w)
+ (cond
+ ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
+ ((syntax-object? x)
+ (make-syntax-object
+ (syntax-object-expression x)
+ (join-wraps w (syntax-object-wrap x))))
+ ((null? x) x)
+ (else (make-syntax-object x w)))))
+
+(define source-wrap
+ (lambda (x w ae)
+ (wrap (if (annotation? ae)
+ (begin
+ (unless (eq? (annotation-expression ae) x)
+ (error 'sc-expand "internal error in source-wrap: ae/x mismatch"))
+ ae)
+ x)
+ w)))
+
+;;; expanding
+
+(define chi-when-list
+ (lambda (when-list w)
+ ; when-list is syntax'd version of list of situations
+ (map (lambda (x)
+ (cond
+ ((literal-id=? x (syntax compile)) 'compile)
+ ((literal-id=? x (syntax load)) 'load)
+ ((literal-id=? x (syntax visit)) 'visit)
+ ((literal-id=? x (syntax revisit)) 'revisit)
+ ((literal-id=? x (syntax eval)) 'eval)
+ (else (syntax-error (wrap x w) "invalid eval-when situation"))))
+ when-list)))
+
+;;; syntax-type returns five values: type, value, e, w, and ae. The first
+;;; two are described in the table below.
+;;;
+;;; type value explanation
+;;; -------------------------------------------------------------------
+;;; alias none alias keyword
+;;; alias-form none alias expression
+;;; begin none begin keyword
+;;; begin-form none begin expression
+;;; call none any other call
+;;; constant none self-evaluating datum
+;;; core procedure core form (including singleton)
+;;; define none define keyword
+;;; define-form none variable definition
+;;; define-syntax none define-syntax keyword
+;;; define-syntax-form none syntax definition
+;;; displaced-lexical none displaced lexical identifier
+;;; eval-when none eval-when keyword
+;;; eval-when-form none eval-when form
+;;; global name global variable reference
+;;; $import none $import keyword
+;;; $import-form none $import form
+;;; lexical name lexical variable reference
+;;; lexical-call name call to lexical variable
+;;; local-syntax rec? letrec-syntax/let-syntax keyword
+;;; local-syntax-form rec? syntax definition
+;;; meta none meta keyword
+;;; meta-form none meta form
+;;; meta-variable name meta variable
+;;; $module none $module keyword
+;;; $module-form none $module definition
+;;; syntax level pattern variable
+;;; other none anything else
+;;;
+;;; For all forms, e is the form, w is the wrap for e. and ae is the
+;;; (possibly) source-annotated form.
+;;;
+;;; syntax-type expands macros and unwraps as necessary to get to
+;;; one of the forms above.
+
+(define syntax-type
+ (lambda (e r w ae rib)
+ (cond
+ ((symbol? e)
+ (let* ((n (id-var-name e w))
+ (b (lookup n r))
+ (type (binding-type b)))
+ (case type
+ ((macro macro!) (syntax-type (chi-macro (binding-value b) e r w ae rib) r empty-wrap #f rib))
+ (else (values type (binding-value b) e w ae)))))
+ ((pair? e)
+ (let ((first (car e)))
+ (if (id? first)
+ (let* ((n (id-var-name first w))
+ (b (lookup n r))
+ (type (binding-type b)))
+ (case type
+ ((lexical) (values 'lexical-call (binding-value b) e w ae))
+ ((macro macro!)
+ (syntax-type (chi-macro (binding-value b) e r w ae rib)
+ r empty-wrap #f rib))
+ ((core) (values type (binding-value b) e w ae))
+ ((begin) (values 'begin-form #f e w ae))
+ ((alias) (values 'alias-form #f e w ae))
+ ((define) (values 'define-form #f e w ae))
+ ((define-syntax) (values 'define-syntax-form #f e w ae))
+ ((set!) (chi-set! e r w ae rib))
+ (($module-key) (values '$module-form #f e w ae))
+ (($import) (values '$import-form #f e w ae))
+ ((eval-when) (values 'eval-when-form #f e w ae))
+ ((meta) (values 'meta-form #f e w ae))
+ ((local-syntax)
+ (values 'local-syntax-form (binding-value b) e w ae))
+ (else (values 'call #f e w ae))))
+ (values 'call #f e w ae))))
+ ((syntax-object? e)
+ (syntax-type (syntax-object-expression e)
+ r
+ (join-wraps w (syntax-object-wrap e))
+ #f rib))
+ ((annotation? e)
+ (syntax-type (annotation-expression e) r w e rib))
+ ((self-evaluating? e) (values 'constant #f e w ae))
+ (else (values 'other #f e w ae)))))
+
+(define chi-top*
+ (lambda (e r w ctem rtem meta? top-ribcage)
+ (let ((meta-residuals '()))
+ (define meta-residualize!
+ (lambda (x)
+ (set! meta-residuals
+ (cons x meta-residuals))))
+ (let ((e (chi-top e r w ctem rtem meta? top-ribcage meta-residualize! #f)))
+ (build-sequence no-source
+ (reverse (cons e meta-residuals)))))))
+
+(define chi-top-sequence
+ (lambda (body r w ae ctem rtem meta? ribcage meta-residualize!)
+ (build-sequence ae
+ (let dobody ((body body))
+ (if (null? body)
+ '()
+ (let ((first (chi-top (car body) r w ctem rtem meta? ribcage meta-residualize! #f)))
+ (cons first (dobody (cdr body)))))))))
+
+(define chi-top
+ (lambda (e r w ctem rtem meta? top-ribcage meta-residualize! meta-seen?)
+ (let-values (((type value e w ae) (syntax-type e r w no-source top-ribcage)))
+ (case type
+ ((begin-form)
+ (let ((forms (parse-begin e w ae #t)))
+ (if (null? forms)
+ (chi-void)
+ (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!))))
+ ((local-syntax-form)
+ (let-values (((forms r mr w ae) (chi-local-syntax value e r r w ae)))
+ ; mr should be same as r here
+ (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!)))
+ ((eval-when-form)
+ (let-values (((when-list forms) (parse-eval-when e w ae)))
+ (let ((ctem (update-mode-set when-list ctem))
+ (rtem (update-mode-set when-list rtem)))
+ (if (and (null? ctem) (null? rtem))
+ (chi-void)
+ (chi-top-sequence forms r w ae ctem rtem meta? top-ribcage meta-residualize!)))))
+ ((meta-form) (chi-top (parse-meta e w ae) r w ctem rtem #t top-ribcage meta-residualize! #t))
+ ((define-syntax-form)
+ (let-values (((id rhs w) (parse-define-syntax e w ae)))
+ (let ((id (wrap id w)))
+ (when (displaced-lexical? id r) (displaced-lexical-error id))
+ (unless (top-ribcage-mutable? top-ribcage)
+ (syntax-error (source-wrap e w ae)
+ "invalid definition in read-only environment"))
+ (let ((sym (id-sym-name id)))
+ (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap id)) top-ribcage)))
+ (unless (eq? (id-var-name id empty-wrap) valsym)
+ (syntax-error (source-wrap e w ae)
+ "definition not permitted"))
+ (when (read-only-binding? valsym)
+ (syntax-error (source-wrap e w ae)
+ "invalid definition of read-only identifier"))
+ (ct-eval/residualize2 ctem
+ (lambda ()
+ (build-cte-install
+ bound-id
+ (chi rhs r r w #t)
+ (top-ribcage-key top-ribcage)))))))))
+ ((define-form)
+ (let-values (((id rhs w) (parse-define e w ae)))
+ (let ((id (wrap id w)))
+ (when (displaced-lexical? id r) (displaced-lexical-error id))
+ (unless (top-ribcage-mutable? top-ribcage)
+ (syntax-error (source-wrap e w ae)
+ "invalid definition in read-only environment"))
+ (let ((sym (id-sym-name id)))
+ (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap id)) top-ribcage)))
+ (unless (eq? (id-var-name id empty-wrap) valsym)
+ (syntax-error (source-wrap e w ae)
+ "definition not permitted"))
+ (when (read-only-binding? valsym)
+ (syntax-error (source-wrap e w ae)
+ "invalid definition of read-only identifier"))
+ (if meta?
+ (ct-eval/residualize2 ctem
+ (lambda ()
+ (build-sequence no-source
+ (list
+ (build-cte-install bound-id
+ (build-data no-source (make-binding 'meta-variable valsym))
+ (top-ribcage-key top-ribcage))
+ (build-global-definition ae valsym (chi rhs r r w #t))))))
+ ; make sure compile-time definitions occur before we
+ ; expand the run-time code
+ (let ((x (ct-eval/residualize2 ctem
+ (lambda ()
+ (build-cte-install
+ bound-id
+ (build-data no-source (make-binding 'global valsym))
+ (top-ribcage-key top-ribcage))))))
+ (build-sequence no-source
+ (list
+ x
+ (rt-eval/residualize rtem
+ (lambda ()
+ (build-global-definition ae valsym (chi rhs r r w #f)))))))))
+ ))))
+ (($module-form)
+ (let ((ribcage (make-empty-ribcage)))
+ (let-values (((orig id exports forms)
+ (parse-module e w ae
+ (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))))
+ (when (displaced-lexical? id r) (displaced-lexical-error (wrap id w)))
+ (unless (top-ribcage-mutable? top-ribcage)
+ (syntax-error orig
+ "invalid definition in read-only environment"))
+ (chi-top-module orig r r top-ribcage ribcage ctem rtem meta? id exports forms meta-residualize!))))
+ (($import-form)
+ (let-values (((orig only? mid) (parse-import e w ae)))
+ (unless (top-ribcage-mutable? top-ribcage)
+ (syntax-error orig
+ "invalid definition in read-only environment"))
+ (ct-eval/residualize2 ctem
+ (lambda ()
+ (let ((binding (lookup (id-var-name mid empty-wrap) null-env)))
+ (case (binding-type binding)
+ (($module) (do-top-import only? top-ribcage mid (interface-token (binding-value binding))))
+ ((displaced-lexical) (displaced-lexical-error mid))
+ (else (syntax-error mid "unknown module"))))))))
+ ((alias-form)
+ (let-values (((new-id old-id) (parse-alias e w ae)))
+ (let ((new-id (wrap new-id w)))
+ (when (displaced-lexical? new-id r) (displaced-lexical-error new-id))
+ (unless (top-ribcage-mutable? top-ribcage)
+ (syntax-error (source-wrap e w ae)
+ "invalid definition in read-only environment"))
+ (let ((sym (id-sym-name new-id)))
+ (let-values (((valsym bound-id) (top-id-bound-var-name sym (wrap-marks (syntax-object-wrap new-id)) top-ribcage)))
+ (unless (eq? (id-var-name new-id empty-wrap) valsym)
+ (syntax-error (source-wrap e w ae)
+ "definition not permitted"))
+ (when (read-only-binding? valsym)
+ (syntax-error (source-wrap e w ae)
+ "invalid definition of read-only identifier"))
+ (ct-eval/residualize2 ctem
+ (lambda ()
+ (build-cte-install
+ (make-resolved-id sym (wrap-marks (syntax-object-wrap new-id)) (id-var-name old-id w))
+ (build-data no-source (make-binding 'do-alias #f))
+ (top-ribcage-key top-ribcage)))))))))
+ (else
+ (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
+ (if meta?
+ (let ((x (chi-expr type value e r r w ae #t)))
+ (top-level-eval-hook x)
+ (ct-eval/residualize3 ctem void (lambda () x)))
+ (rt-eval/residualize rtem
+ (lambda ()
+ (chi-expr type value e r r w ae #f)))))))))
+
+(define flatten-exports
+ (lambda (exports)
+ (let loop ((exports exports) (ls '()))
+ (if (null? exports)
+ ls
+ (loop (cdr exports)
+ (if (pair? (car exports))
+ (loop (car exports) ls)
+ (cons (car exports) ls)))))))
+
+
+(define-structure (interface marks exports token))
+
+;; leaves interfaces unresolved so that indirect labels can be followed.
+;; (can't resolve until indirect labels have their final value)
+(define make-unresolved-interface
+ ; trim out implicit exports
+ (lambda (mid exports)
+ (make-interface
+ (wrap-marks (syntax-object-wrap mid))
+ (list->vector (map (lambda (x) (if (pair? x) (car x) x)) exports))
+ #f)))
+
+(define make-resolved-interface
+ ; trim out implicit exports & resolve others to actual top-level symbol
+ (lambda (mid exports token)
+ (make-interface
+ (wrap-marks (syntax-object-wrap mid))
+ (list->vector (map (lambda (x) (id->resolved-id (if (pair? x) (car x) x))) exports))
+ token)))
+
+(define-structure (module-binding type id label imps val exported))
+(define create-module-binding
+ (lambda (type id label imps val)
+ (make-module-binding type id label imps val #f)))
+
+;;; frobs represent body forms
+(define-structure (frob e meta?))
+
+(define chi-top-module
+ (lambda (orig r mr top-ribcage ribcage ctem rtem meta? id exports forms meta-residualize!)
+ (let ((fexports (flatten-exports exports)))
+ (let-values (((r mr bindings inits)
+ (chi-external ribcage orig
+ (map (lambda (d) (make-frob d meta?)) forms) r mr ctem exports fexports
+ meta-residualize!)))
+ ; identify exported identifiers, create ctdefs
+ (let process-exports ((fexports fexports) (ctdefs (lambda () '())))
+ (if (null? fexports)
+ ; remaining bindings are either identified global vars,
+ ; local vars, or local compile-time entities
+ ; dts: type (local/global)
+ ; dvs & des: define lhs & rhs
+ (let process-locals ((bs bindings) (r r) (dts '()) (dvs '()) (des '()))
+ (if (null? bs)
+ (let ((des (chi-frobs des r mr #f))
+ (inits (chi-frobs inits r mr #f)))
+ (build-sequence no-source
+ (append
+ ; we wait to establish global compile-time definitions so that
+ ; expansion of des use local versions of modules and macros
+ ; in case ctem tells us not to eval ctdefs now. this means that
+ ; local code can use exported compile-time values (modules, macros,
+ ; meta variables) just as it can unexported ones.
+ (ctdefs)
+ (list
+ (ct-eval/residualize2 ctem
+ (lambda ()
+ (let ((sym (id-sym-name id)))
+ (let* ((token (generate-id sym))
+ (b (build-data no-source
+ (make-binding '$module
+ (make-resolved-interface id exports token)))))
+ (let-values (((valsym bound-id)
+ (top-id-bound-var-name sym
+ (wrap-marks (syntax-object-wrap id))
+ top-ribcage)))
+ (unless (eq? (id-var-name id empty-wrap) valsym)
+ (syntax-error orig
+ "definition not permitted"))
+ (when (read-only-binding? valsym)
+ (syntax-error orig
+ "invalid definition of read-only identifier"))
+ (build-cte-install bound-id b
+ (top-ribcage-key top-ribcage)))))))
+ (rt-eval/residualize rtem
+ (lambda ()
+ (build-top-module no-source dts dvs des
+ (if (null? inits)
+ (chi-void)
+ (build-sequence no-source
+ (append inits (list (chi-void))))))))))))
+ (let ((b (car bs)) (bs (cdr bs)))
+ (let ((t (module-binding-type b)))
+ (case (module-binding-type b)
+ ((define-form)
+ (let ((label (get-indirect-label (module-binding-label b))))
+ (if (module-binding-exported b)
+ (let ((var (module-binding-id b)))
+ (process-locals bs r (cons 'global dts) (cons label dvs)
+ (cons (module-binding-val b) des)))
+ (let ((var (gen-var (module-binding-id b))))
+ (process-locals bs
+ ; add lexical bindings only to run-time environment
+ (extend-env label (make-binding 'lexical var) r)
+ (cons 'local dts) (cons var dvs)
+ (cons (module-binding-val b) des))))))
+ ((ctdefine-form define-syntax-form $module-form alias-form) (process-locals bs r dts dvs des))
+ (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))))
+ (let ((id (car fexports)) (fexports (cdr fexports)))
+ (let loop ((bs bindings))
+ (if (null? bs)
+ ; must be rexport from an imported module
+ (process-exports fexports ctdefs)
+ (let ((b (car bs)) (bs (cdr bs)))
+ ; following formerly used bound-id=?, but free-id=? can prevent false positives
+ ; and is okay since the substitutions have already been applied
+ (if (free-id=? (module-binding-id b) id)
+ (if (module-binding-exported b)
+ (process-exports fexports ctdefs)
+ (let* ((t (module-binding-type b))
+ (label (module-binding-label b))
+ (imps (module-binding-imps b))
+ (fexports (append imps fexports)))
+ (set-module-binding-exported! b #t)
+ (case t
+ ((define-form)
+ (let ((sym (generate-id (id-sym-name id))))
+ (set-indirect-label! label sym)
+ (process-exports fexports ctdefs)))
+ ((ctdefine-form)
+ (let ((b (module-binding-val b)))
+ (process-exports fexports
+ (lambda ()
+ (let ((sym (binding-value b)))
+ (set-indirect-label! label sym)
+ (cons (ct-eval/residualize3 ctem
+ (lambda () (put-cte-hook sym b))
+ (lambda () (build-cte-install sym (build-data no-source b) #f)))
+ (ctdefs)))))))
+ ((define-syntax-form)
+ (let ((sym (generate-id (id-sym-name id))))
+ (process-exports fexports
+ (lambda ()
+ (let ((local-label (get-indirect-label label)))
+ (set-indirect-label! label sym)
+ (cons
+ (ct-eval/residualize3 ctem
+ (lambda () (put-cte-hook sym (car (module-binding-val b))))
+ (lambda () (build-cte-install sym (cdr (module-binding-val b)) #f)))
+ (ctdefs)))))))
+ (($module-form)
+ (let ((sym (generate-id (id-sym-name id)))
+ (exports (module-binding-val b)))
+ (process-exports (append (flatten-exports exports) fexports)
+ (lambda ()
+ (set-indirect-label! label sym)
+ (let ((rest (ctdefs))) ; set indirect labels before resolving
+ (let ((x (make-binding '$module (make-resolved-interface id exports sym))))
+ (cons (ct-eval/residualize3 ctem
+ (lambda () (put-cte-hook sym x))
+ (lambda () (build-cte-install sym (build-data no-source x) #f)))
+ rest)))))))
+ ((alias-form)
+ (process-exports
+ fexports
+ (lambda ()
+ (let ((rest (ctdefs))) ; set indirect labels before resolving
+ (when (indirect-label? label)
+ (unless (symbol? (get-indirect-label label))
+ (syntax-error (module-binding-id b) "unexported target of alias")))
+ rest))))
+ (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))
+ (loop bs))))))))))))
+
+(define id-set-diff
+ (lambda (exports defs)
+ (cond
+ ((null? exports) '())
+ ((bound-id-member? (car exports) defs) (id-set-diff (cdr exports) defs))
+ (else (cons (car exports) (id-set-diff (cdr exports) defs))))))
+
+(define check-module-exports
+ ; After processing the definitions of a module this is called to verify that the
+ ; module has defined or imported each exported identifier. Because ids in fexports are
+ ; wrapped with the given ribcage, they will contain substitutions for anything defined
+ ; or imported here. These subsitutions can be used by do-import! and do-import-top! to
+ ; provide access to reexported bindings, for example.
+ (lambda (source-exp fexports ids)
+ (define defined?
+ (lambda (e ids)
+ (ormap (lambda (x)
+ (if (import-interface? x)
+ (let ((x.iface (import-interface-interface x))
+ (x.new-marks (import-interface-new-marks x)))
+ (cond
+ ((interface-token x.iface) =>
+ (lambda (token)
+ (lookup-import-binding-name (id-sym-name e) (id-marks e) token x.new-marks)))
+ (else
+ (let ((v (interface-exports x.iface)))
+ (let lp ((i (fx- (vector-length v) 1)))
+ (and (fx>= i 0)
+ (or (let ((id (vector-ref v i)))
+ (help-bound-id=?
+ (id-sym-name id)
+ (join-marks x.new-marks (id-marks id))
+ (id-sym-name e) (id-marks e)))
+ (lp (fx- i 1)))))))))
+ (bound-id=? e x)))
+ ids)))
+ (let loop ((fexports fexports) (missing '()))
+ (if (null? fexports)
+ (unless (null? missing)
+ (syntax-error (car missing)
+ (if (= (length missing) 1)
+ "missing definition for export"
+ "missing definition for multiple exports, including")))
+ (let ((e (car fexports)) (fexports (cdr fexports)))
+ (if (defined? e ids)
+ (loop fexports missing)
+ (loop fexports (cons e missing))))))))
+
+(define check-defined-ids
+ (lambda (source-exp ls)
+ (define vfold
+ (lambda (v p cls)
+ (let ((len (vector-length v)))
+ (let lp ((i 0) (cls cls))
+ (if (fx= i len)
+ cls
+ (lp (fx+ i 1) (p (vector-ref v i) cls)))))))
+ (define conflicts
+ (lambda (x y cls)
+ (if (import-interface? x)
+ (let ((x.iface (import-interface-interface x))
+ (x.new-marks (import-interface-new-marks x)))
+ (if (import-interface? y)
+ (let ((y.iface (import-interface-interface y))
+ (y.new-marks (import-interface-new-marks y)))
+ (let ((xe (interface-exports x.iface)) (ye (interface-exports y.iface)))
+ (if (fx> (vector-length xe) (vector-length ye))
+ (vfold ye
+ (lambda (id cls)
+ (id-iface-conflicts id y.new-marks x.iface x.new-marks cls)) cls)
+ (vfold xe
+ (lambda (id cls)
+ (id-iface-conflicts id x.new-marks y.iface y.new-marks cls)) cls))))
+ (id-iface-conflicts y '() x.iface x.new-marks cls)))
+ (if (import-interface? y)
+ (let ((y.iface (import-interface-interface y))
+ (y.new-marks (import-interface-new-marks y)))
+ (id-iface-conflicts x '() y.iface y.new-marks cls))
+ (if (bound-id=? x y) (cons x cls) cls)))))
+ (define id-iface-conflicts
+ (lambda (id id.new-marks iface iface.new-marks cls)
+ (let ((id.sym (id-sym-name id))
+ (id.marks (join-marks id.new-marks (id-marks id))))
+ (cond
+ ((interface-token iface) =>
+ (lambda (token)
+ (if (lookup-import-binding-name id.sym id.marks token iface.new-marks)
+ (cons id cls)
+ cls)))
+ (else
+ (vfold (interface-exports iface)
+ (lambda (*id cls)
+ (let ((*id.sym (id-sym-name *id))
+ (*id.marks (join-marks iface.new-marks (id-marks *id))))
+ (if (help-bound-id=? *id.sym *id.marks id.sym id.marks)
+ (cons *id cls)
+ cls)))
+ cls))))))
+ (unless (null? ls)
+ (let lp ((x (car ls)) (ls (cdr ls)) (cls '()))
+ (if (null? ls)
+ (unless (null? cls)
+ (let ((cls (syntax-object->datum cls)))
+ (syntax-error source-exp "duplicate definition for "
+ (symbol->string (car cls))
+ " in")))
+ (let lp2 ((ls2 ls) (cls cls))
+ (if (null? ls2)
+ (lp (car ls) (cdr ls) cls)
+ (lp2 (cdr ls2) (conflicts x (car ls2) cls)))))))))
+
+(define chi-external
+ (lambda (ribcage source-exp body r mr ctem exports fexports meta-residualize!)
+ (define return
+ (lambda (r mr bindings ids inits)
+ (check-defined-ids source-exp ids)
+ (check-module-exports source-exp fexports ids)
+ (values r mr bindings inits)))
+ (define get-implicit-exports
+ (lambda (id)
+ (let f ((exports exports))
+ (if (null? exports)
+ '()
+ (if (and (pair? (car exports)) (bound-id=? id (caar exports)))
+ (flatten-exports (cdar exports))
+ (f (cdr exports)))))))
+ (define update-imp-exports
+ (lambda (bindings exports)
+ (let ((exports (map (lambda (x) (if (pair? x) (car x) x)) exports)))
+ (map (lambda (b)
+ (let ((id (module-binding-id b)))
+ (if (not (bound-id-member? id exports))
+ b
+ (create-module-binding
+ (module-binding-type b)
+ id
+ (module-binding-label b)
+ (append (get-implicit-exports id) (module-binding-imps b))
+ (module-binding-val b)))))
+ bindings))))
+ (let parse ((body body) (r r) (mr mr) (ids '()) (bindings '()) (inits '()) (meta-seen? #f))
+ (if (null? body)
+ (return r mr bindings ids inits)
+ (let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
+ (let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
+ (case type
+ ((define-form)
+ (let-values (((id rhs w) (parse-define e w ae)))
+ (let* ((id (wrap id w))
+ (label (gen-indirect-label))
+ (imps (get-implicit-exports id)))
+ (extend-ribcage! ribcage id label)
+ (cond
+ (meta?
+ (let* ((sym (generate-id (id-sym-name id)))
+ (b (make-binding 'meta-variable sym)))
+ ; add meta bindings only to meta environment
+ (let ((mr (extend-env (get-indirect-label label) b mr)))
+ (let ((exp (chi rhs mr mr w #t)))
+ (define-top-level-value-hook sym (top-level-eval-hook exp))
+ (meta-residualize!
+ (ct-eval/residualize3 ctem
+ void
+ (lambda () (build-global-definition no-source sym exp))))
+ (parse (cdr body) r mr
+ (cons id ids)
+ (cons (create-module-binding 'ctdefine-form id label imps b) bindings)
+ inits
+ #f)))))
+ (else
+ (parse (cdr body) r mr
+ (cons id ids)
+ (cons (create-module-binding type id label
+ imps (make-frob (wrap rhs w) meta?))
+ bindings)
+ inits
+ #f))))))
+ ((define-syntax-form)
+ (let-values (((id rhs w) (parse-define-syntax e w ae)))
+ (let* ((id (wrap id w))
+ (label (gen-indirect-label))
+ (imps (get-implicit-exports id))
+ (exp (chi rhs mr mr w #t)))
+ (extend-ribcage! ribcage id label)
+ (let ((l (get-indirect-label label)) (b (defer-or-eval-transformer top-level-eval-hook exp)))
+ (parse (cdr body)
+ (extend-env l b r)
+ (extend-env l b mr)
+ (cons id ids)
+ (cons (create-module-binding type id label imps (cons b exp))
+ bindings)
+ inits
+ #f)))))
+ (($module-form)
+ (let* ((*ribcage (make-empty-ribcage))
+ (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
+ (let-values (((orig id *exports forms) (parse-module e w ae *w)))
+ (let-values (((r mr *bindings *inits)
+ (chi-external *ribcage orig
+ (map (lambda (d) (make-frob d meta?)) forms)
+ r mr ctem *exports (flatten-exports *exports) meta-residualize!)))
+ (let ((iface (make-unresolved-interface id *exports))
+ (bindings (append *bindings bindings))
+ (inits (append inits *inits))
+ (label (gen-indirect-label))
+ (imps (get-implicit-exports id)))
+ (extend-ribcage! ribcage id label)
+ (let ((l (get-indirect-label label)) (b (make-binding '$module iface)))
+ (parse (cdr body)
+ (extend-env l b r)
+ (extend-env l b mr)
+ (cons id ids)
+ (cons (create-module-binding type id label imps *exports) bindings)
+ inits
+ #f)))))))
+ (($import-form)
+ (let-values (((orig only? mid) (parse-import e w ae)))
+ (let ((mlabel (id-var-name mid empty-wrap)))
+ (let ((binding (lookup mlabel r)))
+ (case (binding-type binding)
+ (($module)
+ (let* ((iface (binding-value binding))
+ (import-iface (make-import-interface iface (import-mark-delta mid iface))))
+ (when only? (extend-ribcage-barrier! ribcage mid))
+ (do-import! import-iface ribcage)
+ (parse (cdr body) r mr
+ (cons import-iface ids)
+ (update-imp-exports bindings (vector->list (interface-exports iface)))
+ inits
+ #f)))
+ ((displaced-lexical) (displaced-lexical-error mid))
+ (else (syntax-error mid "unknown module")))))))
+ ((alias-form)
+ (let-values (((new-id old-id) (parse-alias e w ae)))
+ (let* ((new-id (wrap new-id w))
+ (label (id-var-name-loc old-id w))
+ (imps (get-implicit-exports new-id)))
+ (extend-ribcage! ribcage new-id label)
+ (parse (cdr body) r mr
+ (cons new-id ids)
+ (cons (create-module-binding type new-id label imps #f)
+ bindings)
+ inits
+ #f))))
+ ((begin-form)
+ (parse (let f ((forms (parse-begin e w ae #t)))
+ (if (null? forms)
+ (cdr body)
+ (cons (make-frob (wrap (car forms) w) meta?)
+ (f (cdr forms)))))
+ r mr ids bindings inits #f))
+ ((eval-when-form)
+ (let-values (((when-list forms) (parse-eval-when e w ae)))
+ (parse (if (memq 'eval when-list) ; mode set is implicitly (E)
+ (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (make-frob (wrap (car forms) w) meta?)
+ (f (cdr forms)))))
+ (cdr body))
+ r mr ids bindings inits #f)))
+ ((meta-form)
+ (parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
+ (cdr body))
+ r mr ids bindings inits #t))
+ ((local-syntax-form)
+ (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
+ (parse (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (make-frob (wrap (car forms) w) meta?)
+ (f (cdr forms)))))
+ r mr ids bindings inits #f)))
+ (else ; found an init expression
+ (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
+ (let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
+ (if (or (null? body) (not (frob-meta? (car body))))
+ (return r mr bindings ids (append inits body))
+ (begin
+ ; expand and eval meta inits for effect only
+ (let ((x (chi-meta-frob (car body) mr)))
+ (top-level-eval-hook x)
+ (meta-residualize! (ct-eval/residualize3 ctem void (lambda () x))))
+ (f (cdr body)))))))))))))
+
+(define vmap
+ (lambda (fn v)
+ (do ((i (fx- (vector-length v) 1) (fx- i 1))
+ (ls '() (cons (fn (vector-ref v i)) ls)))
+ ((fx< i 0) ls))))
+
+(define vfor-each
+ (lambda (fn v)
+ (let ((len (vector-length v)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len))
+ (fn (vector-ref v i))))))
+
+(define do-top-import
+ (lambda (import-only? top-ribcage mid token)
+ ; silently treat import-only like regular import at top level
+ (build-cte-install mid
+ (build-data no-source
+ (make-binding 'do-import token))
+ (top-ribcage-key top-ribcage))))
+
+(define update-mode-set
+ (let ((table
+ '((L (load . L) (compile . C) (visit . V) (revisit . R) (eval . -))
+ (C (load . -) (compile . -) (visit . -) (revisit . -) (eval . C))
+ (V (load . V) (compile . C) (visit . V) (revisit . -) (eval . -))
+ (R (load . R) (compile . C) (visit . -) (revisit . R) (eval . -))
+ (E (load . -) (compile . -) (visit . -) (revisit . -) (eval . E)))))
+ (lambda (when-list mode-set)
+ (define remq
+ (lambda (x ls)
+ (if (null? ls)
+ '()
+ (if (eq? (car ls) x)
+ (remq x (cdr ls))
+ (cons (car ls) (remq x (cdr ls)))))))
+ (remq '-
+ (apply append
+ (map (lambda (m)
+ (let ((row (cdr (assq m table))))
+ (map (lambda (s) (cdr (assq s row)))
+ when-list)))
+ mode-set))))))
+
+(define initial-mode-set
+ (lambda (when-list compiling-a-file)
+ (apply append
+ (map (lambda (s)
+ (if compiling-a-file
+ (case s
+ ((compile) '(C))
+ ((load) '(L))
+ ((visit) '(V))
+ ((revisit) '(R))
+ (else '()))
+ (case s
+ ((eval) '(E))
+ (else '()))))
+ when-list))))
+
+(define rt-eval/residualize
+ (lambda (rtem thunk)
+ (if (memq 'E rtem)
+ (thunk)
+ (let ((thunk (if (memq 'C rtem)
+ (let ((x (thunk)))
+ (top-level-eval-hook x)
+ (lambda () x))
+ thunk)))
+ (if (memq 'V rtem)
+ (if (or (memq 'L rtem) (memq 'R rtem))
+ (thunk) ; visit-revisit
+ (build-visit-only (thunk)))
+ (if (or (memq 'L rtem) (memq 'R rtem))
+ (build-revisit-only (thunk))
+ (chi-void)))))))
+
+(define ct-eval/residualize2
+ (lambda (ctem thunk)
+ (let ((t #f))
+ (ct-eval/residualize3 ctem
+ (lambda ()
+ (unless t (set! t (thunk)))
+ (top-level-eval-hook t))
+ (lambda () (or t (thunk)))))))
+(define ct-eval/residualize3
+ (lambda (ctem eval-thunk residualize-thunk)
+ (if (memq 'E ctem)
+ (begin (eval-thunk) (chi-void))
+ (begin
+ (when (memq 'C ctem) (eval-thunk))
+ (if (memq 'R ctem)
+ (if (or (memq 'L ctem) (memq 'V ctem))
+ (residualize-thunk) ; visit-revisit
+ (build-revisit-only (residualize-thunk)))
+ (if (or (memq 'L ctem) (memq 'V ctem))
+ (build-visit-only (residualize-thunk))
+ (chi-void)))))))
+
+(define chi-frobs
+ (lambda (frob* r mr m?)
+ (map (lambda (x) (chi (frob-e x) r mr empty-wrap m?)) frob*)))
+
+(define chi-meta-frob
+ (lambda (x mr)
+ (chi (frob-e x) mr mr empty-wrap #t)))
+
+(define chi-sequence
+ (lambda (body r mr w ae m?)
+ (build-sequence ae
+ (let dobody ((body body))
+ (if (null? body)
+ '()
+ (let ((first (chi (car body) r mr w m?)))
+ (cons first (dobody (cdr body)))))))))
+
+(define chi
+ (lambda (e r mr w m?)
+ (let-values (((type value e w ae) (syntax-type e r w no-source #f)))
+ (chi-expr type value e r mr w ae m?))))
+
+(define chi-expr
+ (lambda (type value e r mr w ae m?)
+ (case type
+ ((lexical)
+ (build-lexical-reference 'value ae value))
+ ((core) (value e r mr w ae m?))
+ ((lexical-call)
+ (chi-application
+ (build-lexical-reference 'fun
+ (let ((x (car e)))
+ (if (syntax-object? x) (syntax-object-expression x) x))
+ value)
+ e r mr w ae m?))
+ ((constant) (build-data ae (strip (source-wrap e w ae) empty-wrap)))
+ ((global) (build-global-reference ae value))
+ ((meta-variable)
+ (if m?
+ (build-global-reference ae value)
+ (displaced-lexical-error (source-wrap e w ae))))
+ ((call) (chi-application (chi (car e) r mr w m?) e r mr w ae m?))
+ ((begin-form) (chi-sequence (parse-begin e w ae #f) r mr w ae m?))
+ ((local-syntax-form)
+ (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
+ (chi-sequence forms r mr w ae m?)))
+ ((eval-when-form)
+ (let-values (((when-list forms) (parse-eval-when e w ae)))
+ (if (memq 'eval when-list) ; mode set is implicitly (E)
+ (chi-sequence forms r mr w ae m?)
+ (chi-void))))
+ ((meta-form)
+ (syntax-error (source-wrap e w ae) "invalid context for meta definition"))
+ ((define-form)
+ (parse-define e w ae)
+ (syntax-error (source-wrap e w ae) "invalid context for definition"))
+ ((define-syntax-form)
+ (parse-define-syntax e w ae)
+ (syntax-error (source-wrap e w ae) "invalid context for definition"))
+ (($module-form)
+ (let-values (((orig id exports forms) (parse-module e w ae w)))
+ (syntax-error orig "invalid context for definition")))
+ (($import-form)
+ (let-values (((orig only? mid) (parse-import e w ae)))
+ (syntax-error orig "invalid context for definition")))
+ ((alias-form)
+ (parse-alias e w ae)
+ (syntax-error (source-wrap e w ae) "invalid context for definition"))
+ ((syntax)
+ (syntax-error (source-wrap e w ae)
+ "reference to pattern variable outside syntax form"))
+ ((displaced-lexical) (displaced-lexical-error (source-wrap e w ae)))
+ (else (syntax-error (source-wrap e w ae))))))
+
+(define chi-application
+ (lambda (x e r mr w ae m?)
+ (syntax-case e ()
+ ((e0 e1 ...)
+ (build-application ae x
+ (map (lambda (e) (chi e r mr w m?)) (syntax (e1 ...)))))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(define chi-set!
+ (lambda (e r w ae rib)
+ (syntax-case e ()
+ ((_ id val)
+ (id? (syntax id))
+ (let ((n (id-var-name (syntax id) w)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((macro!)
+ (let ((id (wrap (syntax id) w)) (val (wrap (syntax val) w)))
+ (syntax-type (chi-macro (binding-value b)
+ `(,(syntax set!) ,id ,val)
+ r empty-wrap #f rib) r empty-wrap #f rib)))
+ (else
+ (values 'core
+ (lambda (e r mr w ae m?)
+ ; repeat lookup in case we were first expression (init) in
+ ; module or lambda body. we repeat id-var-name as well,
+ ; although this is only necessary if we allow inits to
+ ; preced definitions
+ (let ((val (chi (syntax val) r mr w m?))
+ (n (id-var-name (syntax id) w)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((lexical) (build-lexical-assignment ae (binding-value b) val))
+ ((global)
+ (let ((sym (binding-value b)))
+ (when (read-only-binding? n)
+ (syntax-error (source-wrap e w ae)
+ "invalid assignment to read-only variable"))
+ (build-global-assignment ae sym val)))
+ ((meta-variable)
+ (if m?
+ (build-global-assignment ae (binding-value b) val)
+ (displaced-lexical-error (wrap (syntax id) w))))
+ ((displaced-lexical)
+ (displaced-lexical-error (wrap (syntax id) w)))
+ (else (syntax-error (source-wrap e w ae)))))))
+ e w ae))))))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(define chi-macro
+ (lambda (p e r w ae rib)
+ (define rebuild-macro-output
+ (lambda (x m)
+ (cond ((pair? x)
+ (cons (rebuild-macro-output (car x) m)
+ (rebuild-macro-output (cdr x) m)))
+ ((syntax-object? x)
+ (let ((w (syntax-object-wrap x)))
+ (let ((ms (wrap-marks w)) (s (wrap-subst w)))
+ (make-syntax-object (syntax-object-expression x)
+ (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+ (make-wrap (cdr ms) (cdr s))
+ (make-wrap (cons m ms)
+ (if rib
+ (cons rib (cons 'shift s))
+ (cons 'shift s))))))))
+ ((vector? x)
+ (let* ((n (vector-length x)) (v (make-vector n)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i n) v)
+ (vector-set! v i
+ (rebuild-macro-output (vector-ref x i) m)))))
+ ((symbol? x)
+ (syntax-error (source-wrap e w ae)
+ "encountered raw symbol "
+ (symbol->string x)
+ " in output of macro"))
+ (else x))))
+ (rebuild-macro-output
+ (let ((out (p (source-wrap e (anti-mark w) ae))))
+ (if (procedure? out)
+ (out (lambda (id)
+ (unless (identifier? id)
+ (syntax-error id
+ "environment argument is not an identifier"))
+ (lookup (id-var-name id empty-wrap) r)))
+ out))
+ (new-mark))))
+
+(define chi-body
+ (lambda (body outer-form r mr w m?)
+ (let* ((ribcage (make-empty-ribcage))
+ (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))
+ (body (map (lambda (x) (make-frob (wrap x w) #f)) body)))
+ (let-values (((r mr exprs ids vars vals inits)
+ (chi-internal ribcage outer-form body r mr m?)))
+ (when (null? exprs) (syntax-error outer-form "no expressions in body"))
+ (build-body no-source
+ (reverse vars) (chi-frobs (reverse vals) r mr m?)
+ (build-sequence no-source
+ (chi-frobs (append inits exprs) r mr m?)))))))
+
+(define chi-internal
+ ;; In processing the forms of the body, we create a new, empty wrap.
+ ;; This wrap is augmented (destructively) each time we discover that
+ ;; the next form is a definition. This is done:
+ ;;
+ ;; (1) to allow the first nondefinition form to be a call to
+ ;; one of the defined ids even if the id previously denoted a
+ ;; definition keyword or keyword for a macro expanding into a
+ ;; definition;
+ ;; (2) to prevent subsequent definition forms (but unfortunately
+ ;; not earlier ones) and the first nondefinition form from
+ ;; confusing one of the bound identifiers for an auxiliary
+ ;; keyword; and
+ ;; (3) so that we do not need to restart the expansion of the
+ ;; first nondefinition form, which is problematic anyway
+ ;; since it might be the first element of a begin that we
+ ;; have just spliced into the body (meaning if we restarted,
+ ;; we'd really need to restart with the begin or the macro
+ ;; call that expanded into the begin, and we'd have to give
+ ;; up allowing (begin <defn>+ <expr>+), which is itself
+ ;; problematic since we don't know if a begin contains only
+ ;; definitions until we've expanded it).
+ ;;
+ ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
+ ;; into the body.
+ ;;
+ ;; outer-form is fully wrapped w/source
+ (lambda (ribcage source-exp body r mr m?)
+ (define return
+ (lambda (r mr exprs ids vars vals inits)
+ (check-defined-ids source-exp ids)
+ (values r mr exprs ids vars vals inits)))
+ (let parse ((body body) (r r) (mr mr) (ids '()) (vars '()) (vals '()) (inits '()) (meta-seen? #f))
+ (if (null? body)
+ (return r mr body ids vars vals inits)
+ (let* ((fr (car body)) (e (frob-e fr)) (meta? (frob-meta? fr)))
+ (let-values (((type value e w ae) (syntax-type e r empty-wrap no-source ribcage)))
+ (case type
+ ((define-form)
+ (let-values (((id rhs w) (parse-define e w ae)))
+ (let ((id (wrap id w)) (label (gen-label)))
+ (cond
+ (meta?
+ (let ((sym (generate-id (id-sym-name id))))
+ (extend-ribcage! ribcage id label)
+ ; add meta bindings only to meta environment
+ ; so visible only to next higher level and beyond
+ (let ((mr (extend-env label (make-binding 'meta-variable sym) mr)))
+ (define-top-level-value-hook sym
+ (top-level-eval-hook (chi rhs mr mr w #t)))
+ (parse (cdr body) r mr (cons id ids) vars vals inits #f))))
+ (else
+ (let ((var (gen-var id)))
+ (extend-ribcage! ribcage id label)
+ ; add lexical bindings only to run-time environment
+ (parse (cdr body)
+ (extend-env label (make-binding 'lexical var) r)
+ mr
+ (cons id ids)
+ (cons var vars)
+ (cons (make-frob (wrap rhs w) meta?) vals)
+ inits
+ #f)))))))
+ ((define-syntax-form)
+ (let-values (((id rhs w) (parse-define-syntax e w ae)))
+ (let ((id (wrap id w))
+ (label (gen-label))
+ (exp (chi rhs mr mr w #t)))
+ (extend-ribcage! ribcage id label)
+ (let ((b (defer-or-eval-transformer local-eval-hook exp)))
+ (parse (cdr body)
+ (extend-env label b r) (extend-env label b mr)
+ (cons id ids) vars vals inits #f)))))
+ (($module-form)
+ (let* ((*ribcage (make-empty-ribcage))
+ (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
+ (let-values (((orig id exports forms) (parse-module e w ae *w)))
+ (let-values (((r mr *body *ids *vars *vals *inits)
+ (chi-internal *ribcage orig
+ (map (lambda (d) (make-frob d meta?)) forms)
+ r mr m?)))
+ ; valid bound ids checked already by chi-internal
+ (check-module-exports source-exp (flatten-exports exports) *ids)
+ (let ((iface (make-resolved-interface id exports #f))
+ (vars (append *vars vars))
+ (vals (append *vals vals))
+ (inits (append inits *inits *body))
+ (label (gen-label)))
+ (extend-ribcage! ribcage id label)
+ (let ((b (make-binding '$module iface)))
+ (parse (cdr body)
+ (extend-env label b r) (extend-env label b mr)
+ (cons id ids) vars vals inits #f)))))))
+ (($import-form)
+ (let-values (((orig only? mid) (parse-import e w ae)))
+ (let ((mlabel (id-var-name mid empty-wrap)))
+ (let ((binding (lookup mlabel r)))
+ (case (binding-type binding)
+ (($module)
+ (let* ((iface (binding-value binding))
+ (import-iface (make-import-interface iface (import-mark-delta mid iface))))
+ (when only? (extend-ribcage-barrier! ribcage mid))
+ (do-import! import-iface ribcage)
+ (parse (cdr body) r mr (cons import-iface ids) vars vals inits #f)))
+ ((displaced-lexical) (displaced-lexical-error mid))
+ (else (syntax-error mid "unknown module")))))))
+ ((alias-form)
+ (let-values (((new-id old-id) (parse-alias e w ae)))
+ (let ((new-id (wrap new-id w)))
+ (extend-ribcage! ribcage new-id (id-var-name-loc old-id w))
+ (parse (cdr body) r mr
+ (cons new-id ids)
+ vars
+ vals
+ inits
+ #f))))
+ ((begin-form)
+ (parse (let f ((forms (parse-begin e w ae #t)))
+ (if (null? forms)
+ (cdr body)
+ (cons (make-frob (wrap (car forms) w) meta?)
+ (f (cdr forms)))))
+ r mr ids vars vals inits #f))
+ ((eval-when-form)
+ (let-values (((when-list forms) (parse-eval-when e w ae)))
+ (parse (if (memq 'eval when-list) ; mode set is implicitly (E)
+ (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (make-frob (wrap (car forms) w) meta?)
+ (f (cdr forms)))))
+ (cdr body))
+ r mr ids vars vals inits #f)))
+ ((meta-form)
+ (parse (cons (make-frob (wrap (parse-meta e w ae) w) #t)
+ (cdr body))
+ r mr ids vars vals inits #t))
+ ((local-syntax-form)
+ (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
+ (parse (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (make-frob (wrap (car forms) w) meta?)
+ (f (cdr forms)))))
+ r mr ids vars vals inits #f)))
+ (else ; found a non-definition
+ (when meta-seen? (syntax-error (source-wrap e w ae) "invalid meta definition"))
+ (let f ((body (cons (make-frob (source-wrap e w ae) meta?) (cdr body))))
+ (if (or (null? body) (not (frob-meta? (car body))))
+ (return r mr body ids vars vals inits)
+ (begin
+ ; expand meta inits for effect only
+ (top-level-eval-hook (chi-meta-frob (car body) mr))
+ (f (cdr body)))))))))))))
+
+(define import-mark-delta
+ ; returns list of marks layered on top of module id beyond those
+ ; cached in the interface
+ (lambda (mid iface)
+ (diff-marks (id-marks mid) (interface-marks iface))))
+
+(define lookup-import-label
+ (lambda (id)
+ (let ((label (id-var-name-loc id empty-wrap)))
+ (unless label
+ (syntax-error id "exported identifier not visible"))
+ label)))
+
+(define do-import!
+ (lambda (import-iface ribcage)
+ (let ((ie (interface-exports (import-interface-interface import-iface))))
+ (if (<= (vector-length ie) 20)
+ (let ((new-marks (import-interface-new-marks import-iface)))
+ (vfor-each
+ (lambda (id)
+ (import-extend-ribcage! ribcage new-marks id
+ (lookup-import-label id)))
+ ie))
+ (extend-ribcage-subst! ribcage import-iface)))))
+
+(define parse-module
+ (lambda (e w ae *w)
+ (define listify
+ (lambda (exports)
+ (if (null? exports)
+ '()
+ (cons (syntax-case (car exports) ()
+ ((ex ...) (listify (syntax (ex ...))))
+ (x (if (id? (syntax x))
+ (wrap (syntax x) *w)
+ (syntax-error (source-wrap e w ae)
+ "invalid exports list in"))))
+ (listify (cdr exports))))))
+ (syntax-case e ()
+ ((_ orig mid (ex ...) form ...)
+ (id? (syntax mid))
+ ; id receives old wrap so it won't be confused with id of same name
+ ; defined within the module
+ (values (syntax orig) (wrap (syntax mid) w) (listify (syntax (ex ...))) (map (lambda (x) (wrap x *w)) (syntax (form ...)))))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(define parse-import
+ (lambda (e w ae)
+ (syntax-case e ()
+ ((_ orig #t mid)
+ (id? (syntax mid))
+ (values (syntax orig) #t (wrap (syntax mid) w)))
+ ((_ orig #f mid)
+ (id? (syntax mid))
+ (values (syntax orig) #f (wrap (syntax mid) w)))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(define parse-define
+ (lambda (e w ae)
+ (syntax-case e ()
+ ((_ name val)
+ (id? (syntax name))
+ (values (syntax name) (syntax val) w))
+ ((_ (name . args) e1 e2 ...)
+ (and (id? (syntax name))
+ (valid-bound-ids? (lambda-var-list (syntax args))))
+ (values (wrap (syntax name) w)
+ (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
+ empty-wrap))
+ ((_ name)
+ (id? (syntax name))
+ (values (wrap (syntax name) w) (syntax (void)) empty-wrap))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(define parse-define-syntax
+ (lambda (e w ae)
+ (syntax-case e ()
+ ((_ (name id) e1 e2 ...)
+ (and (id? (syntax name)) (id? (syntax id)))
+ (values (wrap (syntax name) w)
+ `(,(syntax lambda) ,(wrap (syntax (id)) w)
+ ,@(wrap (syntax (e1 e2 ...)) w))
+ empty-wrap))
+ ((_ name val)
+ (id? (syntax name))
+ (values (syntax name) (syntax val) w))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(define parse-meta
+ (lambda (e w ae)
+ (syntax-case e ()
+ ((_ . form) (syntax form))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(define parse-eval-when
+ (lambda (e w ae)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (values (chi-when-list (syntax (x ...)) w) (syntax (e1 e2 ...))))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(define parse-alias
+ (lambda (e w ae)
+ (syntax-case e ()
+ ((_ new-id old-id)
+ (and (id? (syntax new-id)) (id? (syntax old-id)))
+ (values (syntax new-id) (syntax old-id)))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(define parse-begin
+ (lambda (e w ae empty-okay?)
+ (syntax-case e ()
+ ((_) empty-okay? '())
+ ((_ e1 e2 ...) (syntax (e1 e2 ...)))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(define chi-lambda-clause
+ (lambda (e c r mr w m?)
+ (syntax-case c ()
+ (((id ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (syntax-error e "invalid parameter list in")
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (values
+ new-vars
+ (chi-body (syntax (e1 e2 ...))
+ e
+ (extend-var-env* labels new-vars r)
+ mr
+ (make-binding-wrap ids labels w)
+ m?))))))
+ ((ids e1 e2 ...)
+ (let ((old-ids (lambda-var-list (syntax ids))))
+ (if (not (valid-bound-ids? old-ids))
+ (syntax-error e "invalid parameter list in")
+ (let ((labels (gen-labels old-ids))
+ (new-vars (map gen-var old-ids)))
+ (values
+ (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
+ (if (null? ls1)
+ ls2
+ (f (cdr ls1) (cons (car ls1) ls2))))
+ (chi-body (syntax (e1 e2 ...))
+ e
+ (extend-var-env* labels new-vars r)
+ mr
+ (make-binding-wrap old-ids labels w)
+ m?))))))
+ (_ (syntax-error e)))))
+
+(define chi-local-syntax
+ (lambda (rec? e r mr w ae)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
+ (source-wrap e w ae)
+ "keyword")
+ (let ((labels (gen-labels ids)))
+ (let ((new-w (make-binding-wrap ids labels w)))
+ (let ((b* (let ((w (if rec? new-w w)))
+ (map (lambda (x)
+ (defer-or-eval-transformer
+ local-eval-hook
+ (chi x mr mr w #t)))
+ (syntax (val ...))))))
+ (values
+ (syntax (e1 e2 ...))
+ (extend-env* labels b* r)
+ (extend-env* labels b* mr)
+ new-w
+ ae)))))))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(define chi-void
+ (lambda ()
+ (build-application no-source (build-primref no-source 'void) '())))
+
+(define ellipsis?
+ (lambda (x)
+ (and (nonsymbol-id? x)
+ (literal-id=? x (syntax (... ...))))))
+
+;;; data
+
+;;; strips all annotations from potentially circular reader output.
+
+(define strip-annotation
+ (lambda (x)
+ (cond
+ ((pair? x)
+ (cons (strip-annotation (car x))
+ (strip-annotation (cdr x))))
+ ((annotation? x) (annotation-stripped x))
+ (else x))))
+
+;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
+;;; on an annotation, strips the annotation as well.
+;;; since only the head of a list is annotated by the reader, not each pair
+;;; in the spine, we also check for pairs whose cars are annotated in case
+;;; we've been passed the cdr of an annotated list
+
+(define strip*
+ (lambda (x w fn)
+ (if (top-marked? w)
+ (fn x)
+ (let f ((x x))
+ (cond
+ ((syntax-object? x)
+ (strip* (syntax-object-expression x) (syntax-object-wrap x) fn))
+ ((pair? x)
+ (let ((a (f (car x))) (d (f (cdr x))))
+ (if (and (eq? a (car x)) (eq? d (cdr x)))
+ x
+ (cons a d))))
+ ((vector? x)
+ (let ((old (vector->list x)))
+ (let ((new (map f old)))
+ (if (andmap eq? old new) x (list->vector new)))))
+ (else x))))))
+
+(define strip
+ (lambda (x w)
+ (strip* x w
+ (lambda (x)
+ (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
+ (strip-annotation x)
+ x)))))
+
+;;; lexical variables
+
+(define gen-var
+ (lambda (id)
+ (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
+ (if (annotation? id)
+ (build-lexical-var id (annotation-expression id))
+ (build-lexical-var id id)))))
+
+(define lambda-var-list
+ (lambda (vars)
+ (let lvl ((vars vars) (ls '()) (w empty-wrap))
+ (cond
+ ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
+ ((id? vars) (cons (wrap vars w) ls))
+ ((null? vars) ls)
+ ((syntax-object? vars)
+ (lvl (syntax-object-expression vars)
+ ls
+ (join-wraps w (syntax-object-wrap vars))))
+ ((annotation? vars)
+ (lvl (annotation-expression vars) ls w))
+ ; include anything else to be caught by subsequent error
+ ; checking
+ (else (cons vars ls))))))
+
+
+; must precede global-extends
+
+(set! $sc-put-cte
+ (lambda (id b top-token)
+ (define sc-put-module
+ (lambda (exports token new-marks)
+ (vfor-each
+ (lambda (id) (store-import-binding id token new-marks))
+ exports)))
+ (define (put-cte id binding token)
+ (let ((sym (if (symbol? id) id (id-var-name id empty-wrap))))
+ (store-import-binding id token '())
+ (put-global-definition-hook sym
+ ; global binding is assumed; if global pass #f to remove existing binding, if any
+ (if (and (eq? (binding-type binding) 'global)
+ (eq? (binding-value binding) sym))
+ #f
+ binding))))
+ (let ((binding (make-transformer-binding b)))
+ (case (binding-type binding)
+ (($module)
+ (let ((iface (binding-value binding)))
+ (sc-put-module (interface-exports iface) (interface-token iface) '()))
+ (put-cte id binding top-token))
+ ((do-alias) (store-import-binding id top-token '()))
+ ((do-import)
+ ; fake binding: id is module id binding-value is token
+ (let ((token (binding-value b)))
+ (let ((b (lookup (id-var-name id empty-wrap) null-env)))
+ (case (binding-type b)
+ (($module)
+ (let* ((iface (binding-value b))
+ (exports (interface-exports iface)))
+ (unless (eq? (interface-token iface) token)
+ (syntax-error id "import mismatch for module"))
+ (sc-put-module (interface-exports iface) top-token
+ (import-mark-delta id iface))))
+ (else (syntax-error id "unknown module"))))))
+ (else (put-cte id binding top-token))))
+ ))
+
+
+;;; core transformers
+
+(global-extend 'local-syntax 'letrec-syntax #t)
+(global-extend 'local-syntax 'let-syntax #f)
+
+
+(global-extend 'core 'fluid-let-syntax
+ (lambda (e r mr w ae m?)
+ (syntax-case e ()
+ ((_ ((var val) ...) e1 e2 ...)
+ (valid-bound-ids? (syntax (var ...)))
+ (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
+ (for-each
+ (lambda (id n)
+ (case (binding-type (lookup n r))
+ ((displaced-lexical) (displaced-lexical-error (wrap id w)))))
+ (syntax (var ...))
+ names)
+ (let ((b* (map (lambda (x)
+ (defer-or-eval-transformer
+ local-eval-hook
+ (chi x mr mr w #t)))
+ (syntax (val ...)))))
+ (chi-body
+ (syntax (e1 e2 ...))
+ (source-wrap e w ae)
+ (extend-env* names b* r)
+ (extend-env* names b* mr)
+ w
+ m?))))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(global-extend 'core 'quote
+ (lambda (e r mr w ae m?)
+ (syntax-case e ()
+ ((_ e) (build-data ae (strip (syntax e) w)))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+(global-extend 'core 'syntax
+ (let ()
+ (define gen-syntax
+ (lambda (src e r maps ellipsis? vec?)
+ (if (id? e)
+ (let ((label (id-var-name e empty-wrap)))
+ (let ((b (lookup label r)))
+ (if (eq? (binding-type b) 'syntax)
+ (let-values (((var maps)
+ (let ((var.lev (binding-value b)))
+ (gen-ref src (car var.lev) (cdr var.lev) maps))))
+ (values `(ref ,var) maps))
+ (if (ellipsis? e)
+ (syntax-error src "misplaced ellipsis in syntax form")
+ (values `(quote ,e) maps)))))
+ (syntax-case e ()
+ ((dots e)
+ (ellipsis? (syntax dots))
+ (if vec?
+ (syntax-error src "misplaced ellipsis in syntax template")
+ (gen-syntax src (syntax e) r maps (lambda (x) #f) #f)))
+ ((x dots . y)
+ ; this could be about a dozen lines of code, except that we
+ ; choose to handle (syntax (x ... ...)) forms
+ (ellipsis? (syntax dots))
+ (let f ((y (syntax y))
+ (k (lambda (maps)
+ (let-values (((x maps)
+ (gen-syntax src (syntax x) r
+ (cons '() maps) ellipsis? #f)))
+ (if (null? (car maps))
+ (syntax-error src
+ "extra ellipsis in syntax form")
+ (values (gen-map x (car maps))
+ (cdr maps)))))))
+ (syntax-case y ()
+ ((dots . y)
+ (ellipsis? (syntax dots))
+ (f (syntax y)
+ (lambda (maps)
+ (let-values (((x maps) (k (cons '() maps))))
+ (if (null? (car maps))
+ (syntax-error src
+ "extra ellipsis in syntax form")
+ (values (gen-mappend x (car maps))
+ (cdr maps)))))))
+ (_ (let-values (((y maps) (gen-syntax src y r maps ellipsis? vec?)))
+ (let-values (((x maps) (k maps)))
+ (values (gen-append x y) maps)))))))
+ ((x . y)
+ (let-values (((xnew maps) (gen-syntax src (syntax x) r maps ellipsis? #f)))
+ (let-values (((ynew maps) (gen-syntax src (syntax y) r maps ellipsis? vec?)))
+ (values (gen-cons e (syntax x) (syntax y) xnew ynew)
+ maps))))
+ (#(x1 x2 ...)
+ (let ((ls (syntax (x1 x2 ...))))
+ (let-values (((lsnew maps) (gen-syntax src ls r maps ellipsis? #t)))
+ (values (gen-vector e ls lsnew) maps))))
+ (_ (values `(quote ,e) maps))))))
+
+ (define gen-ref
+ (lambda (src var level maps)
+ (if (fx= level 0)
+ (values var maps)
+ (if (null? maps)
+ (syntax-error src "missing ellipsis in syntax form")
+ (let-values (((outer-var outer-maps) (gen-ref src var (fx- level 1) (cdr maps))))
+ (let ((b (assq outer-var (car maps))))
+ (if b
+ (values (cdr b) maps)
+ (let ((inner-var (gen-var 'tmp)))
+ (values inner-var
+ (cons (cons (cons outer-var inner-var)
+ (car maps))
+ outer-maps))))))))))
+
+ (define gen-append
+ (lambda (x y)
+ (if (equal? y '(quote ()))
+ x
+ `(append ,x ,y))))
+
+ (define gen-mappend
+ (lambda (e map-env)
+ `(apply (primitive append) ,(gen-map e map-env))))
+
+ (define gen-map
+ (lambda (e map-env)
+ (let ((formals (map cdr map-env))
+ (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
+ (cond
+ ((eq? (car e) 'ref)
+ ; identity map equivalence:
+ ; (map (lambda (x) x) y) == y
+ (car actuals))
+ ((andmap
+ (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+ (cdr e))
+ ; eta map equivalence:
+ ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
+ `(map (primitive ,(car e))
+ ,@(map (let ((r (map cons formals actuals)))
+ (lambda (x) (cdr (assq (cadr x) r))))
+ (cdr e))))
+ (else `(map (lambda ,formals ,e) ,@actuals))))))
+
+ ; 12/12/00: semantic change: we now return original syntax object (e)
+ ; if no pattern variables were found within, to avoid dropping
+ ; source annotations prematurely. the "syntax returns lists" for
+ ; lists in its input guarantee counts only for substructure that
+ ; contains pattern variables
+ (define gen-cons
+ (lambda (e x y xnew ynew)
+ (case (car ynew)
+ ((quote)
+ (if (eq? (car xnew) 'quote)
+ (let ((xnew (cadr xnew)) (ynew (cadr ynew)))
+ (if (and (eq? xnew x) (eq? ynew y))
+ `',e
+ `'(,xnew . ,ynew)))
+ (if (eq? (cadr ynew) '()) `(list ,xnew) `(cons ,xnew ,ynew))))
+ ((list) `(list ,xnew ,@(cdr ynew)))
+ (else `(cons ,xnew ,ynew)))))
+
+ (define gen-vector
+ (lambda (e ls lsnew)
+ (cond
+ ((eq? (car lsnew) 'quote)
+ (if (eq? (cadr lsnew) ls)
+ `',e
+ `(quote #(,@(cadr lsnew)))))
+ ((eq? (car lsnew) 'list) `(vector ,@(cdr lsnew)))
+ (else `(list->vector ,lsnew)))))
+
+
+ (define regen
+ (lambda (x)
+ (case (car x)
+ ((ref) (build-lexical-reference 'value no-source (cadr x)))
+ ((primitive) (build-primref no-source (cadr x)))
+ ((quote) (build-data no-source (cadr x)))
+ ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
+ ((map) (let ((ls (map regen (cdr x))))
+ (build-application no-source
+ (if (fx= (length ls) 2)
+ (build-primref no-source 'map)
+ ; really need to do our own checking here
+ (build-primref no-source 2 'map)) ; require error check
+ ls)))
+ (else (build-application no-source
+ (build-primref no-source (car x))
+ (map regen (cdr x)))))))
+
+ (lambda (e r mr w ae m?)
+ (let ((e (source-wrap e w ae)))
+ (syntax-case e ()
+ ((_ x)
+ (let-values (((e maps) (gen-syntax e (syntax x) r '() ellipsis? #f)))
+ (regen e)))
+ (_ (syntax-error e)))))))
+
+
+(global-extend 'core 'lambda
+ (lambda (e r mr w ae m?)
+ (syntax-case e ()
+ ((_ . c)
+ (let-values (((vars body) (chi-lambda-clause (source-wrap e w ae) (syntax c) r mr w m?)))
+ (build-lambda ae vars body))))))
+
+
+(global-extend 'core 'letrec
+ (lambda (e r mr w ae m?)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
+ (source-wrap e w ae) "bound variable")
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (let ((w (make-binding-wrap ids labels w))
+ (r (extend-var-env* labels new-vars r)))
+ (build-letrec ae
+ new-vars
+ (map (lambda (x) (chi x r mr w m?)) (syntax (val ...)))
+ (chi-body (syntax (e1 e2 ...)) (source-wrap e w ae) r mr w m?)))))))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+
+(global-extend 'core 'if
+ (lambda (e r mr w ae m?)
+ (syntax-case e ()
+ ((_ test then)
+ (build-conditional ae
+ (chi (syntax test) r mr w m?)
+ (chi (syntax then) r mr w m?)
+ (chi-void)))
+ ((_ test then else)
+ (build-conditional ae
+ (chi (syntax test) r mr w m?)
+ (chi (syntax then) r mr w m?)
+ (chi (syntax else) r mr w m?)))
+ (_ (syntax-error (source-wrap e w ae))))))
+
+
+
+(global-extend 'set! 'set! '())
+
+(global-extend 'alias 'alias '())
+(global-extend 'begin 'begin '())
+
+(global-extend '$module-key '$module '())
+(global-extend '$import '$import '())
+
+(global-extend 'define 'define '())
+
+(global-extend 'define-syntax 'define-syntax '())
+
+(global-extend 'eval-when 'eval-when '())
+
+(global-extend 'meta 'meta '())
+
+(global-extend 'core 'syntax-case
+ (let ()
+ (define convert-pattern
+ ; accepts pattern & keys
+ ; returns syntax-dispatch pattern & ids
+ (lambda (pattern keys)
+ (define cvt*
+ (lambda (p* n ids)
+ (if (null? p*)
+ (values '() ids)
+ (let-values (((y ids) (cvt* (cdr p*) n ids)))
+ (let-values (((x ids) (cvt (car p*) n ids)))
+ (values (cons x y) ids))))))
+ (define cvt
+ (lambda (p n ids)
+ (if (id? p)
+ (if (bound-id-member? p keys)
+ (values (vector 'free-id p) ids)
+ (values 'any (cons (cons p n) ids)))
+ (syntax-case p ()
+ ((x dots)
+ (ellipsis? (syntax dots))
+ (let-values (((p ids) (cvt (syntax x) (fx+ n 1) ids)))
+ (values (if (eq? p 'any) 'each-any (vector 'each p))
+ ids)))
+ ((x dots y ... . z)
+ (ellipsis? (syntax dots))
+ (let-values (((z ids) (cvt (syntax z) n ids)))
+ (let-values (((y ids) (cvt* (syntax (y ...)) n ids)))
+ (let-values (((x ids) (cvt (syntax x) (fx+ n 1) ids)))
+ (values `#(each+ ,x ,(reverse y) ,z) ids)))))
+ ((x . y)
+ (let-values (((y ids) (cvt (syntax y) n ids)))
+ (let-values (((x ids) (cvt (syntax x) n ids)))
+ (values (cons x y) ids))))
+ (() (values '() ids))
+ (#(x ...)
+ (let-values (((p ids) (cvt (syntax (x ...)) n ids)))
+ (values (vector 'vector p) ids)))
+ (x (values (vector 'atom (strip p empty-wrap)) ids))))))
+ (cvt pattern 0 '())))
+
+ (define build-dispatch-call
+ (lambda (pvars exp y r mr m?)
+ (let ((ids (map car pvars)) (levels (map cdr pvars)))
+ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+ (build-application no-source
+ (build-primref no-source 'apply)
+ (list (build-lambda no-source new-vars
+ (chi exp
+ (extend-env*
+ labels
+ (map (lambda (var level)
+ (make-binding 'syntax `(,var . ,level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ mr
+ (make-binding-wrap ids labels empty-wrap)
+ m?))
+ y))))))
+
+ (define gen-clause
+ (lambda (x keys clauses r mr m? pat fender exp)
+ (let-values (((p pvars) (convert-pattern pat keys)))
+ (cond
+ ((not (distinct-bound-ids? (map car pvars)))
+ (invalid-ids-error (map car pvars) pat "pattern variable"))
+ ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
+ (syntax-error pat
+ "misplaced ellipsis in syntax-case pattern"))
+ (else
+ (let ((y (gen-var 'tmp)))
+ ; fat finger binding and references to temp variable y
+ (build-application no-source
+ (build-lambda no-source (list y)
+ (let-syntax ((y (identifier-syntax
+ (build-lexical-reference 'value no-source y))))
+ (build-conditional no-source
+ (syntax-case fender ()
+ (#t y)
+ (_ (build-conditional no-source
+ y
+ (build-dispatch-call pvars fender y r mr m?)
+ (build-data no-source #f))))
+ (build-dispatch-call pvars exp y r mr m?)
+ (gen-syntax-case x keys clauses r mr m?))))
+ (list (if (eq? p 'any)
+ (build-application no-source
+ (build-primref no-source 'list)
+ (list (build-lexical-reference no-source 'value x)))
+ (build-application no-source
+ (build-primref no-source '$syntax-dispatch)
+ (list (build-lexical-reference no-source 'value x)
+ (build-data no-source p))))))))))))
+
+ (define gen-syntax-case
+ (lambda (x keys clauses r mr m?)
+ (if (null? clauses)
+ (build-application no-source
+ (build-primref no-source 'syntax-error)
+ (list (build-lexical-reference 'value no-source x)))
+ (syntax-case (car clauses) ()
+ ((pat exp)
+ (if (and (id? (syntax pat))
+ (not (bound-id-member? (syntax pat) keys))
+ (not (ellipsis? (syntax pat))))
+ (let ((label (gen-label))
+ (var (gen-var (syntax pat))))
+ (build-application no-source
+ (build-lambda no-source (list var)
+ (chi (syntax exp)
+ (extend-env label (make-binding 'syntax `(,var . 0)) r)
+ mr
+ (make-binding-wrap (syntax (pat))
+ (list label) empty-wrap)
+ m?))
+ (list (build-lexical-reference 'value no-source x))))
+ (gen-clause x keys (cdr clauses) r mr m?
+ (syntax pat) #t (syntax exp))))
+ ((pat fender exp)
+ (gen-clause x keys (cdr clauses) r mr m?
+ (syntax pat) (syntax fender) (syntax exp)))
+ (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
+
+ (lambda (e r mr w ae m?)
+ (let ((e (source-wrap e w ae)))
+ (syntax-case e ()
+ ((_ val (key ...) m ...)
+ (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
+ (syntax (key ...)))
+ (let ((x (gen-var 'tmp)))
+ ; fat finger binding and references to temp variable x
+ (build-application ae
+ (build-lambda no-source (list x)
+ (gen-syntax-case x
+ (syntax (key ...)) (syntax (m ...))
+ r mr m?))
+ (list (chi (syntax val) r mr empty-wrap m?))))
+ (syntax-error e "invalid literals list in"))))))))
+
+(put-cte-hook 'module
+ (lambda (x)
+ (define proper-export?
+ (lambda (e)
+ (syntax-case e ()
+ ((id e ...)
+ (and (identifier? (syntax id))
+ (andmap proper-export? (syntax (e ...)))))
+ (id (identifier? (syntax id))))))
+ (with-syntax ((orig x))
+ (syntax-case x ()
+ ((_ (e ...) d ...)
+ (if (andmap proper-export? (syntax (e ...)))
+ (syntax (begin ($module orig anon (e ...) d ...) ($import orig #f anon)))
+ (syntax-error x "invalid exports list in")))
+ ((_ m (e ...) d ...)
+ (identifier? (syntax m))
+ (if (andmap proper-export? (syntax (e ...)))
+ (syntax ($module orig m (e ...) d ...))
+ (syntax-error x "invalid exports list in")))))))
+
+(let ()
+ (define $module-exports
+ (lambda (m r)
+ (let ((b (r m)))
+ (case (binding-type b)
+ (($module)
+ (let* ((interface (binding-value b))
+ (new-marks (import-mark-delta m interface)))
+ (vmap (lambda (x)
+ (let ((id (if (pair? x) (car x) x)))
+ (make-syntax-object
+ (syntax-object->datum id)
+ (let ((marks (join-marks new-marks (wrap-marks (syntax-object-wrap id)))))
+ (make-wrap marks
+ ; the anti mark should always be present at the head
+ ; of new-marks, but we paranoically check anyway
+ (if (eq? (car marks) the-anti-mark)
+ (cons 'shift (wrap-subst top-wrap))
+ (wrap-subst top-wrap)))))))
+ (interface-exports interface))))
+ ((displaced-lexical) (displaced-lexical-error m))
+ (else (syntax-error m "unknown module"))))))
+ (define $import-help
+ (lambda (orig import-only?)
+ (lambda (r)
+ (define difference
+ (lambda (ls1 ls2)
+ (if (null? ls1)
+ ls1
+ (if (bound-id-member? (car ls1) ls2)
+ (difference (cdr ls1) ls2)
+ (cons (car ls1) (difference (cdr ls1) ls2))))))
+ (define prefix-add
+ (lambda (prefix-id)
+ (let ((prefix (symbol->string (syntax-object->datum prefix-id))))
+ (lambda (id)
+ (datum->syntax-object id
+ (string->symbol
+ (string-append prefix
+ (symbol->string (syntax-object->datum id)))))))))
+ (define prefix-drop
+ (lambda (prefix-id)
+ (let ((prefix (symbol->string (syntax-object->datum prefix-id))))
+ (lambda (id)
+ (let ((s (symbol->string (syntax-object->datum id))))
+ (let ((np (string-length prefix)) (ns (string-length s)))
+ (unless (and (>= ns np) (string=? (substring s 0 np) prefix))
+ (syntax-error id (string-append "missing expected prefix " prefix)))
+ (datum->syntax-object id
+ (string->symbol (substring s np ns)))))))))
+ (define gen-mid
+ (lambda (mid)
+ ; introduced module ids must have same marks as original
+ ; for import-only, since the barrier carries the marks of
+ ; the module id
+ (datum->syntax-object mid (generate-id (id-sym-name mid)))))
+ (define (modspec m exports?)
+ (with-syntax ((orig orig) (import-only? import-only?))
+ (syntax-case m (only-for-syntax also-for-syntax
+ only except
+ add-prefix drop-prefix rename alias)
+ ((only m id ...)
+ (andmap identifier? (syntax (id ...)))
+ (let-values (((mid d exports) (modspec (syntax m) #f)))
+ (with-syntax ((d d) (tmid (gen-mid mid)))
+ (values mid
+ (syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
+ (and exports? (syntax (id ...)))))))
+ ((except m id ...)
+ (andmap identifier? (syntax (id ...)))
+ (let-values (((mid d exports) (modspec (syntax m) #t)))
+ (with-syntax ((d d)
+ (tmid (gen-mid mid))
+ ((id ...) (difference exports (syntax (id ...)))))
+ (values mid
+ (syntax (begin ($module orig tmid (id ...) d) ($import orig import-only? tmid)))
+ (and exports? (syntax (id ...)))))))
+ ((add-prefix m prefix-id)
+ (identifier? (syntax prefix-id))
+ (let-values (((mid d exports) (modspec (syntax m) #t)))
+ (with-syntax ((d d)
+ (tmid (gen-mid mid))
+ ((old-id ...) exports)
+ ((tmp ...) (generate-temporaries exports))
+ ((id ...) (map (prefix-add (syntax prefix-id)) exports)))
+ (values mid
+ (syntax (begin ($module orig tmid ((id tmp) ...)
+ ($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
+ ($import orig import-only? tmid)
+ (alias id tmp) ...)
+ ($import orig import-only? tmid)))
+ (and exports? (syntax (id ...)))))))
+ ((drop-prefix m prefix-id)
+ (identifier? (syntax prefix-id))
+ (let-values (((mid d exports) (modspec (syntax m) #t)))
+ (with-syntax ((d d)
+ (tmid (gen-mid mid))
+ ((old-id ...) exports)
+ ((tmp ...) (generate-temporaries exports))
+ ((id ...) (map (prefix-drop (syntax prefix-id)) exports)))
+ (values mid
+ (syntax (begin ($module orig tmid ((id tmp) ...)
+ ($module orig tmid ((tmp old-id) ...) d (alias tmp old-id) ...)
+ ($import orig import-only? tmid)
+ (alias id tmp) ...)
+ ($import orig import-only? tmid)))
+ (and exports? (syntax (id ...)))))))
+ ((rename m (new-id old-id) ...)
+ (and (andmap identifier? (syntax (new-id ...)))
+ (andmap identifier? (syntax (old-id ...))))
+ (let-values (((mid d exports) (modspec (syntax m) #t)))
+ (with-syntax ((d d)
+ (tmid (gen-mid mid))
+ ((tmp ...) (generate-temporaries (syntax (old-id ...))))
+ ((other-id ...) (difference exports (syntax (old-id ...)))))
+ (values mid
+ (syntax (begin ($module orig tmid ((new-id tmp) ... other-id ...)
+ ($module orig tmid (other-id ... (tmp old-id) ...) d (alias tmp old-id) ...)
+ ($import orig import-only? tmid)
+ (alias new-id tmp) ...)
+ ($import orig import-only? tmid)))
+ (and exports? (syntax (new-id ... other-id ...)))))))
+ ((alias m (new-id old-id) ...)
+ (and (andmap identifier? (syntax (new-id ...)))
+ (andmap identifier? (syntax (old-id ...))))
+ (let-values (((mid d exports) (modspec (syntax m) #t)))
+ (with-syntax ((d d)
+ (tmid (gen-mid mid))
+ ((other-id ...) exports))
+ (values mid
+ (syntax (begin ($module orig tmid ((new-id old-id) ... other-id ...) d (alias new-id old-id) ...)
+ ($import orig import-only? tmid)))
+ (and exports? (syntax (new-id ... other-id ...)))))))
+ ; base cases
+ (mid
+ (identifier? (syntax mid))
+ (values (syntax mid)
+ (syntax ($import orig import-only? mid))
+ (and exports? ($module-exports (syntax mid) r))))
+ ((mid)
+ (identifier? (syntax mid))
+ (values (syntax mid)
+ (syntax ($import orig import-only? mid))
+ (and exports? ($module-exports (syntax mid) r))))
+ (_ (syntax-error m "invalid module specifier")))))
+ (define modspec*
+ (lambda (m)
+ (let-values (((mid d exports) (modspec m #f))) d)))
+ (syntax-case orig ()
+ ((_ m ...)
+ (with-syntax (((d ...) (map modspec* (syntax (m ...)))))
+ (syntax (begin d ...))))))))
+
+ (put-cte-hook 'import
+ (lambda (orig)
+ ($import-help orig #f)))
+
+ (put-cte-hook 'import-only
+ (lambda (orig)
+ ($import-help orig #t)))
+)
+
+;;; To support eval-when, we maintain two mode sets:
+;;;
+;;; ctem (compile-time-expression mode)
+;;; determines whether/when to evaluate compile-time expressions such
+;;; as macro definitions, module definitions, and compile-time
+;;; registration of variable definitions
+;;;
+;;; rtem (run-time-expression mode)
+;;; determines whether/when to evaluate run-time expressions such
+;;; as the actual assignment performed by a variable definition or
+;;; arbitrary top-level expressions
+
+;;; Possible modes in the mode set are:
+;;;
+;;; L (load): evaluate at load time. implies V for compile-time
+;;; expressions and R for run-time expressions.
+;;;
+;;; C (compile): evaluate at compile (file) time
+;;;
+;;; E (eval): evaluate at evaluation (compile or interpret) time
+;;;
+;;; V (visit): evaluate at visit time
+;;;
+;;; R (revisit): evaluate at revisit time
+
+;;; The mode set for the body of an eval-when is determined by
+;;; translating each mode in the old mode set based on the situations
+;;; present in the eval-when form and combining these into a set,
+;;; using the following table. See also update-mode-set.
+
+;;; load compile visit revisit eval
+;;;
+;;; L L C V R -
+;;;
+;;; C - - - - C
+;;;
+;;; V V C V - -
+;;;
+;;; R R C - R -
+;;;
+;;; E - - - - E
+
+;;; When we complete the expansion of a compile or run-time expression,
+;;; the current ctem or rtem determines how the expression will be
+;;; treated. See ct-eval/residualize and rt-eval/residualize.
+
+;;; Initial mode sets
+;;;
+;;; when compiling a file:
+;;;
+;;; initial ctem: (L C)
+;;;
+;;; initial rtem: (L)
+;;;
+;;; when not compiling a file:
+;;;
+;;; initial ctem: (E)
+;;;
+;;; initial rtem: (E)
+;;;
+;;;
+;;; This means that top-level syntactic definitions are evaluated
+;;; immediately after they are expanded, and the expanded definitions
+;;; are also residualized into the object file if we are compiling
+;;; a file.
+
+(set! sc-expand
+ (let ((ctem '(E)) (rtem '(E)))
+ (lambda (x)
+ (let ((env (interaction-environment)))
+ (if (and (pair? x) (equal? (car x) noexpand))
+ (cadr x)
+ (chi-top* x null-env
+ (env-wrap env)
+ ctem rtem #f
+ (env-top-ribcage env)))))))
+
+
+
+(set! $make-environment
+ (lambda (token mutable?)
+ (let ((top-ribcage (make-top-ribcage token mutable?)))
+ (make-env
+ top-ribcage
+ (make-wrap
+ (wrap-marks top-wrap)
+ (cons top-ribcage (wrap-subst top-wrap)))))))
+
+(set! environment?
+ (lambda (x)
+ (env? x)))
+
+
+
+(set! interaction-environment
+ (let ((e ($make-environment '*top* #t)))
+ (lambda () e)))
+
+(set! identifier?
+ (lambda (x)
+ (nonsymbol-id? x)))
+
+(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->list
+ (lambda (orig-ls)
+ (let f ((ls orig-ls))
+ (syntax-case ls ()
+ (() '())
+ ((x . r) (cons #'x (f #'r)))
+ (_ (error 'syntax->list "invalid argument ~s" orig-ls))))))
+
+(set! syntax->vector
+ (lambda (v)
+ (syntax-case v ()
+ (#(x ...) (apply vector (syntax->list #'(x ...))))
+ (_ (error 'syntax->vector "invalid argument ~s" v)))))
+
+(set! syntax-object->datum
+ ; accepts any object, since syntax objects may consist partially
+ ; or entirely of unwrapped, nonsymbolic data
+ (lambda (x)
+ (strip x empty-wrap)))
+
+(set! generate-temporaries
+ (let ((n 0))
+ (lambda (ls)
+ (arg-check list? ls 'generate-temporaries)
+ (map (lambda (x)
+ (set! n (+ n 1))
+ (wrap
+ ; unique name to distinguish from other temporaries
+ (string->symbol (string-append "t" (number->string n)))
+ ; unique mark (in tmp-wrap) to distinguish from non-temporaries
+ tmp-wrap))
+ ls))))
+
+(set! free-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'free-identifier=?)
+ (arg-check nonsymbol-id? y 'free-identifier=?)
+ (free-id=? x y)))
+
+(set! bound-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'bound-identifier=?)
+ (arg-check nonsymbol-id? y 'bound-identifier=?)
+ (bound-id=? x y)))
+
+(set! literal-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'literal-identifier=?)
+ (arg-check nonsymbol-id? y 'literal-identifier=?)
+ (literal-id=? x y)))
+
+(set! syntax-error
+ (lambda (object . messages)
+ (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
+ (let ((message (if (null? messages)
+ "invalid syntax"
+ (apply string-append messages))))
+ (error-hook #f message (strip object empty-wrap)))))
+
+;;; syntax-dispatch expects an expression and a pattern. If the expression
+;;; matches the pattern a list of the matching expressions for each
+;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
+;;; not work on r4rs implementations that violate the ieee requirement
+;;; that #f and () be distinct.)
+
+;;; The expression is matched with the pattern as follows:
+
+;;; p in pattern: matches:
+;;; () empty list
+;;; any anything
+;;; (p1 . p2) pair (list)
+;;; #(free-id <key>) <key> with literal-identifier=?
+;;; each-any any proper list
+;;; #(each p) (p*)
+;;; #(each+ p1 (p2_1 ...p2_n) p3) (p1* (p2_n ... p2_1) . p3)
+;;; #(vector p) (list->vector p)
+;;; #(atom <object>) <object> with "equal?"
+
+;;; Vector cops out to pair under assumption that vectors are rare. If
+;;; not, should convert to:
+;;; #(vector p) #(p*)
+
+(let ()
+
+(define match-each
+ (lambda (e p w)
+ (cond
+ ((annotation? e)
+ (match-each (annotation-expression e) p w))
+ ((pair? e)
+ (let ((first (match (car e) p w '())))
+ (and first
+ (let ((rest (match-each (cdr e) p w)))
+ (and rest (cons first rest))))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))))
+ (else #f))))
+
+(define match-each+
+ (lambda (e x-pat y-pat z-pat w r)
+ (let f ((e e) (w w))
+ (cond
+ ((pair? e)
+ (let-values (((xr* y-pat r) (f (cdr e) w)))
+ (if r
+ (if (null? y-pat)
+ (let ((xr (match (car e) x-pat w '())))
+ (if xr
+ (values (cons xr xr*) y-pat r)
+ (values #f #f #f)))
+ (values '() (cdr y-pat) (match (car e) (car y-pat) w r)))
+ (values #f #f #f))))
+ ((annotation? e) (f (annotation-expression e) w))
+ ((syntax-object? e) (f (syntax-object-expression e)
+ (join-wraps w (syntax-object-wrap e))))
+ (else (values '() y-pat (match e z-pat w r)))))))
+
+(define match-each-any
+ (lambda (e w)
+ (cond
+ ((annotation? e)
+ (match-each-any (annotation-expression e) w))
+ ((pair? e)
+ (let ((l (match-each-any (cdr e) w)))
+ (and l (cons (wrap (car e) w) l))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each-any (syntax-object-expression e)
+ (join-wraps w (syntax-object-wrap e))))
+ (else #f))))
+
+(define match-empty
+ (lambda (p r)
+ (cond
+ ((null? p) r)
+ ((eq? p 'any) (cons '() r))
+ ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
+ ((eq? p 'each-any) (cons '() r))
+ (else
+ (case (vector-ref p 0)
+ ((each) (match-empty (vector-ref p 1) r))
+ ((each+) (match-empty (vector-ref p 1)
+ (match-empty (reverse (vector-ref p 2))
+ (match-empty (vector-ref p 3) r))))
+ ((free-id atom) r)
+ ((vector) (match-empty (vector-ref p 1) r)))))))
+
+(define combine
+ (lambda (r* r)
+ (if (null? (car r*))
+ r
+ (cons (map car r*) (combine (map cdr r*) r)))))
+
+(define match*
+ (lambda (e p w r)
+ (cond
+ ((null? p) (and (null? e) r))
+ ((pair? p)
+ (and (pair? e) (match (car e) (car p) w
+ (match (cdr e) (cdr p) w r))))
+ ((eq? p 'each-any)
+ (let ((l (match-each-any e w))) (and l (cons l r))))
+ (else
+ (case (vector-ref p 0)
+ ((each)
+ (if (null? e)
+ (match-empty (vector-ref p 1) r)
+ (let ((r* (match-each e (vector-ref p 1) w)))
+ (and r* (combine r* r)))))
+ ((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r))
+ ((each+)
+ (let-values (((xr* y-pat r)
+ (match-each+ e (vector-ref p 1) (vector-ref p 2)
+ (vector-ref p 3) w r)))
+ (and r (null? y-pat)
+ (if (null? xr*)
+ (match-empty (vector-ref p 1) r)
+ (combine xr* r)))))
+ ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
+ ((vector)
+ (and (vector? e)
+ (match (vector->list e) (vector-ref p 1) w r))))))))
+
+(define match
+ (lambda (e p w r)
+ (cond
+ ((not r) #f)
+ ((eq? p 'any) (cons (wrap e w) r))
+ ((syntax-object? e)
+ (match*
+ (unannotate (syntax-object-expression e))
+ p
+ (join-wraps w (syntax-object-wrap e))
+ r))
+ (else (match* (unannotate e) p w r)))))
+
+(set! $syntax-dispatch
+ (lambda (e p)
+ (cond
+ ((eq? p 'any) (list e))
+ ((syntax-object? e)
+ (match* (unannotate (syntax-object-expression e))
+ p (syntax-object-wrap e) '()))
+ (else (match* (unannotate e) p empty-wrap '())))))
+))
+
+
+(define-syntax with-syntax
+ (lambda (x)
+ (syntax-case x ()
+ ((_ () e1 e2 ...)
+ (syntax (begin e1 e2 ...)))
+ ((_ ((out in)) e1 e2 ...)
+ (syntax (syntax-case in () (out (begin e1 e2 ...)))))
+ ((_ ((out in) ...) e1 e2 ...)
+ (syntax (syntax-case (list in ...) ()
+ ((out ...) (begin e1 e2 ...))))))))
+
+(define-syntax with-implicit
+ (syntax-rules ()
+ ((_ (tid id ...) e1 e2 ...)
+ (andmap identifier? (syntax (tid id ...)))
+ (begin
+ (unless (identifier? (syntax tid))
+ (syntax-error (syntax tid) "non-identifier with-implicit template"))
+ (with-syntax ((id (datum->syntax-object (syntax tid) 'id)) ...)
+ e1 e2 ...)))))
+
+(define-syntax datum
+ (syntax-rules ()
+ ((_ x) (syntax-object->datum (syntax x)))))
+
+(define-syntax syntax-rules
+ (lambda (x)
+ (define clause
+ (lambda (y)
+ (syntax-case y ()
+ (((keyword . pattern) template)
+ (syntax ((dummy . pattern) (syntax template))))
+ (((keyword . pattern) fender template)
+ (syntax ((dummy . pattern) fender (syntax template))))
+ (_ (syntax-error x)))))
+ (syntax-case x ()
+ ((_ (k ...) cl ...)
+ (andmap identifier? (syntax (k ...)))
+ (with-syntax (((cl ...) (map clause (syntax (cl ...)))))
+ (syntax (lambda (x) (syntax-case x (k ...) cl ...))))))))
+
+(define-syntax or
+ (lambda (x)
+ (syntax-case x ()
+ ((_) (syntax #f))
+ ((_ e) (syntax e))
+ ((_ e1 e2 e3 ...)
+ (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
+
+(define-syntax and
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
+ ((_ e) (syntax e))
+ ((_) (syntax #t)))))
+
+(define-syntax let
+ (lambda (x)
+ (syntax-case x ()
+ ((_ ((x v) ...) e1 e2 ...)
+ (andmap identifier? (syntax (x ...)))
+ (syntax ((lambda (x ...) e1 e2 ...) v ...)))
+ ((_ f ((x v) ...) e1 e2 ...)
+ (andmap identifier? (syntax (f x ...)))
+ (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
+ v ...))))))
+
+(define-syntax let*
+ (lambda (x)
+ (syntax-case x ()
+ ((let* ((x v) ...) e1 e2 ...)
+ (andmap identifier? (syntax (x ...)))
+ (let f ((bindings (syntax ((x v) ...))))
+ (if (null? bindings)
+ (syntax (let () e1 e2 ...))
+ (with-syntax ((body (f (cdr bindings)))
+ (binding (car bindings)))
+ (syntax (let (binding) body)))))))))
+
+(define-syntax cond
+ (lambda (x)
+ (syntax-case x ()
+ ((_ m1 m2 ...)
+ (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
+ (if (null? clauses)
+ (syntax-case clause (else =>)
+ ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
+ ((e0) (syntax (let ((t e0)) (if t t))))
+ ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
+ ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
+ (_ (syntax-error x)))
+ (with-syntax ((rest (f (car clauses) (cdr clauses))))
+ (syntax-case clause (else =>)
+ ((e0) (syntax (let ((t e0)) (if t t rest))))
+ ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
+ ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
+ (_ (syntax-error x))))))))))
+
+(define-syntax do
+ (lambda (orig-x)
+ (syntax-case orig-x ()
+ ((_ ((var init . step) ...) (e0 e1 ...) c ...)
+ (with-syntax (((step ...)
+ (map (lambda (v s)
+ (syntax-case s ()
+ (() v)
+ ((e) (syntax e))
+ (_ (syntax-error orig-x))))
+ (syntax (var ...))
+ (syntax (step ...)))))
+ (syntax-case (syntax (e1 ...)) ()
+ (() (syntax (let do ((var init) ...)
+ (if (not e0)
+ (begin c ... (do step ...))))))
+ ((e1 e2 ...)
+ (syntax (let do ((var init) ...)
+ (if e0
+ (begin e1 e2 ...)
+ (begin c ... (do step ...))))))))))))
+
+(define-syntax quasiquote
+ (let ()
+ (define (quasi p lev)
+ (syntax-case p (unquote quasiquote)
+ ((unquote p)
+ (if (= lev 0)
+ #'("value" p)+ (quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))+ ((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))+ ((p . q)
+ (syntax-case #'p (unquote unquote-splicing)
+ ((unquote p ...)
+ (if (= lev 0)
+ (quasilist* #'(("value" p) ...) (quasi #'q lev))+ (quasicons
+ (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))+ (quasi #'q lev))))
+ ((unquote-splicing p ...)
+ (if (= lev 0)
+ (quasiappend #'(("value" p) ...) (quasi #'q lev))+ (quasicons
+ (quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))+ (quasi #'q lev))))
+ (_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
+ (#(x ...) (quasivector (vquasi #'(x ...) lev)))
+ (p #'("quote" p))))+ (define (vquasi p lev)
+ (syntax-case p ()
+ ((p . q)
+ (syntax-case #'p (unquote unquote-splicing)
+ ((unquote p ...)
+ (if (= lev 0)
+ (quasilist* #'(("value" p) ...) (vquasi #'q lev))+ (quasicons
+ (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))+ (vquasi #'q lev))))
+ ((unquote-splicing p ...)
+ (if (= lev 0)
+ (quasiappend #'(("value" p) ...) (vquasi #'q lev))+ (quasicons
+ (quasicons
+ #'("quote" unquote-splicing)+ (quasi #'(p ...) (- lev 1)))
+ (vquasi #'q lev))))
+ (_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
+ (() #'("quote" ()))))+ (define (quasicons x y)
+ (with-syntax ((x x) (y y))
+ (syntax-case #'y ()
+ (("quote" dy)+ (syntax-case #'x ()
+ (("quote" dx) #'("quote" (dx . dy)))+ (_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))+ (("list" . stuff) #'("list" x . stuff))+ (("list*" . stuff) #'("list*" x . stuff))+ (_ #'("list*" x y)))))+ (define (quasiappend x y)
+ (syntax-case y ()
+ (("quote" ())+ (cond
+ ((null? x) #'("quote" ()))+ ((null? (cdr x)) (car x))
+ (else (with-syntax (((p ...) x)) #'("append" p ...)))))+ (_
+ (cond
+ ((null? x) y)
+ (else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))+ (define (quasilist* x y)
+ (let f ((x x))
+ (if (null? x)
+ y
+ (quasicons (car x) (f (cdr x))))))
+ (define (quasivector x)
+ (syntax-case x ()
+ (("quote" (x ...)) #'("quote" #(x ...)))+ (_
+ (let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))+ (syntax-case y ()
+ (("quote" (y ...)) (k #'(("quote" y) ...)))+ (("list" y ...) (k #'(y ...)))+ (("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))+ (else #`("list->vector" #,x)))))))+ (define (emit x)
+ (syntax-case x ()
+ (("quote" x) #''x)+ (("list" x ...) #`(list #,@(map emit #'(x ...))))+ ; could emit list* for 3+ arguments if implementation supports list*
+ (("list*" x ... y)+ (let f ((x* #'(x ...)))
+ (if (null? x*)
+ (emit #'y)
+ #`(cons #,(emit (car x*)) #,(f (cdr x*))))))
+ (("append" x ...) #`(append #,@(map emit #'(x ...))))+ (("vector" x ...) #`(vector #,@(map emit #'(x ...))))+ (("list->vector" x) #`(list->vector #,(emit #'x)))+ (("value" x) #'x)))+ (lambda (x)
+ (syntax-case x ()
+ ; convert to intermediate language, combining introduced (but not
+ ; unquoted source) quote expressions where possible and choosing
+ ; optimal construction code otherwise, then emit Scheme code
+ ; corresponding to the intermediate language forms.
+ ((_ e) (emit (quasi #'e 0)))))))
+
+(define-syntax unquote
+ (lambda (x)
+ (syntax-error x "misplaced")))
+
+(define-syntax unquote-splicing
+ (lambda (x)
+ (syntax-error x "misplaced")))
+
+(define-syntax quasisyntax
+ (lambda (x)
+ (define (qs q n b* k)
+ (syntax-case q (quasisyntax unsyntax unsyntax-splicing)
+ ((quasisyntax . d)
+ (qs #'d (+ n 1) b*
+ (lambda (b* dnew)
+ (k b*
+ (if (eq? dnew #'d)
+ q
+ (with-syntax ((d dnew)) #'(quasisyntax . d)))))))
+ ((unsyntax . d)
+ (not (= n 0))
+ (qs #'d (- n 1) b*
+ (lambda (b* dnew)
+ (k b*
+ (if (eq? dnew #'d)
+ q
+ (with-syntax ((d dnew)) #'(unsyntax . d)))))))
+ ((unsyntax-splicing . d)
+ (not (= n 0))
+ (qs #'d (- n 1) b*
+ (lambda (b* dnew)
+ (k b*
+ (if (eq? dnew #'d)
+ q
+ (with-syntax ((d dnew)) #'(unsyntax-splicing . d)))))))
+ ((unsyntax q)
+ (= n 0)
+ (with-syntax (((t) (generate-temporaries #'(q))))
+ (k (cons #'(t q) b*) #'t)))
+ (((unsyntax q ...) . d)
+ (= n 0)
+ (qs #'d n b*
+ (lambda (b* dnew)
+ (with-syntax (((t ...) (generate-temporaries #'(q ...))))
+ (k (append #'((t q) ...) b*)
+ (with-syntax ((d dnew)) #'(t ... . d)))))))
+ (((unsyntax-splicing q ...) . d)
+ (= n 0)
+ (qs #'d n b*
+ (lambda (b* dnew)
+ (with-syntax (((t ...) (generate-temporaries #'(q ...))))
+ (k (append #'(((t (... ...)) q) ...) b*)
+ (with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
+ (with-syntax ((d dnew)) #'(m ... ... . d))))))))
+ ((a . d)
+ (qs #'a n b*
+ (lambda (b* anew)
+ (qs #'d n b*
+ (lambda (b* dnew)
+ (k b*
+ (if (and (eq? anew #'a) (eq? dnew #'d))
+ q
+ (with-syntax ((a anew) (d dnew)) #'(a . d)))))))))
+ (#(x ...)
+ (vqs #'(x ...) n b*
+ (lambda (b* xnew*)
+ (k b*
+ (if (let same? ((x* #'(x ...)) (xnew* xnew*))
+ (if (null? x*)
+ (null? xnew*)
+ (and (not (null? xnew*))
+ (eq? (car x*) (car xnew*))
+ (same? (cdr x*) (cdr xnew*)))))
+ q
+ (with-syntax (((x ...) xnew*)) #'#(x ...)))))))
+ (_ (k b* q))))
+ (define (vqs x* n b* k)
+ (if (null? x*)
+ (k b* '())
+ (vqs (cdr x*) n b*
+ (lambda (b* xnew*)
+ (syntax-case (car x*) (unsyntax unsyntax-splicing)
+ ((unsyntax q ...)
+ (= n 0)
+ (with-syntax (((t ...) (generate-temporaries #'(q ...))))
+ (k (append #'((t q) ...) b*)
+ (append #'(t ...) xnew*))))
+ ((unsyntax-splicing q ...)
+ (= n 0)
+ (with-syntax (((t ...) (generate-temporaries #'(q ...))))
+ (k (append #'(((t (... ...)) q) ...) b*)
+ (with-syntax ((((m ...) ...) #'((t (... ...)) ...)))
+ (append #'(m ... ...) xnew*)))))
+ (_ (qs (car x*) n b*
+ (lambda (b* xnew)
+ (k b* (cons xnew xnew*))))))))))
+ (syntax-case x ()
+ ((_ x)
+ (qs #'x 0 '()
+ (lambda (b* xnew)
+ (if (eq? xnew #'x)
+ #'(syntax x)
+ (with-syntax (((b ...) b*) (x xnew))
+ #'(with-syntax (b ...) (syntax x))))))))))
+
+(define-syntax unsyntax
+ (lambda (x)
+ (syntax-error x "misplaced")))
+
+(define-syntax unsyntax-splicing
+ (lambda (x)
+ (syntax-error x "misplaced")))
+
+(define-syntax include
+ (lambda (x)
+ (define read-file
+ (lambda (fn k)
+ (let ((p (open-input-file fn)))
+ (let f ()
+ (let ((x (read p)))
+ (if (eof-object? x)
+ (begin (close-input-port p) '())
+ (cons (datum->syntax-object k x) (f))))))))
+ (syntax-case x ()
+ ((k filename)
+ (let ((fn (syntax-object->datum (syntax filename))))
+ (with-syntax (((exp ...) (read-file fn (syntax k))))
+ (syntax (begin exp ...))))))))
+
+(define-syntax case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e m1 m2 ...)
+ (with-syntax
+ ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
+ (if (null? clauses)
+ (syntax-case clause (else)
+ ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
+ (((k ...) e1 e2 ...)
+ (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
+ (_ (syntax-error x)))
+ (with-syntax ((rest (f (car clauses) (cdr clauses))))
+ (syntax-case clause (else)
+ (((k ...) e1 e2 ...)
+ (syntax (if (memv t '(k ...))
+ (begin e1 e2 ...)
+ rest)))
+ (_ (syntax-error x))))))))
+ (syntax (let ((t e)) body)))))))
+
+(define-syntax identifier-syntax
+ (syntax-rules (set!)
+ ((_ e)
+ (lambda (x)
+ (syntax-case x ()
+ (id (identifier? (syntax id)) (syntax e))
+ ((_ x (... ...)) (syntax (e x (... ...)))))))
+ ((_ (id exp1) ((set! var val) exp2))
+ (and (identifier? (syntax id)) (identifier? (syntax var)))
+ (cons 'macro!
+ (lambda (x)
+ (syntax-case x (set!)
+ ((set! var val) (syntax exp2))
+ ((id x (... ...)) (syntax (exp1 x (... ...))))
+ (id (identifier? (syntax id)) (syntax exp1))))))))
+
--- /dev/null
+++ b/lib/sort.scm
@@ -1,0 +1,193 @@
+;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
+;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
+;;;
+;;; This code is in the public domain.
+
+;;; Updated: 11 June 1991
+;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
+;;; Updated: 19 June 1995
+;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09
+;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
+;;; jaffer: 2006-10-08:
+;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument.
+;;; jaffer: 2006-11-05:
+;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once
+;;; per element.
+
+;(require 'array)
+
+;;; (sorted? sequence less?)
+;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
+;;; such that for all 1 <= i <= m,
+;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
+;@
+(define (sorted? seq less? . opt-key)
+ (define key (if (null? opt-key) identity (car opt-key)))
+ (cond ((null? seq) #t)
+ ((array? seq)
+ (let ((dimax (+ -1 (car (array-dimensions seq)))))
+ (or (<= dimax 1)
+ (let loop ((idx (+ -1 dimax))
+ (last (key (array-ref seq dimax))))
+ (or (negative? idx)
+ (let ((nxt (key (array-ref seq idx))))
+ (and (less? nxt last)
+ (loop (+ -1 idx) nxt))))))))
+ ((null? (cdr seq)) #t)
+ (else
+ (let loop ((last (key (car seq)))
+ (next (cdr seq)))
+ (or (null? next)
+ (let ((nxt (key (car next))))
+ (and (not (less? nxt last))
+ (loop nxt (cdr next)))))))))
+
+;;; (merge a b less?)
+;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
+;;; and returns a new list in which the elements of a and b have been stably
+;;; interleaved so that (sorted? (merge a b less?) less?).
+;;; Note: this does _not_ accept arrays. See below.
+;@
+(define (merge a b less? . opt-key)
+ (define key (if (null? opt-key) identity (car opt-key)))
+ (cond ((null? a) b)
+ ((null? b) a)
+ (else
+ (let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
+ (y (car b)) (ky (key (car b))) (b (cdr b)))
+ ;; The loop handles the merging of non-empty lists. It has
+ ;; been written this way to save testing and car/cdring.
+ (if (less? ky kx)
+ (if (null? b)
+ (cons y (cons x a))
+ (cons y (loop x kx a (car b) (key (car b)) (cdr b))))
+ ;; x <= y
+ (if (null? a)
+ (cons x (cons y b))
+ (cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
+
+(define (sort:merge! a b less? key)
+ (define (loop r a kcara b kcarb)
+ (cond ((less? kcarb kcara)
+ (set-cdr! r b)
+ (if (null? (cdr b))
+ (set-cdr! b a)
+ (loop b a kcara (cdr b) (key (cadr b)))))
+ (else ; (car a) <= (car b)
+ (set-cdr! r a)
+ (if (null? (cdr a))
+ (set-cdr! a b)
+ (loop a (cdr a) (key (cadr a)) b kcarb)))))
+ (cond ((null? a) b)
+ ((null? b) a)
+ (else
+ (let ((kcara (key (car a)))
+ (kcarb (key (car b))))
+ (cond
+ ((less? kcarb kcara)
+ (if (null? (cdr b))
+ (set-cdr! b a)
+ (loop b a kcara (cdr b) (key (cadr b))))
+ b)
+ (else ; (car a) <= (car b)
+ (if (null? (cdr a))
+ (set-cdr! a b)
+ (loop a (cdr a) (key (cadr a)) b kcarb))
+ a))))))
+
+;;; takes two sorted lists a and b and smashes their cdr fields to form a
+;;; single sorted list including the elements of both.
+;;; Note: this does _not_ accept arrays.
+;@
+(define (merge! a b less? . opt-key)
+ (sort:merge! a b less? (if (null? opt-key) identity (car opt-key))))
+
+(define (sort:sort-list! seq less? key)
+ (define keyer (if key car identity))
+ (define (step n)
+ (cond ((> n 2) (let* ((j (quotient n 2))
+ (a (step j))
+ (k (- n j))
+ (b (step k)))
+ (sort:merge! a b less? keyer)))
+ ((= n 2) (let ((x (car seq))
+ (y (cadr seq))
+ (p seq))
+ (set! seq (cddr seq))
+ (cond ((less? (keyer y) (keyer x))
+ (set-car! p y)
+ (set-car! (cdr p) x)))
+ (set-cdr! (cdr p) '())
+ p))
+ ((= n 1) (let ((p seq))
+ (set! seq (cdr seq))
+ (set-cdr! p '())
+ p))
+ (else '())))
+ (define (key-wrap! lst)
+ (cond ((null? lst))
+ (else (set-car! lst (cons (key (car lst)) (car lst)))
+ (key-wrap! (cdr lst)))))
+ (define (key-unwrap! lst)
+ (cond ((null? lst))
+ (else (set-car! lst (cdar lst))
+ (key-unwrap! (cdr lst)))))
+ (cond (key
+ (key-wrap! seq)
+ (set! seq (step (length seq)))
+ (key-unwrap! seq)
+ seq)
+ (else
+ (step (length seq)))))
+
+(define (rank-1-array->list array)
+ (define dimensions (array-dimensions array))
+ (do ((idx (+ -1 (car dimensions)) (+ -1 idx))
+ (lst '() (cons (array-ref array idx) lst)))
+ ((< idx 0) lst)))
+
+;;; (sort! sequence less?)
+;;; sorts the list, array, or string sequence destructively. It uses
+;;; a version of merge-sort invented, to the best of my knowledge, by
+;;; David H. D. Warren, and first used in the DEC-10 Prolog system.
+;;; R. A. O'Keefe adapted it to work destructively in Scheme.
+;;; A. Jaffer modified to always return the original list.
+;@
+(define (sort! seq less? . opt-key)
+ (define key (if (null? opt-key) #f (car opt-key)))
+ (cond ((array? seq)
+ (let ((dims (array-dimensions seq)))
+ (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
+ (cdr sorted))
+ (i 0 (+ i 1)))
+ ((null? sorted) seq)
+ (array-set! seq (car sorted) i))))
+ (else ; otherwise, assume it is a list
+ (let ((ret (sort:sort-list! seq less? key)))
+ (if (not (eq? ret seq))
+ (do ((crt ret (cdr crt)))
+ ((eq? (cdr crt) seq)
+ (set-cdr! crt ret)
+ (let ((scar (car seq)) (scdr (cdr seq)))
+ (set-car! seq (car ret)) (set-cdr! seq (cdr ret))
+ (set-car! ret scar) (set-cdr! ret scdr)))))
+ seq))))
+
+;;; (sort sequence less?)
+;;; sorts a array, string, or list non-destructively. It does this
+;;; by sorting a copy of the sequence. My understanding is that the
+;;; Standard says that the result of append is always "newly
+;;; allocated" except for sharing structure with "the last argument",
+;;; so (append x '()) ought to be a standard way of copying a list x.
+;@
+(define (sort seq less? . opt-key)
+ (define key (if (null? opt-key) #f (car opt-key)))
+ (cond ((array? seq)
+ (let ((dims (array-dimensions seq)))
+ (define newra (apply make-array seq dims))
+ (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
+ (cdr sorted))
+ (i 0 (+ i 1)))
+ ((null? sorted) newra)
+ (array-set! newra (car sorted) i))))
+ (else (sort:sort-list! (append seq '()) less? key))))
--- /dev/null
+++ b/mkboot0.lsp
@@ -1,0 +1,20 @@
+; -*- scheme -*-
+
+(if (not (bound? 'top-level-value)) (set! top-level-value %eval))
+(if (not (bound? 'set-top-level-value!)) (set! set-top-level-value! set))
+(if (not (bound? 'eof-object?)) (set! eof-object? (lambda (x) #f)))
+
+;(load "compiler.lsp")
+
+(define (compile-file inf)
+ (let ((in (file inf :read)))
+ (let next ((E (read in)))
+ (if (not (io.eof? in))
+ (begin (print (compile-thunk (expand E)))
+ (princ "\n")
+ (next (read in)))))
+ (io.close in)))
+
+(for-each (lambda (file)
+ (compile-file file))
+ (cdr *argv*))
--- /dev/null
+++ b/mkboot1.lsp
@@ -1,0 +1,5 @@
+; -*- scheme -*-
+
+(load "system.lsp")
+(load "compiler.lsp")
+(make-system-image "flisp.boot")
--- /dev/null
+++ b/opaque_type_template.c
@@ -1,0 +1,63 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdarg.h>
+#include <string.h>
+#include <assert.h>
+#include <sys/types.h>
+#include "llt.h"
+#include "flisp.h"
+
+// global replace TYPE with your type name to make your very own type!
+
+static value_t TYPEsym;
+static fltype_t *TYPEtype;
+
+void print_TYPE(value_t v, ios_t *f, int princ)
+{+}
+
+void print_traverse_TYPE(value_t self)
+{+}
+
+void free_TYPE(value_t self)
+{+}
+
+void relocate_TYPE(value_t oldv, value_t newv)
+{+}
+
+cvtable_t TYPE_vtable = { print_TYPE, relocate_TYPE, free_TYPE,+ print_traverse_TYPE };
+
+int isTYPE(value_t v)
+{+ return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == TYPEtype;
+}
+
+value_t fl_TYPEp(value_t *args, uint32_t nargs)
+{+ argcount("TYPE?", nargs, 1);+ return isTYPE(args[0]) ? FL_T : FL_F;
+}
+
+static TYPE_t *toTYPE(value_t v, char *fname)
+{+ if (!isTYPE(v))
+ type_error(fname, "TYPE", v);
+ return (TYPE_t*)cv_data((cvalue_t*)ptr(v));
+}
+
+static builtinspec_t TYPEfunc_info[] = {+ { "TYPE?", fl_TYPEp },+ { NULL, NULL }+};
+
+void TYPE_init()
+{+ TYPEsym = symbol("TYPE");+ TYPEtype = define_opaque_type(TYPEsym, sizeof(TYPE_t),
+ &TYPE_vtable, NULL);
+ assign_global_builtins(TYPEfunc_info);
+}
--- /dev/null
+++ b/opcodes.h
@@ -1,0 +1,101 @@
+#ifndef __OPCODES_H_
+#define __OPCODES_H_
+
+enum {+ OP_NOP=0, OP_DUP, OP_POP, OP_CALL, OP_TCALL, OP_JMP, OP_BRF, OP_BRT,
+ OP_JMPL, OP_BRFL, OP_BRTL, OP_RET,
+
+ OP_EQ, OP_EQV, OP_EQUAL, OP_ATOMP, OP_NOT, OP_NULLP, OP_BOOLEANP,
+ OP_SYMBOLP, OP_NUMBERP, OP_BOUNDP, OP_PAIRP, OP_BUILTINP, OP_VECTORP,
+ OP_FIXNUMP, OP_FUNCTIONP,
+
+ OP_CONS, OP_LIST, OP_CAR, OP_CDR, OP_SETCAR, OP_SETCDR,
+ OP_APPLY,
+
+ OP_ADD, OP_SUB, OP_MUL, OP_DIV, OP_IDIV, OP_NUMEQ, OP_LT, OP_COMPARE,
+
+ OP_VECTOR, OP_AREF, OP_ASET,
+
+ OP_LOADT, OP_LOADF, OP_LOADNIL, OP_LOAD0, OP_LOAD1, OP_LOADI8,
+ OP_LOADV, OP_LOADVL,
+ OP_LOADG, OP_LOADGL,
+ OP_LOADA, OP_LOADAL, OP_LOADC, OP_LOADCL,
+ OP_SETG, OP_SETGL,
+ OP_SETA, OP_SETAL, OP_SETC, OP_SETCL,
+
+ OP_CLOSURE, OP_ARGC, OP_VARGC, OP_TRYCATCH, OP_FOR,
+ OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_LARGC, OP_LVARGC,
+ OP_LOADA0, OP_LOADA1, OP_LOADC00, OP_LOADC01, OP_CALLL, OP_TCALLL,
+ OP_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL,
+ OP_OPTARGS, OP_BRBOUND, OP_KEYARGS,
+
+ OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST, OP_EOF_OBJECT,
+
+ N_OPCODES
+};
+
+#ifdef USE_COMPUTED_GOTO
+#define VM_LABELS \
+ static void *vm_labels[] = { \+NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
+ &&L_OP_BRF, &&L_OP_BRT, \
+ &&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
+ \
+ &&L_OP_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, &&L_OP_NOT, \
+ &&L_OP_NULLP, &&L_OP_BOOLEANP, \
+ &&L_OP_SYMBOLP, &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, \
+ &&L_OP_BUILTINP, &&L_OP_VECTORP, \
+ &&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
+ \
+ &&L_OP_CONS, &&L_OP_LIST, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_SETCAR, \
+ &&L_OP_SETCDR, &&L_OP_APPLY, \
+ \
+ &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, &&L_OP_IDIV, &&L_OP_NUMEQ, \
+ &&L_OP_LT, &&L_OP_COMPARE, \
+ \
+ &&L_OP_VECTOR, &&L_OP_AREF, &&L_OP_ASET, \
+ \
+ &&L_OP_LOADT, &&L_OP_LOADF, &&L_OP_LOADNIL, &&L_OP_LOAD0, &&L_OP_LOAD1, \
+ &&L_OP_LOADI8, \
+ &&L_OP_LOADV, &&L_OP_LOADVL, \
+ &&L_OP_LOADG, &&L_OP_LOADGL, \
+ &&L_OP_LOADA, &&L_OP_LOADAL, &&L_OP_LOADC, &&L_OP_LOADCL, \
+ &&L_OP_SETG, &&L_OP_SETGL, \
+ &&L_OP_SETA, &&L_OP_SETAL, &&L_OP_SETC, &&L_OP_SETCL, \
+ \
+ &&L_OP_CLOSURE, &&L_OP_ARGC, &&L_OP_VARGC, &&L_OP_TRYCATCH, \
+ &&L_OP_FOR, \
+ &&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, &&L_OP_NEG, &&L_OP_LARGC, \
+ &&L_OP_LVARGC, \
+ &&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01, \
+ &&L_OP_CALLL, &&L_OP_TCALLL, &&L_OP_BRNE, &&L_OP_BRNEL, &&L_OP_CADR,\
+ &&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL, \
+ &&L_OP_OPTARGS, &&L_OP_BRBOUND, &&L_OP_KEYARGS \
+ }
+
+#define VM_APPLY_LABELS \
+ static void *vm_apply_labels[] = { \+NULL, &&L_OP_DUP, &&L_OP_POP, &&L_OP_CALL, &&L_OP_TCALL, &&L_OP_JMP, \
+ &&L_OP_BRF, &&L_OP_BRT, \
+ &&L_OP_JMPL, &&L_OP_BRFL, &&L_OP_BRTL, &&L_OP_RET, \
+ \
+ &&L_OP_EQ, &&L_OP_EQV, &&L_OP_EQUAL, &&L_OP_ATOMP, &&L_OP_NOT, \
+ &&L_OP_NULLP, &&L_OP_BOOLEANP, \
+ &&L_OP_SYMBOLP, &&L_OP_NUMBERP, &&L_OP_BOUNDP, &&L_OP_PAIRP, \
+ &&L_OP_BUILTINP, &&L_OP_VECTORP, \
+ &&L_OP_FIXNUMP, &&L_OP_FUNCTIONP, \
+ \
+ &&L_OP_CONS, &&apply_list, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_SETCAR, \
+ &&L_OP_SETCDR, &&apply_apply, \
+ \
+ &&apply_add, &&apply_sub, &&apply_mul, &&apply_div, &&L_OP_IDIV, &&L_OP_NUMEQ, \
+ &&L_OP_LT, &&L_OP_COMPARE, \
+ \
+ &&apply_vector, &&L_OP_AREF, &&L_OP_ASET \
+ }
+#else
+#define VM_LABELS
+#define VM_APPLY_LABELS
+#endif
+
+#endif
--- /dev/null
+++ b/print.c
@@ -1,0 +1,773 @@
+extern void *memrchr(const void *s, int c, size_t n);
+
+static htable_t printconses;
+static u_int32_t printlabel;
+static int print_pretty;
+static int print_princ;
+static fixnum_t print_length;
+static fixnum_t print_level;
+static fixnum_t P_LEVEL;
+static int SCR_WIDTH = 80;
+
+static int HPOS=0, VPOS;
+static void outc(char c, ios_t *f)
+{+ ios_putc(c, f);
+ if (c == '\n')
+ HPOS = 0;
+ else
+ HPOS++;
+}
+static void outs(char *s, ios_t *f)
+{+ ios_puts(s, f);
+ HPOS += u8_strwidth(s);
+}
+static void outsn(char *s, ios_t *f, size_t n)
+{+ ios_write(f, s, n);
+ HPOS += u8_strwidth(s);
+}
+static int outindent(int n, ios_t *f)
+{+ // move back to left margin if we get too indented
+ if (n > SCR_WIDTH-12)
+ n = 2;
+ int n0 = n;
+ ios_putc('\n', f);+ VPOS++;
+ HPOS = n;
+ while (n >= 8) {+ ios_putc('\t', f);+ n -= 8;
+ }
+ while (n) {+ ios_putc(' ', f);+ n--;
+ }
+ return n0;
+}
+
+void fl_print_chr(char c, ios_t *f)
+{+ outc(c, f);
+}
+
+void fl_print_str(char *s, ios_t *f)
+{+ outs(s, f);
+}
+
+void print_traverse(value_t v)
+{+ value_t *bp;
+ while (iscons(v)) {+ if (ismarked(v)) {+ bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
+ if (*bp == (value_t)HT_NOTFOUND)
+ *bp = fixnum(printlabel++);
+ return;
+ }
+ mark_cons(v);
+ print_traverse(car_(v));
+ v = cdr_(v);
+ }
+ if (!ismanaged(v) || issymbol(v))
+ return;
+ if (ismarked(v)) {+ bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
+ if (*bp == (value_t)HT_NOTFOUND)
+ *bp = fixnum(printlabel++);
+ return;
+ }
+ if (isvector(v)) {+ if (vector_size(v) > 0)
+ mark_cons(v);
+ unsigned int i;
+ for(i=0; i < vector_size(v); i++)
+ print_traverse(vector_elt(v,i));
+ }
+ else if (iscprim(v)) {+ mark_cons(v);
+ }
+ else if (isclosure(v)) {+ mark_cons(v);
+ function_t *f = (function_t*)ptr(v);
+ print_traverse(f->bcode);
+ print_traverse(f->vals);
+ print_traverse(f->env);
+ }
+ else {+ assert(iscvalue(v));
+ cvalue_t *cv = (cvalue_t*)ptr(v);
+ // don't consider shared references to ""
+ if (!cv_isstr(cv) || cv_len(cv)!=0)
+ mark_cons(v);
+ fltype_t *t = cv_class(cv);
+ if (t->vtable != NULL && t->vtable->print_traverse != NULL)
+ t->vtable->print_traverse(v);
+ }
+}
+
+static void print_symbol_name(ios_t *f, char *name)
+{+ int i, escape=0, charescape=0;
+
+ if ((name[0] == '\0') ||
+ (name[0] == '.' && name[1] == '\0') ||
+ (name[0] == '#') ||
+ isnumtok(name, NULL))
+ escape = 1;
+ i=0;
+ while (name[i]) {+ if (!symchar(name[i])) {+ escape = 1;
+ if (name[i]=='|' || name[i]=='\\') {+ charescape = 1;
+ break;
+ }
+ }
+ i++;
+ }
+ if (escape) {+ if (charescape) {+ outc('|', f);+ i=0;
+ while (name[i]) {+ if (name[i]=='|' || name[i]=='\\')
+ outc('\\', f);+ outc(name[i], f);
+ i++;
+ }
+ outc('|', f);+ }
+ else {+ outc('|', f);+ outs(name, f);
+ outc('|', f);+ }
+ }
+ else {+ outs(name, f);
+ }
+}
+
+/*
+ The following implements a simple pretty-printing algorithm. This is
+ an unlimited-width approach that doesn't require an extra pass.
+ It uses some heuristics to guess whether an expression is "small",
+ and avoids wrapping symbols across lines. The result is high
+ performance and nice output for typical code. Quality is poor for
+ pathological or deeply-nested expressions, but those are difficult
+ to print anyway.
+*/
+#define SMALL_STR_LEN 20
+static inline int tinyp(value_t v)
+{+ if (issymbol(v))
+ return (u8_strwidth(symbol_name(v)) < SMALL_STR_LEN);
+ if (fl_isstring(v))
+ return (cv_len((cvalue_t*)ptr(v)) < SMALL_STR_LEN);
+ return (isfixnum(v) || isbuiltin(v) || v==FL_F || v==FL_T || v==FL_NIL ||
+ v == FL_EOF);
+}
+
+static int smallp(value_t v)
+{+ if (tinyp(v)) return 1;
+ if (fl_isnumber(v)) return 1;
+ if (iscons(v)) {+ if (tinyp(car_(v)) && (tinyp(cdr_(v)) ||
+ (iscons(cdr_(v)) && tinyp(car_(cdr_(v))) &&
+ cdr_(cdr_(v))==NIL)))
+ return 1;
+ return 0;
+ }
+ if (isvector(v)) {+ size_t s = vector_size(v);
+ return (s == 0 || (tinyp(vector_elt(v,0)) &&
+ (s == 1 || (s == 2 &&
+ tinyp(vector_elt(v,1))))));
+ }
+ return 0;
+}
+
+static int specialindent(value_t head)
+{+ // indent these forms 2 spaces, not lined up with the first argument
+ if (head == LAMBDA || head == TRYCATCH || head == definesym ||
+ head == defmacrosym || head == forsym)
+ return 2;
+ return -1;
+}
+
+static int lengthestimate(value_t v)
+{+ // get the width of an expression if we can do so cheaply
+ if (issymbol(v))
+ return u8_strwidth(symbol_name(v));
+ return -1;
+}
+
+static int allsmallp(value_t v)
+{+ int n = 1;
+ while (iscons(v)) {+ if (!smallp(car_(v)))
+ return 0;
+ v = cdr_(v);
+ n++;
+ if (n > 25)
+ return n;
+ }
+ return n;
+}
+
+static int indentafter3(value_t head, value_t v)
+{+ // for certain X always indent (X a b c) after b
+ return ((head == forsym) && !allsmallp(cdr_(v)));
+}
+
+static int indentafter2(value_t head, value_t v)
+{+ // for certain X always indent (X a b) after a
+ return ((head == definesym || head == defmacrosym) &&
+ !allsmallp(cdr_(v)));
+}
+
+static int indentevery(value_t v)
+{+ // indent before every subform of a special form, unless every
+ // subform is "small"
+ value_t c = car_(v);
+ if (c == LAMBDA || c == setqsym)
+ return 0;
+ if (c == IF) // TODO: others
+ return !allsmallp(cdr_(v));
+ return 0;
+}
+
+static int blockindent(value_t v)
+{+ // in this case we switch to block indent mode, where the head
+ // is no longer considered special:
+ // (a b c d e
+ // f g h i j)
+ return (allsmallp(v) > 9);
+}
+
+static void print_pair(ios_t *f, value_t v)
+{+ value_t cd;
+ char *op = NULL;
+ if (iscons(cdr_(v)) && cdr_(cdr_(v)) == NIL &&
+ !ptrhash_has(&printconses, (void*)cdr_(v)) &&
+ (((car_(v) == QUOTE) && (op = "'")) ||
+ ((car_(v) == BACKQUOTE) && (op = "`")) ||
+ ((car_(v) == COMMA) && (op = ",")) ||
+ ((car_(v) == COMMAAT) && (op = ",@")) ||
+ ((car_(v) == COMMADOT) && (op = ",.")))) {+ // special prefix syntax
+ unmark_cons(v);
+ unmark_cons(cdr_(v));
+ outs(op, f);
+ fl_print_child(f, car_(cdr_(v)));
+ return;
+ }
+ int startpos = HPOS;
+ outc('(', f);+ int newindent=HPOS, blk=blockindent(v);
+ int lastv, n=0, si, ind=0, est, always=0, nextsmall, thistiny;
+ if (!blk) always = indentevery(v);
+ value_t head = car_(v);
+ int after3 = indentafter3(head, v);
+ int after2 = indentafter2(head, v);
+ int n_unindented = 1;
+ while (1) {+ cd = cdr_(v);
+ if (print_length >= 0 && n >= print_length && cd!=NIL) {+ outsn("...)", f, 4);+ break;
+ }
+ lastv = VPOS;
+ unmark_cons(v);
+ fl_print_child(f, car_(v));
+ if (!iscons(cd) || ptrhash_has(&printconses, (void*)cd)) {+ if (cd != NIL) {+ outsn(" . ", f, 3);+ fl_print_child(f, cd);
+ }
+ outc(')', f);+ break;
+ }
+
+ if (!print_pretty ||
+ ((head == LAMBDA) && n == 0)) {+ // never break line before lambda-list
+ ind = 0;
+ }
+ else {+ est = lengthestimate(car_(cd));
+ nextsmall = smallp(car_(cd));
+ thistiny = tinyp(car_(v));
+ ind = (((VPOS > lastv) ||
+ (HPOS>SCR_WIDTH/2 && !nextsmall && !thistiny && n>0)) ||
+
+ (HPOS > SCR_WIDTH-4) ||
+
+ (est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
+
+ ((head == LAMBDA) && !nextsmall) ||
+
+ (n > 0 && always) ||
+
+ (n == 2 && after3) ||
+ (n == 1 && after2) ||
+
+ (n_unindented >= 3 && !nextsmall) ||
+
+ (n == 0 && !smallp(head)));
+ }
+
+ if (ind) {+ newindent = outindent(newindent, f);
+ n_unindented = 1;
+ }
+ else {+ n_unindented++;
+ outc(' ', f);+ if (n==0) {+ // set indent level after printing head
+ si = specialindent(head);
+ if (si != -1)
+ newindent = startpos + si;
+ else if (!blk)
+ newindent = HPOS;
+ }
+ }
+ n++;
+ v = cd;
+ }
+}
+
+static void cvalue_print(ios_t *f, value_t v);
+
+static int print_circle_prefix(ios_t *f, value_t v)
+{+ value_t label;
+ if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) !=
+ (value_t)HT_NOTFOUND) {+ if (!ismarked(v)) {+ HPOS+=ios_printf(f, "#%ld#", numval(label));
+ return 1;
+ }
+ HPOS+=ios_printf(f, "#%ld=", numval(label));
+ }
+ if (ismanaged(v))
+ unmark_cons(v);
+ return 0;
+}
+
+void fl_print_child(ios_t *f, value_t v)
+{+ char *name;
+ if (print_level >= 0 && P_LEVEL >= print_level &&
+ (iscons(v) || isvector(v) || isclosure(v))) {+ outc('#', f);+ return;
+ }
+ P_LEVEL++;
+
+ switch (tag(v)) {+ case TAG_NUM :
+ case TAG_NUM1: HPOS+=ios_printf(f, "%ld", numval(v)); break;
+ case TAG_SYM:
+ name = symbol_name(v);
+ if (print_princ)
+ outs(name, f);
+ else if (ismanaged(v)) {+ outsn("#:", f, 2);+ outs(name, f);
+ }
+ else
+ print_symbol_name(f, name);
+ break;
+ case TAG_FUNCTION:
+ if (v == FL_T) {+ outsn("#t", f, 2);+ }
+ else if (v == FL_F) {+ outsn("#f", f, 2);+ }
+ else if (v == FL_NIL) {+ outsn("()", f, 2);+ }
+ else if (v == FL_EOF) {+ outsn("#<eof>", f, 6);+ }
+ else if (isbuiltin(v)) {+ if (!print_princ)
+ outsn("#.", f, 2);+ outs(builtin_names[uintval(v)], f);
+ }
+ else {+ assert(isclosure(v));
+ if (!print_princ) {+ if (print_circle_prefix(f, v)) break;
+ function_t *fn = (function_t*)ptr(v);
+ outs("#fn(", f);+ char *data = cvalue_data(fn->bcode);
+ size_t i, sz = cvalue_len(fn->bcode);
+ for(i=0; i < sz; i++) data[i] += 48;
+ fl_print_child(f, fn->bcode);
+ for(i=0; i < sz; i++) data[i] -= 48;
+ outc(' ', f);+ fl_print_child(f, fn->vals);
+ if (fn->env != NIL) {+ outc(' ', f);+ fl_print_child(f, fn->env);
+ }
+ if (fn->name != LAMBDA) {+ outc(' ', f);+ fl_print_child(f, fn->name);
+ }
+ outc(')', f);+ }
+ else {+ outs("#<function>", f);+ }
+ }
+ break;
+ case TAG_CVALUE:
+ case TAG_CPRIM:
+ if (v == UNBOUND) { outs("#<undefined>", f); break; }+ case TAG_VECTOR:
+ case TAG_CONS:
+ if (print_circle_prefix(f, v)) break;
+ if (isvector(v)) {+ outc('[', f);+ int newindent = HPOS, est;
+ int i, sz = vector_size(v);
+ for(i=0; i < sz; i++) {+ if (print_length >= 0 && i >= print_length && i < sz-1) {+ outsn("...", f, 3);+ break;
+ }
+ fl_print_child(f, vector_elt(v,i));
+ if (i < sz-1) {+ if (!print_pretty) {+ outc(' ', f);+ }
+ else {+ est = lengthestimate(vector_elt(v,i+1));
+ if (HPOS > SCR_WIDTH-4 ||
+ (est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
+ (HPOS > SCR_WIDTH/2 &&
+ !smallp(vector_elt(v,i+1)) &&
+ !tinyp(vector_elt(v,i))))
+ newindent = outindent(newindent, f);
+ else
+ outc(' ', f);+ }
+ }
+ }
+ outc(']', f);+ break;
+ }
+ if (iscvalue(v) || iscprim(v))
+ cvalue_print(f, v);
+ else
+ print_pair(f, v);
+ break;
+ }
+ P_LEVEL--;
+}
+
+static void print_string(ios_t *f, char *str, size_t sz)
+{+ char buf[512];
+ size_t i = 0;
+ uint8_t c;
+ static char hexdig[] = "0123456789abcdef";
+
+ outc('"', f);+ if (!u8_isvalid(str, sz)) {+ // alternate print algorithm that preserves data if it's not UTF-8
+ for(i=0; i < sz; i++) {+ c = str[i];
+ if (c == '\\')
+ outsn("\\\\", f, 2);+ else if (c == '"')
+ outsn("\\\"", f, 2);+ else if (c >= 32 && c < 0x7f)
+ outc(c, f);
+ else {+ outsn("\\x", f, 2);+ outc(hexdig[c>>4], f);
+ outc(hexdig[c&0xf], f);
+ }
+ }
+ }
+ else {+ while (i < sz) {+ size_t n = u8_escape(buf, sizeof(buf), str, &i, sz, 1, 0);
+ outsn(buf, f, n-1);
+ }
+ }
+ outc('"', f);+}
+
+static numerictype_t sym_to_numtype(value_t type);
+
+// 'weak' means we don't need to accurately reproduce the type, so
+// for example #int32(0) can be printed as just 0. this is used
+// printing in a context where a type is already implied, e.g. inside
+// an array.
+static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
+ int weak)
+{+ if (type == bytesym) {+ unsigned char ch = *(unsigned char*)data;
+ if (print_princ)
+ outc(ch, f);
+ else if (weak)
+ HPOS+=ios_printf(f, "0x%hhx", ch);
+ else
+ HPOS+=ios_printf(f, "#byte(0x%hhx)", ch);
+ }
+ else if (type == wcharsym) {+ uint32_t wc = *(uint32_t*)data;
+ char seq[8];
+ size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1);
+ seq[nb] = '\0';
+ if (print_princ) {+ // TODO: better multibyte handling
+ outs(seq, f);
+ }
+ else {+ outsn("#\\", f, 2);+ if (wc == 0x00) outsn("nul", f, 3);+ else if (wc == 0x07) outsn("alarm", f, 5);+ else if (wc == 0x08) outsn("backspace", f, 9);+ else if (wc == 0x09) outsn("tab", f, 3);+ else if (wc == 0x0A) outsn("linefeed", f, 8);+ //else if (wc == 0x0A) outsn("newline", f, 7);+ else if (wc == 0x0B) outsn("vtab", f, 4);+ else if (wc == 0x0C) outsn("page", f, 4);+ else if (wc == 0x0D) outsn("return", f, 6);+ else if (wc == 0x1B) outsn("esc", f, 3);+ else if (wc == 0x20) outsn("space", f, 5);+ else if (wc == 0x7F) outsn("delete", f, 6);+ else if (iswprint(wc)) outs(seq, f);
+ else HPOS+=ios_printf(f, "x%04x", (int)wc);
+ }
+ }
+ else if (type == floatsym || type == doublesym) {+ char buf[64];
+ double d;
+ int ndec;
+ if (type == floatsym) { d = (double)*(float*)data; ndec = 8; }+ else { d = *(double*)data; ndec = 16; }+ if (!DFINITE(d)) {+ char *rep;
+ if (isnan(d))
+ rep = sign_bit(d) ? "-nan.0" : "+nan.0";
+ else
+ rep = sign_bit(d) ? "-inf.0" : "+inf.0";
+ if (type == floatsym && !print_princ && !weak)
+ HPOS+=ios_printf(f, "#%s(%s)", symbol_name(type), rep);
+ else
+ outs(rep, f);
+ }
+ else if (d == 0) {+ if (1/d < 0)
+ outsn("-0.0", f, 4);+ else
+ outsn("0.0", f, 3);+ if (type == floatsym && !print_princ && !weak)
+ outc('f', f);+ }
+ else {+ snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10);
+ int hasdec = (strpbrk(buf, ".eE") != NULL);
+ outs(buf, f);
+ if (!hasdec) outsn(".0", f, 2);+ if (type == floatsym && !print_princ && !weak)
+ outc('f', f);+ }
+ }
+ else if (type == uint64sym
+#ifdef BITS64
+ || type == ulongsym
+#endif
+ ) {+ uint64_t ui64 = *(uint64_t*)data;
+ if (weak || print_princ)
+ HPOS += ios_printf(f, "%llu", ui64);
+ else
+ HPOS += ios_printf(f, "#%s(%llu)", symbol_name(type), ui64);
+ }
+ else if (issymbol(type)) {+ // handle other integer prims. we know it's smaller than uint64
+ // at this point, so int64 is big enough to capture everything.
+ int64_t i64 = conv_to_int64(data, sym_to_numtype(type));
+ if (weak || print_princ)
+ HPOS += ios_printf(f, "%lld", i64);
+ else
+ HPOS += ios_printf(f, "#%s(%lld)", symbol_name(type), i64);
+ }
+ else if (iscons(type)) {+ if (car_(type) == arraysym) {+ value_t eltype = car(cdr_(type));
+ size_t cnt, elsize;
+ if (iscons(cdr_(cdr_(type)))) {+ cnt = toulong(car_(cdr_(cdr_(type))), "length");
+ elsize = cnt ? len/cnt : 0;
+ }
+ else {+ // incomplete array type
+ int junk;
+ elsize = ctype_sizeof(eltype, &junk);
+ cnt = elsize ? len/elsize : 0;
+ }
+ if (eltype == bytesym) {+ if (print_princ) {+ ios_write(f, data, len);
+ /*
+ char *nl = memrchr(data, '\n', len);
+ if (nl)
+ HPOS = u8_strwidth(nl+1);
+ else
+ HPOS += u8_strwidth(data);
+ */
+ }
+ else {+ print_string(f, (char*)data, len);
+ }
+ return;
+ }
+ else if (eltype == wcharsym) {+ // TODO wchar
+ }
+ else {+ }
+ size_t i;
+ if (!weak) {+ if (eltype == uint8sym) {+ outsn("#vu8(", f, 5);+ }
+ else {+ outsn("#array(", f, 7);+ fl_print_child(f, eltype);
+ if (cnt > 0)
+ outc(' ', f);+ }
+ }
+ else {+ outc('[', f);+ }
+ for(i=0; i < cnt; i++) {+ if (i > 0)
+ outc(' ', f);+ cvalue_printdata(f, data, elsize, eltype, 1);
+ data += elsize;
+ }
+ if (!weak)
+ outc(')', f);+ else
+ outc(']', f);+ }
+ else if (car_(type) == enumsym) {+ int n = *(int*)data;
+ value_t syms = car(cdr_(type));
+ assert(isvector(syms));
+ if (!weak) {+ outsn("#enum(", f, 6);+ fl_print_child(f, syms);
+ outc(' ', f);+ }
+ if (n >= (int)vector_size(syms)) {+ cvalue_printdata(f, data, len, int32sym, 1);
+ }
+ else {+ fl_print_child(f, vector_elt(syms, n));
+ }
+ if (!weak)
+ outc(')', f);+ }
+ }
+}
+
+static void cvalue_print(ios_t *f, value_t v)
+{+ cvalue_t *cv = (cvalue_t*)ptr(v);
+ void *data = cptr(v);
+ value_t label;
+
+ if (cv_class(cv) == builtintype) {+ void *fptr = *(void**)data;
+ label = (value_t)ptrhash_get(&reverse_dlsym_lookup_table, cv);
+ if (label == (value_t)HT_NOTFOUND) {+ HPOS += ios_printf(f, "#<builtin @0x%08lx>",
+ (unsigned long)(builtin_t)fptr);
+ }
+ else {+ if (print_princ) {+ outs(symbol_name(label), f);
+ }
+ else {+ outsn("#fn(", f, 4);+ outs(symbol_name(label), f);
+ outc(')', f);+ }
+ }
+ }
+ else if (cv_class(cv)->vtable != NULL &&
+ cv_class(cv)->vtable->print != NULL) {+ cv_class(cv)->vtable->print(v, f);
+ }
+ else {+ value_t type = cv_type(cv);
+ size_t len = iscprim(v) ? cv_class(cv)->size : cv_len(cv);
+ cvalue_printdata(f, data, len, type, 0);
+ }
+}
+
+static void set_print_width()
+{+ value_t pw = symbol_value(printwidthsym);
+ if (!isfixnum(pw)) return;
+ SCR_WIDTH = numval(pw);
+}
+
+void fl_print(ios_t *f, value_t v)
+{+ print_pretty = (symbol_value(printprettysym) != FL_F);
+ if (print_pretty)
+ set_print_width();
+ print_princ = (symbol_value(printreadablysym) == FL_F);
+
+ value_t pl = symbol_value(printlengthsym);
+ if (isfixnum(pl)) print_length = numval(pl);
+ else print_length = -1;
+ pl = symbol_value(printlevelsym);
+ if (isfixnum(pl)) print_level = numval(pl);
+ else print_level = -1;
+ P_LEVEL = 0;
+
+ printlabel = 0;
+ print_traverse(v);
+ HPOS = VPOS = 0;
+
+ fl_print_child(f, v);
+
+ if (print_level >= 0 || print_length >= 0) {+ memset(consflags, 0, 4*bitvector_nwords(heapsize/sizeof(cons_t)));
+ }
+
+ if ((iscons(v) || isvector(v) || isfunction(v) || iscvalue(v)) &&
+ !fl_isstring(v) && v!=FL_T && v!=FL_F && v!=FL_NIL) {+ htable_reset(&printconses, 32);
+ }
+}
--- /dev/null
+++ b/read.c
@@ -1,0 +1,685 @@
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
+ TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
+ TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE, TOK_SHARPOPEN,
+ TOK_OPENB, TOK_CLOSEB, TOK_SHARPSYM, TOK_GENSYM, TOK_DOUBLEQUOTE
+};
+
+#define F value2c(ios_t*,readstate->source)
+
+// defines which characters are ordinary symbol characters.
+// exceptions are '.', which is an ordinary symbol character
+// unless it's the only character in the symbol, and '#', which is
+// an ordinary symbol character unless it's the first character.
+static inline int symchar(char c)
+{+ static char *special = "()[]'\";`,\\| \f\n\r\t\v";
+ return !strchr(special, c);
+}
+
+int isnumtok_base(char *tok, value_t *pval, int base)
+{+ char *end;
+ int64_t i64;
+ uint64_t ui64;
+ double d;
+ if (*tok == '\0')
+ return 0;
+ if (!((tok[0]=='0' && tok[1]=='x') || (base >= 15)) &&
+ strpbrk(tok, ".eEpP")) {+ d = strtod(tok, &end);
+ if (*end == '\0') {+ if (pval) *pval = mk_double(d);
+ return 1;
+ }
+ // floats can end in f or f0
+ if (end > tok && end[0] == 'f' &&
+ (end[1] == '\0' ||
+ (end[1] == '0' && end[2] == '\0'))) {+ if (pval) *pval = mk_float((float)d);
+ return 1;
+ }
+ }
+
+ if (tok[0] == '+') {+ if (!strcmp(tok,"+NaN") || !strcasecmp(tok,"+nan.0")) {+ if (pval) *pval = mk_double(D_PNAN);
+ return 1;
+ }
+ if (!strcmp(tok,"+Inf") || !strcasecmp(tok,"+inf.0")) {+ if (pval) *pval = mk_double(D_PINF);
+ return 1;
+ }
+ }
+ else if (tok[0] == '-') {+ if (!strcmp(tok,"-NaN") || !strcasecmp(tok,"-nan.0")) {+ if (pval) *pval = mk_double(D_NNAN);
+ return 1;
+ }
+ if (!strcmp(tok,"-Inf") || !strcasecmp(tok,"-inf.0")) {+ if (pval) *pval = mk_double(D_NINF);
+ return 1;
+ }
+ errno = 0;
+ i64 = strtoll(tok, &end, base);
+ if (errno)
+ return 0;
+ if (pval) *pval = return_from_int64(i64);
+ return (*end == '\0');
+ }
+ errno = 0;
+ ui64 = strtoull(tok, &end, base);
+ if (errno)
+ return 0;
+ if (pval) *pval = return_from_uint64(ui64);
+ return (*end == '\0');
+}
+
+static int isnumtok(char *tok, value_t *pval)
+{+ return isnumtok_base(tok, pval, 0);
+}
+
+static int read_numtok(char *tok, value_t *pval, int base)
+{+ int result;
+ errno = 0;
+ result = isnumtok_base(tok, pval, base);
+ if (errno == ERANGE)
+ lerrorf(ParseError, "read: overflow in numeric constant %s", tok);
+ return result;
+}
+
+static u_int32_t toktype = TOK_NONE;
+static value_t tokval;
+static char buf[256];
+
+static char nextchar()
+{+ int ch;
+ char c;
+ ios_t *f = F;
+
+ do {+ if (f->bpos < f->size) {+ ch = f->buf[f->bpos++];
+ }
+ else {+ ch = ios_getc(f);
+ if (ch == IOS_EOF)
+ return 0;
+ }
+ c = (char)ch;
+ if (c == ';') {+ // single-line comment
+ do {+ ch = ios_getc(f);
+ if (ch == IOS_EOF)
+ return 0;
+ } while ((char)ch != '\n');
+ c = (char)ch;
+ }
+ } while (c==' ' || isspace(c));
+ return c;
+}
+
+static void take(void)
+{+ toktype = TOK_NONE;
+}
+
+static void accumchar(char c, int *pi)
+{+ buf[(*pi)++] = c;
+ if (*pi >= (int)(sizeof(buf)-1))
+ lerror(ParseError, "read: token too long");
+}
+
+// return: 1 if escaped (forced to be symbol)
+static int read_token(char c, int digits)
+{+ int i=0, ch, escaped=0, issym=0, first=1;
+
+ while (1) {+ if (!first) {+ ch = ios_getc(F);
+ if (ch == IOS_EOF)
+ goto terminate;
+ c = (char)ch;
+ }
+ first = 0;
+ if (c == '|') {+ issym = 1;
+ escaped = !escaped;
+ }
+ else if (c == '\\') {+ issym = 1;
+ ch = ios_getc(F);
+ if (ch == IOS_EOF)
+ goto terminate;
+ accumchar((char)ch, &i);
+ }
+ else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {+ break;
+ }
+ else {+ accumchar(c, &i);
+ }
+ }
+ ios_ungetc(c, F);
+ terminate:
+ buf[i++] = '\0';
+ return issym;
+}
+
+static value_t do_read_sexpr(value_t label);
+
+static u_int32_t peek()
+{+ char c, *end;
+ fixnum_t x;
+ int ch, base;
+
+ if (toktype != TOK_NONE)
+ return toktype;
+ c = nextchar();
+ if (ios_eof(F)) return TOK_NONE;
+ if (c == '(') {+ toktype = TOK_OPEN;
+ }
+ else if (c == ')') {+ toktype = TOK_CLOSE;
+ }
+ else if (c == '[') {+ toktype = TOK_OPENB;
+ }
+ else if (c == ']') {+ toktype = TOK_CLOSEB;
+ }
+ else if (c == '\'') {+ toktype = TOK_QUOTE;
+ }
+ else if (c == '`') {+ toktype = TOK_BQ;
+ }
+ else if (c == '"') {+ toktype = TOK_DOUBLEQUOTE;
+ }
+ else if (c == '#') {+ ch = ios_getc(F); c = (char)ch;
+ if (ch == IOS_EOF)
+ lerror(ParseError, "read: invalid read macro");
+ if (c == '.') {+ toktype = TOK_SHARPDOT;
+ }
+ else if (c == '\'') {+ toktype = TOK_SHARPQUOTE;
+ }
+ else if (c == '\\') {+ uint32_t cval;
+ if (ios_getutf8(F, &cval) == IOS_EOF)
+ lerror(ParseError, "read: end of input in character constant");
+ if (cval == (uint32_t)'u' || cval == (uint32_t)'U' ||
+ cval == (uint32_t)'x') {+ read_token('u', 0);+ if (buf[1] != '\0') { // not a solitary 'u','U','x'+ if (!read_numtok(&buf[1], &tokval, 16))
+ lerror(ParseError,
+ "read: invalid hex character constant");
+ cval = numval(tokval);
+ }
+ }
+ else if (cval >= 'a' && cval <= 'z') {+ read_token((char)cval, 0);
+ tokval = symbol(buf);
+ if (buf[1] == '\0') /* one character */;
+ else if (tokval == nulsym) cval = 0x00;
+ else if (tokval == alarmsym) cval = 0x07;
+ else if (tokval == backspacesym) cval = 0x08;
+ else if (tokval == tabsym) cval = 0x09;
+ else if (tokval == linefeedsym) cval = 0x0A;
+ else if (tokval == newlinesym) cval = 0x0A;
+ else if (tokval == vtabsym) cval = 0x0B;
+ else if (tokval == pagesym) cval = 0x0C;
+ else if (tokval == returnsym) cval = 0x0D;
+ else if (tokval == escsym) cval = 0x1B;
+ else if (tokval == spacesym) cval = 0x20;
+ else if (tokval == deletesym) cval = 0x7F;
+ else
+ lerrorf(ParseError, "read: unknown character #\\%s", buf);
+ }
+ toktype = TOK_NUM;
+ tokval = mk_wchar(cval);
+ }
+ else if (c == '(') {+ toktype = TOK_SHARPOPEN;
+ }
+ else if (c == '<') {+ lerror(ParseError, "read: unreadable object");
+ }
+ else if (isdigit(c)) {+ read_token(c, 1);
+ c = (char)ios_getc(F);
+ if (c == '#')
+ toktype = TOK_BACKREF;
+ else if (c == '=')
+ toktype = TOK_LABEL;
+ else
+ lerror(ParseError, "read: invalid label");
+ errno = 0;
+ x = strtol(buf, &end, 10);
+ if (*end != '\0' || errno)
+ lerror(ParseError, "read: invalid label");
+ tokval = fixnum(x);
+ }
+ else if (c == '!') {+ // #! single line comment for shbang script support
+ do {+ ch = ios_getc(F);
+ } while (ch != IOS_EOF && (char)ch != '\n');
+ return peek();
+ }
+ else if (c == '|') {+ // multiline comment
+ int commentlevel=1;
+ while (1) {+ ch = ios_getc(F);
+ hashpipe_gotc:
+ if (ch == IOS_EOF)
+ lerror(ParseError, "read: eof within comment");
+ if ((char)ch == '|') {+ ch = ios_getc(F);
+ if ((char)ch == '#') {+ commentlevel--;
+ if (commentlevel == 0)
+ break;
+ else
+ continue;
+ }
+ goto hashpipe_gotc;
+ }
+ else if ((char)ch == '#') {+ ch = ios_getc(F);
+ if ((char)ch == '|')
+ commentlevel++;
+ else
+ goto hashpipe_gotc;
+ }
+ }
+ // this was whitespace, so keep peeking
+ return peek();
+ }
+ else if (c == ';') {+ // datum comment
+ (void)do_read_sexpr(UNBOUND); // skip
+ return peek();
+ }
+ else if (c == ':') {+ // gensym
+ ch = ios_getc(F);
+ if ((char)ch == 'g')
+ ch = ios_getc(F);
+ read_token((char)ch, 0);
+ errno = 0;
+ x = strtol(buf, &end, 10);
+ if (*end != '\0' || buf[0] == '\0' || errno)
+ lerror(ParseError, "read: invalid gensym label");
+ toktype = TOK_GENSYM;
+ tokval = fixnum(x);
+ }
+ else if (symchar(c)) {+ read_token(ch, 0);
+
+ if (((c == 'b' && (base= 2)) ||
+ (c == 'o' && (base= 8)) ||
+ (c == 'd' && (base=10)) ||
+ (c == 'x' && (base=16))) &&
+ (isdigit_base(buf[1],base) ||
+ buf[1]=='-')) {+ if (!read_numtok(&buf[1], &tokval, base))
+ lerrorf(ParseError, "read: invalid base %d constant", base);
+ return (toktype=TOK_NUM);
+ }
+
+ toktype = TOK_SHARPSYM;
+ tokval = symbol(buf);
+ }
+ else {+ lerror(ParseError, "read: unknown read macro");
+ }
+ }
+ else if (c == ',') {+ toktype = TOK_COMMA;
+ ch = ios_getc(F);
+ if (ch == IOS_EOF)
+ return toktype;
+ if ((char)ch == '@')
+ toktype = TOK_COMMAAT;
+ else if ((char)ch == '.')
+ toktype = TOK_COMMADOT;
+ else
+ ios_ungetc((char)ch, F);
+ }
+ else {+ if (!read_token(c, 0)) {+ if (buf[0]=='.' && buf[1]=='\0') {+ return (toktype=TOK_DOT);
+ }
+ else {+ if (read_numtok(buf, &tokval, 0))
+ return (toktype=TOK_NUM);
+ }
+ }
+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ return toktype;
+}
+
+// NOTE: this is NOT an efficient operation. it is only used by the
+// reader, and requires at least 1 and up to 3 garbage collections!
+static value_t vector_grow(value_t v)
+{+ size_t i, s = vector_size(v);
+ size_t d = vector_grow_amt(s);
+ PUSH(v);
+ assert(s+d > s);
+ value_t newv = alloc_vector(s+d, 1);
+ v = Stack[SP-1];
+ for(i=0; i < s; i++)
+ vector_elt(newv, i) = vector_elt(v, i);
+ // use gc to rewrite references from the old vector to the new
+ Stack[SP-1] = newv;
+ if (s > 0) {+ ((size_t*)ptr(v))[0] |= 0x1;
+ vector_elt(v, 0) = newv;
+ gc(0);
+ }
+ return POP();
+}
+
+static value_t read_vector(value_t label, u_int32_t closer)
+{+ value_t v=the_empty_vector, elt;
+ u_int32_t i=0;
+ PUSH(v);
+ if (label != UNBOUND)
+ ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
+ while (peek() != closer) {+ if (ios_eof(F))
+ lerror(ParseError, "read: unexpected end of input");
+ if (i >= vector_size(v)) {+ v = Stack[SP-1] = vector_grow(v);
+ if (label != UNBOUND)
+ ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
+ }
+ elt = do_read_sexpr(UNBOUND);
+ v = Stack[SP-1];
+ assert(i < vector_size(v));
+ vector_elt(v,i) = elt;
+ i++;
+ }
+ take();
+ if (i > 0)
+ vector_setsize(v, i);
+ return POP();
+}
+
+static value_t read_string()
+{+ char *buf, *temp;
+ char eseq[10];
+ size_t i=0, j, sz = 64, ndig;
+ int c;
+ value_t s;
+ u_int32_t wc;
+
+ buf = malloc(sz);
+ while (1) {+ if (i >= sz-4) { // -4: leaves room for longest utf8 sequence+ sz *= 2;
+ temp = realloc(buf, sz);
+ if (temp == NULL) {+ free(buf);
+ lerror(ParseError, "read: out of memory reading string");
+ }
+ buf = temp;
+ }
+ c = ios_getc(F);
+ if (c == IOS_EOF) {+ free(buf);
+ lerror(ParseError, "read: unexpected end of input in string");
+ }
+ if (c == '"')
+ break;
+ else if (c == '\\') {+ c = ios_getc(F);
+ if (c == IOS_EOF) {+ free(buf);
+ lerror(ParseError, "read: end of input in escape sequence");
+ }
+ j=0;
+ if (octal_digit(c)) {+ do {+ eseq[j++] = c;
+ c = ios_getc(F);
+ } while (octal_digit(c) && j<3 && (c!=IOS_EOF));
+ if (c!=IOS_EOF) ios_ungetc(c, F);
+ eseq[j] = '\0';
+ wc = strtol(eseq, NULL, 8);
+ // \DDD and \xXX read bytes, not characters
+ buf[i++] = ((char)wc);
+ }
+ else if ((c=='x' && (ndig=2)) ||
+ (c=='u' && (ndig=4)) ||
+ (c=='U' && (ndig=8))) {+ c = ios_getc(F);
+ while (hex_digit(c) && j<ndig && (c!=IOS_EOF)) {+ eseq[j++] = c;
+ c = ios_getc(F);
+ }
+ if (c!=IOS_EOF) ios_ungetc(c, F);
+ eseq[j] = '\0';
+ if (j) wc = strtol(eseq, NULL, 16);
+ else {+ free(buf);
+ lerror(ParseError, "read: invalid escape sequence");
+ }
+ if (ndig == 2)
+ buf[i++] = ((char)wc);
+ else
+ i += u8_wc_toutf8(&buf[i], wc);
+ }
+ else {+ buf[i++] = read_escape_control_char((char)c);
+ }
+ }
+ else {+ buf[i++] = c;
+ }
+ }
+ s = cvalue_string(i);
+ memcpy(cvalue_data(s), buf, i);
+ free(buf);
+ return s;
+}
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void read_list(value_t *pval, value_t label)
+{+ value_t c, *pc;
+ u_int32_t t;
+
+ PUSH(NIL);
+ pc = &Stack[SP-1]; // to keep track of current cons cell
+ t = peek();
+ while (t != TOK_CLOSE) {+ if (ios_eof(F))
+ lerror(ParseError, "read: unexpected end of input");
+ c = mk_cons(); car_(c) = cdr_(c) = NIL;
+ if (iscons(*pc)) {+ cdr_(*pc) = c;
+ }
+ else {+ *pval = c;
+ if (label != UNBOUND)
+ ptrhash_put(&readstate->backrefs, (void*)label, (void*)c);
+ }
+ *pc = c;
+ c = do_read_sexpr(UNBOUND); // must be on separate lines due to
+ car_(*pc) = c; // undefined evaluation order
+
+ t = peek();
+ if (t == TOK_DOT) {+ take();
+ c = do_read_sexpr(UNBOUND);
+ cdr_(*pc) = c;
+ t = peek();
+ if (ios_eof(F))
+ lerror(ParseError, "read: unexpected end of input");
+ if (t != TOK_CLOSE)
+ lerror(ParseError, "read: expected ')'");
+ }
+ }
+ take();
+ (void)POP();
+}
+
+// label is the backreference we'd like to fix up with this read
+static value_t do_read_sexpr(value_t label)
+{+ value_t v, sym, oldtokval, *head;
+ value_t *pv;
+ u_int32_t t;
+ char c;
+
+ t = peek();
+ take();
+ switch (t) {+ case TOK_CLOSE:
+ lerror(ParseError, "read: unexpected ')'");
+ case TOK_CLOSEB:
+ lerror(ParseError, "read: unexpected ']'");
+ case TOK_DOT:
+ lerror(ParseError, "read: unexpected '.'");
+ case TOK_SYM:
+ case TOK_NUM:
+ return tokval;
+ case TOK_COMMA:
+ head = &COMMA; goto listwith;
+ case TOK_COMMAAT:
+ head = &COMMAAT; goto listwith;
+ case TOK_COMMADOT:
+ head = &COMMADOT; goto listwith;
+ case TOK_BQ:
+ head = &BACKQUOTE; goto listwith;
+ case TOK_QUOTE:
+ head = "E;
+ listwith:
+ v = cons_reserve(2);
+ car_(v) = *head;
+ cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS);
+ car_(cdr_(v)) = cdr_(cdr_(v)) = NIL;
+ PUSH(v);
+ if (label != UNBOUND)
+ ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
+ v = do_read_sexpr(UNBOUND);
+ car_(cdr_(Stack[SP-1])) = v;
+ return POP();
+ case TOK_SHARPQUOTE:
+ // femtoLisp doesn't need symbol-function, so #' does nothing
+ return do_read_sexpr(label);
+ case TOK_OPEN:
+ PUSH(NIL);
+ read_list(&Stack[SP-1], label);
+ return POP();
+ case TOK_SHARPSYM:
+ sym = tokval;
+ if (sym == tsym || sym == Tsym)
+ return FL_T;
+ else if (sym == fsym || sym == Fsym)
+ return FL_F;
+ // constructor notation
+ c = nextchar();
+ if (c != '(') {+ take();
+ lerrorf(ParseError, "read: expected argument list for %s",
+ symbol_name(tokval));
+ }
+ PUSH(NIL);
+ read_list(&Stack[SP-1], UNBOUND);
+ if (sym == vu8sym) {+ sym = arraysym;
+ Stack[SP-1] = fl_cons(uint8sym, Stack[SP-1]);
+ }
+ else if (sym == fnsym) {+ sym = FUNCTION;
+ }
+ v = symbol_value(sym);
+ if (v == UNBOUND)
+ fl_raise(fl_list2(UnboundError, sym));
+ return fl_apply(v, POP());
+ case TOK_OPENB:
+ return read_vector(label, TOK_CLOSEB);
+ case TOK_SHARPOPEN:
+ return read_vector(label, TOK_CLOSE);
+ case TOK_SHARPDOT:
+ // eval-when-read
+ // evaluated expressions can refer to existing backreferences, but they
+ // cannot see pending labels. in other words:
+ // (... #2=#.#0# ... ) OK
+ // (... #2=#.(#2#) ... ) DO NOT WANT
+ sym = do_read_sexpr(UNBOUND);
+ if (issymbol(sym)) {+ v = symbol_value(sym);
+ if (v == UNBOUND)
+ fl_raise(fl_list2(UnboundError, sym));
+ return v;
+ }
+ return fl_toplevel_eval(sym);
+ case TOK_LABEL:
+ // create backreference label
+ if (ptrhash_has(&readstate->backrefs, (void*)tokval))
+ lerrorf(ParseError, "read: label %ld redefined", numval(tokval));
+ oldtokval = tokval;
+ v = do_read_sexpr(tokval);
+ ptrhash_put(&readstate->backrefs, (void*)oldtokval, (void*)v);
+ return v;
+ case TOK_BACKREF:
+ // look up backreference
+ v = (value_t)ptrhash_get(&readstate->backrefs, (void*)tokval);
+ if (v == (value_t)HT_NOTFOUND)
+ lerrorf(ParseError, "read: undefined label %ld", numval(tokval));
+ return v;
+ case TOK_GENSYM:
+ pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval);
+ if (*pv == (value_t)HT_NOTFOUND)
+ *pv = fl_gensym(NULL, 0);
+ return *pv;
+ case TOK_DOUBLEQUOTE:
+ return read_string();
+ }
+ return FL_UNSPECIFIED;
+}
+
+value_t fl_read_sexpr(value_t f)
+{+ value_t v;
+ fl_readstate_t state;
+ state.prev = readstate;
+ htable_new(&state.backrefs, 8);
+ htable_new(&state.gensyms, 8);
+ state.source = f;
+ readstate = &state;
+ assert(toktype == TOK_NONE);
+ fl_gc_handle(&tokval);
+
+ v = do_read_sexpr(UNBOUND);
+
+ fl_free_gc_handles(1);
+ readstate = state.prev;
+ free_readstate(&state);
+ return v;
+}
--- /dev/null
+++ b/string.c
@@ -1,0 +1,416 @@
+/*
+ string functions
+*/
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <ctype.h>
+#include <wchar.h>
+#include <wctype.h>
+#include <sys/types.h>
+#include <sys/time.h>
+#include <errno.h>
+#include "llt.h"
+#include "flisp.h"
+
+value_t fl_stringp(value_t *args, u_int32_t nargs)
+{+ argcount("string?", nargs, 1);+ return fl_isstring(args[0]) ? FL_T : FL_F;
+}
+
+value_t fl_string_count(value_t *args, u_int32_t nargs)
+{+ size_t start = 0;
+ if (nargs < 1 || nargs > 3)
+ argcount("string.count", nargs, 1);+ if (!fl_isstring(args[0]))
+ type_error("string.count", "string", args[0]);+ size_t len = cv_len((cvalue_t*)ptr(args[0]));
+ size_t stop = len;
+ if (nargs > 1) {+ start = toulong(args[1], "string.count");
+ if (start > len)
+ bounds_error("string.count", args[0], args[1]);+ if (nargs > 2) {+ stop = toulong(args[2], "string.count");
+ if (stop > len)
+ bounds_error("string.count", args[0], args[2]);+ if (stop <= start)
+ return fixnum(0);
+ }
+ }
+ char *str = cvalue_data(args[0]);
+ return size_wrap(u8_charnum(str+start, stop-start));
+}
+
+value_t fl_string_width(value_t *args, u_int32_t nargs)
+{+ argcount("string.width", nargs, 1);+ if (iscprim(args[0])) {+ cprim_t *cp = (cprim_t*)ptr(args[0]);
+ if (cp_class(cp) == wchartype) {+ int w = wcwidth(*(uint32_t*)cp_data(cp));
+ if (w < 0)
+ return FL_F;
+ return fixnum(w);
+ }
+ }
+ char *s = tostring(args[0], "string.width");
+ return size_wrap(u8_strwidth(s));
+}
+
+value_t fl_string_reverse(value_t *args, u_int32_t nargs)
+{+ argcount("string.reverse", nargs, 1);+ if (!fl_isstring(args[0]))
+ type_error("string.reverse", "string", args[0]);+ size_t len = cv_len((cvalue_t*)ptr(args[0]));
+ value_t ns = cvalue_string(len);
+ u8_reverse(cvalue_data(ns), cvalue_data(args[0]), len);
+ return ns;
+}
+
+value_t fl_string_encode(value_t *args, u_int32_t nargs)
+{+ argcount("string.encode", nargs, 1);+ if (iscvalue(args[0])) {+ cvalue_t *cv = (cvalue_t*)ptr(args[0]);
+ fltype_t *t = cv_class(cv);
+ if (t->eltype == wchartype) {+ size_t nc = cv_len(cv) / sizeof(uint32_t);
+ uint32_t *ptr = (uint32_t*)cv_data(cv);
+ size_t nbytes = u8_codingsize(ptr, nc);
+ value_t str = cvalue_string(nbytes);
+ ptr = cv_data((cvalue_t*)ptr(args[0])); // relocatable pointer
+ u8_toutf8(cvalue_data(str), nbytes, ptr, nc);
+ return str;
+ }
+ }
+ type_error("string.encode", "wchar array", args[0]);+}
+
+value_t fl_string_decode(value_t *args, u_int32_t nargs)
+{+ int term=0;
+ if (nargs == 2) {+ term = (args[1] != FL_F);
+ }
+ else {+ argcount("string.decode", nargs, 1);+ }
+ if (!fl_isstring(args[0]))
+ type_error("string.decode", "string", args[0]);+ cvalue_t *cv = (cvalue_t*)ptr(args[0]);
+ char *ptr = (char*)cv_data(cv);
+ size_t nb = cv_len(cv);
+ size_t nc = u8_charnum(ptr, nb);
+ size_t newsz = nc*sizeof(uint32_t);
+ if (term) newsz += sizeof(uint32_t);
+ value_t wcstr = cvalue(wcstringtype, newsz);
+ ptr = cv_data((cvalue_t*)ptr(args[0])); // relocatable pointer
+ uint32_t *pwc = cvalue_data(wcstr);
+ u8_toucs(pwc, nc, ptr, nb);
+ if (term) pwc[nc] = 0;
+ return wcstr;
+}
+
+extern value_t fl_buffer(value_t *args, u_int32_t nargs);
+extern value_t stream_to_string(value_t *ps);
+
+value_t fl_string(value_t *args, u_int32_t nargs)
+{+ if (nargs == 1 && fl_isstring(args[0]))
+ return args[0];
+ value_t arg, buf = fl_buffer(NULL, 0);
+ ios_t *s = value2c(ios_t*,buf);
+ uint32_t i;
+ value_t oldpr = symbol_value(printreadablysym);
+ value_t oldpp = symbol_value(printprettysym);
+ set(printreadablysym, FL_F);
+ set(printprettysym, FL_F);
+ FOR_ARGS(i,0,arg,args) {+ fl_print(s, args[i]);
+ }
+ set(printreadablysym, oldpr);
+ set(printprettysym, oldpp);
+ fl_gc_handle(&buf);
+ value_t outp = stream_to_string(&buf);
+ fl_free_gc_handles(1);
+ return outp;
+}
+
+value_t fl_string_split(value_t *args, u_int32_t nargs)
+{+ argcount("string.split", nargs, 2);+ char *s = tostring(args[0], "string.split");
+ char *delim = tostring(args[1], "string.split");
+ size_t len = cv_len((cvalue_t*)ptr(args[0]));
+ size_t dlen = cv_len((cvalue_t*)ptr(args[1]));
+ size_t ssz, tokend=0, tokstart=0, i=0;
+ value_t first=FL_NIL, c=FL_NIL, last;
+ size_t junk;
+ fl_gc_handle(&first);
+ fl_gc_handle(&last);
+
+ do {+ // find and allocate next token
+ tokstart = tokend = i;
+ while (i < len &&
+ !u8_memchr(delim, u8_nextmemchar(s, &i), dlen, &junk))
+ tokend = i;
+ ssz = tokend - tokstart;
+ last = c; // save previous cons cell
+ c = fl_cons(cvalue_string(ssz), FL_NIL);
+
+ // we've done allocation; reload movable pointers
+ s = cv_data((cvalue_t*)ptr(args[0]));
+ delim = cv_data((cvalue_t*)ptr(args[1]));
+
+ if (ssz) memcpy(cv_data((cvalue_t*)ptr(car_(c))), &s[tokstart], ssz);
+
+ // link new cell
+ if (last == FL_NIL)
+ first = c; // first time, save first cons
+ else
+ ((cons_t*)ptr(last))->cdr = c;
+
+ // note this tricky condition: if the string ends with a
+ // delimiter, we need to go around one more time to add an
+ // empty string. this happens when (i==len && tokend<i)
+ } while (i < len || (i==len && (tokend!=i)));
+ fl_free_gc_handles(2);
+ return first;
+}
+
+value_t fl_string_sub(value_t *args, u_int32_t nargs)
+{+ if (nargs != 2)
+ argcount("string.sub", nargs, 3);+ char *s = tostring(args[0], "string.sub");
+ size_t len = cv_len((cvalue_t*)ptr(args[0]));
+ size_t i1, i2;
+ i1 = toulong(args[1], "string.sub");
+ if (i1 > len)
+ bounds_error("string.sub", args[0], args[1]);+ if (nargs == 3) {+ i2 = toulong(args[2], "string.sub");
+ if (i2 > len)
+ bounds_error("string.sub", args[0], args[2]);+ }
+ else {+ i2 = len;
+ }
+ if (i2 <= i1)
+ return cvalue_string(0);
+ value_t ns = cvalue_string(i2-i1);
+ memcpy(cv_data((cvalue_t*)ptr(ns)), &s[i1], i2-i1);
+ return ns;
+}
+
+value_t fl_string_char(value_t *args, u_int32_t nargs)
+{+ argcount("string.char", nargs, 2);+ char *s = tostring(args[0], "string.char");
+ size_t len = cv_len((cvalue_t*)ptr(args[0]));
+ size_t i = toulong(args[1], "string.char");
+ if (i >= len)
+ bounds_error("string.char", args[0], args[1]);+ size_t sl = u8_seqlen(&s[i]);
+ if (sl > len || i > len-sl)
+ bounds_error("string.char", args[0], args[1]);+ return mk_wchar(u8_nextchar(s, &i));
+}
+
+value_t fl_char_upcase(value_t *args, u_int32_t nargs)
+{+ argcount("char.upcase", nargs, 1);+ cprim_t *cp = (cprim_t*)ptr(args[0]);
+ if (!iscprim(args[0]) || cp_class(cp) != wchartype)
+ type_error("char.upcase", "wchar", args[0]);+ return mk_wchar(towupper(*(int32_t*)cp_data(cp)));
+}
+value_t fl_char_downcase(value_t *args, u_int32_t nargs)
+{+ argcount("char.downcase", nargs, 1);+ cprim_t *cp = (cprim_t*)ptr(args[0]);
+ if (!iscprim(args[0]) || cp_class(cp) != wchartype)
+ type_error("char.downcase", "wchar", args[0]);+ return mk_wchar(towlower(*(int32_t*)cp_data(cp)));
+}
+
+static value_t mem_find_byte(char *s, char c, size_t start, size_t len)
+{+ char *p = memchr(s+start, c, len-start);
+ if (p == NULL)
+ return FL_F;
+ return size_wrap((size_t)(p - s));
+}
+
+value_t fl_string_find(value_t *args, u_int32_t nargs)
+{+ char cbuf[8];
+ size_t start = 0;
+ if (nargs == 3)
+ start = toulong(args[2], "string.find");
+ else
+ argcount("string.find", nargs, 2);+ char *s = tostring(args[0], "string.find");
+ size_t len = cv_len((cvalue_t*)ptr(args[0]));
+ if (start > len)
+ bounds_error("string.find", args[0], args[2]);+ char *needle; size_t needlesz;
+
+ value_t v = args[1];
+ cprim_t *cp = (cprim_t*)ptr(v);
+ if (iscprim(v) && cp_class(cp) == wchartype) {+ uint32_t c = *(uint32_t*)cp_data(cp);
+ if (c <= 0x7f)
+ return mem_find_byte(s, (char)c, start, len);
+ needlesz = u8_toutf8(cbuf, sizeof(cbuf), &c, 1);
+ needle = cbuf;
+ }
+ else if (iscprim(v) && cp_class(cp) == bytetype) {+ return mem_find_byte(s, *(char*)cp_data(cp), start, len);
+ }
+ else if (fl_isstring(v)) {+ cvalue_t *cv = (cvalue_t*)ptr(v);
+ needlesz = cv_len(cv);
+ needle = (char*)cv_data(cv);
+ }
+ else {+ type_error("string.find", "string", args[1]);+ }
+ if (needlesz > len-start)
+ return FL_F;
+ else if (needlesz == 1)
+ return mem_find_byte(s, needle[0], start, len);
+ else if (needlesz == 0)
+ return size_wrap(start);
+ size_t i;
+ for(i=start; i < len-needlesz+1; i++) {+ if (s[i] == needle[0]) {+ if (!memcmp(&s[i+1], needle+1, needlesz-1))
+ return size_wrap(i);
+ }
+ }
+ return FL_F;
+}
+
+value_t fl_string_inc(value_t *args, u_int32_t nargs)
+{+ if (nargs < 2 || nargs > 3)
+ argcount("string.inc", nargs, 2);+ char *s = tostring(args[0], "string.inc");
+ size_t len = cv_len((cvalue_t*)ptr(args[0]));
+ size_t i = toulong(args[1], "string.inc");
+ size_t cnt = 1;
+ if (nargs == 3)
+ cnt = toulong(args[2], "string.inc");
+ while (cnt--) {+ if (i >= len)
+ bounds_error("string.inc", args[0], args[1]);+ (void)(isutf(s[++i]) || isutf(s[++i]) || isutf(s[++i]) || ++i);
+ }
+ return size_wrap(i);
+}
+
+value_t fl_string_dec(value_t *args, u_int32_t nargs)
+{+ if (nargs < 2 || nargs > 3)
+ argcount("string.dec", nargs, 2);+ char *s = tostring(args[0], "string.dec");
+ size_t len = cv_len((cvalue_t*)ptr(args[0]));
+ size_t i = toulong(args[1], "string.dec");
+ size_t cnt = 1;
+ if (nargs == 3)
+ cnt = toulong(args[2], "string.dec");
+ // note: i is allowed to start at index len
+ if (i > len)
+ bounds_error("string.dec", args[0], args[1]);+ while (cnt--) {+ if (i == 0)
+ bounds_error("string.dec", args[0], args[1]);+ (void)(isutf(s[--i]) || isutf(s[--i]) || isutf(s[--i]) || --i);
+ }
+ return size_wrap(i);
+}
+
+static unsigned long get_radix_arg(value_t arg, char *fname)
+{+ unsigned long radix = toulong(arg, fname);
+ if (radix < 2 || radix > 36)
+ lerrorf(ArgError, "%s: invalid radix", fname);
+ return radix;
+}
+
+value_t fl_numbertostring(value_t *args, u_int32_t nargs)
+{+ if (nargs < 1 || nargs > 2)
+ argcount("number->string", nargs, 2);+ value_t n = args[0];
+ int neg = 0;
+ uint64_t num;
+ if (isfixnum(n)) num = numval(n);
+ else if (!iscprim(n)) type_error("number->string", "integer", n);+ else num = conv_to_uint64(cp_data((cprim_t*)ptr(n)),
+ cp_numtype((cprim_t*)ptr(n)));
+ if (numval(fl_compare(args[0],fixnum(0))) < 0) {+ num = -num;
+ neg = 1;
+ }
+ unsigned long radix = 10;
+ if (nargs == 2)
+ radix = get_radix_arg(args[1], "number->string");
+ char buf[128];
+ char *str = uint2str(buf, sizeof(buf), num, radix);
+ if (neg && str > &buf[0])
+ *(--str) = '-';
+ return string_from_cstr(str);
+}
+
+value_t fl_stringtonumber(value_t *args, uint32_t nargs)
+{+ if (nargs < 1 || nargs > 2)
+ argcount("string->number", nargs, 2);+ char *str = tostring(args[0], "string->number");
+ value_t n;
+ ulong radix = 0;
+ if (nargs == 2)
+ radix = get_radix_arg(args[1], "string->number");
+ if (!isnumtok_base(str, &n, (int)radix))
+ return FL_F;
+ return n;
+}
+
+static builtinspec_t stringfunc_info[] = {+ { "string", fl_string },+ { "string?", fl_stringp },+ { "string.count", fl_string_count },+ { "string.width", fl_string_width },+ { "string.split", fl_string_split },+ { "string.sub", fl_string_sub },+ { "string.find", fl_string_find },+ { "string.char", fl_string_char },+ { "string.inc", fl_string_inc },+ { "string.dec", fl_string_dec },+ { "string.reverse", fl_string_reverse },+ { "string.encode", fl_string_encode },+ { "string.decode", fl_string_decode },+
+ { "char.upcase", fl_char_upcase },+ { "char.downcase", fl_char_downcase },+
+ { "number->string", fl_numbertostring },+ { "string->number", fl_stringtonumber },+
+ { NULL, NULL }+};
+
+void stringfuncs_init()
+{+ assign_global_builtins(stringfunc_info);
+}
--- /dev/null
+++ b/system.lsp
@@ -1,0 +1,1072 @@
+; -*- scheme -*-
+; femtoLisp standard library
+; by Jeff Bezanson (C) 2009
+; Distributed under the BSD License
+
+(define (void) #t) ; the unspecified value
+
+(define *builtins*
+ (vector
+ 0 0 0 0 0 0 0 0 0 0 0 0
+ (lambda (x y) (eq? x y)) (lambda (x y) (eqv? x y))
+ (lambda (x y) (equal? x y)) (lambda (x) (atom? x))
+ (lambda (x) (not x)) (lambda (x) (null? x))
+ (lambda (x) (boolean? x)) (lambda (x) (symbol? x))
+ (lambda (x) (number? x)) (lambda (x) (bound? x))
+ (lambda (x) (pair? x)) (lambda (x) (builtin? x))
+ (lambda (x) (vector? x)) (lambda (x) (fixnum? x))
+ (lambda (x) (function? x)) (lambda (x y) (cons x y))
+ (lambda rest (apply list rest)) (lambda (x) (car x))
+ (lambda (x) (cdr x)) (lambda (x y) (set-car! x y))
+ (lambda (x y) (set-cdr! x y)) (lambda rest (apply apply rest))
+ (lambda rest (apply + rest)) (lambda rest (apply - rest))
+ (lambda rest (apply * rest)) (lambda rest (apply / rest))
+ (lambda rest (apply div0 rest)) (lambda (x y) (= x y))
+ (lambda (x y) (< x y)) (lambda (x y) (compare x y))
+ (lambda rest (apply vector rest)) (lambda (x y) (aref x y))
+ (lambda (x y z) (aset! x y z))))
+
+(if (not (bound? '*syntax-environment*))
+ (define *syntax-environment* (table)))
+
+(define (set-syntax! s v) (put! *syntax-environment* s v))
+(define (symbol-syntax s) (get *syntax-environment* s #f))
+
+(define-macro (define-macro form . body)
+ `(set-syntax! ',(car form)
+ (lambda ,(cdr form) ,@body)))
+
+#;(define (map1 f lst acc)
+ (cdr
+ (prog1 acc
+ (while (pair? lst)
+ (begin (set! acc
+ (cdr (set-cdr! acc (cons (f (car lst)) ()))))
+ (set! lst (cdr lst)))))))
+
+#;(define (mapn f lsts)
+ (if (null? (car lsts))
+ ()
+ (cons (apply f (map1 car lsts (list ())))
+ (mapn f (map1 cdr lsts (list ()))))))
+
+#;(define (map f lst . lsts)
+ (if (null? lsts)
+ (map1 f lst (list ()))
+ (mapn f (cons lst lsts))))
+
+(define-macro (letrec binds . body)
+ `((lambda ,(map car binds)
+ ,.(map (lambda (b) `(set! ,@b)) binds)
+ ,@body)
+ ,.(map (lambda (x) (void)) binds)))
+
+(define-macro (let binds . body)
+ (let ((lname #f))
+ (if (symbol? binds)
+ (begin (set! lname binds)
+ (set! binds (car body))
+ (set! body (cdr body))))
+ (let ((thelambda
+ `(lambda ,(map (lambda (c) (if (pair? c) (car c) c))
+ binds)
+ ,@body))
+ (theargs
+ (map (lambda (c) (if (pair? c) (cadr c) (void))) binds)))
+ (cons (if lname
+ `(letrec ((,lname ,thelambda)) ,lname)
+ thelambda)
+ theargs))))
+
+(define-macro (cond . clauses)
+ (define (cond-clauses->if lst)
+ (if (atom? lst)
+ #f
+ (let ((clause (car lst)))
+ (if (or (eq? (car clause) 'else)
+ (eq? (car clause) #t))
+ (if (null? (cdr clause))
+ (car clause)
+ (cons 'begin (cdr clause)))
+ (if (null? (cdr clause))
+ ; test by itself
+ (list 'or
+ (car clause)
+ (cond-clauses->if (cdr lst)))
+ ; test => expression
+ (if (eq? (cadr clause) '=>)
+ (if (1arg-lambda? (caddr clause))
+ ; test => (lambda (x) ...)
+ (let ((var (caadr (caddr clause))))
+ `(let ((,var ,(car clause)))
+ (if ,var ,(cons 'begin (cddr (caddr clause)))
+ ,(cond-clauses->if (cdr lst)))))
+ ; test => proc
+ (let ((b (gensym)))
+ `(let ((,b ,(car clause)))
+ (if ,b
+ (,(caddr clause) ,b)
+ ,(cond-clauses->if (cdr lst))))))
+ (list 'if
+ (car clause)
+ (cons 'begin (cdr clause))
+ (cond-clauses->if (cdr lst)))))))))
+ (cond-clauses->if clauses))
+
+; standard procedures ---------------------------------------------------------
+
+(define (member item lst)
+ (cond ((atom? lst) #f)
+ ((equal? (car lst) item) lst)
+ (#t (member item (cdr lst)))))
+(define (memv item lst)
+ (cond ((atom? lst) #f)
+ ((eqv? (car lst) item) lst)
+ (#t (memv item (cdr lst)))))
+
+(define (assoc item lst)
+ (cond ((atom? lst) #f)
+ ((equal? (caar lst) item) (car lst))
+ (#t (assoc item (cdr lst)))))
+(define (assv item lst)
+ (cond ((atom? lst) #f)
+ ((eqv? (caar lst) item) (car lst))
+ (#t (assv item (cdr lst)))))
+
+(define (> a b) (< b a))
+(define (<= a b) (or (< a b) (= a b)))
+(define (>= a b) (or (< b a) (= a b)))
+(define (negative? x) (< x 0))
+(define (zero? x) (= x 0))
+(define (positive? x) (> x 0))
+(define (even? x) (= (logand x 1) 0))
+(define (odd? x) (not (even? x)))
+(define (identity x) x)
+(define (1+ n) (+ n 1))
+(define (1- n) (- n 1))
+(define (mod0 x y) (- x (* (div0 x y) y)))
+(define (div x y) (+ (div0 x y)
+ (or (and (< x 0)
+ (or (and (< y 0) 1)
+ -1))
+ 0)))
+(define (mod x y) (- x (* (div x y) y)))
+(define (random n)
+ (if (integer? n)
+ (mod (rand) n)
+ (* (rand.double) n)))
+(define (abs x) (if (< x 0) (- x) x))
+(define (max x0 . xs)
+ (if (null? xs) x0
+ (foldl (lambda (a b) (if (< a b) b a)) x0 xs)))
+(define (min x0 . xs)
+ (if (null? xs) x0
+ (foldl (lambda (a b) (if (< a b) a b)) x0 xs)))
+(define (char? x) (eq? (typeof x) 'wchar))
+(define (array? x) (or (vector? x)
+ (let ((t (typeof x)))
+ (and (pair? t) (eq? (car t) 'array)))))
+(define (closure? x) (and (function? x) (not (builtin? x))))
+
+(define (caar x) (car (car x)))
+(define (cadr x) (car (cdr x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (car (cdr x))))
+(define (cadar x) (car (cdr (car x))))
+(define (caddr x) (car (cdr (cdr x))))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (car (cdr x))))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+(define (caaaar x) (car (car (car (car x)))))
+(define (caaadr x) (car (car (car (cdr x)))))
+(define (caadar x) (car (car (cdr (car x)))))
+(define (caaddr x) (car (car (cdr (cdr x)))))
+(define (cadaar x) (car (cdr (car (car x)))))
+(define (cadadr x) (car (cdr (car (cdr x)))))
+(define (caddar x) (car (cdr (cdr (car x)))))
+(define (cadddr x) (car (cdr (cdr (cdr x)))))
+(define (cdaaar x) (cdr (car (car (car x)))))
+(define (cdaadr x) (cdr (car (car (cdr x)))))
+(define (cdadar x) (cdr (car (cdr (car x)))))
+(define (cdaddr x) (cdr (car (cdr (cdr x)))))
+(define (cddaar x) (cdr (cdr (car (car x)))))
+(define (cddadr x) (cdr (cdr (car (cdr x)))))
+(define (cdddar x) (cdr (cdr (cdr (car x)))))
+(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
+
+(let ((*values* (list '*values*)))
+ (set! values
+ (lambda vs
+ (if (and (pair? vs) (null? (cdr vs)))
+ (car vs)
+ (cons *values* vs))))
+ (set! call-with-values
+ (lambda (producer consumer)
+ (let ((res (producer)))
+ (if (and (pair? res) (eq? *values* (car res)))
+ (apply consumer (cdr res))
+ (consumer res))))))
+
+; list utilities --------------------------------------------------------------
+
+(define (every pred lst)
+ (or (atom? lst)
+ (and (pred (car lst))
+ (every pred (cdr lst)))))
+
+(define (any pred lst)
+ (and (pair? lst)
+ (or (pred (car lst))
+ (any pred (cdr lst)))))
+
+(define (list? a) (or (null? a) (and (pair? a) (list? (cdr a)))))
+
+(define (list-tail lst n)
+ (if (<= n 0) lst
+ (list-tail (cdr lst) (- n 1))))
+
+(define (list-head lst n)
+ (if (<= n 0) ()
+ (cons (car lst)
+ (list-head (cdr lst) (- n 1)))))
+
+(define (list-ref lst n)
+ (car (list-tail lst n)))
+
+; bounded length test
+; use this instead of (= (length lst) n), since it avoids unnecessary
+; work and always terminates.
+(define (length= lst n)
+ (cond ((< n 0) #f)
+ ((= n 0) (atom? lst))
+ ((atom? lst) (= n 0))
+ (else (length= (cdr lst) (- n 1)))))
+
+(define (length> lst n)
+ (cond ((< n 0) lst)
+ ((= n 0) (and (pair? lst) lst))
+ ((atom? lst) (< n 0))
+ (else (length> (cdr lst) (- n 1)))))
+
+(define (last-pair l)
+ (if (atom? (cdr l))
+ l
+ (last-pair (cdr l))))
+
+(define (lastcdr l)
+ (if (atom? l)
+ l
+ (cdr (last-pair l))))
+
+(define (to-proper l)
+ (cond ((null? l) l)
+ ((atom? l) (list l))
+ (else (cons (car l) (to-proper (cdr l))))))
+
+(define (map! f lst)
+ (prog1 lst
+ (while (pair? lst)
+ (set-car! lst (f (car lst)))
+ (set! lst (cdr lst)))))
+
+(define (filter pred lst)
+ (define (filter- f lst acc)
+ (cdr
+ (prog1 acc
+ (while (pair? lst)
+ (begin (if (pred (car lst))
+ (set! acc
+ (cdr (set-cdr! acc (cons (car lst) ())))))
+ (set! lst (cdr lst)))))))
+ (filter- pred lst (list ())))
+
+(define (separate pred lst)
+ (define (separate- pred lst yes no)
+ (let ((vals
+ (prog1
+ (cons yes no)
+ (while (pair? lst)
+ (begin (if (pred (car lst))
+ (set! yes
+ (cdr (set-cdr! yes (cons (car lst) ()))))
+ (set! no
+ (cdr (set-cdr! no (cons (car lst) ())))))
+ (set! lst (cdr lst)))))))
+ (values (cdr (car vals)) (cdr (cdr vals)))))
+ (separate- pred lst (list ()) (list ())))
+
+(define (count f l)
+ (define (count- f l n)
+ (if (null? l)
+ n
+ (count- f (cdr l) (if (f (car l))
+ (+ n 1)
+ n))))
+ (count- f l 0))
+
+(define (nestlist f zero n)
+ (if (<= n 0) ()
+ (cons zero (nestlist f (f zero) (- n 1)))))
+
+(define (foldr f zero lst)
+ (if (null? lst) zero
+ (f (car lst) (foldr f zero (cdr lst)))))
+
+(define (foldl f zero lst)
+ (if (null? lst) zero
+ (foldl f (f (car lst) zero) (cdr lst))))
+
+(define (reverse- zero lst)
+ (if (null? lst) zero
+ (reverse- (cons (car lst) zero) (cdr lst))))
+
+(define (reverse lst) (reverse- () lst))
+
+(define (reverse!- prev l)
+ (while (pair? l)
+ (set! l (prog1 (cdr l)
+ (set-cdr! l (prog1 prev
+ (set! prev l))))))
+ prev)
+
+(define (reverse! l) (reverse!- () l))
+
+(define (copy-tree l)
+ (if (atom? l) l
+ (cons (copy-tree (car l))
+ (copy-tree (cdr l)))))
+
+(define (delete-duplicates lst)
+ (if (atom? lst)
+ lst
+ (let ((elt (car lst))
+ (tail (cdr lst)))
+ (if (member elt tail)
+ (delete-duplicates tail)
+ (cons elt
+ (delete-duplicates tail))))))
+
+; backquote -------------------------------------------------------------------
+
+(define (revappend l1 l2) (reverse- l2 l1))
+(define (nreconc l1 l2) (reverse!- l2 l1))
+
+(define (self-evaluating? x)
+ (or (and (atom? x)
+ (not (symbol? x)))
+ (and (constant? x)
+ (symbol? x)
+ (eq x (top-level-value x)))))
+
+(define-macro (quasiquote x) (bq-process x 0))
+
+(define (splice-form? x)
+ (or (and (pair? x) (or (eq? (car x) 'unquote-splicing)
+ (eq? (car x) 'unquote-nsplicing)
+ (and (eq? (car x) 'unquote)
+ (length> x 2))))
+ (eq? x 'unquote)))
+
+;; bracket without splicing
+(define (bq-bracket1 x d)
+ (if (and (pair? x) (eq? (car x) 'unquote))
+ (if (= d 0)
+ (cadr x)
+ (list cons ''unquote
+ (bq-process (cdr x) (- d 1))))
+ (bq-process x d)))
+
+(define (bq-bracket x d)
+ (cond ((atom? x) (list list (bq-process x d)))
+ ((eq? (car x) 'unquote)
+ (if (= d 0)
+ (cons list (cdr x))
+ (list list (list cons ''unquote
+ (bq-process (cdr x) (- d 1))))))
+ ((eq? (car x) 'unquote-splicing)
+ (if (= d 0)
+ (list 'copy-list (cadr x))
+ (list list (list list ''unquote-splicing
+ (bq-process (cadr x) (- d 1))))))
+ ((eq? (car x) 'unquote-nsplicing)
+ (if (= d 0)
+ (cadr x)
+ (list list (list list ''unquote-nsplicing
+ (bq-process (cadr x) (- d 1))))))
+ (else (list list (bq-process x d)))))
+
+(define (bq-process x d)
+ (cond ((symbol? x) (list 'quote x))
+ ((vector? x)
+ (let ((body (bq-process (vector->list x) d)))
+ (if (eq? (car body) list)
+ (cons vector (cdr body))
+ (list apply vector body))))
+ ((atom? x) x)
+ ((eq? (car x) 'quasiquote)
+ (list list ''quasiquote (bq-process (cadr x) (+ d 1))))
+ ((eq? (car x) 'unquote)
+ (if (and (= d 0) (length= x 2))
+ (cadr x)
+ (list cons ''unquote (bq-process (cdr x) (- d 1)))))
+ ((or (> d 0) (not (any splice-form? x)))
+ (let ((lc (lastcdr x))
+ (forms (map (lambda (x) (bq-bracket1 x d)) x)))
+ (if (null? lc)
+ (cons list forms)
+ (if (null? (cdr forms))
+ (list cons (car forms) (bq-process lc d))
+ (nconc (cons list* forms) (list (bq-process lc d)))))))
+ (else
+ (let loop ((p x) (q ()))
+ (cond ((null? p) ;; proper list
+ (cons 'nconc (reverse! q)))
+ ((pair? p)
+ (cond ((eq? (car p) 'unquote)
+ ;; (... . ,x)
+ (cons 'nconc
+ (nreconc q
+ (if (= d 0)
+ (cdr p)
+ (list (list list ''unquote)
+ (bq-process (cdr p)
+ (- d 1)))))))
+ (else
+ (loop (cdr p) (cons (bq-bracket (car p) d) q)))))
+ (else
+ ;; (... . x)
+ (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))
+
+; standard macros -------------------------------------------------------------
+
+(define (quote-value v)
+ (if (self-evaluating? v)
+ v
+ (list 'quote v)))
+
+(define-macro (let* binds . body)
+ (if (atom? binds) `((lambda () ,@body))
+ `((lambda (,(caar binds))
+ ,@(if (pair? (cdr binds))
+ `((let* ,(cdr binds) ,@body))
+ body))
+ ,(cadar binds))))
+
+(define-macro (when c . body) (list 'if c (cons 'begin body) #f))
+(define-macro (unless c . body) (list 'if c #f (cons 'begin body)))
+
+(define-macro (case key . clauses)
+ (define (vals->cond key v)
+ (cond ((eq? v 'else) 'else)
+ ((null? v) #f)
+ ((symbol? v) `(eq? ,key ,(quote-value v)))
+ ((atom? v) `(eqv? ,key ,(quote-value v)))
+ ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v))))
+ ((every symbol? v)
+ `(memq ,key ',v))
+ (else `(memv ,key ',v))))
+ (let ((g (gensym)))
+ `(let ((,g ,key))
+ (cond ,.(map (lambda (clause)
+ (cons (vals->cond g (car clause))
+ (cdr clause)))
+ clauses)))))
+
+(define-macro (do vars test-spec . commands)
+ (let ((loop (gensym))
+ (test-expr (car test-spec))
+ (vars (map car vars))
+ (inits (map cadr vars))
+ (steps (map (lambda (x)
+ (if (pair? (cddr x))
+ (caddr x)
+ (car x)))
+ vars)))
+ `(letrec ((,loop (lambda ,vars
+ (if ,test-expr
+ (begin
+ ,@(cdr test-spec))
+ (begin
+ ,@commands
+ (,loop ,.steps))))))
+ (,loop ,.inits))))
+
+; SRFI 8
+(define-macro (receive formals expr . body)
+ `(call-with-values (lambda () ,expr)
+ (lambda ,formals ,@body)))
+
+(define-macro (dotimes var . body)
+ (let ((v (car var))
+ (cnt (cadr var)))
+ `(for 0 (- ,cnt 1)
+ (lambda (,v) ,@body))))
+
+(define (map-int f n)
+ (if (<= n 0)
+ ()
+ (let ((first (cons (f 0) ()))
+ (acc ()))
+ (set! acc first)
+ (for 1 (- n 1)
+ (lambda (i)
+ (begin (set-cdr! acc (cons (f i) ()))
+ (set! acc (cdr acc)))))
+ first)))
+
+(define (iota n) (map-int identity n))
+
+(define (for-each f l . lsts)
+ (define (for-each-n f lsts)
+ (if (pair? (car lsts))
+ (begin (apply f (map car lsts))
+ (for-each-n f (map cdr lsts)))))
+ (if (null? lsts)
+ (while (pair? l)
+ (begin (f (car l))
+ (set! l (cdr l))))
+ (for-each-n f (cons l lsts)))
+ #t)
+
+(define-macro (with-bindings binds . body)
+ (let ((vars (map car binds))
+ (vals (map cadr binds))
+ (olds (map (lambda (x) (gensym)) binds)))
+ `(let ,(map list olds vars)
+ ,@(map (lambda (v val) `(set! ,v ,val)) vars vals)
+ (unwind-protect
+ (begin ,@body)
+ (begin ,@(map (lambda (v old) `(set! ,v ,old)) vars olds))))))
+
+; exceptions ------------------------------------------------------------------
+
+(define (error . args) (raise (cons 'error args)))
+
+(define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value)))
+(define-macro (catch tag expr)
+ (let ((e (gensym)))
+ `(trycatch ,expr
+ (lambda (,e) (if (and (pair? ,e)
+ (eq (car ,e) 'thrown-value)
+ (eq (cadr ,e) ,tag))
+ (caddr ,e)
+ (raise ,e))))))
+
+(define-macro (unwind-protect expr finally)
+ (let ((e (gensym))
+ (thk (gensym)))
+ `(let ((,thk (lambda () ,finally)))
+ (prog1 (trycatch ,expr
+ (lambda (,e) (begin (,thk) (raise ,e))))
+ (,thk)))))
+
+; debugging utilities ---------------------------------------------------------
+
+(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
+
+(define traced?
+ (letrec ((sample-traced-lambda (lambda args (begin (write (cons 'x args))
+ (newline)
+ (apply #.apply args)))))
+ (lambda (f)
+ (and (closure? f)
+ (equal? (function:code f)
+ (function:code sample-traced-lambda))))))
+
+(define (trace sym)
+ (let* ((func (top-level-value sym))
+ (args (gensym)))
+ (if (not (traced? func))
+ (set-top-level-value! sym
+ (eval
+ `(lambda ,args
+ (begin (write (cons ',sym ,args))
+ (newline)
+ (apply ',func ,args)))))))
+ 'ok)
+
+(define (untrace sym)
+ (let ((func (top-level-value sym)))
+ (if (traced? func)
+ (set-top-level-value! sym
+ (aref (function:vals func) 2)))))
+
+(define-macro (time expr)
+ (let ((t0 (gensym)))
+ `(let ((,t0 (time.now)))
+ (prog1
+ ,expr
+ (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))
+
+; text I/O --------------------------------------------------------------------
+
+(define (print . args) (for-each write args))
+(define (princ . args)
+ (with-bindings ((*print-readably* #f))
+ (for-each write args)))
+
+(define (newline (port *output-stream*))
+ (io.write port *linefeed*)
+ #t)
+
+(define (io.readline s) (io.readuntil s #\linefeed))
+
+; call f on a stream until the stream runs out of data
+(define (read-all-of f s)
+ (let loop ((lines ())
+ (curr (f s)))
+ (if (io.eof? s)
+ (reverse! lines)
+ (loop (cons curr lines) (f s)))))
+
+(define (io.readlines s) (read-all-of io.readline s))
+(define (read-all s) (read-all-of read s))
+
+(define (io.readall s)
+ (let ((b (buffer)))
+ (io.copy b s)
+ (let ((str (io.tostring! b)))
+ (if (and (equal? str "") (io.eof? s))
+ (eof-object)
+ str))))
+
+(define-macro (with-output-to stream . body)
+ `(with-bindings ((*output-stream* ,stream))
+ ,@body))
+(define-macro (with-input-from stream . body)
+ `(with-bindings ((*input-stream* ,stream))
+ ,@body))
+
+; vector functions ------------------------------------------------------------
+
+(define (list->vector l) (apply vector l))
+(define (vector->list v)
+ (let ((n (length v))
+ (l ()))
+ (for 1 n
+ (lambda (i)
+ (set! l (cons (aref v (- n i)) l))))
+ l))
+
+(define (vector.map f v)
+ (let* ((n (length v))
+ (nv (vector.alloc n)))
+ (for 0 (- n 1)
+ (lambda (i)
+ (aset! nv i (f (aref v i)))))
+ nv))
+
+; table functions -------------------------------------------------------------
+
+(define (table.pairs t)
+ (table.foldl (lambda (k v z) (cons (cons k v) z))
+ () t))
+(define (table.keys t)
+ (table.foldl (lambda (k v z) (cons k z))
+ () t))
+(define (table.values t)
+ (table.foldl (lambda (k v z) (cons v z))
+ () t))
+(define (table.clone t)
+ (let ((nt (table)))
+ (table.foldl (lambda (k v z) (put! nt k v))
+ () t)
+ nt))
+(define (table.invert t)
+ (let ((nt (table)))
+ (table.foldl (lambda (k v z) (put! nt v k))
+ () t)
+ nt))
+(define (table.foreach f t)
+ (table.foldl (lambda (k v z) (begin (f k v) #t)) () t))
+
+; string functions ------------------------------------------------------------
+
+(define (string.tail s n) (string.sub s (string.inc s 0 n)))
+
+(define *whitespace*
+ (string.encode #array(wchar 9 10 11 12 13 32 133 160 5760 6158 8192
+ 8193 8194 8195 8196 8197 8198 8199 8200
+ 8201 8202 8232 8233 8239 8287 12288)))
+
+(define (string.trim s at-start at-end)
+ (define (trim-start s chars i L)
+ (if (and (< i L)
+ (string.find chars (string.char s i)))
+ (trim-start s chars (string.inc s i) L)
+ i))
+ (define (trim-end s chars i)
+ (if (and (> i 0)
+ (string.find chars (string.char s (string.dec s i))))
+ (trim-end s chars (string.dec s i))
+ i))
+ (let ((L (length s)))
+ (string.sub s
+ (trim-start s at-start 0 L)
+ (trim-end s at-end L))))
+
+(define (string.map f s)
+ (let ((b (buffer))
+ (n (length s)))
+ (let ((i 0))
+ (while (< i n)
+ (begin (io.putc b (f (string.char s i)))
+ (set! i (string.inc s i)))))
+ (io.tostring! b)))
+
+(define (string.rep s k)
+ (cond ((< k 4)
+ (cond ((<= k 0) "")
+ ((= k 1) (string s))
+ ((= k 2) (string s s))
+ (else (string s s s))))
+ ((odd? k) (string s (string.rep s (- k 1))))
+ (else (string.rep (string s s) (/ k 2)))))
+
+(define (string.lpad s n c) (string (string.rep c (- n (string.count s))) s))
+(define (string.rpad s n c) (string s (string.rep c (- n (string.count s)))))
+
+(define (print-to-string v)
+ (let ((b (buffer)))
+ (write v b)
+ (io.tostring! b)))
+
+(define (string.join strlist sep)
+ (if (null? strlist) ""
+ (let ((b (buffer)))
+ (io.write b (car strlist))
+ (for-each (lambda (s) (begin (io.write b sep)
+ (io.write b s)))
+ (cdr strlist))
+ (io.tostring! b))))
+
+; toplevel --------------------------------------------------------------------
+
+(define (macrocall? e) (and (symbol? (car e))
+ (symbol-syntax (car e))))
+
+(define (macroexpand-1 e)
+ (if (atom? e) e
+ (let ((f (macrocall? e)))
+ (if f (apply f (cdr e))
+ e))))
+
+(define (expand e)
+ ; symbol resolves to toplevel; i.e. has no shadowing definition
+ (define (top? s env) (not (or (bound? s) (assq s env))))
+
+ (define (splice-begin body)
+ (cond ((atom? body) body)
+ ((equal? body '((begin)))
+ body)
+ ((and (pair? (car body))
+ (eq? (caar body) 'begin))
+ (append (splice-begin (cdar body)) (splice-begin (cdr body))))
+ (else
+ (cons (car body) (splice-begin (cdr body))))))
+
+ (define *expanded* (list '*expanded*))
+
+ (define (expand-body body env)
+ (if (atom? body) body
+ (let* ((body (if (top? 'begin env)
+ (splice-begin body)
+ body))
+ (def? (top? 'define env))
+ (dvars (if def? (get-defined-vars body) ()))
+ (env (nconc (map list dvars) env)))
+ (if (not def?)
+ (map (lambda (x) (expand-in x env)) body)
+ (let* ((ex-nondefs ; expand non-definitions
+ (let loop ((body body))
+ (cond ((atom? body) body)
+ ((and (pair? (car body))
+ (eq? 'define (caar body)))
+ (cons (car body) (loop (cdr body))))
+ (else
+ (let ((form (expand-in (car body) env)))
+ (set! env (nconc
+ (map list (get-defined-vars form))
+ env))
+ (cons
+ (cons *expanded* form)
+ (loop (cdr body))))))))
+ (body ex-nondefs))
+ (while (pair? body) ; now expand deferred definitions
+ (if (not (eq? *expanded* (caar body)))
+ (set-car! body (expand-in (car body) env))
+ (set-car! body (cdar body)))
+ (set! body (cdr body)))
+ ex-nondefs)))))
+
+ (define (expand-lambda-list l env)
+ (if (atom? l) l
+ (cons (if (and (pair? (car l)) (pair? (cdr (car l))))
+ (list (caar l) (expand-in (cadar l) env))
+ (car l))
+ (expand-lambda-list (cdr l) env))))
+
+ (define (l-vars l)
+ (cond ((atom? l) (list l))
+ ((pair? (car l)) (cons (caar l) (l-vars (cdr l))))
+ (else (cons (car l) (l-vars (cdr l))))))
+
+ (define (expand-lambda e env)
+ (let ((formals (cadr e))
+ (name (lastcdr e))
+ (body (cddr e))
+ (vars (l-vars (cadr e))))
+ (let ((env (nconc (map list vars) env)))
+ `(lambda ,(expand-lambda-list formals env)
+ ,.(expand-body body env)
+ . ,name))))
+
+ (define (expand-define e env)
+ (if (or (null? (cdr e)) (atom? (cadr e)))
+ (if (null? (cddr e))
+ e
+ `(define ,(cadr e) ,(expand-in (caddr e) env)))
+ (let ((formals (cdadr e))
+ (name (caadr e))
+ (body (cddr e))
+ (vars (l-vars (cdadr e))))
+ (let ((env (nconc (map list vars) env)))
+ `(define ,(cons name (expand-lambda-list formals env))
+ ,.(expand-body body env))))))
+
+ (define (expand-let-syntax e env)
+ (let ((binds (cadr e)))
+ (cons 'begin
+ (expand-body (cddr e)
+ (nconc
+ (map (lambda (bind)
+ (list (car bind)
+ ((compile-thunk
+ (expand-in (cadr bind) env)))
+ env))
+ binds)
+ env)))))
+
+ ; given let-syntax definition environment (menv) and environment
+ ; at the point of the macro use (lenv), return the environment to
+ ; expand the macro use in. TODO
+ (define (local-expansion-env menv lenv) menv)
+
+ (define (expand-in e env)
+ (if (atom? e) e
+ (let* ((head (car e))
+ (bnd (assq head env))
+ (default (lambda ()
+ (let loop ((e e))
+ (if (atom? e) e
+ (cons (if (atom? (car e))
+ (car e)
+ (expand-in (car e) env))
+ (loop (cdr e))))))))
+ (cond ((and bnd (pair? (cdr bnd))) ; local macro
+ (expand-in (apply (cadr bnd) (cdr e))
+ (local-expansion-env (caddr bnd) env)))
+ ((or bnd ; bound lexical or toplevel var
+ (not (symbol? head))
+ (bound? head))
+ (default))
+ ((macrocall? e) => (lambda (f)
+ (expand-in (apply f (cdr e)) env)))
+ ((eq? head 'quote) e)
+ ((eq? head 'lambda) (expand-lambda e env))
+ ((eq? head 'define) (expand-define e env))
+ ((eq? head 'let-syntax) (expand-let-syntax e env))
+ (else (default))))))
+ (expand-in e ()))
+
+(define (eval x) ((compile-thunk (expand x))))
+
+(define (load-process x) (eval x))
+
+(define (load filename)
+ (let ((F (file filename :read)))
+ (trycatch
+ (let next (prev E v)
+ (if (not (io.eof? F))
+ (next (read F)
+ prev
+ (load-process E))
+ (begin (io.close F)
+ ; evaluate last form in almost-tail position
+ (load-process E))))
+ (lambda (e)
+ (begin
+ (io.close F)
+ (raise `(load-error ,filename ,e)))))))
+
+(define *banner* (string.tail "
+; _
+; |_ _ _ |_ _ | . _ _
+; | (-||||_(_)|__|_)|_)
+;-------------------|----------------------------------------------------------
+
+" 1))
+
+(define (repl)
+ (define (prompt)
+ (princ "> ") (io.flush *output-stream*)
+ (let ((v (trycatch (read)
+ (lambda (e) (begin (io.discardbuffer *input-stream*)
+ (raise e))))))
+ (and (not (io.eof? *input-stream*))
+ (let ((V (load-process v)))
+ (print V)
+ (set! that V)
+ #t))))
+ (define (reploop)
+ (when (trycatch (and (prompt) (newline))
+ (lambda (e)
+ (top-level-exception-handler e)
+ #t))
+ (begin (newline)
+ (reploop))))
+ (reploop)
+ (newline))
+
+(define (top-level-exception-handler e)
+ (with-output-to *stderr*
+ (print-exception e)
+ (print-stack-trace (stacktrace))))
+
+(define (print-stack-trace st)
+ (define (find-in-f f tgt path)
+ (let ((path (cons (function:name f) path)))
+ (if (eq? (function:code f) (function:code tgt))
+ (throw 'ffound path)
+ (let ((v (function:vals f)))
+ (for 0 (1- (length v))
+ (lambda (i) (if (closure? (aref v i))
+ (find-in-f (aref v i) tgt path))))))))
+ (define (fn-name f e)
+ (let ((p (catch 'ffound
+ (begin
+ (for-each (lambda (topfun)
+ (find-in-f topfun f ()))
+ e)
+ #f))))
+ (if p
+ (symbol (string.join (map string (reverse! p)) "/"))
+ 'lambda)))
+ (let ((st (reverse! (list-tail st (if *interactive* 5 4))))
+ (e (filter closure? (map (lambda (s) (and (bound? s)
+ (top-level-value s)))
+ (environment))))
+ (n 0))
+ (for-each
+ (lambda (f)
+ (princ "#" n " ")
+ (print (cons (fn-name (aref f 0) e)
+ (cdr (vector->list f))))
+ (newline)
+ (set! n (+ n 1)))
+ st)))
+
+(define (print-exception e)
+ (cond ((and (pair? e)
+ (eq? (car e) 'type-error)
+ (length= e 4))
+ (princ "type error: " (cadr e) ": expected " (caddr e) ", got ")
+ (print (cadddr e)))
+
+ ((and (pair? e)
+ (eq? (car e) 'bounds-error)
+ (length= e 4))
+ (princ (cadr e) ": index " (cadddr e) " out of bounds for ")
+ (print (caddr e)))
+
+ ((and (pair? e)
+ (eq? (car e) 'unbound-error)
+ (pair? (cdr e)))
+ (princ "eval: variable " (cadr e) " has no value"))
+
+ ((and (pair? e)
+ (eq? (car e) 'error))
+ (princ "error: ")
+ (apply princ (cdr e)))
+
+ ((and (pair? e)
+ (eq? (car e) 'load-error))
+ (print-exception (caddr e))
+ (princ "in file " (cadr e)))
+
+ ((and (list? e)
+ (length= e 2))
+ (print (car e))
+ (princ ": ")
+ (let ((msg (cadr e)))
+ ((if (or (string? msg) (symbol? msg))
+ princ print)
+ msg)))
+
+ (else (princ "*** Unhandled exception: ")
+ (print e)))
+
+ (princ *linefeed*))
+
+(define (simple-sort l)
+ (if (or (null? l) (null? (cdr l))) l
+ (let ((piv (car l)))
+ (receive (less grtr)
+ (separate (lambda (x) (< x piv)) (cdr l))
+ (nconc (simple-sort less)
+ (list piv)
+ (simple-sort grtr))))))
+
+(define (make-system-image fname)
+ (let ((f (file fname :write :create :truncate))
+ (excludes '(*linefeed* *directory-separator* *argv* that
+ *print-pretty* *print-width* *print-readably*
+ *print-level* *print-length* *os-name*)))
+ (with-bindings ((*print-pretty* #t)
+ (*print-readably* #t))
+ (let ((syms
+ (filter (lambda (s)
+ (and (bound? s)
+ (not (constant? s))
+ (or (not (builtin? (top-level-value s)))
+ (not (equal? (string s) ; alias of builtin
+ (string (top-level-value s)))))
+ (not (memq s excludes))
+ (not (iostream? (top-level-value s)))))
+ (simple-sort (environment)))))
+ (write (apply nconc (map list syms (map top-level-value syms))) f)
+ (io.write f *linefeed*))
+ (io.close f))))
+
+; initialize globals that need to be set at load time
+(define (__init_globals)
+ (if (or (eq? *os-name* 'win32)
+ (eq? *os-name* 'win64)
+ (eq? *os-name* 'windows))
+ (begin (set! *directory-separator* "\\")
+ (set! *linefeed* "\r\n"))
+ (begin (set! *directory-separator* "/")
+ (set! *linefeed* "\n")))
+ (set! *output-stream* *stdout*)
+ (set! *input-stream* *stdin*)
+ (set! *error-stream* *stderr*))
+
+(define (__script fname)
+ (trycatch (load fname)
+ (lambda (e) (begin (top-level-exception-handler e)
+ (exit 1)))))
+
+(define (__start argv)
+ (__init_globals)
+ (if (pair? (cdr argv))
+ (begin (set! *argv* (cdr argv))
+ (set! *interactive* #f)
+ (__script (cadr argv)))
+ (begin (set! *argv* argv)
+ (set! *interactive* #t)
+ (princ *banner*)
+ (repl)))
+ (exit 0))
--- /dev/null
+++ b/table.c
@@ -1,0 +1,211 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdarg.h>
+#include <string.h>
+#include <assert.h>
+#include <sys/types.h>
+#include <setjmp.h>
+#include "llt.h"
+#include "flisp.h"
+#include "equalhash.h"
+
+static value_t tablesym;
+static fltype_t *tabletype;
+
+void print_htable(value_t v, ios_t *f)
+{+ htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(v));
+ size_t i;
+ int first=1;
+ fl_print_str("#table(", f);+ for(i=0; i < h->size; i+=2) {+ if (h->table[i+1] != HT_NOTFOUND) {+ if (!first) fl_print_str(" ", f);+ fl_print_child(f, (value_t)h->table[i]);
+ fl_print_chr(' ', f);+ fl_print_child(f, (value_t)h->table[i+1]);
+ first = 0;
+ }
+ }
+ fl_print_chr(')', f);+}
+
+void print_traverse_htable(value_t self)
+{+ htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(self));
+ size_t i;
+ for(i=0; i < h->size; i+=2) {+ if (h->table[i+1] != HT_NOTFOUND) {+ print_traverse((value_t)h->table[i]);
+ print_traverse((value_t)h->table[i+1]);
+ }
+ }
+}
+
+void free_htable(value_t self)
+{+ htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(self));
+ htable_free(h);
+}
+
+void relocate_htable(value_t oldv, value_t newv)
+{+ htable_t *oldh = (htable_t*)cv_data((cvalue_t*)ptr(oldv));
+ htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(newv));
+ if (oldh->table == &oldh->_space[0])
+ h->table = &h->_space[0];
+ size_t i;
+ for(i=0; i < h->size; i++) {+ if (h->table[i] != HT_NOTFOUND)
+ h->table[i] = (void*)relocate_lispvalue((value_t)h->table[i]);
+ }
+}
+
+cvtable_t table_vtable = { print_htable, relocate_htable, free_htable,+ print_traverse_htable };
+
+int ishashtable(value_t v)
+{+ return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == tabletype;
+}
+
+value_t fl_tablep(value_t *args, uint32_t nargs)
+{+ argcount("table?", nargs, 1);+ return ishashtable(args[0]) ? FL_T : FL_F;
+}
+
+static htable_t *totable(value_t v, char *fname)
+{+ if (!ishashtable(v))
+ type_error(fname, "table", v);
+ return (htable_t*)cv_data((cvalue_t*)ptr(v));
+}
+
+value_t fl_table(value_t *args, uint32_t nargs)
+{+ size_t cnt = (size_t)nargs;
+ if (cnt & 1)
+ lerror(ArgError, "table: arguments must come in pairs");
+ value_t nt;
+ // prevent small tables from being added to finalizer list
+ if (cnt <= HT_N_INLINE) {+ tabletype->vtable->finalize = NULL;
+ nt = cvalue(tabletype, sizeof(htable_t));
+ tabletype->vtable->finalize = free_htable;
+ }
+ else {+ nt = cvalue(tabletype, 2*sizeof(void*));
+ }
+ htable_t *h = (htable_t*)cv_data((cvalue_t*)ptr(nt));
+ htable_new(h, cnt/2);
+ uint32_t i;
+ value_t k=FL_NIL, arg=FL_NIL;
+ FOR_ARGS(i,0,arg,args) {+ if (i&1)
+ equalhash_put(h, (void*)k, (void*)arg);
+ else
+ k = arg;
+ }
+ return nt;
+}
+
+// (put! table key value)
+value_t fl_table_put(value_t *args, uint32_t nargs)
+{+ argcount("put!", nargs, 3);+ htable_t *h = totable(args[0], "put!");
+ void **table0 = h->table;
+ equalhash_put(h, (void*)args[1], (void*)args[2]);
+ // register finalizer if we outgrew inline space
+ if (table0 == &h->_space[0] && h->table != &h->_space[0]) {+ cvalue_t *cv = (cvalue_t*)ptr(args[0]);
+ add_finalizer(cv);
+ cv->len = 2*sizeof(void*);
+ }
+ return args[0];
+}
+
+static void key_error(char *fname, value_t key)
+{+ lerrorf(fl_list2(KeyError, key), "%s: key not found", fname);
+}
+
+// (get table key [default])
+value_t fl_table_get(value_t *args, uint32_t nargs)
+{+ if (nargs != 3)
+ argcount("get", nargs, 2);+ htable_t *h = totable(args[0], "get");
+ value_t v = (value_t)equalhash_get(h, (void*)args[1]);
+ if (v == (value_t)HT_NOTFOUND) {+ if (nargs == 3)
+ return args[2];
+ key_error("get", args[1]);+ }
+ return v;
+}
+
+// (has? table key)
+value_t fl_table_has(value_t *args, uint32_t nargs)
+{+ argcount("has", nargs, 2);+ htable_t *h = totable(args[0], "has");
+ return equalhash_has(h, (void*)args[1]) ? FL_T : FL_F;
+}
+
+// (del! table key)
+value_t fl_table_del(value_t *args, uint32_t nargs)
+{+ argcount("del!", nargs, 2);+ htable_t *h = totable(args[0], "del!");
+ if (!equalhash_remove(h, (void*)args[1]))
+ key_error("del!", args[1]);+ return args[0];
+}
+
+value_t fl_table_foldl(value_t *args, uint32_t nargs)
+{+ argcount("table.foldl", nargs, 3);+ value_t f=args[0], zero=args[1], t=args[2];
+ htable_t *h = totable(t, "table.foldl");
+ size_t i, n = h->size;
+ void **table = h->table;
+ fl_gc_handle(&f);
+ fl_gc_handle(&zero);
+ fl_gc_handle(&t);
+ for(i=0; i < n; i+=2) {+ if (table[i+1] != HT_NOTFOUND) {+ zero = fl_applyn(3, f,
+ (value_t)table[i],
+ (value_t)table[i+1],
+ zero);
+ // reload pointer
+ h = (htable_t*)cv_data((cvalue_t*)ptr(t));
+ if (h->size != n)
+ lerror(EnumerationError, "table.foldl: table modified");
+ table = h->table;
+ }
+ }
+ fl_free_gc_handles(3);
+ return zero;
+}
+
+static builtinspec_t tablefunc_info[] = {+ { "table", fl_table },+ { "table?", fl_tablep },+ { "put!", fl_table_put },+ { "get", fl_table_get },+ { "has?", fl_table_has },+ { "del!", fl_table_del },+ { "table.foldl", fl_table_foldl },+ { NULL, NULL }+};
+
+void table_init()
+{+ tablesym = symbol("table");+ tabletype = define_opaque_type(tablesym, sizeof(htable_t),
+ &table_vtable, NULL);
+ assign_global_builtins(tablefunc_info);
+}
--- /dev/null
+++ b/tests/100x100.lsp
@@ -1,0 +1,1 @@
+'#0=(#198=(#197=(#196=(#195=(#194=(#193=(#192=(#191=(#190=(#189=(#188=(#187=(#186=(#185=(#184=(#183=(#182=(#181=(#180=(#179=(#178=(#177=(#176=(#175=(#174=(#173=(#172=(#171=(#170=(#169=(#168=(#167=(#166=(#165=(#164=(#163=(#162=(#161=(#160=(#159=(#158=(#157=(#156=(#155=(#154=(#153=(#152=(#151=(#150=(#149=(#148=(#147=(#146=(#145=(#144=(#143=(#142=(#141=(#140=(#139=(#138=(#137=(#136=(#135=(#134=(#133=(#132=(#131=(#130=(#129=(#128=(#127=(#126=(#125=(#124=(#123=(#122=(#121=(#120=(#119=(#118=(#117=(#116=(#115=(#114=(#113=(#112=(#111=(#110=(#109=(#108=(#107=(#106=(#105=(#104=(#103=(#102=(#101=(#100=(#0# . #1=(#9999=(#9998=(#9997=(#9996=(#9995=(#9994=(#9993=(#9992=(#9991=(#9990=(#9989=(#9988=(#9987=(#9986=(#9985=(#9984=(#9983=(#9982=(#9981=(#9980=(#9979=(#9978=(#9977=(#9976=(#9975=(#9974=(#9973=(#9972=(#9971=(#9970=(#9969=(#9968=(#9967=(#9966=(#9965=(#9964=(#9963=(#9962=(#9961=(#9960=(#9959=(#9958=(#9957=(#9956=(#9955=(#9954=(#9953=(#9952=(#9951=(#9950=(#9949=(#9948=(#9947=(#9946=(#9945=(#9944=(#9943=(#9942=(#9941=(#9940=(#9939=(#9938=(#9937=(#9936=(#9935=(#9934=(#9933=(#9932=(#9931=(#9930=(#9929=(#9928=(#9927=(#9926=(#9925=(#9924=(#9923=(#9922=(#9921=(#9920=(#9919=(#9918=(#9917=(#9916=(#9915=(#9914=(#9913=(#9912=(#9911=(#9910=(#9909=(#9908=(#9907=(#9906=(#9905=(#9904=(#9903=(#9902=(#9901=(#1# . #2=(#9900=(#9899=(#9898=(#9897=(#9896=(#9895=(#9894=(#9893=(#9892=(#9891=(#9890=(#9889=(#9888=(#9887=(#9886=(#9885=(#9884=(#9883=(#9882=(#9881=(#9880=(#9879=(#9878=(#9877=(#9876=(#9875=(#9874=(#9873=(#9872=(#9871=(#9870=(#9869=(#9868=(#9867=(#9866=(#9865=(#9864=(#9863=(#9862=(#9861=(#9860=(#9859=(#9858=(#9857=(#9856=(#9855=(#9854=(#9853=(#9852=(#9851=(#9850=(#9849=(#9848=(#9847=(#9846=(#9845=(#9844=(#9843=(#9842=(#9841=(#9840=(#9839=(#9838=(#9837=(#9836=(#9835=(#9834=(#9833=(#9832=(#9831=(#9830=(#9829=(#9828=(#9827=(#9826=(#9825=(#9824=(#9823=(#9822=(#9821=(#9820=(#9819=(#9818=(#9817=(#9816=(#9815=(#9814=(#9813=(#9812=(#9811=(#9810=(#9809=(#9808=(#9807=(#9806=(#9805=(#9804=(#9803=(#9802=(#2# . #3=(#9801=(#9800=(#9799=(#9798=(#9797=(#9796=(#9795=(#9794=(#9793=(#9792=(#9791=(#9790=(#9789=(#9788=(#9787=(#9786=(#9785=(#9784=(#9783=(#9782=(#9781=(#9780=(#9779=(#9778=(#9777=(#9776=(#9775=(#9774=(#9773=(#9772=(#9771=(#9770=(#9769=(#9768=(#9767=(#9766=(#9765=(#9764=(#9763=(#9762=(#9761=(#9760=(#9759=(#9758=(#9757=(#9756=(#9755=(#9754=(#9753=(#9752=(#9751=(#9750=(#9749=(#9748=(#9747=(#9746=(#9745=(#9744=(#9743=(#9742=(#9741=(#9740=(#9739=(#9738=(#9737=(#9736=(#9735=(#9734=(#9733=(#9732=(#9731=(#9730=(#9729=(#9728=(#9727=(#9726=(#9725=(#9724=(#9723=(#9722=(#9721=(#9720=(#9719=(#9718=(#9717=(#9716=(#9715=(#9714=(#9713=(#9712=(#9711=(#9710=(#9709=(#9708=(#9707=(#9706=(#9705=(#9704=(#9703=(#3# . #4=(#9702=(#9701=(#9700=(#9699=(#9698=(#9697=(#9696=(#9695=(#9694=(#9693=(#9692=(#9691=(#9690=(#9689=(#9688=(#9687=(#9686=(#9685=(#9684=(#9683=(#9682=(#9681=(#9680=(#9679=(#9678=(#9677=(#9676=(#9675=(#9674=(#9673=(#9672=(#9671=(#9670=(#9669=(#9668=(#9667=(#9666=(#9665=(#9664=(#9663=(#9662=(#9661=(#9660=(#9659=(#9658=(#9657=(#9656=(#9655=(#9654=(#9653=(#9652=(#9651=(#9650=(#9649=(#9648=(#9647=(#9646=(#9645=(#9644=(#9643=(#9642=(#9641=(#9640=(#9639=(#9638=(#9637=(#9636=(#9635=(#9634=(#9633=(#9632=(#9631=(#9630=(#9629=(#9628=(#9627=(#9626=(#9625=(#9624=(#9623=(#9622=(#9621=(#9620=(#9619=(#9618=(#9617=(#9616=(#9615=(#9614=(#9613=(#9612=(#9611=(#9610=(#9609=(#9608=(#9607=(#9606=(#9605=(#9604=(#4# . #5=(#9603=(#9602=(#9601=(#9600=(#9599=(#9598=(#9597=(#9596=(#9595=(#9594=(#9593=(#9592=(#9591=(#9590=(#9589=(#9588=(#9587=(#9586=(#9585=(#9584=(#9583=(#9582=(#9581=(#9580=(#9579=(#9578=(#9577=(#9576=(#9575=(#9574=(#9573=(#9572=(#9571=(#9570=(#9569=(#9568=(#9567=(#9566=(#9565=(#9564=(#9563=(#9562=(#9561=(#9560=(#9559=(#9558=(#9557=(#9556=(#9555=(#9554=(#9553=(#9552=(#9551=(#9550=(#9549=(#9548=(#9547=(#9546=(#9545=(#9544=(#9543=(#9542=(#9541=(#9540=(#9539=(#9538=(#9537=(#9536=(#9535=(#9534=(#9533=(#9532=(#9531=(#9530=(#9529=(#9528=(#9527=(#9526=(#9525=(#9524=(#9523=(#9522=(#9521=(#9520=(#9519=(#9518=(#9517=(#9516=(#9515=(#9514=(#9513=(#9512=(#9511=(#9510=(#9509=(#9508=(#9
\ No newline at end of file
--- /dev/null
+++ b/tests/argv.lsp
@@ -1,0 +1,1 @@
+(print *argv*) (princ "\n")
--- /dev/null
+++ b/tests/ast/asttools.lsp
@@ -1,0 +1,171 @@
+; -*- scheme -*-
+; utilities for AST processing
+
+(define (symconcat s1 s2)
+ (symbol (string s1 s2)))
+
+(define (list-adjoin item lst)
+ (if (member item lst)
+ lst
+ (cons item lst)))
+
+(define (index-of item lst start)
+ (cond ((null? lst) #f)
+ ((eq item (car lst)) start)
+ (#t (index-of item (cdr lst) (+ start 1)))))
+
+(define (each f l)
+ (if (null? l) l
+ (begin (f (car l))
+ (each f (cdr l)))))
+
+(define (maptree-pre f tr)
+ (let ((new-t (f tr)))
+ (if (pair? new-t)
+ (map (lambda (e) (maptree-pre f e)) new-t)
+ new-t)))
+
+(define (maptree-post f tr)
+ (if (not (pair? tr))
+ (f tr)
+ (let ((new-t (map (lambda (e) (maptree-post f e)) tr)))
+ (f new-t))))
+
+(define (foldtree-pre f t zero)
+ (if (not (pair? t))
+ (f t zero)
+ (foldl t (lambda (e state) (foldtree-pre f e state)) (f t zero))))
+
+(define (foldtree-post f t zero)
+ (if (not (pair? t))
+ (f t zero)
+ (f t (foldl t (lambda (e state) (foldtree-post f e state)) zero))))
+
+; general tree transformer
+; folds in preorder (foldtree-pre), maps in postorder (maptree-post)
+; therefore state changes occur immediately, just by looking at the current node,
+; while transformation follows evaluation order. this seems to be the most natural
+; approach.
+; (mapper tree state) - should return transformed tree given current state
+; (folder tree state) - should return new state
+(define (map&fold t zero mapper folder)
+ (let ((head (and (pair? t) (car t))))
+ (cond ((eq? head 'quote)
+ t)
+ ((or (eq? head 'the) (eq? head 'meta))
+ (list head
+ (cadr t)
+ (map&fold (caddr t) zero mapper folder)))
+ (else
+ (let ((new-s (folder t zero)))
+ (mapper
+ (if (pair? t)
+ ; head symbol is a tag; never transform it
+ (cons (car t)
+ (map (lambda (e) (map&fold e new-s mapper folder))
+ (cdr t)))
+ t)
+ new-s))))))
+
+; convert to proper list, i.e. remove "dots", and append
+(define (append.2 l tail)
+ (cond ((null? l) tail)
+ ((atom? l) (cons l tail))
+ (#t (cons (car l) (append.2 (cdr l) tail)))))
+
+; transform code by calling (f expr env) on each subexpr, where
+; env is a list of lexical variables in effect at that point.
+(define (lexical-walk f t)
+ (map&fold t () f
+ (lambda (tree state)
+ (if (and (eq? (car t) 'lambda)
+ (pair? (cdr t)))
+ (append.2 (cadr t) state)
+ state))))
+
+; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
+(define (flatten-left-op op e)
+ (maptree-post (lambda (node)
+ (if (and (pair? node)
+ (eq (car node) op)
+ (pair? (cdr node))
+ (pair? (cadr node))
+ (eq (caadr node) op))
+ (cons op
+ (append (cdadr node) (cddr node)))
+ node))
+ e))
+
+; convert all local variable references to (lexref rib slot name)
+; where rib is the nesting level and slot is the stack slot#
+; name is just there for reference
+; this assumes lambda is the only remaining naming form
+(define (lookup-var v env lev)
+ (if (null? env) v
+ (let ((i (index-of v (car env) 0)))
+ (if i (list 'lexref lev i v)
+ (lookup-var v (cdr env) (+ lev 1))))))
+(define (lvc- e env)
+ (cond ((symbol? e) (lookup-var e env 0))
+ ((pair? e)
+ (if (eq (car e) 'quote)
+ e
+ (let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
+ (newenv (if newvs (cons newvs env) env)))
+ (if newvs
+ (cons 'lambda
+ (cons (cadr e)
+ (map (lambda (se) (lvc- se newenv))
+ (cddr e))))
+ (map (lambda (se) (lvc- se env)) e)))))
+ (#t e)))
+(define (lexical-var-conversion e)
+ (lvc- e ()))
+
+; convert let to lambda
+(define (let-expand e)
+ (maptree-post (lambda (n)
+ (if (and (pair? n) (eq (car n) 'let))
+ `((lambda ,(map car (cadr n)) ,@(cddr n))
+ ,@(map cadr (cadr n)))
+ n))
+ e))
+
+; alpha renaming
+; transl is an assoc list ((old-sym-name . new-sym-name) ...)
+(define (alpha-rename e transl)
+ (map&fold e
+ ()
+ ; mapper: replace symbol if unbound
+ (lambda (t env)
+ (if (symbol? t)
+ (let ((found (assq t transl)))
+ (if (and found
+ (not (memq t env)))
+ (cdr found)
+ t))
+ t))
+ ; folder: add locals to environment if entering a new scope
+ (lambda (t env)
+ (if (and (pair? t) (or (eq? (car t) 'let)
+ (eq? (car t) 'lambda)))
+ (append (cadr t) env)
+ env))))
+
+; flatten op with any associativity
+(define-macro (flatten-all-op op e)
+ `(pattern-expand
+ (pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...))
+ (cons ',op (append l (cdr inner) r)))
+ ,e))
+
+(define-macro (pattern-lambda pat body)
+ (let* ((args (patargs pat))
+ (expander `(lambda ,args ,body)))
+ `(lambda (expr)
+ (let ((m (match ',pat expr)))
+ (if m
+ ; matches; perform expansion
+ (apply ,expander (map (lambda (var) (cdr (or (assq var m) '(0 . #f))))
+ ',args))
+ #f)))))
--- /dev/null
+++ b/tests/ast/datetimeR.lsp
@@ -1,0 +1,79 @@
+'(r-expressions
+ (<- Sys.time (function () (r-call structure (r-call .Internal (r-call Sys.time)) (*named* class (r-call c "POSIXt" "POSIXct"))) ()))
+ (<- Sys.timezone (function () (r-call as.vector (r-call Sys.getenv "TZ")) ()))
+ (<- as.POSIXlt (function ((*named* x *r-missing*) (*named* tz "")) (r-block (<- fromchar (function ((*named* x *r-missing*)) (r-block (<- xx (r-call r-index x 1)) (if (r-call is.na xx) (r-block (<- j 1) (while (&& (r-call is.na xx) (r-call <= (<- j (r-call + j 1)) (r-call length x))) (<- xx (r-call r-index x j))) (if (r-call is.na xx) (<- f "%Y-%m-%d")))) (if (\|\| (\|\| (\|\| (\|\| (\|\| (\|\| (r-call is.na xx) (r-call ! (r-call is.na (r-call strptime xx (<- f "%Y-%m-%d %H:%M:%OS"))))) (r-call ! (r-call is.na (r-call strptime xx (<- f "%Y/%m/%d %H:%M:%OS"))))) (r-call ! (r-call is.na (r-call strptime xx (<- f "%Y-%m-%d %H:%M"))))) (r-call ! (r-call is.na (r-call strptime xx (<- f "%Y/%m/%d %H:%M"))))) (r-call ! (r-call is.na (r-call strptime xx (<- f "%Y-%m-%d"))))) (r-call ! (r-call is.na (r-call strptime xx (<- f "%Y/%m/%d"))))) (r-block (<- res (r-call strptime x f)) (if (r-call nchar tz) (<- (r-call attr res "tzone") tz)) (return res))) (r-call stop "character string is not in a standard unambiguous format")) ())) (if (r-call inherits x "POSIXlt") (return x)) (if (r-call inherits x "Date") (return (r-call .Internal (r-call Date2POSIXlt x)))) (<- tzone (r-call attr x "tzone")) (if (\|\| (r-call inherits x "date") (r-call inherits x "dates")) (<- x (r-call as.POSIXct x))) (if (r-call is.character x) (return (r-call fromchar (r-call unclass x)))) (if (r-call is.factor x) (return (r-call fromchar (r-call as.character x)))) (if (&& (r-call is.logical x) (r-call all (r-call is.na x))) (<- x (r-call as.POSIXct.default x))) (if (r-call ! (r-call inherits x "POSIXct")) (r-call stop (r-call gettextf "do not know how to convert '%s' to class \"POSIXlt\"" (r-call deparse (substitute x))))) (if (&& (missing tz) (r-call ! (r-call is.null tzone))) (<- tz (r-call r-index tzone 1))) (r-call .Internal (r-call as.POSIXlt x tz))) ()))
+ (<- as.POSIXct (function ((*named* x *r-missing*) (*named* tz "")) (r-call UseMethod "as.POSIXct") ()))
+ (<- as.POSIXct.Date (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call structure (r-call * (r-call unclass x) 86400) (*named* class (r-call c "POSIXt" "POSIXct"))) ()))
+ (<- as.POSIXct.date (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (if (r-call inherits x "date") (r-block (<- x (r-call * (r-call - x 3653) 86400)) (return (r-call structure x (*named* class (r-call c "POSIXt" "POSIXct"))))) (r-call stop (r-call gettextf "'%s' is not a \"date\" object" (r-call deparse (substitute x)))))) ()))
+ (<- as.POSIXct.dates (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (if (r-call inherits x "dates") (r-block (<- z (r-call attr x "origin")) (<- x (r-call * (r-call as.numeric x) 86400)) (if (&& (r-call == (r-call length z) 3) (r-call is.numeric z)) (<- x (r-call + x (r-call as.numeric (r-call ISOdate (r-call r-index z 3) (r-call r-index z 1) (r-call r-index z 2) 0))))) (return (r-call structure x (*named* class (r-call c "POSIXt" "POSIXct"))))) (r-call stop (r-call gettextf "'%s' is not a \"dates\" object" (r-call deparse (substitute x)))))) ()))
+ (<- as.POSIXct.POSIXlt (function ((*named* x *r-missing*) (*named* tz "")) (r-block (<- tzone (r-call attr x "tzone")) (if (&& (missing tz) (r-call ! (r-call is.null tzone))) (<- tz (r-call r-index tzone 1))) (r-call structure (r-call .Internal (r-call as.POSIXct x tz)) (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone tz))) ()))
+ (<- as.POSIXct.default (function ((*named* x *r-missing*) (*named* tz "")) (r-block (if (r-call inherits x "POSIXct") (return x)) (if (\|\| (r-call is.character x) (r-call is.factor x)) (return (r-call as.POSIXct (r-call as.POSIXlt x) tz))) (if (&& (r-call is.logical x) (r-call all (r-call is.na x))) (return (r-call structure (r-call as.numeric x) (*named* class (r-call c "POSIXt" "POSIXct"))))) (r-call stop (r-call gettextf "do not know how to convert '%s' to class \"POSIXlt\"" (r-call deparse (substitute x))))) ()))
+ (<- as.numeric.POSIXlt (function ((*named* x *r-missing*)) (r-call as.POSIXct x) ()))
+ (<- format.POSIXlt (function ((*named* x *r-missing*) (*named* format "") (*named* usetz *r-false*) (*named* ... *r-missing*)) (r-block (if (r-call ! (r-call inherits x "POSIXlt")) (r-call stop "wrong class")) (if (r-call == format "") (r-block (<- times (r-call unlist (r-call r-index (r-call unclass x) (r-call : 1 3)))) (<- secs ($ x sec)) (<- secs (r-call r-index secs (r-call ! (r-call is.na secs)))) (<- np (r-call getOption "digits.secs")) (if (r-call is.null np) (<- np 0) (<- np (r-call min 6 np))) (if (r-call >= np 1) (r-block (for i (r-call - (r-call : 1 np) 1) (if (r-call all (r-call < (r-call abs (r-call - secs (r-call round secs i))) 1e-06)) (r-block (<- np i) (break)))))) (<- format (if (r-call all (r-call == (r-call r-index times (r-call ! (r-call is.na times))) 0)) "%Y-%m-%d" (if (r-call == np 0) "%Y-%m-%d %H:%M:%S" (r-call paste "%Y-%m-%d %H:%M:%OS" np (*named* sep ""))))))) (r-call .Internal (r-call format.POSIXlt x format usetz))) ()))
+ (<- strftime format.POSIXlt)
+ (<- strptime (function ((*named* x *r-missing*) (*named* format *r-missing*) (*named* tz "")) (r-call .Internal (r-call strptime (r-call as.character x) format tz)) ()))
+ (<- format.POSIXct (function ((*named* x *r-missing*) (*named* format "") (*named* tz "") (*named* usetz *r-false*) (*named* ... *r-missing*)) (r-block (if (r-call ! (r-call inherits x "POSIXct")) (r-call stop "wrong class")) (if (&& (missing tz) (r-call ! (r-call is.null (<- tzone (r-call attr x "tzone"))))) (<- tz tzone)) (r-call structure (r-call format.POSIXlt (r-call as.POSIXlt x tz) format usetz r-dotdotdot) (*named* names (r-call names x)))) ()))
+ (<- print.POSIXct (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call print (r-call format x (*named* usetz *r-true*) r-dotdotdot) r-dotdotdot) (r-call invisible x)) ()))
+ (<- print.POSIXlt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call print (r-call format x (*named* usetz *r-true*)) r-dotdotdot) (r-call invisible x)) ()))
+ (<- summary.POSIXct (function ((*named* object *r-missing*) (*named* digits 15) (*named* ... *r-missing*)) (r-block (<- x (r-call r-index (r-call summary.default (r-call unclass object) (*named* digits digits) r-dotdotdot) (r-call : 1 6))) (<- (r-call class x) (r-call oldClass object)) (<- (r-call attr x "tzone") (r-call attr object "tzone")) x) ()))
+ (<- summary.POSIXlt (function ((*named* object *r-missing*) (*named* digits 15) (*named* ... *r-missing*)) (r-call summary (r-call as.POSIXct object) (*named* digits digits) r-dotdotdot) ()))
+ (<- "+.POSIXt" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (r-block (switch (r-call attr x "units") (*named* secs x) (*named* mins (r-call * 60 x)) (*named* hours (r-call * (r-call * 60 60) x)) (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) x)))) ())) (if (r-call == (r-call nargs) 1) (return e1)) (if (&& (r-call inherits e1 "POSIXt") (r-call inherits e2 "POSIXt")) (r-call stop "binary + is not defined for \"POSIXt\" objects")) (if (r-call inherits e1 "POSIXlt") (<- e1 (r-call as.POSIXct e1))) (if (r-call inherits e2 "POSIXlt") (<- e2 (r-call as.POSIXct e2))) (if (r-call inherits e1 "difftime") (<- e1 (r-call coerceTimeUnit e1))) (if (r-call inherits e2 "difftime") (<- e2 (r-call coerceTimeUnit e2))) (r-call structure (r-call + (r-call unclass e1) (r-call unclass e2)) (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone (r-call check_tzones e1 e2)))) ()))
+ (<- "-.POSIXt" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (r-block (switch (r-call attr x "units") (*named* secs x) (*named* mins (r-call * 60 x)) (*named* hours (r-call * (r-call * 60 60) x)) (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) x)))) ())) (if (r-call ! (r-call inherits e1 "POSIXt")) (r-call stop "Can only subtract from POSIXt objects")) (if (r-call == (r-call nargs) 1) (r-call stop "unary - is not defined for \"POSIXt\" objects")) (if (r-call inherits e2 "POSIXt") (return (r-call difftime e1 e2))) (if (r-call inherits e2 "difftime") (<- e2 (r-call unclass (r-call coerceTimeUnit e2)))) (if (r-call ! (r-call is.null (r-call attr e2 "class"))) (r-call stop "can only subtract numbers from POSIXt objects")) (r-call structure (r-call - (r-call unclass (r-call as.POSIXct e1)) e2) (*named* class (r-call c "POSIXt" "POSIXct")))) ()))
+ (<- Ops.POSIXt (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (if (r-call == (r-call nargs) 1) (r-call stop "unary" .Generic " not defined for \"POSIXt\" objects")) (<- boolean (switch .Generic (*named* < *r-missing*) (*named* > *r-missing*) (*named* == *r-missing*) (*named* != *r-missing*) (*named* <= *r-missing*) (*named* >= *r-true*) *r-false*)) (if (r-call ! boolean) (r-call stop .Generic " not defined for \"POSIXt\" objects")) (if (\|\| (r-call inherits e1 "POSIXlt") (r-call is.character e1)) (<- e1 (r-call as.POSIXct e1))) (if (\|\| (r-call inherits e2 "POSIXlt") (r-call is.character e1)) (<- e2 (r-call as.POSIXct e2))) (r-call check_tzones e1 e2) (r-call NextMethod .Generic)) ()))
+ (<- Math.POSIXt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call stop .Generic " not defined for POSIXt objects")) ()))
+ (<- check_tzones (function ((*named* ... *r-missing*)) (r-block (<- tzs (r-call unique (r-call sapply (r-call list r-dotdotdot) (function ((*named* x *r-missing*)) (r-block (<- y (r-call attr x "tzone")) (if (r-call is.null y) "" y)) ())))) (<- tzs (r-call r-index tzs (r-call != tzs ""))) (if (r-call > (r-call length tzs) 1) (r-call warning "'tzone' attributes are inconsistent")) (if (r-call length tzs) (r-call r-index tzs 1) ())) ()))
+ (<- Summary.POSIXct (function ((*named* ... *r-missing*) (*named* na.rm *r-missing*)) (r-block (<- ok (switch .Generic (*named* max *r-missing*) (*named* min *r-missing*) (*named* range *r-true*) *r-false*)) (if (r-call ! ok) (r-call stop .Generic " not defined for \"POSIXct\" objects")) (<- args (r-call list r-dotdotdot)) (<- tz (r-call do.call "check_tzones" args)) (<- val (r-call NextMethod .Generic)) (<- (r-call class val) (r-call oldClass (r-call r-aref args 1))) (<- (r-call attr val "tzone") tz) val) ()))
+ (<- Summary.POSIXlt (function ((*named* ... *r-missing*) (*named* na.rm *r-missing*)) (r-block (<- ok (switch .Generic (*named* max *r-missing*) (*named* min *r-missing*) (*named* range *r-true*) *r-false*)) (if (r-call ! ok) (r-call stop .Generic " not defined for \"POSIXlt\" objects")) (<- args (r-call list r-dotdotdot)) (<- tz (r-call do.call "check_tzones" args)) (<- args (r-call lapply args as.POSIXct)) (<- val (r-call do.call .Generic (r-call c args (*named* na.rm na.rm)))) (r-call as.POSIXlt (r-call structure val (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone tz)))) ()))
+ (<- "[.POSIXct" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- cl (r-call oldClass x)) (<- (r-call class x) ()) (<- val (r-call NextMethod "[")) (<- (r-call class val) cl) (<- (r-call attr val "tzone") (r-call attr x "tzone")) val) ()))
+ (<- "[[.POSIXct" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- cl (r-call oldClass x)) (<- (r-call class x) ()) (<- val (r-call NextMethod "[[")) (<- (r-call class val) cl) (<- (r-call attr val "tzone") (r-call attr x "tzone")) val) ()))
+ (<- "[<-.POSIXct" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* value *r-missing*)) (r-block (if (r-call ! (r-call as.logical (r-call length value))) (return x)) (<- value (r-call as.POSIXct value)) (<- cl (r-call oldClass x)) (<- tz (r-call attr x "tzone")) (<- (r-call class x) (<- (r-call class value) ())) (<- x (r-call NextMethod .Generic)) (<- (r-call class x) cl) (<- (r-call attr x "tzone") tz) x) ()))
+ (<- as.character.POSIXt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call format x r-dotdotdot) ()))
+ (<- as.data.frame.POSIXct as.data.frame.vector)
+ (<- is.na.POSIXlt (function ((*named* x *r-missing*)) (r-call is.na (r-call as.POSIXct x)) ()))
+ (<- c.POSIXct (function ((*named* ... *r-missing*) (*named* recursive *r-false*)) (r-call structure (r-call c (r-call unlist (r-call lapply (r-call list r-dotdotdot) unclass))) (*named* class (r-call c "POSIXt" "POSIXct"))) ()))
+ (<- c.POSIXlt (function ((*named* ... *r-missing*) (*named* recursive *r-false*)) (r-call as.POSIXlt (r-call do.call "c" (r-call lapply (r-call list r-dotdotdot) as.POSIXct))) ()))
+ (<- all.equal.POSIXct (function ((*named* target *r-missing*) (*named* current *r-missing*) (*named* ... *r-missing*) (*named* scale 1)) (r-block (r-call check_tzones target current) (r-call NextMethod "all.equal")) ()))
+ (<- ISOdatetime (function ((*named* year *r-missing*) (*named* month *r-missing*) (*named* day *r-missing*) (*named* hour *r-missing*) (*named* min *r-missing*) (*named* sec *r-missing*) (*named* tz "")) (r-block (<- x (r-call paste year month day hour min sec (*named* sep "-"))) (r-call as.POSIXct (r-call strptime x "%Y-%m-%d-%H-%M-%OS" (*named* tz tz)) (*named* tz tz))) ()))
+ (<- ISOdate (function ((*named* year *r-missing*) (*named* month *r-missing*) (*named* day *r-missing*) (*named* hour 12) (*named* min 0) (*named* sec 0) (*named* tz "GMT")) (r-call ISOdatetime year month day hour min sec tz) ()))
+ (<- as.matrix.POSIXlt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call as.matrix (r-call as.data.frame (r-call unclass x)) r-dotdotdot)) ()))
+ (<- mean.POSIXct (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call structure (r-call mean (r-call unclass x) r-dotdotdot) (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone (r-call attr x "tzone"))) ()))
+ (<- mean.POSIXlt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call as.POSIXlt (r-call mean (r-call as.POSIXct x) r-dotdotdot)) ()))
+ (<- difftime (function ((*named* time1 *r-missing*) (*named* time2 *r-missing*) (*named* tz "") (*named* units (r-call c "auto" "secs" "mins" "hours" "days" "weeks"))) (r-block (<- time1 (r-call as.POSIXct time1 (*named* tz tz))) (<- time2 (r-call as.POSIXct time2 (*named* tz tz))) (<- z (r-call - (r-call unclass time1) (r-call unclass time2))) (<- units (r-call match.arg units)) (if (r-call == units "auto") (r-block (if (r-call all (r-call is.na z)) (<- units "secs") (r-block (<- zz (r-call min (r-call abs z) (*named* na.rm *r-true*))) (if (\|\| (r-call is.na zz) (r-call < zz 60)) (<- units "secs") (if (r-call < zz 3600) (<- units "mins") (if (r-call < zz 86400) (<- units "hours") (<- units "days")))))))) (switch units (*named* secs (r-call structure z (*named* units "secs") (*named* class "difftime"))) (*named* mins (r-call structure (r-call / z 60) (*named* units "mins") (*named* class "difftime"))) (*named* hours (r-call structure (r-call / z 3600) (*named* units "hours") (*named* class "difftime"))) (*named* days (r-call structure (r-call / z 86400) (*named* units "days") (*named* class "difftime"))) (*named* weeks (r-call structure (r-call / z (r-call * 7 86400)) (*named* units "weeks") (*named* class "difftime"))))) ()))
+ (<- as.difftime (function ((*named* tim *r-missing*) (*named* format "%X") (*named* units "auto")) (r-block (if (r-call inherits tim "difftime") (return tim)) (if (r-call is.character tim) (r-block (r-call difftime (r-call strptime tim (*named* format format)) (r-call strptime "0:0:0" (*named* format "%X")) (*named* units units))) (r-block (if (r-call ! (r-call is.numeric tim)) (r-call stop "'tim' is not character or numeric")) (if (r-call == units "auto") (r-call stop "need explicit units for numeric conversion")) (if (r-call ! (r-call %in% units (r-call c "secs" "mins" "hours" "days" "weeks"))) (r-call stop "invalid units specified")) (r-call structure tim (*named* units units) (*named* class "difftime"))))) ()))
+ (<- units (function ((*named* x *r-missing*)) (r-call UseMethod "units") ()))
+ (<- "units<-" (function ((*named* x *r-missing*) (*named* value *r-missing*)) (r-call UseMethod "units<-") ()))
+ (<- units.difftime (function ((*named* x *r-missing*)) (r-call attr x "units") ()))
+ (<- "units<-.difftime" (function ((*named* x *r-missing*) (*named* value *r-missing*)) (r-block (<- from (r-call units x)) (if (r-call == from value) (return x)) (if (r-call ! (r-call %in% value (r-call c "secs" "mins" "hours" "days" "weeks"))) (r-call stop "invalid units specified")) (<- sc (r-call cumprod (r-call c (*named* secs 1) (*named* mins 60) (*named* hours 60) (*named* days 24) (*named* weeks 7)))) (<- newx (r-call / (r-call * (r-call as.vector x) (r-call r-index sc from)) (r-call r-index sc value))) (r-call structure newx (*named* units value) (*named* class "difftime"))) ()))
+ (<- as.double.difftime (function ((*named* x *r-missing*) (*named* units "auto") (*named* ... *r-missing*)) (r-block (if (r-call != units "auto") (<- (r-call units x) units)) (r-call as.double (r-call as.vector x))) ()))
+ (<- as.data.frame.difftime as.data.frame.vector)
+ (<- format.difftime (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call paste (r-call format (r-call unclass x) r-dotdotdot) (r-call units x)) ()))
+ (<- print.difftime (function ((*named* x *r-missing*) (*named* digits (r-call getOption "digits")) (*named* ... *r-missing*)) (r-block (if (\|\| (r-call is.array x) (r-call > (r-call length x) 1)) (r-block (r-call cat "Time differences in " (r-call attr x "units") "\n" (*named* sep "")) (<- y (r-call unclass x)) (<- (r-call attr y "units") ()) (r-call print y)) (r-call cat "Time difference of " (r-call format (r-call unclass x) (*named* digits digits)) " " (r-call attr x "units") "\n" (*named* sep ""))) (r-call invisible x)) ()))
+ (<- round.difftime (function ((*named* x *r-missing*) (*named* digits 0) (*named* ... *r-missing*)) (r-block (<- units (r-call attr x "units")) (r-call structure (r-call NextMethod) (*named* units units) (*named* class "difftime"))) ()))
+ (<- "[.difftime" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- cl (r-call oldClass x)) (<- (r-call class x) ()) (<- val (r-call NextMethod "[")) (<- (r-call class val) cl) (<- (r-call attr val "units") (r-call attr x "units")) val) ()))
+ (<- Ops.difftime (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (r-block (switch (r-call attr x "units") (*named* secs x) (*named* mins (r-call * 60 x)) (*named* hours (r-call * (r-call * 60 60) x)) (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) x)))) ())) (if (r-call == (r-call nargs) 1) (r-block (switch .Generic (*named* + (r-block)) (*named* - (r-block (<- (r-call r-index e1 *r-missing*) (r-call - (r-call unclass e1))))) (r-call stop "unary" .Generic " not defined for \"difftime\" objects")) (return e1))) (<- boolean (switch .Generic (*named* < *r-missing*) (*named* > *r-missing*) (*named* == *r-missing*) (*named* != *r-missing*) (*named* <= *r-missing*) (*named* >= *r-true*) *r-false*)) (if boolean (r-block (if (&& (r-call inherits e1 "difftime") (r-call inherits e2 "difftime")) (r-block (<- e1 (r-call coerceTimeUnit e1)) (<- e2 (r-call coerceTimeUnit e2)))) (r-call NextMethod .Generic)) (if (\|\| (r-call == .Generic "+") (r-call == .Generic "-")) (r-block (if (&& (r-call inherits e1 "difftime") (r-call ! (r-call inherits e2 "difftime"))) (return (r-call structure (r-call NextMethod .Generic) (*named* units (r-call attr e1 "units")) (*named* class "difftime")))) (if (&& (r-call ! (r-call inherits e1 "difftime")) (r-call inherits e2 "difftime")) (return (r-call structure (r-call NextMethod .Generic) (*named* units (r-call attr e2 "units")) (*named* class "difftime")))) (<- u1 (r-call attr e1 "units")) (if (r-call == (r-call attr e2 "units") u1) (r-block (r-call structure (r-call NextMethod .Generic) (*named* units u1) (*named* class "difftime"))) (r-block (<- e1 (r-call coerceTimeUnit e1)) (<- e2 (r-call coerceTimeUnit e2)) (r-call structure (r-call NextMethod .Generic) (*named* units "secs") (*named* class "difftime"))))) (r-block (r-call stop .Generic "not defined for \"difftime\" objects"))))) ()))
+ (<- "*.difftime" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (if (&& (r-call inherits e1 "difftime") (r-call inherits e2 "difftime")) (r-call stop "both arguments of * cannot be \"difftime\" objects")) (if (r-call inherits e2 "difftime") (r-block (<- tmp e1) (<- e1 e2) (<- e2 tmp))) (r-call structure (r-call * e2 (r-call unclass e1)) (*named* units (r-call attr e1 "units")) (*named* class "difftime"))) ()))
+ (<- "/.difftime" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (if (r-call inherits e2 "difftime") (r-call stop "second argument of / cannot be a \"difftime\" object")) (r-call structure (r-call / (r-call unclass e1) e2) (*named* units (r-call attr e1 "units")) (*named* class "difftime"))) ()))
+ (<- Math.difftime (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call stop .Generic "not defined for \"difftime\" objects")) ()))
+ (<- mean.difftime (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* na.rm *r-false*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (r-block (r-call as.vector (switch (r-call attr x "units") (*named* secs x) (*named* mins (r-call * 60 x)) (*named* hours (r-call * (r-call * 60 60) x)) (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) x))))) ())) (if (r-call length (r-call list r-dotdotdot)) (r-block (<- args (r-call c (r-call lapply (r-call list x r-dotdotdot) coerceTimeUnit) (*named* na.rm na.rm))) (r-call structure (r-call do.call "mean" args) (*named* units "secs") (*named* class "difftime"))) (r-block (r-call structure (r-call mean (r-call as.vector x) (*named* na.rm na.rm)) (*named* units (r-call attr x "units")) (*named* class "difftime"))))) ()))
+ (<- Summary.difftime (function ((*named* ... *r-missing*) (*named* na.rm *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (r-block (r-call as.vector (switch (r-call attr x "units") (*named* secs x) (*named* mins (r-call * 60 x)) (*named* hours (r-call * (r-call * 60 60) x)) (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) x))))) ())) (<- ok (switch .Generic (*named* max *r-missing*) (*named* min *r-missing*) (*named* range *r-true*) *r-false*)) (if (r-call ! ok) (r-call stop .Generic " not defined for \"difftime\" objects")) (<- args (r-call c (r-call lapply (r-call list r-dotdotdot) coerceTimeUnit) (*named* na.rm na.rm))) (r-call structure (r-call do.call .Generic args) (*named* units "secs") (*named* class "difftime"))) ()))
+ (<- seq.POSIXt (function ((*named* from *r-missing*) (*named* to *r-missing*) (*named* by *r-missing*) (*named* length.out ()) (*named* along.with ()) (*named* ... *r-missing*)) (r-block (if (missing from) (r-call stop "'from' must be specified")) (if (r-call ! (r-call inherits from "POSIXt")) (r-call stop "'from' must be a POSIXt object")) (<- cfrom (r-call as.POSIXct from)) (if (r-call != (r-call length cfrom) 1) (r-call stop "'from' must be of length 1")) (<- tz (r-call attr cfrom "tzone")) (if (r-call ! (missing to)) (r-block (if (r-call ! (r-call inherits to "POSIXt")) (r-call stop "'to' must be a POSIXt object")) (if (r-call != (r-call length (r-call as.POSIXct to)) 1) (r-call stop "'to' must be of length 1")))) (if (r-call ! (missing along.with)) (r-block (<- length.out (r-call length along.with))) (if (r-call ! (r-call is.null length.out)) (r-block (if (r-call != (r-call length length.out) 1) (r-call stop "'length.out' must be of length 1")) (<- length.out (r-call ceiling length.out))))) (<- status (r-call c (r-call ! (missing to)) (r-call ! (missing by)) (r-call ! (r-call is.null length.out)))) (if (r-call != (r-call sum status) 2) (r-call stop "exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")) (if (missing by) (r-block (<- from (r-call unclass cfrom)) (<- to (r-call unclass (r-call as.POSIXct to))) (<- res (r-call seq.int from to (*named* length.out length.out))) (return (r-call structure res (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone tz))))) (if (r-call != (r-call length by) 1) (r-call stop "'by' must be of length 1")) (<- valid 0) (if (r-call inherits by "difftime") (r-block (<- by (r-call * (switch (r-call attr by "units") (*named* secs 1) (*named* mins 60) (*named* hours 3600) (*named* days 86400) (*named* weeks (r-call * 7 86400))) (r-call unclass by)))) (if (r-call is.character by) (r-block (<- by2 (r-call r-aref (r-call strsplit by " " (*named* fixed *r-true*)) 1)) (if (\|\| (r-call > (r-call length by2) 2) (r-call < (r-call length by2) 1)) (r-call stop "invalid 'by' string")) (<- valid (r-call pmatch (r-call r-index by2 (r-call length by2)) (r-call c "secs" "mins" "hours" "days" "weeks" "months" "years" "DSTdays"))) (if (r-call is.na valid) (r-call stop "invalid string for 'by'")) (if (r-call <= valid 5) (r-block (<- by (r-call r-index (r-call c 1 60 3600 86400 (r-call * 7 86400)) valid)) (if (r-call == (r-call length by2) 2) (<- by (r-call * by (r-call as.integer (r-call r-index by2 1)))))) (<- by (if (r-call == (r-call length by2) 2) (r-call as.integer (r-call r-index by2 1)) 1)))) (if (r-call ! (r-call is.numeric by)) (r-call stop "invalid mode for 'by'")))) (if (r-call is.na by) (r-call stop "'by' is NA")) (if (r-call <= valid 5) (r-block (<- from (r-call unclass (r-call as.POSIXct from))) (if (r-call ! (r-call is.null length.out)) (<- res (r-call seq.int from (*named* by by) (*named* length.out length.out))) (r-block (<- to (r-call unclass (r-call as.POSIXct to))) (<- res (r-call + (r-call seq.int 0 (r-call - to from) by) from)))) (return (r-call structure res (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone tz)))) (r-block (<- r1 (r-call as.POSIXlt from)) (if (r-call == valid 7) (r-block (if (missing to) (r-block (<- yr (r-call seq.int ($ r1 year) (*named* by by) (*named* length length.out)))) (r-block (<- to (r-call as.POSIXlt to)) (<- yr (r-call seq.int ($ r1 year) ($ to year) by)))) (<- ($ r1 year) yr) (<- ($ r1 isdst) (r-call - 1)) (<- res (r-call as.POSIXct r1))) (if (r-call == valid 6) (r-block (if (missing to) (r-block (<- mon (r-call seq.int ($ r1 mon) (*named* by by) (*named* length length.out)))) (r-block (<- to (r-call as.POSIXlt to)) (<- mon (r-call seq.int ($ r1 mon) (r-call + (r-call * 12 (r-call - ($ to year) ($ r1 year))) ($ to mon)) by)))) (<- ($ r1 mon) mon) (<- ($ r1 isdst) (r-call - 1)) (<- res (r-call as.POSIXct r1))) (if (r-call == valid 8) (r-block (if (r-call ! (missing to)) (r-block (<- length.out (r-call + 2 (r-call floor (r-call / (r-call - (r-call unclass (r-call as.POSIXct to)) (r-call unclass (r-call as.POSI
\ No newline at end of file
+ (<- cut.POSIXt (function ((*named* x *r-missing*) (*named* breaks *r-missing*) (*named* labels ()) (*named* start.on.monday *r-true*) (*named* right *r-false*) (*named* ... *r-missing*)) (r-block (if (r-call ! (r-call inherits x "POSIXt")) (r-call stop "'x' must be a date-time object")) (<- x (r-call as.POSIXct x)) (if (r-call inherits breaks "POSIXt") (r-block (<- breaks (r-call as.POSIXct breaks))) (if (&& (r-call is.numeric breaks) (r-call == (r-call length breaks) 1)) (r-block) (if (&& (r-call is.character breaks) (r-call == (r-call length breaks) 1)) (r-block (<- by2 (r-call r-aref (r-call strsplit breaks " " (*named* fixed *r-true*)) 1)) (if (\|\| (r-call > (r-call length by2) 2) (r-call < (r-call length by2) 1)) (r-call stop "invalid specification of 'breaks'")) (<- valid (r-call pmatch (r-call r-index by2 (r-call length by2)) (r-call c "secs" "mins" "hours" "days" "weeks" "months" "years" "DSTdays"))) (if (r-call is.na valid) (r-call stop "invalid specification of 'breaks'")) (<- start (r-call as.POSIXlt (r-call min x (*named* na.rm *r-true*)))) (<- incr 1) (if (r-call > valid 1) (r-block (<- ($ start sec) 0) (<- incr 59.99))) (if (r-call > valid 2) (r-block (<- ($ start min) 0) (<- incr (r-call - 3600 1)))) (if (r-call > valid 3) (r-block (<- ($ start hour) 0) (<- incr (r-call - 86400 1)))) (if (r-call == valid 5) (r-block (<- ($ start mday) (r-call - ($ start mday) ($ start wday))) (if start.on.monday (<- ($ start mday) (r-call + ($ start mday) (r-call ifelse (r-call > ($ start wday) 0) 1 (r-call - 6))))) (<- incr (r-call * 7 86400)))) (if (r-call == valid 6) (r-block (<- ($ start mday) 1) (<- incr (r-call * 31 86400)))) (if (r-call == valid 7) (r-block (<- ($ start mon) 0) (<- ($ start mday) 1) (<- incr (r-call * 366 86400)))) (if (r-call == valid 8) (<- incr (r-call * 25 3600))) (if (r-call == (r-call length by2) 2) (<- incr (r-call * incr (r-call as.integer (r-call r-index by2 1))))) (<- maxx (r-call max x (*named* na.rm *r-true*))) (<- breaks (r-call seq.int start (r-call + maxx incr) breaks)) (<- breaks (r-call r-index breaks (r-call : 1 (r-call + 1 (r-call max (r-call which (r-call < breaks maxx)))))))) (r-call stop "invalid specification of 'breaks'")))) (<- res (r-call cut (r-call unclass x) (r-call unclass breaks) (*named* labels labels) (*named* right right) r-dotdotdot)) (if (r-call is.null labels) (<- (r-call levels res) (r-call as.character (r-call r-index breaks (r-call - (r-call length breaks)))))) res) ()))
+ (<- julian (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call UseMethod "julian") ()))
+ (<- julian.POSIXt (function ((*named* x *r-missing*) (*named* origin (r-call as.POSIXct "1970-01-01" (*named* tz "GMT"))) (*named* ... *r-missing*)) (r-block (if (r-call != (r-call length origin) 1) (r-call stop "'origin' must be of length one")) (<- res (r-call difftime (r-call as.POSIXct x) origin (*named* units "days"))) (r-call structure res (*named* origin origin))) ()))
+ (<- weekdays (function ((*named* x *r-missing*) (*named* abbreviate *r-missing*)) (r-call UseMethod "weekdays") ()))
+ (<- weekdays.POSIXt (function ((*named* x *r-missing*) (*named* abbreviate *r-false*)) (r-block (r-call format x (r-call ifelse abbreviate "%a" "%A"))) ()))
+ (<- months (function ((*named* x *r-missing*) (*named* abbreviate *r-missing*)) (r-call UseMethod "months") ()))
+ (<- months.POSIXt (function ((*named* x *r-missing*) (*named* abbreviate *r-false*)) (r-block (r-call format x (r-call ifelse abbreviate "%b" "%B"))) ()))
+ (<- quarters (function ((*named* x *r-missing*) (*named* abbreviate *r-missing*)) (r-call UseMethod "quarters") ()))
+ (<- quarters.POSIXt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (<- x (r-call %/% ($ (r-call as.POSIXlt x) mon) 3)) (r-call paste "Q" (r-call + x 1) (*named* sep ""))) ()))
+ (<- trunc.POSIXt (function ((*named* x *r-missing*) (*named* units (r-call c "secs" "mins" "hours" "days"))) (r-block (<- units (r-call match.arg units)) (<- x (r-call as.POSIXlt x)) (if (r-call > (r-call length ($ x sec)) 0) (switch units (*named* secs (r-block (<- ($ x sec) (r-call trunc ($ x sec))))) (*named* mins (r-block (<- ($ x sec) 0))) (*named* hours (r-block (<- ($ x sec) 0) (<- ($ x min) 0))) (*named* days (r-block (<- ($ x sec) 0) (<- ($ x min) 0) (<- ($ x hour) 0) (<- ($ x isdst) (r-call - 1)))))) x) ()))
+ (<- round.POSIXt (function ((*named* x *r-missing*) (*named* units (r-call c "secs" "mins" "hours" "days"))) (r-block (if (&& (r-call is.numeric units) (r-call == units 0)) (<- units "secs")) (<- units (r-call match.arg units)) (<- x (r-call as.POSIXct x)) (<- x (r-call + x (switch units (*named* secs 0.5) (*named* mins 30) (*named* hours 1800) (*named* days 43200)))) (r-call trunc.POSIXt x (*named* units units))) ()))
+ (<- "[.POSIXlt" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- val (r-call lapply x "[" r-dotdotdot (*named* drop drop))) (<- (r-call attributes val) (r-call attributes x)) val) ()))
+ (<- "[<-.POSIXlt" (function ((*named* x *r-missing*) (*named* i *r-missing*) (*named* value *r-missing*)) (r-block (if (r-call ! (r-call as.logical (r-call length value))) (return x)) (<- value (r-call as.POSIXlt value)) (<- cl (r-call oldClass x)) (<- (r-call class x) (<- (r-call class value) ())) (for n (r-call names x) (<- (r-call r-index (r-call r-aref x n) i) (r-call r-aref value n))) (<- (r-call class x) cl) x) ()))
+ (<- as.data.frame.POSIXlt (function ((*named* x *r-missing*) (*named* row.names ()) (*named* optional *r-false*) (*named* ... *r-missing*)) (r-block (<- value (r-call as.data.frame.POSIXct (r-call as.POSIXct x) row.names optional r-dotdotdot)) (if (r-call ! optional) (<- (r-call names value) (r-call r-aref (r-call deparse (substitute x)) 1))) value) ()))
+ (<- rep.POSIXct (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (<- y (r-call NextMethod)) (r-call structure y (*named* class (r-call c "POSIXt" "POSIXct")) (*named* tzone (r-call attr x "tzone")))) ()))
+ (<- rep.POSIXlt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (<- y (r-call lapply x rep r-dotdotdot)) (<- (r-call attributes y) (r-call attributes x)) y) ()))
+ (<- diff.POSIXt (function ((*named* x *r-missing*) (*named* lag 1) (*named* differences 1) (*named* ... *r-missing*)) (r-block (<- ismat (r-call is.matrix x)) (<- r (if (r-call inherits x "POSIXlt") (r-call as.POSIXct x) x)) (<- xlen (if ismat (r-call r-index (r-call dim x) 1) (r-call length r))) (if (\|\| (\|\| (\|\| (r-call > (r-call length lag) 1) (r-call > (r-call length differences) 1)) (r-call < lag 1)) (r-call < differences 1)) (r-call stop "'lag' and 'differences' must be integers >= 1")) (if (r-call >= (r-call * lag differences) xlen) (return (r-call structure (r-call numeric 0) (*named* class "difftime") (*named* units "secs")))) (<- i1 (r-call : (r-call - 1) (r-call - lag))) (if ismat (for i (r-call : 1 differences) (<- r (r-call - (r-call r-index r i1 *r-missing* (*named* drop *r-false*)) (r-call r-index r (r-call : (r-call - (r-call nrow r)) (r-call - (r-call + (r-call - (r-call nrow r) lag) 1))) *r-missing* (*named* drop *r-false*))))) (for i (r-call : 1 differences) (<- r (r-call - (r-call r-index r i1) (r-call r-index r (r-call : (r-call - (r-call length r)) (r-call - (r-call + (r-call - (r-call length r) lag) 1)))))))) r) ()))
+ (<- duplicated.POSIXlt (function ((*named* x *r-missing*) (*named* incomparables *r-false*) (*named* ... *r-missing*)) (r-block (<- x (r-call as.POSIXct x)) (r-call NextMethod "duplicated" x)) ()))
+ (<- unique.POSIXlt (function ((*named* x *r-missing*) (*named* incomparables *r-false*) (*named* ... *r-missing*)) (r-call r-index x (r-call ! (r-call duplicated x incomparables r-dotdotdot))) ()))
+ (<- sort.POSIXlt (function ((*named* x *r-missing*) (*named* decreasing *r-false*) (*named* na.last NA) (*named* ... *r-missing*)) (r-call r-index x (r-call order (r-call as.POSIXct x) (*named* na.last na.last) (*named* decreasing decreasing))) ())))
--- /dev/null
+++ b/tests/ast/match.lsp
@@ -1,0 +1,181 @@
+; -*- scheme -*-
+; tree regular expression pattern matching
+; by Jeff Bezanson
+
+(define (unique lst)
+ (if (null? lst)
+ ()
+ (cons (car lst)
+ (filter (lambda (x) (not (eq x (car lst))))
+ (unique (cdr lst))))))
+
+; list of special pattern symbols that cannot be variable names
+(define metasymbols '(_ ...))
+
+; expression tree pattern matching
+; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
+; mapping variables to captured subexpressions, or #f if no match.
+; when a match succeeds, __ is always bound to the whole matched expression.
+;
+; p is an expression in the following pattern language:
+;
+; _ match anything, not captured
+; <func> any scheme function; matches if (func expr) returns #t
+; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
+; must match the same thing.
+; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
+; subpatterns matched recursively.
+; (-/ <ex>) match <ex> literally
+; (-^ <p>) complement of pattern <p>
+; (-- <var> <p>) match <p> and capture as <var> if match succeeds
+;
+; regular match constructs:
+; ... match any number of anything
+; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
+; (-* <p>) match any number of <p>
+; (-? <p>) match 0 or 1 of <p>
+; (-+ <p>) match at least 1 of <p>
+; all of these can be wrapped in (-- var ) for capturing purposes
+; This is NP-complete. Be careful.
+;
+(define (match- p expr state)
+ (cond ((symbol? p)
+ (cond ((eq p '_) state)
+ (#t
+ (let ((capt (assq p state)))
+ (if capt
+ (and (equal? expr (cdr capt)) state)
+ (cons (cons p expr) state))))))
+
+ ((procedure? p)
+ (and (p expr) state))
+
+ ((pair? p)
+ (cond ((eq (car p) '-/) (and (equal? (cadr p) expr) state))
+ ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
+ ((eq (car p) '--)
+ (and (match- (caddr p) expr state)
+ (cons (cons (cadr p) expr) state)))
+ ((eq (car p) '-$) ; greedy alternation for toplevel pattern
+ (match-alt (cdr p) () (list expr) state #f 1))
+ (#t
+ (and (pair? expr)
+ (equal? (car p) (car expr))
+ (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
+
+ (#t
+ (and (equal? p expr) state))))
+
+; match an alternation
+(define (match-alt alt prest expr state var L)
+ (if (null? alt) #f ; no alternatives left
+ (let ((subma (match- (car alt) (car expr) state)))
+ (or (and subma
+ (match-seq prest (cdr expr)
+ (if var
+ (cons (cons var (car expr))
+ subma)
+ subma)
+ (- L 1)))
+ (match-alt (cdr alt) prest expr state var L)))))
+
+; match generalized kleene star (try consuming min to max)
+(define (match-star- p prest expr state var min max L sofar)
+ (cond ; case 0: impossible to match
+ ((> min max) #f)
+ ; case 1: only allowed to match 0 subexpressions
+ ((= max 0) (match-seq prest expr
+ (if var (cons (cons var (reverse sofar)) state)
+ state)
+ L))
+ ; case 2: must match at least 1
+ ((> min 0)
+ (and (match- p (car expr) state)
+ (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
+ (cons (car expr) sofar))))
+ ; otherwise, must match either 0 or between 1 and max subexpressions
+ (#t
+ (or (match-star- p prest expr state var 0 0 L sofar)
+ (match-star- p prest expr state var 1 max L sofar)))))
+(define (match-star p prest expr state var min max L)
+ (match-star- p prest expr state var min max L ()))
+
+; match sequences of expressions
+(define (match-seq p expr state L)
+ (cond ((not state) #f)
+ ((null? p) (if (null? expr) state #f))
+ (#t
+ (let ((subp (car p))
+ (var #f))
+ (if (and (pair? subp)
+ (eq (car subp) '--))
+ (begin (set! var (cadr subp))
+ (set! subp (caddr subp)))
+ #f)
+ (let ((head (if (pair? subp) (car subp) ())))
+ (cond ((eq subp '...)
+ (match-star '_ (cdr p) expr state var 0 L L))
+ ((eq head '-*)
+ (match-star (cadr subp) (cdr p) expr state var 0 L L))
+ ((eq head '-+)
+ (match-star (cadr subp) (cdr p) expr state var 1 L L))
+ ((eq head '-?)
+ (match-star (cadr subp) (cdr p) expr state var 0 1 L))
+ ((eq head '-$)
+ (match-alt (cdr subp) (cdr p) expr state var L))
+ (#t
+ (and (pair? expr)
+ (match-seq (cdr p) (cdr expr)
+ (match- (car p) (car expr) state)
+ (- L 1))))))))))
+
+(define (match p expr) (match- p expr (list (cons '__ expr))))
+
+; given a pattern p, return the list of capturing variables it uses
+(define (patargs- p)
+ (cond ((and (symbol? p)
+ (not (member p metasymbols)))
+ (list p))
+
+ ((pair? p)
+ (if (eq (car p) '-/)
+ ()
+ (unique (apply append (map patargs- (cdr p))))))
+
+ (#t ())))
+(define (patargs p)
+ (cons '__ (patargs- p)))
+
+; try to transform expr using a pattern-lambda from plist
+; returns the new expression, or expr if no matches
+(define (apply-patterns plist expr)
+ (if (null? plist) expr
+ (if (procedure? plist)
+ (let ((enew (plist expr)))
+ (if (not enew)
+ expr
+ enew))
+ (let ((enew ((car plist) expr)))
+ (if (not enew)
+ (apply-patterns (cdr plist) expr)
+ enew)))))
+
+; top-down fixed-point macroexpansion. this is a typical algorithm,
+; but it may leave some structure that matches a pattern unexpanded.
+; the advantage is that non-terminating cases cannot arise as a result
+; of expression composition. in other words, if the outer loop terminates
+; on all inputs for a given set of patterns, then the whole algorithm
+; terminates. pattern sets that violate this should be easier to detect,
+; for example
+; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
+; TODO: ignore quoted expressions
+(define (pattern-expand plist expr)
+ (if (not (pair? expr))
+ expr
+ (let ((enew (apply-patterns plist expr)))
+ (if (eq enew expr)
+ ; expr didn't change; move to subexpressions
+ (cons (car expr)
+ (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
+ ; expr changed; iterate
+ (pattern-expand plist enew)))))
--- /dev/null
+++ b/tests/ast/match.scm
@@ -1,0 +1,174 @@
+; tree regular expression pattern matching
+; by Jeff Bezanson
+
+; list of special pattern symbols that cannot be variable names
+(define metasymbols '(_ ...))
+
+; expression tree pattern matching
+; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
+; mapping variables to captured subexpressions, or #f if no match.
+; when a match succeeds, __ is always bound to the whole matched expression.
+;
+; p is an expression in the following pattern language:
+;
+; _ match anything, not captured
+; <func> any scheme function; matches if (func expr) returns #t
+; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
+; must match the same thing.
+; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
+; subpatterns matched recursively.
+; (-/ <ex>) match <ex> literally
+; (-^ <p>) complement of pattern <p>
+; (-- <var> <p>) match <p> and capture as <var> if match succeeds
+;
+; regular match constructs:
+; ... match any number of anything
+; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
+; (-* <p>) match any number of <p>
+; (-? <p>) match 0 or 1 of <p>
+; (-+ <p>) match at least 1 of <p>
+; all of these can be wrapped in (-- var ) for capturing purposes
+; This is NP-complete. Be careful.
+;
+(define (match- p expr state)
+ (cond ((symbol? p)
+ (cond ((eq? p '_) state)
+ (else
+ (let ((capt (assq p state)))
+ (if capt
+ (and (equal? expr (cdr capt)) state)
+ (cons (cons p expr) state))))))
+
+ ((procedure? p)
+ (and (p expr) state))
+
+ ((pair? p)
+ (cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state))
+ ((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state))
+ ((eq? (car p) '--)
+ (and (match- (caddr p) expr state)
+ (cons (cons (cadr p) expr) state)))
+ ((eq? (car p) '-$) ; greedy alternation for toplevel pattern
+ (match-alt (cdr p) () (list expr) state #f 1))
+ (else
+ (and (pair? expr)
+ (equal? (car p) (car expr))
+ (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
+
+ (else
+ (and (equal? p expr) state))))
+
+; match an alternation
+(define (match-alt alt prest expr state var L)
+ (if (null? alt) #f ; no alternatives left
+ (let ((subma (match- (car alt) (car expr) state)))
+ (or (and subma
+ (match-seq prest (cdr expr)
+ (if var
+ (cons (cons var (car expr))
+ subma)
+ subma)
+ (- L 1)))
+ (match-alt (cdr alt) prest expr state var L)))))
+
+; match generalized kleene star (try consuming min to max)
+(define (match-star p prest expr state var min max L)
+ (define (match-star- p prest expr state var min max L sofar)
+ (cond ; case 0: impossible to match
+ ((> min max) #f)
+ ; case 1: only allowed to match 0 subexpressions
+ ((= max 0) (match-seq prest expr
+ (if var (cons (cons var (reverse sofar)) state)
+ state)
+ L))
+ ; case 2: must match at least 1
+ ((> min 0)
+ (and (match- p (car expr) state)
+ (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
+ (cons (car expr) sofar))))
+ ; otherwise, must match either 0 or between 1 and max subexpressions
+ (else
+ (or (match-star- p prest expr state var 0 0 L sofar)
+ (match-star- p prest expr state var 1 max L sofar)))))
+
+ (match-star- p prest expr state var min max L ()))
+
+; match sequences of expressions
+(define (match-seq p expr state L)
+ (cond ((not state) #f)
+ ((null? p) (if (null? expr) state #f))
+ (else
+ (let ((subp (car p))
+ (var #f))
+ (if (and (pair? subp)
+ (eq? (car subp) '--))
+ (begin (set! var (cadr subp))
+ (set! subp (caddr subp)))
+ #f)
+ (let ((head (if (pair? subp) (car subp) ())))
+ (cond ((eq? subp '...)
+ (match-star '_ (cdr p) expr state var 0 L L))
+ ((eq? head '-*)
+ (match-star (cadr subp) (cdr p) expr state var 0 L L))
+ ((eq? head '-+)
+ (match-star (cadr subp) (cdr p) expr state var 1 L L))
+ ((eq? head '-?)
+ (match-star (cadr subp) (cdr p) expr state var 0 1 L))
+ ((eq? head '-$)
+ (match-alt (cdr subp) (cdr p) expr state var L))
+ (else
+ (and (pair? expr)
+ (match-seq (cdr p) (cdr expr)
+ (match- (car p) (car expr) state)
+ (- L 1))))))))))
+
+(define (match p expr) (match- p expr (list (cons '__ expr))))
+
+; given a pattern p, return the list of capturing variables it uses
+(define (patargs p)
+ (define (patargs- p)
+ (cond ((and (symbol? p)
+ (not (member p metasymbols)))
+ (list p))
+
+ ((pair? p)
+ (if (eq? (car p) '-/)
+ ()
+ (delete-duplicates (apply append (map patargs- (cdr p))))))
+
+ (else ())))
+ (cons '__ (patargs- p)))
+
+; try to transform expr using a pattern-lambda from plist
+; returns the new expression, or expr if no matches
+(define (apply-patterns plist expr)
+ (if (null? plist) expr
+ (if (procedure? plist)
+ (let ((enew (plist expr)))
+ (if (not enew)
+ expr
+ enew))
+ (let ((enew ((car plist) expr)))
+ (if (not enew)
+ (apply-patterns (cdr plist) expr)
+ enew)))))
+
+; top-down fixed-point macroexpansion. this is a typical algorithm,
+; but it may leave some structure that matches a pattern unexpanded.
+; the advantage is that non-terminating cases cannot arise as a result
+; of expression composition. in other words, if the outer loop terminates
+; on all inputs for a given set of patterns, then the whole algorithm
+; terminates. pattern sets that violate this should be easier to detect,
+; for example
+; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
+; TODO: ignore quoted expressions
+(define (pattern-expand plist expr)
+ (if (not (pair? expr))
+ expr
+ (let ((enew (apply-patterns plist expr)))
+ (if (eq? enew expr)
+ ; expr didn't change; move to subexpressions
+ (cons (car expr)
+ (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
+ ; expr changed; iterate
+ (pattern-expand plist enew)))))
--- /dev/null
+++ b/tests/ast/rpasses-out.lsp
@@ -1,0 +1,1701 @@
+'(r-expressions (<- Sys.time (lambda ()
+ (let () (r-block (r-call structure (r-call
+ .Internal (r-call
+ Sys.time))
+ (*named* class (r-call
+ c "POSIXt" "POSIXct")))))))
+ (<- Sys.timezone (lambda ()
+ (let ()
+ (r-block (r-call as.vector (r-call
+ Sys.getenv
+ "TZ"))))))
+ (<- as.POSIXlt (lambda (x tz)
+ (let ((x ())
+ (tzone ())
+ (fromchar ())
+ (tz ()))
+ (r-block (when (missing tz)
+ (<- tz ""))
+ (<- fromchar (lambda (x)
+ (let ((res ())
+ (f ())
+ (j ())
+ (xx ()))
+ (r-block (<-
+ xx (r-call r-index x 1))
+ (if (r-call is.na xx) (r-block (<- j 1)
+ (while (&& (r-call is.na xx)
+ (r-call <= (<- j (r-call + j 1))
+ (r-call length x)))
+ (<- xx (r-call r-index x j)))
+ (if (r-call is.na xx)
+ (<- f "%Y-%m-%d"))))
+ (if (|\|\|| (r-call is.na xx) (r-call ! (r-call is.na (r-call strptime xx
+ (<- f "%Y-%m-%d %H:%M:%OS"))))
+ (r-call ! (r-call is.na (r-call strptime xx
+ (<- f "%Y/%m/%d %H:%M:%OS"))))
+ (r-call ! (r-call is.na (r-call strptime xx
+ (<- f "%Y-%m-%d %H:%M"))))
+ (r-call ! (r-call is.na (r-call strptime xx
+ (<- f "%Y/%m/%d %H:%M"))))
+ (r-call ! (r-call is.na (r-call strptime xx
+ (<- f "%Y-%m-%d"))))
+ (r-call ! (r-call is.na (r-call strptime xx
+ (<- f "%Y/%m/%d")))))
+ (r-block (<- res (r-call strptime x f))
+ (if (r-call nchar tz) (r-block (<- res (r-call attr<- res "tzone"
+ tz))
+ tz))
+ (return res)))
+ (r-call stop "character string is not in a standard unambiguous format")))))
+ (if (r-call inherits x "POSIXlt")
+ (return x))
+ (if (r-call inherits x "Date")
+ (return (r-call .Internal (r-call
+ Date2POSIXlt x))))
+ (<- tzone (r-call attr x "tzone"))
+ (if (|\|\|| (r-call inherits x "date")
+ (r-call inherits x "dates"))
+ (<- x (r-call as.POSIXct x)))
+ (if (r-call is.character x)
+ (return (r-call fromchar (r-call
+ unclass x))))
+ (if (r-call is.factor x)
+ (return (r-call fromchar (r-call
+ as.character x))))
+ (if (&& (r-call is.logical x)
+ (r-call all (r-call is.na
+ x)))
+ (<- x (r-call
+ as.POSIXct.default x)))
+ (if (r-call ! (r-call inherits x
+ "POSIXct"))
+ (r-call stop (r-call gettextf
+ "do not know how to convert '%s' to class \"POSIXlt\""
+ (r-call deparse (substitute x)))))
+ (if (&& (missing tz)
+ (r-call ! (r-call is.null
+ tzone)))
+ (<- tz (r-call r-index tzone
+ 1)))
+ (r-call .Internal (r-call
+ as.POSIXlt x
+ tz))))))
+ (<- as.POSIXct (lambda (x tz)
+ (let ((tz ()))
+ (r-block (when (missing tz)
+ (<- tz ""))
+ (r-call UseMethod "as.POSIXct")))))
+ (<- as.POSIXct.Date (lambda (x ...)
+ (let ()
+ (r-block (r-call structure (r-call *
+ (r-call unclass x) 86400)
+ (*named* class (r-call
+ c "POSIXt" "POSIXct")))))))
+ (<- as.POSIXct.date (lambda (x ...)
+ (let ((x ()))
+ (r-block (if (r-call inherits x "date")
+ (r-block (<- x (r-call
+ * (r-call - x 3653) 86400))
+ (return (r-call
+ structure x (*named* class (r-call c "POSIXt" "POSIXct")))))
+ (r-call stop (r-call
+ gettextf "'%s' is not a \"date\" object"
+ (r-call deparse (substitute x)))))))))
+ (<- as.POSIXct.dates (lambda (x ...)
+ (let ((x ())
+ (z ()))
+ (r-block (if (r-call inherits x "dates")
+ (r-block (<- z (r-call
+ attr x "origin"))
+ (<- x (r-call
+ * (r-call as.numeric x) 86400))
+ (if (&& (r-call
+ == (r-call length z) 3)
+ (r-call is.numeric z))
+ (<- x (r-call + x
+ (r-call as.numeric (r-call ISOdate (r-call r-index z 3)
+ (r-call r-index z 1)
+ (r-call r-index z 2) 0)))))
+ (return (r-call
+ structure x (*named* class (r-call c "POSIXt" "POSIXct")))))
+ (r-call stop (r-call
+ gettextf "'%s' is not a \"dates\" object"
+ (r-call deparse (substitute x)))))))))
+ (<- as.POSIXct.POSIXlt (lambda (x tz)
+ (let ((tzone ())
+ (tz ()))
+ (r-block (when (missing tz)
+ (<- tz ""))
+ (<- tzone (r-call attr x
+ "tzone"))
+ (if (&& (missing tz)
+ (r-call ! (r-call
+ is.null tzone)))
+ (<- tz (r-call
+ r-index tzone
+ 1)))
+ (r-call structure (r-call
+ .Internal (r-call as.POSIXct x tz))
+ (*named* class (r-call
+ c "POSIXt" "POSIXct"))
+ (*named* tzone tz))))))
+ (<- as.POSIXct.default (lambda (x tz)
+ (let ((tz ()))
+ (r-block (when (missing tz)
+ (<- tz ""))
+ (if (r-call inherits x "POSIXct")
+ (return x))
+ (if (|\|\|| (r-call
+ is.character
+ x)
+ (r-call
+ is.factor x))
+ (return (r-call
+ as.POSIXct
+ (r-call
+ as.POSIXlt
+ x)
+ tz)))
+ (if (&& (r-call
+ is.logical x)
+ (r-call all (r-call
+ is.na x)))
+ (return (r-call
+ structure (r-call
+ as.numeric x)
+ (*named*
+ class (r-call
+ c "POSIXt" "POSIXct")))))
+ (r-call stop (r-call
+ gettextf "do not know how to convert '%s' to class \"POSIXlt\""
+ (r-call
+ deparse (substitute x))))))))
+ (<- as.numeric.POSIXlt (lambda (x)
+ (let ()
+ (r-block (r-call as.POSIXct x)))))
+ (<- format.POSIXlt (lambda (x format usetz ...)
+ (let ((np ())
+ (secs ())
+ (times ())
+ (usetz ())
+ (format ()))
+ (r-block (when (missing format)
+ (<- format ""))
+ (when (missing usetz)
+ (<- usetz *r-false*))
+ (if (r-call ! (r-call
+ inherits x "POSIXlt"))
+ (r-call stop "wrong class"))
+ (if (r-call == format "")
+ (r-block (<- times (r-call
+ unlist (r-call r-index (r-call unclass x)
+ (r-call : 1 3))))
+ (<- secs (r-call
+ r-aref x (index-in-strlist sec (r-call attr x #0="names"))))
+ (<- secs (r-call
+ r-index secs (r-call ! (r-call is.na secs))))
+ (<- np (r-call
+ getOption "digits.secs"))
+ (if (r-call
+ is.null np)
+ (<- np 0)
+ (<- np (r-call
+ min 6 np)))
+ (if (r-call >=
+ np 1)
+ (r-block (for
+ i (r-call - (r-call : 1 np) 1)
+ (if (r-call all (r-call < (r-call abs (r-call - secs
+ (r-call round secs i)))
+ 9.9999999999999995e-07))
+ (r-block (<- np i) (break))))))
+ (<- format (if
+ (r-call all (r-call == (r-call r-index times
+ (r-call ! (r-call is.na times)))
+ 0))
+ "%Y-%m-%d" (if (r-call == np 0) "%Y-%m-%d %H:%M:%S"
+ (r-call paste "%Y-%m-%d %H:%M:%OS" np
+ (*named* sep "")))))))
+ (r-call .Internal (r-call
+ format.POSIXlt x format usetz))))))
+ (<- strftime format.POSIXlt)
+ (<- strptime (lambda (x format tz)
+ (let ((tz ()))
+ (r-block (when (missing tz)
+ (<- tz ""))
+ (r-call .Internal (r-call strptime
+ (r-call as.character x) format tz))))))
+ (<- format.POSIXct (lambda (x format tz usetz ...)
+ (let ((tzone ())
+ (usetz ())
+ (tz ())
+ (format ()))
+ (r-block (when (missing format)
+ (<- format ""))
+ (when (missing tz)
+ (<- tz ""))
+ (when (missing usetz)
+ (<- usetz *r-false*))
+ (if (r-call ! (r-call
+ inherits x "POSIXct"))
+ (r-call stop "wrong class"))
+ (if (&& (missing tz)
+ (r-call ! (r-call
+ is.null (<- tzone (r-call attr x "tzone")))))
+ (<- tz tzone))
+ (r-call structure (r-call
+ format.POSIXlt (r-call as.POSIXlt x tz) format usetz r-dotdotdot)
+ (*named* names (r-call
+ names x)))))))
+ (<- print.POSIXct (lambda (x ...)
+ (let ()
+ (r-block (r-call print (r-call format
+ x (*named* usetz *r-true*) r-dotdotdot)
+ r-dotdotdot)
+ (r-call invisible x)))))
+ (<- print.POSIXlt (lambda (x ...)
+ (let ()
+ (r-block (r-call print (r-call format
+ x (*named* usetz *r-true*))
+ r-dotdotdot)
+ (r-call invisible x)))))
+ (<- summary.POSIXct (lambda (object digits ...)
+ (let ((x ())
+ (digits ()))
+ (r-block (when (missing digits)
+ (<- digits 15))
+ (<- x (r-call r-index (r-call
+ summary.default (r-call unclass object)
+ (*named* digits digits) r-dotdotdot)
+ (r-call : 1 6)))
+ (r-block (ref= %r:1 (r-call
+ oldClass object))
+ (<- x (r-call
+ class<- x
+ %r:1))
+ %r:1)
+ (r-block (ref= %r:2 (r-call
+ attr object "tzone"))
+ (<- x (r-call
+ attr<- x "tzone"
+ %r:2))
+ %r:2)
+ x))))
+ (<- summary.POSIXlt (lambda (object digits ...)
+ (let ((digits ()))
+ (r-block (when (missing digits)
+ (<- digits 15))
+ (r-call summary (r-call
+ as.POSIXct
+ object)
+ (*named* digits
+ digits)
+ r-dotdotdot)))))
+ (<- "+.POSIXt" (lambda (e1 e2)
+ (let ((e2 ())
+ (e1 ())
+ (coerceTimeUnit ()))
+ (r-block (<- coerceTimeUnit (lambda (x)
+ (let ()
+ (r-block (switch (r-call attr x "units")
+ (*named* secs x) (*named* mins (r-call * 60 x))
+ (*named* hours (r-call * (r-call * 60 60) x))
+ (*named* days (r-call * (r-call * (r-call * 60 60) 24) x))
+ (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60)
+ 24)
+ 7)
+ x)))))))
+ (if (r-call == (r-call nargs) 1)
+ (return e1))
+ (if (&& (r-call inherits e1 "POSIXt")
+ (r-call inherits e2 "POSIXt"))
+ (r-call stop "binary + is not defined for \"POSIXt\" objects"))
+ (if (r-call inherits e1 "POSIXlt")
+ (<- e1 (r-call as.POSIXct e1)))
+ (if (r-call inherits e2 "POSIXlt")
+ (<- e2 (r-call as.POSIXct e2)))
+ (if (r-call inherits e1 "difftime")
+ (<- e1 (r-call coerceTimeUnit
+ e1)))
+ (if (r-call inherits e2 "difftime")
+ (<- e2 (r-call coerceTimeUnit
+ e2)))
+ (r-call structure (r-call + (r-call
+ unclass e1)
+ (r-call unclass e2))
+ (*named* class (r-call c
+ "POSIXt" "POSIXct"))
+ (*named* tzone (r-call
+ check_tzones e1 e2)))))))
+ (<- "-.POSIXt" (lambda (e1 e2)
+ (let ((e2 ())
+ (coerceTimeUnit ()))
+ (r-block (<- coerceTimeUnit (lambda (x)
+ (let ()
+ (r-block (switch (r-call attr x "units")
+ (*named* secs x) (*named* mins (r-call * 60 x))
+ (*named* hours (r-call * (r-call * 60 60) x))
+ (*named* days (r-call * (r-call * (r-call * 60 60) 24) x))
+ (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60)
+ 24)
+ 7)
+ x)))))))
+ (if (r-call ! (r-call inherits e1
+ "POSIXt"))
+ (r-call stop "Can only subtract from POSIXt objects"))
+ (if (r-call == (r-call nargs) 1)
+ (r-call stop "unary - is not defined for \"POSIXt\" objects"))
+ (if (r-call inherits e2 "POSIXt")
+ (return (r-call difftime e1
+ e2)))
+ (if (r-call inherits e2 "difftime")
+ (<- e2 (r-call unclass (r-call
+ coerceTimeUnit e2))))
+ (if (r-call ! (r-call is.null (r-call
+ attr e2 "class")))
+ (r-call stop "can only subtract numbers from POSIXt objects"))
+ (r-call structure (r-call - (r-call
+ unclass (r-call as.POSIXct e1))
+ e2)
+ (*named* class (r-call c
+ "POSIXt" "POSIXct")))))))
+ (<- Ops.POSIXt (lambda (e1 e2)
+ (let ((e2 ())
+ (e1 ())
+ (boolean ()))
+ (r-block (if (r-call == (r-call nargs) 1)
+ (r-call stop "unary" .Generic
+ " not defined for \"POSIXt\" objects"))
+ (<- boolean (switch .Generic (*named*
+ < *r-missing*)
+ (*named* >
+ *r-missing*)
+ (*named* ==
+ *r-missing*)
+ (*named* !=
+ *r-missing*)
+ (*named* <=
+ *r-missing*)
+ (*named* >=
+ *r-true*)
+ *r-false*))
+ (if (r-call ! boolean)
+ (r-call stop .Generic
+ " not defined for \"POSIXt\" objects"))
+ (if (|\|\|| (r-call inherits e1
+ "POSIXlt")
+ (r-call is.character
+ e1))
+ (<- e1 (r-call as.POSIXct e1)))
+ (if (|\|\|| (r-call inherits e2
+ "POSIXlt")
+ (r-call is.character
+ e1))
+ (<- e2 (r-call as.POSIXct e2)))
+ (r-call check_tzones e1 e2)
+ (r-call NextMethod .Generic)))))
+ (<- Math.POSIXt (lambda (x ...)
+ (let () (r-block (r-call stop .Generic
+ " not defined for POSIXt objects")))))
+ (<- check_tzones (lambda (...)
+ (let ((tzs ()))
+ (r-block (<- tzs (r-call unique (r-call
+ sapply (r-call list r-dotdotdot) (lambda (x)
+ (let ((y ()))
+ (r-block (<- y (r-call attr x "tzone"))
+ (if (r-call is.null y) "" y)))))))
+ (<- tzs (r-call r-index tzs
+ (r-call != tzs
+ "")))
+ (if (r-call > (r-call length
+ tzs)
+ 1)
+ (r-call warning "'tzone' attributes are inconsistent"))
+ (if (r-call length tzs)
+ (r-call r-index tzs 1)
+ ())))))
+ (<- Summary.POSIXct (lambda (... na.rm)
+ (let ((val ())
+ (tz ())
+ (args ())
+ (ok ()))
+ (r-block (<- ok (switch .Generic (*named*
+ max *r-missing*)
+ (*named* min
+ *r-missing*)
+ (*named*
+ range
+ *r-true*)
+ *r-false*))
+ (if (r-call ! ok)
+ (r-call stop .Generic
+ " not defined for \"POSIXct\" objects"))
+ (<- args (r-call list
+ r-dotdotdot))
+ (<- tz (r-call do.call "check_tzones"
+ args))
+ (<- val (r-call NextMethod
+ .Generic))
+ (r-block (ref= %r:3 (r-call
+ oldClass (r-call r-aref args 1)))
+ (<- val (r-call
+ class<- val %r:3))
+ %r:3)
+ (r-block (<- val (r-call
+ attr<- val "tzone" tz))
+ tz)
+ val))))
+ (<- Summary.POSIXlt (lambda (... na.rm)
+ (let ((val ())
+ (tz ())
+ (args ())
+ (ok ()))
+ (r-block (<- ok (switch .Generic (*named*
+ max *r-missing*)
+ (*named* min
+ *r-missing*)
+ (*named*
+ range
+ *r-true*)
+ *r-false*))
+ (if (r-call ! ok)
+ (r-call stop .Generic
+ " not defined for \"POSIXlt\" objects"))
+ (<- args (r-call list
+ r-dotdotdot))
+ (<- tz (r-call do.call "check_tzones"
+ args))
+ (<- args (r-call lapply args
+ as.POSIXct))
+ (<- val (r-call do.call
+ .Generic (r-call
+ c args (*named* na.rm na.rm))))
+ (r-call as.POSIXlt (r-call
+ structure val (*named* class (r-call c "POSIXt" "POSIXct"))
+ (*named* tzone tz)))))))
+ (<- "[.POSIXct" (lambda (x ... drop)
+ (let ((val ())
+ (x ())
+ (cl ())
+ (drop ()))
+ (r-block (when (missing drop)
+ (<- drop *r-true*))
+ (<- cl (r-call oldClass x))
+ (r-block (<- x (r-call class<-
+ x ()))
+ ())
+ (<- val (r-call NextMethod "["))
+ (r-block (<- val (r-call class<-
+ val cl))
+ cl)
+ (r-block (ref= %r:4 (r-call attr
+ x "tzone"))
+ (<- val (r-call attr<-
+ val "tzone" %r:4))
+ %r:4)
+ val))))
+ (<- "[[.POSIXct" (lambda (x ... drop)
+ (let ((val ())
+ (x ())
+ (cl ())
+ (drop ()))
+ (r-block (when (missing drop)
+ (<- drop *r-true*))
+ (<- cl (r-call oldClass x))
+ (r-block (<- x (r-call class<-
+ x ()))
+ ())
+ (<- val (r-call NextMethod "[["))
+ (r-block (<- val (r-call
+ class<- val
+ cl))
+ cl)
+ (r-block (ref= %r:5 (r-call
+ attr x "tzone"))
+ (<- val (r-call attr<-
+ val "tzone" %r:5))
+ %r:5)
+ val))))
+ (<- "[<-.POSIXct" (lambda (x ... value)
+ (let ((x ())
+ (tz ())
+ (cl ())
+ (value ()))
+ (r-block (if (r-call ! (r-call
+ as.logical (r-call
+ length value)))
+ (return x))
+ (<- value (r-call as.POSIXct
+ value))
+ (<- cl (r-call oldClass x))
+ (<- tz (r-call attr x "tzone"))
+ (r-block (ref= %r:6 (r-block
+ (<- value (r-call class<- value
+ ()))
+ ()))
+ (<- x (r-call class<-
+ x %r:6))
+ %r:6)
+ (<- x (r-call NextMethod
+ .Generic))
+ (r-block (<- x (r-call class<-
+ x cl))
+ cl)
+ (r-block (<- x (r-call attr<-
+ x "tzone" tz))
+ tz)
+ x))))
+ (<- as.character.POSIXt (lambda (x ...)
+ (let ()
+ (r-block (r-call format x
+ r-dotdotdot)))))
+ (<- as.data.frame.POSIXct as.data.frame.vector)
+ (<- is.na.POSIXlt (lambda (x)
+ (let ()
+ (r-block (r-call is.na (r-call
+ as.POSIXct x))))))
+ (<- c.POSIXct (lambda (... recursive)
+ (let ((recursive ()))
+ (r-block (when (missing recursive)
+ (<- recursive *r-false*))
+ (r-call structure (r-call c (r-call
+ unlist (r-call lapply (r-call list r-dotdotdot) unclass)))
+ (*named* class (r-call c
+ "POSIXt" "POSIXct")))))))
+ (<- c.POSIXlt (lambda (... recursive)
+ (let ((recursive ()))
+ (r-block (when (missing recursive)
+ (<- recursive *r-false*))
+ (r-call as.POSIXlt (r-call do.call
+ "c" (r-call lapply (r-call list r-dotdotdot) as.POSIXct)))))))
+ (<- all.equal.POSIXct (lambda (target current ... scale)
+ (let ((scale ()))
+ (r-block (when (missing scale)
+ (<- scale 1))
+ (r-call check_tzones
+ target current)
+ (r-call NextMethod "all.equal")))))
+ (<- ISOdatetime (lambda (year month day hour min sec tz)
+ (let ((x ())
+ (tz ()))
+ (r-block (when (missing tz)
+ (<- tz ""))
+ (<- x (r-call paste year month
+ day hour min sec
+ (*named* sep "-")))
+ (r-call as.POSIXct (r-call
+ strptime x
+ "%Y-%m-%d-%H-%M-%OS"
+ (*named* tz
+ tz))
+ (*named* tz tz))))))
+ (<- ISOdate (lambda (year month day hour min sec tz)
+ (let ((tz ())
+ (sec ())
+ (min ())
+ (hour ()))
+ (r-block (when (missing hour)
+ (<- hour 12))
+ (when (missing min)
+ (<- min 0))
+ (when (missing sec)
+ (<- sec 0))
+ (when (missing tz)
+ (<- tz "GMT"))
+ (r-call ISOdatetime year month day
+ hour min sec tz)))))
+ (<- as.matrix.POSIXlt (lambda (x ...)
+ (let ()
+ (r-block (r-call as.matrix (r-call
+ as.data.frame (r-call unclass x))
+ r-dotdotdot)))))
+ (<- mean.POSIXct (lambda (x ...)
+ (let ()
+ (r-block (r-call structure (r-call mean
+ (r-call unclass x) r-dotdotdot)
+ (*named* class (r-call
+ c "POSIXt" "POSIXct"))
+ (*named* tzone (r-call
+ attr x "tzone")))))))
+ (<- mean.POSIXlt (lambda (x ...)
+ (let ()
+ (r-block (r-call as.POSIXlt (r-call mean
+ (r-call as.POSIXct x) r-dotdotdot))))))
+ (<- difftime (lambda (time1 time2 tz units)
+ (let ((zz ())
+ (z ())
+ (time2 ())
+ (time1 ())
+ (units ())
+ (tz ()))
+ (r-block (when (missing tz)
+ (<- tz ""))
+ (when (missing units)
+ (<- units (r-call c "auto" "secs"
+ "mins" "hours"
+ "days" "weeks")))
+ (<- time1 (r-call as.POSIXct time1
+ (*named* tz tz)))
+ (<- time2 (r-call as.POSIXct time2
+ (*named* tz tz)))
+ (<- z (r-call - (r-call unclass
+ time1)
+ (r-call unclass time2)))
+ (<- units (r-call match.arg units))
+ (if (r-call == units "auto")
+ (r-block (if (r-call all (r-call
+ is.na z))
+ (<- units "secs")
+ (r-block (<- zz (r-call
+ min (r-call abs z) (*named* na.rm *r-true*)))
+ (if (|\|\|| (r-call is.na zz) (r-call < zz 60))
+ (<- units "secs") (if (r-call < zz 3600)
+ (<- units "mins")
+ (if (r-call < zz 86400)
+ (<- units "hours")
+ (<- units "days"))))))))
+ (switch units (*named* secs (r-call
+ structure z (*named* units "secs")
+ (*named* class "difftime")))
+ (*named* mins (r-call
+ structure (r-call
+ / z 60)
+ (*named*
+ units "mins")
+ (*named*
+ class "difftime")))
+ (*named* hours (r-call
+ structure
+ (r-call /
+ z 3600)
+ (*named*
+ units "hours")
+ (*named*
+ class "difftime")))
+ (*named* days (r-call
+ structure (r-call
+ / z 86400)
+ (*named*
+ units "days")
+ (*named*
+ class "difftime")))
+ (*named* weeks (r-call
+ structure
+ (r-call /
+ z (r-call * 7 86400))
+ (*named*
+ units "weeks")
+ (*named*
+ class "difftime"))))))))
+ (<- as.difftime (lambda (tim format units)
+ (let ((units ())
+ (format ()))
+ (r-block (when (missing format)
+ (<- format "%X"))
+ (when (missing units)
+ (<- units "auto"))
+ (if (r-call inherits tim "difftime")
+ (return tim))
+ (if (r-call is.character tim)
+ (r-block (r-call difftime (r-call
+ strptime tim (*named* format format))
+ (r-call
+ strptime "0:0:0" (*named* format "%X"))
+ (*named*
+ units units)))
+ (r-block (if (r-call ! (r-call
+ is.numeric tim))
+ (r-call stop "'tim' is not character or numeric"))
+ (if (r-call ==
+ units "auto")
+ (r-call stop "need explicit units for numeric conversion"))
+ (if (r-call ! (r-call
+ %in% units (r-call c "secs" "mins" "hours" "days" "weeks")))
+ (r-call stop "invalid units specified"))
+ (r-call structure
+ tim (*named*
+ units units)
+ (*named*
+ class "difftime"))))))))
+ (<- units (lambda (x)
+ (let () (r-block (r-call UseMethod "units")))))
+ (<- "units<-" (lambda (x value)
+ (let () (r-block (r-call UseMethod "units<-")))))
+ (<- units.difftime (lambda (x)
+ (let ()
+ (r-block (r-call attr x "units")))))
+ (<- "units<-.difftime" (lambda (x value)
+ (let ((newx ())
+ (sc ())
+ (from ()))
+ (r-block (<- from (r-call units x))
+ (if (r-call == from value)
+ (return x))
+ (if (r-call ! (r-call
+ %in% value (r-call c "secs" "mins" "hours" "days" "weeks")))
+ (r-call stop "invalid units specified"))
+ (<- sc (r-call cumprod (r-call
+ c (*named* secs 1) (*named* mins 60)
+ (*named* hours 60) (*named* days 24) (*named* weeks 7))))
+ (<- newx (r-call / (r-call
+ * (r-call as.vector x) (r-call r-index sc from))
+ (r-call r-index sc value)))
+ (r-call structure newx
+ (*named* units
+ value)
+ (*named* class "difftime"))))))
+ (<- as.double.difftime (lambda (x units ...)
+ (let ((x ())
+ (units ()))
+ (r-block (when (missing units)
+ (<- units "auto"))
+ (if (r-call != units "auto")
+ (r-block (<- x (r-call
+ units<- x units))
+ units))
+ (r-call as.double (r-call
+ as.vector x))))))
+ (<- as.data.frame.difftime
+ as.data.frame.vector)
+ (<- format.difftime (lambda (x ...)
+ (let ()
+ (r-block (r-call paste (r-call format
+ (r-call unclass x) r-dotdotdot)
+ (r-call units x))))))
+ (<- print.difftime (lambda (x digits ...)
+ (let ((y ())
+ (digits ()))
+ (r-block (when (missing digits)
+ (<- digits (r-call
+ getOption
+ "digits")))
+ (if (|\|\|| (r-call is.array
+ x)
+ (r-call > (r-call
+ length x)
+ 1))
+ (r-block (r-call cat "Time differences in "
+ (r-call attr x "units") "\n" (*named* sep ""))
+ (<- y (r-call
+ unclass x))
+ (r-block (<- y
+ (r-call attr<- y "units"
+ ()))
+ ())
+ (r-call print y))
+ (r-call cat "Time difference of "
+ (r-call format (r-call
+ unclass x)
+ (*named* digits digits))
+ " " (r-call attr
+ x "units")
+ "\n" (*named* sep
+ "")))
+ (r-call invisible x)))))
+ (<- round.difftime (lambda (x digits ...)
+ (let ((units ())
+ (digits ()))
+ (r-block (when (missing digits)
+ (<- digits 0))
+ (<- units (r-call attr x "units"))
+ (r-call structure (r-call
+ NextMethod)
+ (*named* units units)
+ (*named* class "difftime"))))))
+ (<- "[.difftime" (lambda (x ... drop)
+ (let ((val ())
+ (x ())
+ (cl ())
+ (drop ()))
+ (r-block (when (missing drop)
+ (<- drop *r-true*))
+ (<- cl (r-call oldClass x))
+ (r-block (<- x (r-call class<-
+ x ()))
+ ())
+ (<- val (r-call NextMethod "["))
+ (r-block (<- val (r-call
+ class<- val
+ cl))
+ cl)
+ (r-block (ref= %r:7 (r-call
+ attr x "units"))
+ (<- val (r-call attr<-
+ val "units" %r:7))
+ %r:7)
+ val))))
+ (<- Ops.difftime (lambda (e1 e2)
+ (let ((u1 ())
+ (e2 ())
+ (boolean ())
+ (e1 ())
+ (coerceTimeUnit ()))
+ (r-block (<- coerceTimeUnit (lambda (x)
+ (let () (r-block (switch (r-call attr x "units")
+ (*named* secs x)
+ (*named* mins (r-call * 60 x))
+ (*named* hours (r-call * (r-call * 60 60) x))
+ (*named* days (r-call * (r-call * (r-call * 60 60)
+ 24)
+ x))
+ (*named* weeks (r-call * (r-call * (r-call * (r-call
+ * 60 60)
+ 24)
+ 7)
+ x)))))))
+ (if (r-call == (r-call nargs)
+ 1)
+ (r-block (switch .Generic
+ (*named* + (r-block)) (*named* - (r-block (r-block (ref= %r:8 (r-call - (r-call
+ unclass e1)))
+ (<- e1 (r-call r-index<-
+ e1
+ *r-missing*
+ %r:8))
+ %r:8)))
+ (r-call stop "unary" .Generic
+ " not defined for \"difftime\" objects"))
+ (return e1)))
+ (<- boolean (switch .Generic (*named*
+ < *r-missing*)
+ (*named* >
+ *r-missing*)
+ (*named* ==
+ *r-missing*)
+ (*named* !=
+ *r-missing*)
+ (*named* <=
+ *r-missing*)
+ (*named* >=
+ *r-true*)
+ *r-false*))
+ (if boolean (r-block (if (&& (r-call
+ inherits e1 "difftime")
+ (r-call inherits e2 "difftime"))
+ (r-block (<- e1 (r-call coerceTimeUnit e1))
+ (<- e2 (r-call coerceTimeUnit e2))))
+ (r-call NextMethod .Generic))
+ (if (|\|\|| (r-call ==
+ .Generic "+")
+ (r-call ==
+ .Generic "-"))
+ (r-block (if (&& (r-call
+ inherits e1 "difftime")
+ (r-call ! (r-call inherits e2 "difftime")))
+ (return (r-call structure (r-call NextMethod .Generic)
+ (*named* units (r-call attr e1 "units"))
+ (*named* class "difftime"))))
+ (if (&& (r-call
+ ! (r-call inherits e1 "difftime"))
+ (r-call inherits e2 "difftime"))
+ (return (r-call structure (r-call NextMethod .Generic)
+ (*named* units (r-call attr e2 "units"))
+ (*named* class "difftime"))))
+ (<- u1 (r-call
+ attr e1 "units"))
+ (if (r-call ==
+ (r-call attr e2 "units") u1)
+ (r-block (r-call structure (r-call NextMethod .Generic)
+ (*named* units u1) (*named* class "difftime")))
+ (r-block (<- e1 (r-call coerceTimeUnit e1))
+ (<- e2 (r-call coerceTimeUnit e2))
+ (r-call structure (r-call NextMethod .Generic)
+ (*named* units "secs")
+ (*named* class "difftime")))))
+ (r-block (r-call stop
+ .Generic "not defined for \"difftime\" objects"))))))))
+ (<- "*.difftime" (lambda (e1 e2)
+ (let ((e2 ())
+ (e1 ())
+ (tmp ()))
+ (r-block (if (&& (r-call inherits e1 "difftime")
+ (r-call inherits e2 "difftime"))
+ (r-call stop "both arguments of * cannot be \"difftime\" objects"))
+ (if (r-call inherits e2 "difftime")
+ (r-block (<- tmp e1)
+ (<- e1 e2)
+ (<- e2 tmp)))
+ (r-call structure (r-call * e2
+ (r-call unclass e1))
+ (*named* units (r-call
+ attr e1 "units"))
+ (*named* class "difftime"))))))
+ (<- "/.difftime" (lambda (e1 e2)
+ (let ()
+ (r-block (if (r-call inherits e2 "difftime")
+ (r-call stop "second argument of / cannot be a \"difftime\" object"))
+ (r-call structure (r-call / (r-call
+ unclass e1)
+ e2)
+ (*named* units (r-call
+ attr e1 "units"))
+ (*named* class "difftime"))))))
+ (<- Math.difftime (lambda (x ...)
+ (let ()
+ (r-block (r-call stop .Generic
+ "not defined for \"difftime\" objects")))))
+ (<- mean.difftime (lambda (x ... na.rm)
+ (let ((args ())
+ (coerceTimeUnit ())
+ (na.rm ()))
+ (r-block (when (missing na.rm)
+ (<- na.rm *r-false*))
+ (<- coerceTimeUnit (lambda (x)
+ (let () (r-block (r-call as.vector (switch (r-call attr x "units")
+ (*named* secs x)
+ (*named* mins (r-call * 60 x))
+ (*named* hours (r-call * (r-call
+ * 60 60)
+ x))
+ (*named* days (r-call * (r-call *
+ (r-call * 60 60) 24)
+ x))
+ (*named* weeks (r-call * (r-call
+ * (r-call * (r-call * 60 60) 24) 7)
+ x))))))))
+ (if (r-call length (r-call
+ list r-dotdotdot))
+ (r-block (<- args (r-call
+ c (r-call lapply (r-call list x r-dotdotdot) coerceTimeUnit)
+ (*named* na.rm na.rm)))
+ (r-call structure
+ (r-call do.call "mean" args) (*named* units "secs")
+ (*named* class "difftime")))
+ (r-block (r-call structure
+ (r-call mean (r-call as.vector x)
+ (*named* na.rm na.rm))
+ (*named* units (r-call attr x "units"))
+ (*named* class "difftime"))))))))
+ (<- Summary.difftime (lambda (... na.rm)
+ (let ((args ())
+ (ok ())
+ (coerceTimeUnit ()))
+ (r-block (<- coerceTimeUnit (lambda (x)
+ (let () (r-block (r-call as.vector (switch (r-call attr x "units")
+ (*named* secs x)
+ (*named* mins (r-call * 60 x))
+ (*named* hours (r-call * (r-call
+ * 60 60)
+ x))
+ (*named* days (r-call * (r-call *
+ (r-call * 60 60) 24)
+ x))
+ (*named* weeks (r-call * (r-call
+ * (r-call * (r-call * 60 60) 24) 7)
+ x))))))))
+ (<- ok (switch .Generic (*named*
+ max *r-missing*)
+ (*named* min
+ *r-missing*)
+ (*named*
+ range
+ *r-true*)
+ *r-false*))
+ (if (r-call ! ok)
+ (r-call stop .Generic
+ " not defined for \"difftime\" objects"))
+ (<- args (r-call c (r-call
+ lapply (r-call list r-dotdotdot) coerceTimeUnit)
+ (*named* na.rm na.rm)))
+ (r-call structure (r-call
+ do.call .Generic args)
+ (*named* units "secs")
+ (*named* class "difftime"))))))
+ (<- seq.POSIXt (lambda (from to by length.out along.with ...)
+ (let ((mon ())
+ (yr ())
+ (r1 ())
+ (by2 ())
+ (by ())
+ (valid ())
+ (res ())
+ (to ())
+ (from ())
+ (status ())
+ (tz ())
+ (cfrom ())
+ (along.with ())
+ (length.out ()))
+ (r-block (when (missing length.out)
+ (<- length.out ()))
+ (when (missing along.with)
+ (<- along.with ()))
+ (if (missing from)
+ (r-call stop "'from' must be specified"))
+ (if (r-call ! (r-call inherits
+ from "POSIXt"))
+ (r-call stop "'from' must be a POSIXt object"))
+ (<- cfrom (r-call as.POSIXct from))
+ (if (r-call != (r-call length
+ cfrom)
+ 1)
+ (r-call stop "'from' must be of length 1"))
+ (<- tz (r-call attr cfrom "tzone"))
+ (if (r-call ! (missing to))
+ (r-block (if (r-call ! (r-call
+ inherits to "POSIXt"))
+ (r-call stop "'to' must be a POSIXt object"))
+ (if (r-call != (r-call
+ length (r-call as.POSIXct to))
+ 1)
+ (r-call stop "'to' must be of length 1"))))
+ (if (r-call ! (missing along.with))
+ (r-block (<- length.out (r-call
+ length along.with)))
+ (if (r-call ! (r-call is.null
+ length.out))
+ (r-block (if (r-call !=
+ (r-call length length.out) 1)
+ (r-call stop
+ "'length.out' must be of length 1"))
+ (<- length.out
+ (r-call
+ ceiling
+ length.out)))))
+ (<- status (r-call c (r-call ! (missing
+ to))
+ (r-call ! (missing
+ by))
+ (r-call ! (r-call
+ is.null length.out))))
+ (if (r-call != (r-call sum status)
+ 2)
+ (r-call stop "exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified"))
+ (if (missing by)
+ (r-block (<- from (r-call
+ unclass cfrom))
+ (<- to (r-call
+ unclass (r-call
+ as.POSIXct to)))
+ (<- res (r-call
+ seq.int
+ from to (*named*
+ length.out length.out)))
+ (return (r-call
+ structure
+ res (*named*
+ class (r-call c "POSIXt" "POSIXct"))
+ (*named*
+ tzone tz)))))
+ (if (r-call != (r-call length by)
+ 1)
+ (r-call stop "'by' must be of length 1"))
+ (<- valid 0)
+ (if (r-call inherits by "difftime")
+ (r-block (<- by (r-call * (switch
+ (r-call attr by "units") (*named* secs 1)
+ (*named* mins 60) (*named* hours 3600) (*named* days 86400)
+ (*named* weeks (r-call * 7 86400)))
+ (r-call unclass by))))
+ (if (r-call is.character by)
+ (r-block (<- by2 (r-call
+ r-aref (r-call strsplit by " "
+ (*named* fixed *r-true*))
+ 1))
+ (if (|\|\|| (r-call
+ > (r-call length by2) 2)
+ (r-call < (r-call length by2) 1))
+ (r-call stop
+ "invalid 'by' string"))
+ (<- valid (r-call
+ pmatch (r-call r-index by2
+ (r-call length by2))
+ (r-call c "secs" "mins" "hours" "days" "weeks" "months" "years" "DSTdays")))
+ (if (r-call
+ is.na valid)
+ (r-call stop
+ "invalid string for 'by'"))
+ (if (r-call <=
+ valid 5)
+ (r-block (<-
+ by (r-call r-index (r-call c 1 60 3600 86400
+ (r-call * 7 86400))
+ valid))
+ (if (r-call == (r-call length by2) 2) (<- by (r-call * by
+ (r-call as.integer (r-call
+ r-index by2 1))))))
+ (<- by (if
+ (r-call == (r-call length by2) 2) (r-call as.integer (r-call r-index by2 1))
+ 1))))
+ (if (r-call ! (r-call
+ is.numeric by))
+ (r-call stop "invalid mode for 'by'"))))
+ (if (r-call is.na by)
+ (r-call stop "'by' is NA"))
+ (if (r-call <= valid 5)
+ (r-block (<- from (r-call
+ unclass (r-call as.POSIXct from)))
+ (if (r-call ! (r-call
+ is.null length.out))
+ (<- res (r-call
+ seq.int from (*named* by by)
+ (*named* length.out length.out)))
+ (r-block (<- to
+ (r-call unclass (r-call as.POSIXct to)))
+ (<- res (r-call + (r-call seq.int 0
+ (r-call - to from) by)
+ from))))
+ (return (r-call
+ structure
+ res (*named*
+ class (r-call c "POSIXt" "POSIXct"))
+ (*named*
+ tzone tz))))
+ (r-block (<- r1 (r-call
+ as.POSIXlt
+ from))
+ (if (r-call == valid
+ 7)
+ (r-block (if (missing
+ to)
+ (r-block (<- yr (r-call seq.int (r-call r-aref r1
+ (index-in-strlist year (r-call attr
+ r1 #0#)))
+ (*named* by by)
+ (*named* length length.out))))
+ (r-block (<- to (r-call as.POSIXlt to))
+ (<- yr (r-call seq.int (r-call r-aref r1
+ (index-in-strlist year (r-call attr
+ r1 #0#)))
+ (r-call r-aref to
+ (index-in-strlist year (r-call attr to #0#)))
+ by))))
+ (r-block (<- r1 (r-call r-aref<- r1
+ (index-in-strlist year (r-call attr r1 #0#)) yr))
+ yr)
+ (r-block (ref= %r:9 (r-call - 1)) (<- r1 (r-call r-aref<- r1
+ (index-in-strlist isdst (r-call
+ attr r1 #0#))
+ %r:9))
+ %r:9)
+ (<- res (r-call as.POSIXct r1)))
+ (if (r-call ==
+ valid 6)
+ (r-block (if
+ (missing to) (r-block (<- mon (r-call seq.int (r-call r-aref r1
+ (index-in-strlist mon
+ (r-call attr r1 #0#)))
+ (*named* by by)
+ (*named* length length.out))))
+ (r-block (<- to (r-call as.POSIXlt to))
+ (<- mon (r-call seq.int (r-call r-aref r1
+ (index-in-strlist mon (r-call attr
+ r1 #0#)))
+ (r-call + (r-call * 12
+ (r-call - (r-call r-aref to
+ (index-in-strlist
+ year (r-call
+ attr to #0#)))
+ (r-call r-aref r1
+ (index-in-strlist
+ year (r-call attr
+ r1 #0#)))))
+ (r-call r-aref to
+ (index-in-strlist mon (r-call attr
+ to #0#))))
+ by))))
+ (r-block (<- r1 (r-call r-aref<- r1
+ (index-in-strlist mon (r-call attr r1 #0#)) mon))
+ mon)
+ (r-block (ref= %r:10 (r-call - 1)) (<- r1 (r-call r-aref<- r1
+ (index-in-strlist isdst (r-call
+ attr r1 #0#))
+ %r:10))
+ %r:10)
+ (<- res (r-call as.POSIXct r1)))
+ (if (r-call
+ == valid 8)
+ (r-block (if (r-call ! (missing to)) (r-block (<- length.out (r-call + 2
+ (r-call floor (r-call / (r-call - (r-call unclass (r-call as.POSIXct to))
+ (r-call unclass (r-call as.POSIXct from)))
+ 86400))))))
+ (r-block (ref= %r:11 (r-call seq.int (r-call r-aref r1
+ (index-in-strlist mday
+ (r-call attr r1 #0#)))
+ (*named* by by)
+ (*named* length length.out)))
+ (<- r1 (r-call r-aref<- r1
+ (index-in-strlist mday (r-call attr r1 #0#))
+ %r:11))
+ %r:11)
+ (r-block (ref= %r:12 (r-call - 1))
+ (<- r1 (r-call r-aref<- r1
+ (index-in-strlist isdst (r-call attr r1 #0#))
+ %r:12))
+ %r:12)
+ (<- res (r-call as.POSIXct r1))
+ (if (r-call ! (missing to)) (<- res (r-call r-index res
+ (r-call <= res
+ (r-call
+ as.POSIXct to)))))))))
+ (return res)))))))
+ (<- cut.POSIXt (lambda (x breaks labels start.on.monday right
+ ...)
+ (let ((res ())
+ (maxx ())
+ (incr ())
+ (start ())
+ (valid ())
+ (by2 ())
+ (breaks ())
+ (x ())
+ (right ())
+ (start.on.monday ())
+ (labels ()))
+ (r-block (when (missing labels)
+ (<- labels ()))
+ (when (missing start.on.monday)
+ (<- start.on.monday
+ *r-true*))
+ (when (missing right)
+ (<- right *r-false*))
+ (if (r-call ! (r-call inherits x
+ "POSIXt"))
+ (r-call stop "'x' must be a date-time object"))
+ (<- x (r-call as.POSIXct x))
+ (if (r-call inherits breaks "POSIXt")
+ (r-block (<- breaks (r-call
+ as.POSIXct breaks)))
+ (if (&& (r-call is.numeric
+ breaks)
+ (r-call == (r-call
+ length breaks)
+ 1))
+ (r-block)
+ (if (&& (r-call
+ is.character
+ breaks)
+ (r-call == (r-call
+ length breaks)
+ 1))
+ (r-block (<- by2 (r-call
+ r-aref (r-call strsplit breaks " "
+ (*named* fixed *r-true*))
+ 1))
+ (if (|\|\||
+ (r-call > (r-call length by2) 2) (r-call < (r-call length by2) 1))
+ (r-call stop "invalid specification of 'breaks'"))
+ (<- valid (r-call
+ pmatch (r-call r-index by2
+ (r-call length by2))
+ (r-call c "secs" "mins" "hours" "days" "weeks" "months" "years" "DSTdays")))
+ (if (r-call
+ is.na valid)
+ (r-call stop "invalid specification of 'breaks'"))
+ (<- start (r-call
+ as.POSIXlt (r-call min x
+ (*named* na.rm *r-true*))))
+ (<- incr 1)
+ (if (r-call
+ > valid 1)
+ (r-block (r-block (<- start (r-call r-aref<- start
+ (index-in-strlist sec (r-call attr start
+ #0#))
+ 0))
+ 0)
+ (<- incr 59.990000000000002)))
+ (if (r-call
+ > valid 2)
+ (r-block (r-block (<- start (r-call r-aref<- start
+ (index-in-strlist min (r-call attr start
+ #0#))
+ 0))
+ 0)
+ (<- incr (r-call - 3600 1))))
+ (if (r-call
+ > valid 3)
+ (r-block (r-block (<- start (r-call r-aref<- start
+ (index-in-strlist hour (r-call attr start
+ #0#))
+ 0))
+ 0)
+ (<- incr (r-call - 86400 1))))
+ (if (r-call
+ == valid 5)
+ (r-block (r-block (ref= %r:13 (r-call - (r-call r-aref start
+ (index-in-strlist mday (r-call
+ attr start #0#)))
+ (r-call r-aref start
+ (index-in-strlist wday (r-call
+ attr start #0#)))))
+ (<- start (r-call r-aref<- start
+ (index-in-strlist mday (r-call attr start
+ #0#))
+ %r:13))
+ %r:13)
+ (if start.on.monday (r-block (ref= %r:14 (r-call + (r-call r-aref
+ start (index-in-strlist mday (r-call attr start #0#)))
+ (r-call ifelse (r-call
+ > (r-call r-aref start
+ (index-in-strlist wday (r-call attr start #0#)))
+ 0)
+ 1 (r-call
+ - 6))))
+ (<- start (r-call r-aref<- start
+ (index-in-strlist
+ mday (r-call attr
+ start #0#))
+ %r:14))
+ %r:14))
+ (<- incr (r-call * 7 86400))))
+ (if (r-call
+ == valid 6)
+ (r-block (r-block (<- start (r-call r-aref<- start
+ (index-in-strlist mday (r-call attr start
+ #0#))
+ 1))
+ 1)
+ (<- incr (r-call * 31 86400))))
+ (if (r-call
+ == valid 7)
+ (r-block (r-block (<- start (r-call r-aref<- start
+ (index-in-strlist mon (r-call attr start
+ #0#))
+ 0))
+ 0)
+ (r-block (<- start (r-call r-aref<- start
+ (index-in-strlist mday (r-call attr start
+ #0#))
+ 1))
+ 1)
+ (<- incr (r-call * 366 86400))))
+ (if (r-call
+ == valid 8)
+ (<- incr (r-call * 25 3600)))
+ (if (r-call
+ == (r-call length by2) 2)
+ (<- incr (r-call * incr
+ (r-call as.integer (r-call r-index by2 1)))))
+ (<- maxx (r-call
+ max x (*named* na.rm *r-true*)))
+ (<- breaks
+ (r-call seq.int start
+ (r-call + maxx incr) breaks))
+ (<- breaks
+ (r-call r-index breaks
+ (r-call : 1
+ (r-call + 1
+ (r-call max (r-call which (r-call < breaks maxx))))))))
+ (r-call stop "invalid specification of 'breaks'"))))
+ (<- res (r-call cut (r-call
+ unclass x)
+ (r-call unclass
+ breaks)
+ (*named* labels
+ labels)
+ (*named* right
+ right)
+ r-dotdotdot))
+ (if (r-call is.null labels)
+ (r-block (ref= %r:15 (r-call
+ as.character (r-call r-index breaks
+ (r-call - (r-call length breaks)))))
+ (<- res (r-call
+ levels<-
+ res %r:15))
+ %r:15))
+ res))))
+ (<- julian (lambda (x ...)
+ (let () (r-block (r-call UseMethod "julian")))))
+ (<- julian.POSIXt (lambda (x origin ...)
+ (let ((res ())
+ (origin ()))
+ (r-block (when (missing origin)
+ (<- origin (r-call
+ as.POSIXct
+ "1970-01-01"
+ (*named* tz
+ "GMT"))))
+ (if (r-call != (r-call length
+ origin)
+ 1)
+ (r-call stop "'origin' must be of length one"))
+ (<- res (r-call difftime (r-call
+ as.POSIXct x)
+ origin (*named*
+ units "days")))
+ (r-call structure res
+ (*named* origin origin))))))
+ (<- weekdays (lambda (x abbreviate)
+ (let () (r-block (r-call UseMethod "weekdays")))))
+ (<- weekdays.POSIXt (lambda (x abbreviate)
+ (let ((abbreviate ()))
+ (r-block (when (missing abbreviate)
+ (<- abbreviate
+ *r-false*))
+ (r-call format x
+ (r-call ifelse
+ abbreviate
+ "%a" "%A"))))))
+ (<- months (lambda (x abbreviate)
+ (let () (r-block (r-call UseMethod "months")))))
+ (<- months.POSIXt (lambda (x abbreviate)
+ (let ((abbreviate ()))
+ (r-block (when (missing abbreviate)
+ (<- abbreviate *r-false*))
+ (r-call format x
+ (r-call ifelse
+ abbreviate "%b"
+ "%B"))))))
+ (<- quarters (lambda (x abbreviate)
+ (let () (r-block (r-call UseMethod "quarters")))))
+ (<- quarters.POSIXt (lambda (x ...)
+ (let ((x ()))
+ (r-block (<- x (r-call %/% (r-block
+ (ref= %r:0 (r-call as.POSIXlt x)) (r-call r-aref %r:0
+ (index-in-strlist mon (r-call attr
+ %r:0 #0#))))
+ 3))
+ (r-call paste "Q"
+ (r-call + x 1)
+ (*named* sep ""))))))
+ (<- trunc.POSIXt (lambda (x units)
+ (let ((x ())
+ (units ()))
+ (r-block (when (missing units)
+ (<- units (r-call c "secs"
+ "mins" "hours" "days")))
+ (<- units (r-call match.arg
+ units))
+ (<- x (r-call as.POSIXlt x))
+ (if (r-call > (r-call length (r-call
+ r-aref x (index-in-strlist sec (r-call attr x #0#))))
+ 0)
+ (switch units (*named* secs
+ (r-block (r-block (ref= %r:16 (r-call trunc (r-call r-aref x
+ (index-in-strlist sec (r-call
+ attr x #0#)))))
+ (<- x (r-call r-aref<- x
+ (index-in-strlist sec (r-call attr x #0#))
+ %r:16))
+ %r:16)))
+ (*named* mins (r-block
+ (r-block (<- x (r-call r-aref<- x
+ (index-in-strlist sec (r-call attr x #0#)) 0))
+ 0)))
+ (*named* hours (r-block
+ (r-block (<- x (r-call r-aref<- x
+ (index-in-strlist sec (r-call attr x #0#)) 0))
+ 0)
+ (r-block (<- x (r-call r-aref<- x
+ (index-in-strlist min (r-call attr x #0#)) 0))
+ 0)))
+ (*named* days (r-block
+ (r-block (<- x (r-call r-aref<- x
+ (index-in-strlist sec (r-call attr x #0#)) 0))
+ 0)
+ (r-block (<- x (r-call r-aref<- x
+ (index-in-strlist min (r-call attr x #0#)) 0))
+ 0)
+ (r-block (<- x (r-call r-aref<- x
+ (index-in-strlist hour (r-call attr x #0#)) 0))
+ 0)
+ (r-block (ref= %r:17 (r-call - 1)) (<- x (r-call r-aref<- x
+ (index-in-strlist isdst (r-call
+ attr x #0#))
+ %r:17))
+ %r:17)))))
+ x))))
+ (<- round.POSIXt (lambda (x units)
+ (let ((x ())
+ (units ()))
+ (r-block (when (missing units)
+ (<- units (r-call c "secs"
+ "mins" "hours" "days")))
+ (if (&& (r-call is.numeric
+ units)
+ (r-call == units 0))
+ (<- units "secs"))
+ (<- units (r-call match.arg
+ units))
+ (<- x (r-call as.POSIXct x))
+ (<- x (r-call + x
+ (switch units (*named*
+ secs 0.5)
+ (*named* mins 30) (*named* hours 1800) (*named* days 43200))))
+ (r-call trunc.POSIXt x
+ (*named* units units))))))
+ (<- "[.POSIXlt" (lambda (x ... drop)
+ (let ((val ())
+ (drop ()))
+ (r-block (when (missing drop)
+ (<- drop *r-true*))
+ (<- val (r-call lapply x "["
+ r-dotdotdot (*named*
+ drop drop)))
+ (r-block (ref= %r:18 (r-call
+ attributes x))
+ (<- val (r-call
+ attributes<-
+ val %r:18))
+ %r:18)
+ val))))
+ (<- "[<-.POSIXlt" (lambda (x i value)
+ (let ((x ())
+ (cl ())
+ (value ()))
+ (r-block (if (r-call ! (r-call
+ as.logical (r-call
+ length value)))
+ (return x))
+ (<- value (r-call as.POSIXlt
+ value))
+ (<- cl (r-call oldClass x))
+ (r-block (ref= %r:19 (r-block
+ (<- value (r-call class<- value
+ ()))
+ ()))
+ (<- x (r-call class<-
+ x %r:19))
+ %r:19)
+ (for n (r-call names x)
+ (r-block (ref= %r:20 (r-call
+ r-aref value n))
+ (r-block (ref=
+ %r:21 (r-call r-index<- (r-call r-aref x n) i %r:20))
+ (<- x (r-call r-aref<- x n %r:21)) %r:21)
+ %r:20))
+ (r-block (<- x (r-call class<-
+ x cl))
+ cl)
+ x))))
+ (<- as.data.frame.POSIXlt (lambda (x row.names optional ...)
+ (let ((value ())
+ (optional ())
+ (row.names ()))
+ (r-block (when (missing
+ row.names)
+ (<- row.names ()))
+ (when (missing
+ optional)
+ (<- optional
+ *r-false*))
+ (<- value (r-call
+ as.data.frame.POSIXct
+ (r-call
+ as.POSIXct x)
+ row.names
+ optional
+ r-dotdotdot))
+ (if (r-call ! optional)
+ (r-block (ref=
+ %r:22 (r-call r-aref (r-call deparse (substitute x)) 1))
+ (<- value (r-call names<- value %r:22)) %r:22))
+ value))))
+ (<- rep.POSIXct (lambda (x ...)
+ (let ((y ()))
+ (r-block (<- y (r-call NextMethod))
+ (r-call structure y
+ (*named* class (r-call
+ c "POSIXt" "POSIXct"))
+ (*named* tzone (r-call
+ attr x "tzone")))))))
+ (<- rep.POSIXlt (lambda (x ...)
+ (let ((y ()))
+ (r-block (<- y (r-call lapply x rep
+ r-dotdotdot))
+ (r-block (ref= %r:23 (r-call
+ attributes x))
+ (<- y (r-call
+ attributes<- y
+ %r:23))
+ %r:23)
+ y))))
+ (<- diff.POSIXt (lambda (x lag differences ...)
+ (let ((i1 ())
+ (xlen ())
+ (r ())
+ (ismat ())
+ (differences ())
+ (lag ()))
+ (r-block (when (missing lag)
+ (<- lag 1))
+ (when (missing differences)
+ (<- differences 1))
+ (<- ismat (r-call is.matrix x))
+ (<- r (if (r-call inherits x "POSIXlt")
+ (r-call as.POSIXct x)
+ x))
+ (<- xlen (if ismat (r-call
+ r-index (r-call
+ dim x)
+ 1)
+ (r-call length r)))
+ (if (|\|\|| (r-call > (r-call
+ length lag)
+ 1)
+ (r-call > (r-call
+ length differences)
+ 1)
+ (r-call < lag 1)
+ (r-call <
+ differences
+ 1))
+ (r-call stop "'lag' and 'differences' must be integers >= 1"))
+ (if (r-call >= (r-call * lag
+ differences)
+ xlen)
+ (return (r-call structure (r-call
+ numeric 0)
+ (*named*
+ class "difftime")
+ (*named*
+ units "secs"))))
+ (<- i1 (r-call : (r-call - 1)
+ (r-call - lag)))
+ (if ismat (for i (r-call : 1
+ differences)
+ (<- r (r-call - (r-call
+ r-index r i1 *r-missing*
+ (*named* drop *r-false*))
+ (r-call r-index r
+ (r-call : (r-call - (r-call nrow r))
+ (r-call - (r-call + (r-call - (r-call nrow r) lag) 1)))
+ *r-missing* (*named* drop *r-false*)))))
+ (for i (r-call : 1
+ differences)
+ (<- r (r-call - (r-call
+ r-index r i1)
+ (r-call
+ r-index r
+ (r-call :
+ (r-call - (r-call length r)) (r-call - (r-call + (r-call - (r-call length r)
+ lag)
+ 1))))))))
+ r))))
+ (<- duplicated.POSIXlt (lambda (x incomparables ...)
+ (let ((x ())
+ (incomparables ()))
+ (r-block (when (missing
+ incomparables)
+ (<- incomparables
+ *r-false*))
+ (<- x (r-call as.POSIXct
+ x))
+ (r-call NextMethod "duplicated"
+ x)))))
+ (<- unique.POSIXlt (lambda (x incomparables ...)
+ (let ((incomparables ()))
+ (r-block (when (missing incomparables)
+ (<- incomparables
+ *r-false*))
+ (r-call r-index x
+ (r-call ! (r-call
+ duplicated x incomparables r-dotdotdot)))))))
+ (<- sort.POSIXlt (lambda (x decreasing na.last ...)
+ (let ((na.last ())
+ (decreasing ()))
+ (r-block (when (missing decreasing)
+ (<- decreasing *r-false*))
+ (when (missing na.last)
+ (<- na.last NA))
+ (r-call r-index x
+ (r-call order (r-call
+ as.POSIXct x)
+ (*named*
+ na.last
+ na.last)
+ (*named*
+ decreasing
+ decreasing))))))))
--- /dev/null
+++ b/tests/ast/rpasses.lsp
@@ -1,0 +1,110 @@
+; -*- scheme -*-
+(load "match.lsp")
+(load "asttools.lsp")
+
+(define missing-arg-tag '*r-missing*)
+
+; tree inspection utils
+
+(define (assigned-var e)
+ (and (pair? e)
+ (or (eq (car e) '<-) (eq (car e) 'ref=))
+ (symbol? (cadr e))
+ (cadr e)))
+
+(define (func-argnames f)
+ (let ((argl (cadr f)))
+ (if (eq argl '*r-null*) ()
+ (map cadr argl))))
+
+; transformations
+
+(let ((ctr 0))
+ (set! r-gensym (lambda ()
+ (prog1 (symbol (string "%r:" ctr))
+ (set! ctr (+ ctr 1))))))
+
+(define (dollarsign-transform e)
+ (pattern-expand
+ (pattern-lambda ($ lhs name)
+ (let* ((g (if (not (pair? lhs)) lhs (r-gensym)))
+ (n (if (symbol? name)
+ name ;(symbol->string name)
+ name))
+ (expr `(r-call
+ r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
+ (if (not (pair? lhs))
+ expr
+ `(r-block (ref= ,g ,lhs) ,expr))))
+ e))
+
+; lower r expressions of the form f(lhs,...) <- rhs
+; TODO: if there are any special forms that can be f in this expression,
+; they need to be handled separately. For example a$b can be lowered
+; to an index assignment (by dollarsign-transform), after which
+; this transform applies. I don't think there are any others though.
+(define (fancy-assignment-transform e)
+ (pattern-expand
+ (pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
+ (<<- (r-call f lhs ...) rhs))
+ (let ((g (if (pair? rhs) (r-gensym) rhs))
+ (op (car __)))
+ `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ())
+ (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
+ ,g)))
+ e))
+
+; map an arglist with default values to appropriate init code
+; function(x=blah) { ... } gets+; if (missing(x)) x = blah
+; added to its body
+(define (gen-default-inits arglist)
+ (map (lambda (arg)
+ (let ((name (cadr arg))
+ (default (caddr arg)))
+ `(when (missing ,name)
+ (<- ,name ,default))))
+ (filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) arglist)))
+
+; convert r function expressions to lambda
+(define (normalize-r-functions e)
+ (maptree-post (lambda (n)
+ (if (and (pair? n) (eq (car n) 'function))
+ `(lambda ,(func-argnames n)
+ (r-block ,@(gen-default-inits (cadr n))
+ ,@(if (and (pair? (caddr n))
+ (eq (car (caddr n)) 'r-block))
+ (cdr (caddr n))
+ (list (caddr n)))))
+ n))
+ e))
+
+(define (find-assigned-vars n)
+ (let ((vars ()))
+ (maptree-pre (lambda (s)
+ (if (not (pair? s)) s
+ (cond ((eq (car s) 'lambda) ())
+ ((eq (car s) '<-)
+ (set! vars (list-adjoin (cadr s) vars))
+ (cddr s))
+ (#t s))))
+ n)
+ vars))
+
+; introduce let based on assignment statements
+(define (letbind-locals e)
+ (maptree-post (lambda (n)
+ (if (and (pair? n) (eq (car n) 'lambda))
+ (let ((vars (find-assigned-vars (cddr n))))
+ `(lambda ,(cadr n) (let ,(map (lambda (v) (list v ()))
+ vars)
+ ,@(cddr n))))
+ n))
+ e))
+
+(define (compile-ish e)
+ (letbind-locals
+ (normalize-r-functions
+ (fancy-assignment-transform
+ (dollarsign-transform
+ (flatten-all-op && (flatten-all-op \|\| e)))))))
--- /dev/null
+++ b/tests/color.lsp
@@ -1,0 +1,89 @@
+; -*- scheme -*-
+
+; dictionaries ----------------------------------------------------------------
+(define (dict-new) ())
+
+(define (dict-extend dl key value)
+ (cond ((null? dl) (list (cons key value)))
+ ((equal? key (caar dl)) (cons (cons key value) (cdr dl)))
+ (else (cons (car dl) (dict-extend (cdr dl) key value)))))
+
+(define (dict-lookup dl key)
+ (cond ((null? dl) ())
+ ((equal? key (caar dl)) (cdar dl))
+ (else (dict-lookup (cdr dl) key))))
+
+(define (dict-keys dl) (map car dl))
+
+; graphs ----------------------------------------------------------------------
+(define (graph-empty) (dict-new))
+
+(define (graph-connect g n1 n2)
+ (dict-extend
+ (dict-extend g n2 (cons n1 (dict-lookup g n2)))
+ n1
+ (cons n2 (dict-lookup g n1))))
+
+(define (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1)))
+
+(define (graph-neighbors g n) (dict-lookup g n))
+
+(define (graph-nodes g) (dict-keys g))
+
+(define (graph-add-node g n1) (dict-extend g n1 ()))
+
+(define (graph-from-edges edge-list)
+ (if (null? edge-list)
+ (graph-empty)
+ (graph-connect (graph-from-edges (cdr edge-list))
+ (caar edge-list)
+ (cdar edge-list))))
+
+; graph coloring --------------------------------------------------------------
+(define (node-colorable? g coloring node-to-color color-of-node)
+ (not (member
+ color-of-node
+ (map
+ (lambda (n)
+ (let ((color-pair (assq n coloring)))
+ (if (pair? color-pair) (cdr color-pair) ())))
+ (graph-neighbors g node-to-color)))))
+
+(define (try-each f lst)
+ (if (null? lst) #f
+ (let ((ret (f (car lst))))
+ (if ret ret (try-each f (cdr lst))))))
+
+(define (color-node g coloring colors uncolored-nodes color)
+ (cond
+ ((null? uncolored-nodes) coloring)
+ ((node-colorable? g coloring (car uncolored-nodes) color)
+ (let ((new-coloring
+ (cons (cons (car uncolored-nodes) color) coloring)))
+ (try-each (lambda (c)
+ (color-node g new-coloring colors (cdr uncolored-nodes) c))
+ colors)))))
+
+(define (color-graph g colors)
+ (if (null? colors)
+ (and (null? (graph-nodes g)) ())
+ (color-node g () colors (graph-nodes g) (car colors))))
+
+(define (color-pairs pairs colors)
+ (color-graph (graph-from-edges pairs) colors))
+
+; queens ----------------------------------------------------------------------
+(define (can-attack x y)
+ (let ((x1 (mod x 5))
+ (y1 (truncate (/ x 5)))
+ (x2 (mod y 5))
+ (y2 (truncate (/ y 5))))
+ (or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1))))))
+
+(define (generate-5x5-pairs)
+ (let ((result ()))
+ (dotimes (x 25)
+ (dotimes (y 25)
+ (if (and (not (= x y)) (can-attack x y))
+ (set! result (cons (cons x y) result)) ())))
+ result))
--- /dev/null
+++ b/tests/equal.scm
@@ -1,0 +1,68 @@
+; Terminating equal predicate
+; by Jeff Bezanson
+;
+; This version only considers pairs and simple atoms.
+
+; equal?, with bounded recursion. returns 0 if we suspect
+; nontermination, otherwise #t or #f for the correct answer.
+(define (bounded-equal a b N)
+ (cond ((<= N 0) 0)
+ ((and (pair? a) (pair? b))
+ (let ((as
+ (bounded-equal (car a) (car b) (- N 1))))
+ (if (number? as)
+ 0
+ (and as
+ (bounded-equal (cdr a) (cdr b) (- N 1))))))
+ (else (eq? a b))))
+
+; union-find algorithm
+
+; find equivalence class of a cons cell, or #f if not yet known
+; the root of a class is a cons that is its own class
+(define (class table key)
+ (let ((c (hashtable-ref table key #f)))
+ (if (or (not c) (eq? c key))
+ c
+ (class table c))))
+
+; move a and b to the same equivalence class, given c and cb
+; as the current values of (class table a) and (class table b)
+; Note: this is not quite optimal. We blindly pick 'a' as the
+; root of the new class, but we should pick whichever class is
+; larger.
+(define (union! table a b c cb)
+ (let ((ca (if c c a)))
+ (if cb
+ (hashtable-set! table cb ca))
+ (hashtable-set! table a ca)
+ (hashtable-set! table b ca)))
+
+; cyclic equal. first, attempt to compare a and b as best
+; we can without recurring. if we can't prove them different,
+; set them equal and move on.
+(define (cyc-equal a b table)
+ (cond ((eq? a b) #t)
+ ((not (and (pair? a) (pair? b))) (eq? a b))
+ (else
+ (let ((aa (car a)) (da (cdr a))
+ (ab (car b)) (db (cdr b)))
+ (cond ((or (not (eq? (atom? aa) (atom? ab)))
+ (not (eq? (atom? da) (atom? db)))) #f)
+ ((and (atom? aa)
+ (not (eq? aa ab))) #f)
+ ((and (atom? da)
+ (not (eq? da db))) #f)
+ (else
+ (let ((ca (class table a))
+ (cb (class table b)))
+ (if (and ca cb (eq? ca cb))
+ #t
+ (begin (union! table a b ca cb)
+ (and (cyc-equal aa ab table)
+ (cyc-equal da db table)))))))))))
+
+(define (equal a b)
+ (let ((guess (bounded-equal a b 2048)))
+ (if (boolean? guess) guess
+ (cyc-equal a b (make-eq-hashtable)))))
--- /dev/null
+++ b/tests/err.lsp
@@ -1,0 +1,4 @@
+(define (f x) (begin (list-tail '(1) 3) 3))
+(f 2)
+a
+(trycatch a (lambda (e) (print (stacktrace))))
--- /dev/null
+++ b/tests/hashtest.lsp
@@ -1,0 +1,40 @@
+; -*- scheme -*-
+
+(define (hins1)
+ (let ((h (table)))
+ (dotimes (n 200000)
+ (put! h (mod (rand) 1000) 'apple))
+ h))
+
+(define (hread h)
+ (dotimes (n 200000)
+ (get h (mod (rand) 10000) nil)))
+
+(time (dotimes (i 100000)
+ (table :a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :foo 8 :bar 9)))
+(time (dotimes (i 100000) (table :a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :foo 8)))
+(time (dotimes (i 100000) (table :a 1 :b 2 :c 3 :d 4)))
+(time (dotimes (i 100000) (table :a 1 :b 2)))
+(time (dotimes (i 100000) (table)))
+
+#t
+
+#|
+
+with HT_N_INLINE==16
+Elapsed time: 0.0796329975128174 seconds
+Elapsed time: 0.0455679893493652 seconds
+Elapsed time: 0.0272290706634521 seconds
+Elapsed time: 0.0177979469299316 seconds
+Elapsed time: 0.0102229118347168 seconds
+
+
+with HT_N_INLINE==8
+
+Elapsed time: 0.1010119915008545 seconds
+Elapsed time: 0.174872875213623 seconds
+Elapsed time: 0.0322129726409912 seconds
+Elapsed time: 0.0195930004119873 seconds
+Elapsed time: 0.008836030960083 seconds
+
+|#
--- /dev/null
+++ b/tests/perf.lsp
@@ -1,0 +1,37 @@
+(load "test.lsp")
+
+(princ "colorgraph: ")
+(load "tcolor.lsp")
+
+(princ "fib(34): ")
+(assert (equal? (time (fib 34)) 5702887))
+(princ "yfib(32): ")
+(assert (equal? (time (yfib 32)) 2178309))
+
+(princ "sort: ")
+(set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
+(time (simple-sort r))
+
+(princ "expand: ")
+(time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2))))
+
+(define (my-append . lsts)
+ (cond ((null? lsts) ())
+ ((null? (cdr lsts)) (car lsts))
+ (else (letrec ((append2 (lambda (l d)
+ (if (null? l) d
+ (cons (car l)
+ (append2 (cdr l) d))))))
+ (append2 (car lsts) (apply my-append (cdr lsts)))))))
+
+(princ "append: ")
+(set! L (map-int (lambda (x) (map-int identity 20)) 20))
+(time (dotimes (n 1000) (apply my-append L)))
+
+(path.cwd "ast")
+(princ "p-lambda: ")
+(load "rpasses.lsp")
+(define *input* (load "datetimeR.lsp"))
+(time (set! *output* (compile-ish *input*)))
+(assert (equal? *output* (load "rpasses-out.lsp")))
+(path.cwd "..")
--- /dev/null
+++ b/tests/pisum.lsp
@@ -1,0 +1,8 @@
+(define (pisum)
+ (dotimes (j 500)
+ ((label sumloop
+ (lambda (i sum)
+ (if (> i 10000)
+ sum
+ (sumloop (+ i 1) (+ sum (/ (* i i)))))))
+ 1.0 0.0)))
--- /dev/null
+++ b/tests/printcases.lsp
@@ -1,0 +1,26 @@
+expand
+append
+bq-process
+
+(define (syntax-environment)
+ (map (lambda (s) (cons s (symbol-syntax s)))
+ (filter symbol-syntax (environment))))
+
+(syntax-environment)
+
+(symbol-syntax 'try)
+
+(map-int (lambda (x) `(a b c d e)) 90)
+
+(list->vector (map-int (lambda (x) `(a b c d e)) 90))
+
+'((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y))
+
+'((lambda (x y) (if (< x y) x yffffffffffffffffffff)) (a b c) (d e f) 2 3 (r t y))
+
+'((lambda (x y) (if (< x y) x y)) (a b c) (d (e zz zzz) f) 2 3 (r t y))
+
+'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))
--- /dev/null
+++ b/tests/tcolor.lsp
@@ -1,0 +1,16 @@
+; -*- scheme -*-
+; color for performance
+
+(load "color.lsp")
+
+; 100x color 5 queens
+(define Q (generate-5x5-pairs))
+(define (ct)
+ (set! C (color-pairs Q '(a b c d e)))
+ (dotimes (n 99) (color-pairs Q '(a b c d e))))
+(time (ct))
+(assert (equal? C
+ '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))))
--- /dev/null
+++ b/tests/test.lsp
@@ -1,0 +1,294 @@
+; -*- scheme -*-
+
+; make label self-evaluating, but evaluating the lambda in the process
+;(defmacro labl (name f)
+; (list list ''labl (list 'quote name) f))
+
+(define-macro (labl name f)
+ `(let (,name) (set! ,name ,f)))
+
+;(define (reverse lst)
+; ((label rev-help (lambda (lst result)
+; (if (null? lst) result
+; (rev-help (cdr lst) (cons (car lst) result)))))
+; lst ()))
+
+(define (append- . lsts)
+ ((label append-h
+ (lambda (lsts)
+ (cond ((null? lsts) ())
+ ((null? (cdr lsts)) (car lsts))
+ (#t ((label append2 (lambda (l d)
+ (if (null? l) d
+ (cons (car l)
+ (append2 (cdr l) d)))))
+ (car lsts) (append-h (cdr lsts)))))))
+ lsts))
+
+;(princ 'Hello '| | 'world! "\n")
+;(filter (lambda (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0))
+(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+;(princ (time (fib 34)) "\n")
+;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8))
+;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6)))
+;(dotimes (i 80000) (list 1 2 3 4 5))
+;(set! a (map-int identity 10000))
+;(dotimes (i 200) (rfoldl cons () a))
+
+#|
+(define-macro (dotimes var . body)
+ (let ((v (car var))
+ (cnt (cadr var)))
+ `(let ((,v 0))
+ (while (< ,v ,cnt)
+ (prog1
+ ,(cons 'begin body)
+ (set! ,v (+ ,v 1)))))))
+
+(define (map-int f n)
+ (if (<= n 0)
+ ()
+ (let ((first (cons (f 0) ())))
+ ((label map-int-
+ (lambda (acc i n)
+ (if (= i n)
+ first
+ (begin (set-cdr! acc (cons (f i) ()))
+ (map-int- (cdr acc) (+ i 1) n)))))
+ first 1 n))))
+|#
+
+(define-macro (labl name fn)
+ `((lambda (,name) (set! ,name ,fn)) ()))
+
+(define (square x) (* x x))
+(define (expt b p)
+ (cond ((= p 0) 1)
+ ((= b 0) 0)
+ ((even? p) (square (expt b (div0 p 2))))
+ (#t (* b (expt b (- p 1))))))
+
+(define (gcd a b)
+ (cond ((= a 0) b)
+ ((= b 0) a)
+ ((< a b) (gcd a (- b a)))
+ (#t (gcd b (- a b)))))
+
+; like eval-when-compile
+(define-macro (literal expr)
+ (let ((v (eval expr)))
+ (if (self-evaluating? v) v (list quote v))))
+
+(define (cardepth l)
+ (if (atom? l) 0
+ (+ 1 (cardepth (car l)))))
+
+(define (nestlist f zero n)
+ (if (<= n 0) ()
+ (cons zero (nestlist f (f zero) (- n 1)))))
+
+(define (mapl f . lsts)
+ ((label mapl-
+ (lambda (lsts)
+ (if (null? (car lsts)) ()
+ (begin (apply f lsts) (mapl- (map cdr lsts))))))
+ lsts))
+
+; test to see if a symbol begins with :
+(define (keywordp s)
+ (and (>= s '|:|) (<= s '|:~|)))
+
+; swap the cars and cdrs of every cons in a structure
+(define (swapad c)
+ (if (atom? c) c
+ (set-cdr! c (K (swapad (car c))
+ (set-car! c (swapad (cdr c)))))))
+
+(define (without x l)
+ (filter (lambda (e) (not (eq e x))) l))
+
+(define (conscount c)
+ (if (pair? c) (+ 1
+ (conscount (car c))
+ (conscount (cdr c)))
+ 0))
+
+; _ Welcome to
+; (_ _ _ |_ _ | . _ _ 2
+; | (-||||_(_)|__|_)|_)
+; ==================|==
+
+;[` _ ,_ |- | . _ 2
+;| (/_||||_()|_|_\|)
+; |
+
+(define-macro (while- test . forms)
+ `((label -loop- (lambda ()
+ (if ,test
+ (begin ,@forms
+ (-loop-))
+ ())))))
+
+; this would be a cool use of thunking to handle 'finally' clauses, but
+; this code doesn't work in the case where the user manually re-raises
+; inside a catch block. one way to handle it would be to replace all
+; their uses of 'raise' with '*_try_finally_raise_*' which calls the thunk.
+; (try expr
+; (catch (TypeError e) . exprs)
+; (catch (IOError e) . exprs)
+; (finally . exprs))
+(define-macro (try expr . forms)
+ (let ((final (f-body (cdr (or (assq 'finally forms) '(())))))
+ (body (foldr
+ ; create a function to check for and handle one exception
+ ; type, and pass off control to the next when no match
+ (lambda (catc next)
+ (let ((var (cadr (cadr catc)))
+ (extype (caadr catc))
+ (todo (f-body (cddr catc))))
+ `(lambda (,var)
+ (if (or (eq ,var ',extype)
+ (and (pair? ,var)
+ (eq (car ,var) ',extype)))
+ ,todo
+ (,next ,var)))))
+
+ ; default function; no matches so re-raise
+ '(lambda (e) (begin (*_try_finally_thunk_*) (raise e)))
+
+ ; make list of catch forms
+ (filter (lambda (f) (eq (car f) 'catch)) forms))))
+ `(let ((*_try_finally_thunk_* (lambda () ,final)))
+ (prog1 (attempt ,expr ,body)
+ (*_try_finally_thunk_*)))))
+
+(define Y
+ (lambda (f)
+ ((lambda (h)
+ (f (lambda (x) ((h h) x))))
+ (lambda (h)
+ (f (lambda (x) ((h h) x)))))))
+
+(define yfib
+ (Y (lambda (fib)
+ (lambda (n)
+ (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
+
+;(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) )))
+;(tt)
+;(tt)
+;(tt)
+
+(define-macro (accumulate-while cnd what . body)
+ (let ((acc (gensym)))
+ `(let ((,acc (list ())))
+ (cdr
+ (prog1 ,acc
+ (while ,cnd
+ (begin (set! ,acc
+ (cdr (set-cdr! ,acc (cons ,what ()))))
+ ,@body)))))))
+
+(define-macro (accumulate-for var lo hi what . body)
+ (let ((acc (gensym)))
+ `(let ((,acc (list ())))
+ (cdr
+ (prog1 ,acc
+ (for ,lo ,hi
+ (lambda (,var)
+ (begin (set! ,acc
+ (cdr (set-cdr! ,acc (cons ,what ()))))
+ ,@body))))))))
+
+(define (map-indexed f lst)
+ (if (atom? lst) lst
+ (let ((i 0))
+ (accumulate-while (pair? lst) (f (car lst) i)
+ (begin (set! lst (cdr lst))
+ (set! i (1+ i)))))))
+
+(define (string.findall haystack needle . offs)
+ (define (sub h n offs lst)
+ (let ((i (string.find h n offs)))
+ (if i
+ (sub h n (string.inc h i) (cons i lst))
+ (reverse! lst))))
+ (sub haystack needle (if (null? offs) 0 (car offs)) ()))
+
+(let ((*profiles* (table)))
+ (set! profile
+ (lambda (s)
+ (let ((f (top-level-value s)))
+ (put! *profiles* s (cons 0 0))
+ (set-top-level-value! s
+ (lambda args
+ (define tt (get *profiles* s))
+ (define count (car tt))
+ (define time (cdr tt))
+ (define t0 (time.now))
+ (define v (apply f args))
+ (set-cdr! tt (+ time (- (time.now) t0)))
+ (set-car! tt (+ count 1))
+ v)))))
+ (set! show-profiles
+ (lambda ()
+ (define pr (filter (lambda (x) (> (cadr x) 0))
+ (table.pairs *profiles*)))
+ (define width (+ 4
+ (apply max
+ (map (lambda (x)
+ (length (string x)))
+ (cons 'Function
+ (map car pr))))))
+ (princ (string.rpad "Function" width #\ )
+ "#Calls Time (seconds)")
+ (newline)
+ (princ (string.rpad "--------" width #\ )
+ "------ --------------")
+ (newline)
+ (for-each
+ (lambda (p)
+ (princ (string.rpad (string (caddr p)) width #\ )
+ (string.rpad (string (cadr p)) 11 #\ )
+ (car p))
+ (newline))
+ (simple-sort (map (lambda (l) (reverse (to-proper l)))
+ pr)))))
+ (set! clear-profiles
+ (lambda ()
+ (for-each (lambda (k)
+ (put! *profiles* k (cons 0 0)))
+ (table.keys *profiles*)))))
+
+#;(for-each profile
+ '(emit encode-byte-code const-to-idx-vec
+ index-of lookup-sym in-env? any every
+ compile-sym compile-if compile-begin
+ compile-arglist expand builtin->instruction
+ compile-app separate nconc get-defined-vars
+ compile-in compile compile-f delete-duplicates
+ map length> length= count filter append
+ lastcdr to-proper reverse reverse! list->vector
+ table.foreach list-head list-tail assq memq assoc member
+ assv memv nreconc bq-process))
+
+(define (filt1 pred lst)
+ (define (filt1- pred lst accum)
+ (if (null? lst) accum
+ (if (pred (car lst))
+ (filt1- pred (cdr lst) (cons (car lst) accum))
+ (filt1- pred (cdr lst) accum))))
+ (filt1- pred lst ()))
+
+(define (filto pred lst (accum ()))
+ (if (atom? lst) accum
+ (if (pred (car lst))
+ (filto pred (cdr lst) (cons (car lst) accum))
+ (filto pred (cdr lst) accum))))
+
+; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
+(define (pairwise? pred . args)
+ (or (null? args)
+ (let f ((a (car args)) (d (cdr args)))
+ (or (null? d)
+ (and (pred a (car d)) (f (car d) (cdr d)))))))
--- /dev/null
+++ b/tests/tme.lsp
@@ -1,0 +1,4 @@
+(let ((t (table)))
+ (time (dotimes (i 2000000)
+ (put! t (rand) (rand)))))
+#t
--- /dev/null
+++ b/tests/torture.scm
@@ -1,0 +1,24 @@
+(define ones (map (lambda (x) 1) (iota 1000000)))
+
+(write (apply + ones))
+(newline)
+
+(define (big n)
+ (if (<= n 0)
+ 0
+ `(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
+
+(define nst (big 100000))
+
+(write (eval nst))
+(newline)
+
+(define longg (cons '+ ones))
+(write (eval longg))
+(newline)
+
+(define (f x)
+ (begin (write x)
+ (newline)
+ (f (+ x 1))
+ 0))
--- /dev/null
+++ b/tests/torus.lsp
@@ -1,0 +1,48 @@
+; -*- scheme -*-
+(define (maplist f l)
+ (if (null? l) ()
+ (cons (f l) (maplist f (cdr l)))))
+
+; produce a beautiful, toroidal cons structure
+; make m copies of a CDR-circular list of length n, and connect corresponding
+; conses in CAR-circular loops
+; replace maplist 'identity' with 'copy-tree' for rapdily exploding memory use
+(define (torus m n)
+ (let* ((l (map-int identity n))
+ (g l)
+ (prev g))
+ (dotimes (i (- m 1))
+ (set! prev g)
+ (set! g (maplist identity g))
+ (set-cdr! (last-pair prev) prev))
+ (set-cdr! (last-pair g) g)
+ (let ((a l)
+ (b g))
+ (dotimes (i n)
+ (set-car! a b)
+ (set! a (cdr a))
+ (set! b (cdr b))))
+ l))
+
+(define (cyl m n)
+ (let* ((l (map-int identity n))
+ (g l))
+ (dotimes (i (- m 1))
+ (set! g (maplist identity g)))
+ (let ((a l)
+ (b g))
+ (dotimes (i n)
+ (set-car! a b)
+ (set! a (cdr a))
+ (set! b (cdr b))))
+ l))
+
+(time (begin (print (torus 100 100)) ()))
+;(time (dotimes (i 1) (load "100x100.lsp")))
+; with ltable
+; printing time: 0.415sec
+; reading time: 0.165sec
+
+; with ptrhash
+; printing time: 0.081sec
+; reading time: 0.0264sec
--- /dev/null
+++ b/tests/unittest.lsp
@@ -1,0 +1,274 @@
+; -*- scheme -*-
+(define-macro (assert-fail expr . what)
+ `(assert (trycatch (begin ,expr #f)
+ (lambda (e) ,(if (null? what) #t
+ `(eq? (car e) ',(car what)))))))
+
+(define (every-int n)
+ (list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n)
+ (int64 n) (uint64 n)))
+
+(define (every-sint n)
+ (list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n)))
+
+(define (each f l)
+ (if (atom? l) ()
+ (begin (f (car l))
+ (each f (cdr l)))))
+
+(define (each^2 f l m)
+ (each (lambda (o) (each (lambda (p) (f o p)) m)) l))
+
+(define (test-lt a b)
+ (each^2 (lambda (neg pos)
+ (begin
+ (eval `(assert (= -1 (compare ,neg ,pos))))
+ (eval `(assert (= 1 (compare ,pos ,neg))))))
+ a
+ b))
+
+(define (test-eq a b)
+ (each^2 (lambda (a b)
+ (begin
+ (eval `(assert (= 0 (compare ,a ,b))))))
+ a
+ b))
+
+(test-lt (every-sint -1) (every-int 1))
+(test-lt (every-int 0) (every-int 1))
+(test-eq (every-int 88) (every-int 88))
+(test-eq (every-sint -88) (every-sint -88))
+
+(define (test-square a)
+ (each (lambda (i) (eval `(assert (>= (* ,i ,i) 0))))
+ a))
+
+(test-square (every-sint -67))
+(test-square (every-int 3))
+(test-square (every-int 0x80000000))
+(test-square (every-sint 0x80000000))
+(test-square (every-sint -0x80000000))
+
+(assert (= (* 128 0x02000001) 0x100000080))
+
+(assert (= (/ 1) 1))
+(assert (= (/ -1) -1))
+(assert (= (/ 2.0) 0.5))
+
+(assert (= (- 4999950000 4999941999) 8001))
+
+(assert (not (eqv? 10 #\newline)))
+(assert (not (eqv? #\newline 10)))
+
+; tricky cases involving INT_MIN
+(assert (< (- #uint32(0x80000000)) 0))
+(assert (> (- #int32(0x80000000)) 0))
+(assert (< (- #uint64(0x8000000000000000)) 0))
+(assert (> (- #int64(0x8000000000000000)) 0))
+
+(assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000))))
+(assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
+ #uint64(0x8000000000000000)))
+(assert (equal? (* 2 #int64(0x4000000000000000))
+ #uint64(0x8000000000000000)))
+
+(assert (equal? (uint64 (double -123)) #uint64(0xffffffffffffff85)))
+
+(assert (equal? (string 'sym #byte(65) #wchar(945) "blah") "symA\u03B1blah"))
+
+; NaNs
+(assert (equal? +nan.0 +nan.0))
+(assert (not (= +nan.0 +nan.0)))
+(assert (not (= +nan.0 -nan.0)))
+(assert (equal? (< +nan.0 3) (> 3 +nan.0)))
+(assert (equal? (< +nan.0 (double 3)) (> (double 3) +nan.0)))
+(assert (equal? (< +nan.0 3) (> (double 3) +nan.0)))
+(assert (equal? (< +nan.0 (double 3)) (> 3 +nan.0)))
+(assert (equal? (< +nan.0 3) (< +nan.0 (double 3))))
+(assert (equal? (> +nan.0 3) (> +nan.0 (double 3))))
+(assert (equal? (< 3 +nan.0) (> +nan.0 (double 3))))
+(assert (equal? (> 3 +nan.0) (> (double 3) +nan.0)))
+(assert (not (>= +nan.0 +nan.0)))
+
+; -0.0 etc.
+(assert (not (equal? 0.0 0)))
+(assert (equal? 0.0 0.0))
+(assert (not (equal? -0.0 0.0)))
+(assert (not (equal? -0.0 0)))
+(assert (not (eqv? 0.0 0)))
+(assert (not (eqv? -0.0 0)))
+(assert (not (eqv? -0.0 0.0)))
+(assert (= 0.0 -0.0))
+
+; this crashed once
+(for 1 10 (lambda (i) 0))
+
+; failing applications
+(assert-fail ((lambda (x) x) 1 2))
+(assert-fail ((lambda (x) x)))
+(assert-fail ((lambda (x y . z) z) 1))
+(assert-fail (car 'x) type-error)
+(assert-fail gjegherqpfdf___trejif unbound-error)
+
+; long argument lists
+(assert (= (apply + (iota 100000)) 4999950000))
+(define ones (map (lambda (x) 1) (iota 80000)))
+(assert (= (eval `(if (< 2 1)
+ (+ ,@ones)
+ (+ ,@(cdr ones))))
+ 79999))
+
+(define MAX_ARGS 255)
+
+(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 1))))
+(define f (compile `(lambda ,as ,(lastcdr as))))
+(assert (equal? (apply f (iota (+ MAX_ARGS 0))) `()))
+(assert (equal? (apply f (iota (+ MAX_ARGS 1))) `(,MAX_ARGS)))
+(assert (equal? (apply f (iota (+ MAX_ARGS 2))) `(,MAX_ARGS ,(+ MAX_ARGS 1))))
+
+(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 100))))
+(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
+ ,(car (last-pair as)))))
+(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
+(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
+ (lambda () ,(car (last-pair as))))))
+(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
+
+(define as (map-int (lambda (x) (gensym)) 1000))
+(define f (compile `(lambda ,as ,(car (last-pair as)))))
+(assert (equal? (apply f (iota 1000)) 999))
+
+(define as (apply list* (map-int (lambda (x) (gensym)) 995)))
+(define f (compile `(lambda ,as ,(lastcdr as))))
+(assert (equal? (apply f (iota 994)) '()))
+(assert (equal? (apply f (iota 995)) '(994)))
+(assert (equal? (apply f (iota 1000)) '(994 995 996 997 998 999)))
+
+; optional arguments
+(assert (equal? ((lambda ((b 0)) b)) 0))
+(assert (equal? ((lambda (a (b 2)) (list a b)) 1) '(1 2)))
+(assert (equal? ((lambda (a (b 2)) (list a b)) 1 3) '(1 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1) '(1 2 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8) '(1 8 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8 9) '(1 8 9)))
+(assert (equal? ((lambda ((x 0) . r) (list x r))) '(0 ())))
+(assert (equal? ((lambda ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
+
+; keyword arguments
+(assert (keyword? kw:))
+(assert (not (keyword? 'kw)))
+(assert (not (keyword? ':)))
+(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
+ '(1 0 0 (8 4 5))))
+(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
+ '(0 2 3 (1))))
+(define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d))
+(assert (equal? (keys4 a: 10) '(10 3 7 6)))
+(assert (equal? (keys4 b: 10) '(8 10 7 6)))
+(assert (equal? (keys4 c: 10) '(8 3 10 6)))
+(assert (equal? (keys4 d: 10) '(8 3 7 10)))
+(assert-fail (keys4 e: 10)) ; unsupported keyword
+(assert-fail (keys4 a: 1 b:)) ; keyword with no argument
+
+; cvalues and arrays
+(assert (equal? (typeof "") '(array byte)))
+(assert-fail (aref #(1) 3) bounds-error)
+(define iarr (array 'int64 32 16 8 7 1))
+(assert (equal? (aref iarr 0) 32))
+(assert (equal? (aref iarr #int8(3)) 7))
+
+; gensyms
+(assert (gensym? (gensym)))
+(assert (not (gensym? 'a)))
+(assert (not (eq? (gensym) (gensym))))
+(assert (not (equal? (string (gensym)) (string (gensym)))))
+(let ((gs (gensym))) (assert (eq? gs gs)))
+
+; eof object
+(assert (eof-object? (eof-object)))
+(assert (not (eof-object? 1)))
+(assert (not (eof-object? 'a)))
+(assert (not (eof-object? '())))
+(assert (not (eof-object? #f)))
+(assert (not (null? (eof-object))))
+(assert (not (builtin? (eof-object))))
+(assert (not (function? (eof-object))))
+
+; ok, a couple end-to-end tests as well
+(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+(assert (equal? (fib 20) 6765))
+
+(load "color.lsp")
+(assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e))
+ '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))))
+
+; hashing strange things
+(assert (equal?
+ (hash '#0=(1 1 #0# . #0#))
+ (hash '#1=(1 1 #1# 1 1 #1# . #1#))))
+
+(assert (not (equal?
+ (hash '#0=(1 1 #0# . #0#))
+ (hash '#1=(1 2 #1# 1 1 #1# . #1#)))))
+
+(assert (equal?
+ (hash '#0=((1 . #0#) . #0#))
+ (hash '#1=((1 . #1#) (1 . #1#) . #1#))))
+
+(assert (not (equal?
+ (hash '#0=((1 . #0#) . #0#))
+ (hash '#1=((2 . #1#) (1 . #1#) . #1#)))))
+
+(assert (not (equal?
+ (hash '#0=((1 . #0#) . #0#))
+ (hash '#1=((1 . #1#) (2 . #1#) . #1#)))))
+
+(assert (equal?
+ (hash '(#0=(#0#) 0))
+ (hash '(#1=(((((#1#))))) 0))))
+
+(assert (not (equal?
+ (hash '(#0=(#0#) 0))
+ (hash '(#1=(((((#1#))))) 1)))))
+
+(assert (equal?
+ (hash #0=[1 [2 [#0#]] 3])
+ (hash #1=[1 [2 [[1 [2 [#1#]] 3]]] 3])))
+
+(assert (not (equal?
+ (hash #0=[1 [2 [#0#]] 3])
+ (hash #1=[1 [2 [[5 [2 [#1#]] 3]]] 3]))))
+
+(assert (equal?
+ (hash #0=[1 #0# [2 [#0#]] 3])
+ (hash #1=[1 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3])))
+
+(assert (not (equal?
+ (hash #0=[1 #0# [2 [#0#]] 3])
+ (hash #1=[6 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3]))))
+
+(assert (equal?
+ (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])
+ (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])))
+
+(assert (not (equal?
+ (hash [6 1 [2 [[3 1 [2 [1]] 3]]] 3])
+ (hash [6 1 [2 [[1 1 [2 [1]] 3]]] 3]))))
+
+(assert (equal? (hash '#0=(1 . #0#))
+ (hash '#1=(1 1 . #1#))))
+
+(assert (not (equal? (hash '#0=(1 1 . #0#))
+ (hash '#1=(1 #0# . #1#)))))
+
+(assert (not (equal? (hash (iota 10))
+ (hash (iota 20)))))
+
+(assert (not (equal? (hash (iota 41))
+ (hash (iota 42)))))
+
+(princ "all tests pass\n")
+#t
--- /dev/null
+++ b/tests/wt.lsp
@@ -1,0 +1,28 @@
+(define-macro (while- test . forms)
+ `((label -loop- (lambda ()
+ (if ,test
+ (begin ,@forms
+ (-loop-))
+ ())))))
+
+(define (tw)
+ (set! i 0)
+ (while (< i 10000000) (set! i (+ i 1))))
+
+(define (tw2)
+ (letrec ((loop (lambda ()
+ (if (< i 10000000)
+ (begin (set! i (+ i 1))
+ (loop))
+ ()))))
+ (loop)))
+
+#|
+interpreter:
+while: 1.82sec
+macro: 2.98sec
+
+compiler:
+while: 0.72sec
+macro: 1.24sec
+|#
--- /dev/null
+++ b/tiny/Makefile
@@ -1,0 +1,22 @@
+CC = gcc
+
+NAME = lisp
+SRC = $(NAME).c
+EXENAME = $(NAME)
+
+FLAGS = -Wall -Wextra
+LIBS =
+
+DEBUGFLAGS = -g -DDEBUG $(FLAGS)
+SHIPFLAGS = -O3 -fomit-frame-pointer $(FLAGS)
+
+default: release
+
+debug: $(SRC)
+ $(CC) $(DEBUGFLAGS) $(SRC) -o $(EXENAME) $(LIBS)
+
+release: $(SRC)
+ $(CC) $(SHIPFLAGS) $(SRC) -o $(EXENAME) $(LIBS)
+
+clean:
+ rm -f $(EXENAME)
--- /dev/null
+++ b/tiny/eval1
@@ -1,0 +1,390 @@
+value_t eval_sexpr(value_t e, value_t *penv)
+{+ value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
+ value_t *rest;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e)
+ return cdr_(bind);
+ v = cdr_(v);
+ }
+ if ((v = sym->binding) == UNBOUND)
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ f = eval(car_(e), penv);
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 1;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v))
+ lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ v = cdr_(v);
+ PUSH(car(v));
+ argsyms = &Stack[SP-1];
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
+ cons(argsyms, cons(body, penv)));
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v)); // name
+ pv = &Stack[SP-1];
+ PUSH(car(cdr_(v))); // function
+ body = &Stack[SP-1];
+ *body = eval(*body, penv); // evaluate lambda
+ v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v, penv) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ v = eval(v, penv);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ if ((v=eval(c->car, penv)) != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ while (iscons(*pv)) {+ v = eval(car_(*pv), penv);
+ *pv = cdr_(*pv);
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ while (iscons(*pv)) {+ if ((v=eval(car_(*pv), penv)) == NIL)
+ break;
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ if ((v=eval(car_(*pv), penv)) != NIL)
+ break;
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_WHILE:
+ PUSH(car(cdr(cdr_(Stack[saveSP]))));
+ body = &Stack[SP-1];
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL); pv = &Stack[SP-1];
+ while (eval(*cond, penv) != NIL)
+ *pv = eval(*body, penv);
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ v = eval(car_(*pv), penv);
+ *pv = cdr_(*pv);
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e) {+ cdr_(bind) = (v=Stack[SP-1]);
+ SP=saveSP; return v;
+ }
+ v = cdr_(v);
+ }
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1)
+ lerror("-: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1)
+ lerror("/: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0)
+ lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
+ v = T;
+ else
+ v = NIL;
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = eval(Stack[SP-1], &NIL);
+ break;
+ case F_PRINT:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i]);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1)
+ lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+1];
+ break;
+ case F_APPLY:
+ // unpack a list onto the stack
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ }
+ // apply lambda or macro expression
+ PUSH(cdr(cdr(cdr_(f))));
+ lenv = &Stack[SP-1];
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ PUSH(car_(cdr_(cdr_(f))));
+ body = &Stack[SP-1];
+ if (labl) {+ // add label binding to environment
+ PUSH(labl);
+ PUSH(car_(cdr_(labl)));
+ *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
+ POPN(3);
+ v = Stack[saveSP]; // refetch arglist
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ else if (headsym != LAMBDA)
+ lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (!issymbol(asym))
+ lerror("apply: error: formal argument not a symbol\n");+ v = car_(v);
+ if (!noeval) v = eval(v, penv);
+ PUSH(v);
+ *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
+ POPN(2);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ if (noeval) {+ *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
+ }
+ else {+ PUSH(NIL);
+ PUSH(NIL);
+ rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ SP = saveSP; // free temporary stack space
+ PUSH(*lenv); // preserve environment on stack
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ POP();
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO)
+ return eval(v, penv);
+ return v;
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
--- /dev/null
+++ b/tiny/eval2
@@ -1,0 +1,407 @@
+value_t eval_sexpr(value_t e, value_t *penv)
+{+ value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
+ value_t *rest;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e)
+ return cdr_(bind);
+ v = cdr_(v);
+ }
+ if ((v = sym->binding) == UNBOUND)
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ f = eval(car_(e), penv);
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 1;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v))
+ lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ v = cdr_(v);
+ PUSH(car(v));
+ argsyms = &Stack[SP-1];
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
+ cons(argsyms, cons(body, penv)));
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v)); // name
+ pv = &Stack[SP-1];
+ PUSH(car(cdr_(v))); // function
+ body = &Stack[SP-1];
+ *body = eval(*body, penv); // evaluate lambda
+ v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v, penv) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ v = eval(v, penv);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ if ((v=eval(c->car, penv)) != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ while (iscons(*pv)) {+ v = eval(car_(*pv), penv);
+ *pv = cdr_(*pv);
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ while (iscons(*pv)) {+ if ((v=eval(car_(*pv), penv)) == NIL)
+ break;
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ if ((v=eval(car_(*pv), penv)) != NIL)
+ break;
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_WHILE:
+ PUSH(car(cdr(cdr_(Stack[saveSP]))));
+ body = &Stack[SP-1];
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL); pv = &Stack[SP-1];
+ while (eval(*cond, penv) != NIL)
+ *pv = eval(*body, penv);
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ v = eval(car_(*pv), penv);
+ *pv = cdr_(*pv);
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e) {+ cdr_(bind) = (v=Stack[SP-1]);
+ SP=saveSP; return v;
+ }
+ v = cdr_(v);
+ }
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_CONSP:
+ argcount("consp", nargs, 1);+ v = (iscons(Stack[SP-1]) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1)
+ lerror("-: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1)
+ lerror("/: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0)
+ lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
+ v = T;
+ else
+ v = NIL;
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = eval(Stack[SP-1], &NIL);
+ break;
+ case F_PRINT:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 0);
+ fprintf(stdout, "\n");
+ break;
+ case F_PRINC:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 1);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_EXIT:
+ exit(0);
+ break;
+ case F_ERROR:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stderr, Stack[i], 1);
+ lerror("\n");+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1)
+ lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+1];
+ break;
+ case F_APPLY:
+ // unpack a list onto the stack
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ }
+ // apply lambda or macro expression
+ PUSH(cdr(cdr(cdr_(f))));
+ lenv = &Stack[SP-1];
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ PUSH(car_(cdr_(cdr_(f))));
+ body = &Stack[SP-1];
+ if (labl) {+ // add label binding to environment
+ PUSH(labl);
+ PUSH(car_(cdr_(labl)));
+ *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
+ POPN(3);
+ v = Stack[saveSP]; // refetch arglist
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ else if (headsym != LAMBDA)
+ lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (!issymbol(asym))
+ lerror("apply: error: formal argument not a symbol\n");+ v = car_(v);
+ if (!noeval) v = eval(v, penv);
+ PUSH(v);
+ *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
+ POPN(2);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ if (noeval) {+ *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
+ }
+ else {+ PUSH(NIL);
+ PUSH(NIL);
+ rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ SP = saveSP; // free temporary stack space
+ PUSH(*lenv); // preserve environment on stack
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ POP();
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO)
+ return eval(v, penv);
+ return v;
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
--- /dev/null
+++ b/tiny/evalt
@@ -1,0 +1,443 @@
+value_t eval_sexpr(value_t e, value_t *penv)
+{+ value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
+ value_t *rest;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ eval_top:
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e)
+ return cdr_(bind);
+ v = cdr_(v);
+ }
+ if ((v = sym->binding) == UNBOUND)
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ PUSH(*penv);
+ f = eval(car_(e), penv);
+ *penv = Stack[saveSP+1];
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ *penv = Stack[saveSP+1];
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 2;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v))
+ lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ v = cdr_(v);
+ PUSH(car(v));
+ argsyms = &Stack[SP-1];
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
+ cons(argsyms, cons(body, penv)));
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v)); // name
+ pv = &Stack[SP-1];
+ PUSH(car(cdr_(v))); // function
+ body = &Stack[SP-1];
+ *body = eval(*body, penv); // evaluate lambda
+ v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v, penv) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ tail_eval(v, Stack[saveSP+1]);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ v = eval(c->car, penv);
+ *penv = Stack[saveSP+1];
+ if (v != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv), penv);
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv), penv)) == NIL) {+ SP = saveSP; return NIL;
+ }
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv), penv)) != NIL) {+ SP = saveSP; return v;
+ }
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ case F_WHILE:
+ PUSH(car(cdr(cdr_(Stack[saveSP]))));
+ body = &Stack[SP-1];
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL); pv = &Stack[SP-1];
+ while (eval(*cond, penv) != NIL) {+ *penv = Stack[saveSP+1];
+ *pv = eval(*body, penv);
+ *penv = Stack[saveSP+1];
+ }
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv), penv);
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e) {+ cdr_(bind) = (v=Stack[SP-1]);
+ SP=saveSP; return v;
+ }
+ v = cdr_(v);
+ }
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_CONSP:
+ argcount("consp", nargs, 1);+ v = (iscons(Stack[SP-1]) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+2; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1)
+ lerror("-: error: too few arguments\n");+ i = saveSP+2;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+2; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1)
+ lerror("/: error: too few arguments\n");+ i = saveSP+2;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0)
+ lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
+ v = T;
+ else
+ v = NIL;
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = Stack[SP-1];
+ tail_eval(v, NIL);
+ break;
+ case F_PRINT:
+ for (i=saveSP+2; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 0);
+ fprintf(stdout, "\n");
+ break;
+ case F_PRINC:
+ for (i=saveSP+2; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 1);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_EXIT:
+ exit(0);
+ break;
+ case F_ERROR:
+ for (i=saveSP+2; i < (int)SP; i++)
+ print(stderr, Stack[i], 1);
+ lerror("\n");+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1)
+ lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+2];
+ break;
+ case F_APPLY:
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ // unpack arglist onto the stack
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ }
+ // apply lambda or macro expression
+ PUSH(cdr(cdr(cdr_(f))));
+ lenv = &Stack[SP-1];
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ PUSH(car_(cdr_(cdr_(f))));
+ body = &Stack[SP-1];
+ if (labl) {+ // add label binding to environment
+ PUSH(labl);
+ PUSH(car_(cdr_(labl)));
+ *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
+ POPN(3);
+ v = Stack[saveSP]; // refetch arglist
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ else if (headsym != LAMBDA)
+ lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (!issymbol(asym))
+ lerror("apply: error: formal argument not a symbol\n");+ v = car_(v);
+ if (!noeval) {+ v = eval(v, penv);
+ *penv = Stack[saveSP+1];
+ }
+ PUSH(v);
+ *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
+ POPN(2);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ if (noeval) {+ *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
+ }
+ else {+ PUSH(NIL);
+ PUSH(NIL);
+ rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ *penv = Stack[saveSP+1];
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ noeval = 0;
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO) {+ SP = saveSP;
+ PUSH(*lenv);
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ tail_eval(v, *penv);
+ }
+ else {+ tail_eval(*body, *lenv);
+ }
+ // not reached
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
--- /dev/null
+++ b/tiny/flutils.c
@@ -1,0 +1,119 @@
+u_int32_t *bitvector_resize(u_int32_t *b, size_t n)
+{+ u_int32_t *p;
+ size_t sz = ((n+31)>>5) * 4;
+ p = realloc(b, sz);
+ if (p == NULL) return NULL;
+ memset(p, 0, sz);
+ return p;
+}
+
+u_int32_t *mk_bitvector(size_t n)
+{+ return bitvector_resize(NULL, n);
+}
+
+void bitvector_set(u_int32_t *b, u_int32_t n, u_int32_t c)
+{+ if (c)
+ b[n>>5] |= (1<<(n&31));
+ else
+ b[n>>5] &= ~(1<<(n&31));
+}
+
+u_int32_t bitvector_get(u_int32_t *b, u_int32_t n)
+{+ return b[n>>5] & (1<<(n&31));
+}
+
+typedef struct {+ size_t n, maxsize;
+ unsigned long *items;
+} ltable_t;
+
+void ltable_init(ltable_t *t, size_t n)
+{+ t->n = 0;
+ t->maxsize = n;
+ t->items = (unsigned long*)malloc(n * sizeof(unsigned long));
+}
+
+void ltable_clear(ltable_t *t)
+{+ t->n = 0;
+}
+
+void ltable_insert(ltable_t *t, unsigned long item)
+{+ unsigned long *p;
+
+ if (t->n == t->maxsize) {+ p = realloc(t->items, (t->maxsize*2)*sizeof(unsigned long));
+ if (p == NULL) return;
+ t->items = p;
+ t->maxsize *= 2;
+ }
+ t->items[t->n++] = item;
+}
+
+#define NOTFOUND ((int)-1)
+
+int ltable_lookup(ltable_t *t, unsigned long item)
+{+ int i;
+ for(i=0; i < (int)t->n; i++)
+ if (t->items[i] == item)
+ return i;
+ return NOTFOUND;
+}
+
+void ltable_adjoin(ltable_t *t, unsigned long item)
+{+ if (ltable_lookup(t, item) == NOTFOUND)
+ ltable_insert(t, item);
+}
+
+static const u_int32_t offsetsFromUTF8[6] = {+ 0x00000000UL, 0x00003080UL, 0x000E2080UL,
+ 0x03C82080UL, 0xFA082080UL, 0x82082080UL
+};
+
+static const char trailingBytesForUTF8[256] = {+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5
+};
+
+int u8_seqlen(const char c)
+{+ return trailingBytesForUTF8[(unsigned int)(unsigned char)c] + 1;
+}
+
+#define UEOF ((u_int32_t)EOF)
+
+u_int32_t u8_fgetc(FILE *f)
+{+ int amt=0, sz, c;
+ u_int32_t ch=0;
+
+ c = fgetc(f);
+ if (c == EOF)
+ return UEOF;
+ ch = (u_int32_t)c;
+ amt = sz = u8_seqlen(ch);
+ while (--amt) {+ ch <<= 6;
+ c = fgetc(f);
+ if (c == EOF)
+ return UEOF;
+ ch += (u_int32_t)c;
+ }
+ ch -= offsetsFromUTF8[sz-1];
+
+ return ch;
+}
--- /dev/null
+++ b/tiny/lisp-nontail.c
@@ -1,0 +1,975 @@
+/*
+ femtoLisp
+
+ a minimal interpreter for a minimal lisp dialect
+
+ this lisp dialect uses lexical scope and self-evaluating lambda.
+ it supports 30-bit integers, symbols, conses, and full macros.
+ it is case-sensitive.
+ it features a simple compacting copying garbage collector.
+ it uses a Scheme-style evaluation rule where any expression may appear in
+ head position as long as it evaluates to a function.
+ it uses Scheme-style varargs (dotted formal argument lists)
+ lambdas can have only 1 body expression; use (progn ...) for multiple
+ expressions. this is due to the closure representation
+ (lambda args body . env)
+
+ by Jeff Bezanson
+ Public Domain
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <ctype.h>
+#include <sys/types.h>
+
+typedef u_int32_t value_t;
+typedef int32_t number_t;
+
+typedef struct {+ value_t car;
+ value_t cdr;
+} cons_t;
+
+typedef struct _symbol_t {+ value_t binding; // global value binding
+ value_t constant; // constant binding (used only for builtins)
+ struct _symbol_t *left;
+ struct _symbol_t *right;
+ char name[1];
+} symbol_t;
+
+#define TAG_NUM 0x0
+#define TAG_BUILTIN 0x1
+#define TAG_SYM 0x2
+#define TAG_CONS 0x3
+#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
+#define tag(x) ((x)&0x3)
+#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
+#define tagptr(p,t) (((value_t)(p)) | (t))
+#define number(x) ((value_t)((x)<<2))
+#define numval(x) (((number_t)(x))>>2)
+#define intval(x) (((int)(x))>>2)
+#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isnumber(x) (tag(x) == TAG_NUM)
+#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v),"car")->car)
+#define cdr(v) (tocons((v),"cdr")->cdr)
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
+
+enum {+ // special forms
+ F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
+ F_PROGN,
+ // functions
+ F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
+ F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
+ F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
+};
+#define isspecial(v) (intval(v) <= (int)F_PROGN)
+
+static char *builtin_names[] =
+ { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",+ "progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
+ "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
+ "prog1", "apply", "rplaca", "rplacd", "boundp" };
+
+static char *stack_bottom;
+#define PROCESS_STACK_SIZE (2*1024*1024)
+#define N_STACK 49152
+static value_t Stack[N_STACK];
+static u_int32_t SP = 0;
+#define PUSH(v) (Stack[SP++] = (v))
+#define POP() (Stack[--SP])
+#define POPN(n) (SP-=(n))
+
+value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
+
+value_t read_sexpr(FILE *f);
+void print(FILE *f, value_t v);
+value_t eval_sexpr(value_t e, value_t *penv);
+value_t load_file(char *fname);
+
+// error utilities ------------------------------------------------------------
+
+jmp_buf toplevel;
+
+void lerror(char *format, ...)
+{+ va_list args;
+ va_start(args, format);
+ vfprintf(stderr, format, args);
+ va_end(args);
+ longjmp(toplevel, 1);
+}
+
+void type_error(char *fname, char *expected, value_t got)
+{+ fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
+ print(stderr, got); lerror("\n");+}
+
+// safe cast operators --------------------------------------------------------
+
+#define SAFECAST_OP(type,ctype,cnvt) \
+ctype to##type(value_t v, char *fname) \
+{ \+ if (is##type(v)) \
+ return (ctype)cnvt(v); \
+ type_error(fname, #type, v); \
+ return (ctype)0; \
+}
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol,symbol_t*,ptr)
+SAFECAST_OP(number,number_t, numval)
+
+// symbol table ---------------------------------------------------------------
+
+static symbol_t *symtab = NULL;
+
+static symbol_t *mk_symbol(char *str)
+{+ symbol_t *sym;
+
+ sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
+ sym->left = sym->right = NULL;
+ sym->constant = sym->binding = UNBOUND;
+ strcpy(&sym->name[0], str);
+ return sym;
+}
+
+static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
+{+ int x;
+
+ while(*ptree != NULL) {+ x = strcmp(str, (*ptree)->name);
+ if (x == 0)
+ return ptree;
+ if (x < 0)
+ ptree = &(*ptree)->left;
+ else
+ ptree = &(*ptree)->right;
+ }
+ return ptree;
+}
+
+value_t symbol(char *str)
+{+ symbol_t **pnode;
+
+ pnode = symtab_lookup(&symtab, str);
+ if (*pnode == NULL)
+ *pnode = mk_symbol(str);
+ return tagptr(*pnode, TAG_SYM);
+}
+
+// initialization -------------------------------------------------------------
+
+static unsigned char *fromspace;
+static unsigned char *tospace;
+static unsigned char *curheap;
+static unsigned char *lim;
+static u_int32_t heapsize = 64*1024;//bytes
+
+void lisp_init(void)
+{+ int i;
+
+ fromspace = malloc(heapsize);
+ tospace = malloc(heapsize);
+ curheap = fromspace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ NIL = symbol("nil"); setc(NIL, NIL);+ T = symbol("t"); setc(T, T);+ LAMBDA = symbol("lambda");+ MACRO = symbol("macro");+ LABEL = symbol("label");+ QUOTE = symbol("quote");+ for (i=0; i < (int)N_BUILTINS; i++)
+ setc(symbol(builtin_names[i]), builtin(i));
+ setc(symbol("princ"), builtin(F_PRINT));+}
+
+// conses ---------------------------------------------------------------------
+
+void gc(void);
+
+static value_t mk_cons(void)
+{+ cons_t *c;
+
+ if (curheap > lim)
+ gc();
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+static value_t cons_(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ return c;
+}
+
+value_t *cons(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ PUSH(c);
+ return &Stack[SP-1];
+}
+
+// collector ------------------------------------------------------------------
+
+static value_t relocate(value_t v)
+{+ value_t a, d, nc;
+
+ if (!iscons(v))
+ return v;
+ if (car_(v) == UNBOUND)
+ return cdr_(v);
+ nc = mk_cons();
+ a = car_(v); d = cdr_(v);
+ car_(v) = UNBOUND; cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ cdr_(nc) = relocate(d);
+ return nc;
+}
+
+static void trace_globals(symbol_t *root)
+{+ while (root != NULL) {+ root->binding = relocate(root->binding);
+ trace_globals(root->left);
+ root = root->right;
+ }
+}
+
+void gc(void)
+{+ static int grew = 0;
+ unsigned char *temp;
+ u_int32_t i;
+
+ curheap = tospace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ for (i=0; i < SP; i++)
+ Stack[i] = relocate(Stack[i]);
+ trace_globals(symtab);
+#ifdef VERBOSEGC
+ printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);+#endif
+ temp = tospace;
+ tospace = fromspace;
+ fromspace = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if (grew || ((lim-curheap) < (int)(heapsize/5))) {+ temp = realloc(tospace, grew ? heapsize : heapsize*2);
+ if (temp == NULL)
+ lerror("out of memory\n");+ tospace = temp;
+ if (!grew)
+ heapsize*=2;
+ grew = !grew;
+ }
+ if (curheap > lim) // all data was live
+ gc();
+}
+
+// read -----------------------------------------------------------------------
+
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
+};
+
+static int symchar(char c)
+{+ static char *special = "()';\\|";
+ return (!isspace(c) && !strchr(special, c));
+}
+
+static u_int32_t toktype = TOK_NONE;
+static value_t tokval;
+static char buf[256];
+
+static char nextchar(FILE *f)
+{+ char c;
+ int ch;
+
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ c = (char)ch;
+ if (c == ';') {+ // single-line comment
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ } while ((char)ch != '\n');
+ c = (char)ch;
+ }
+ } while (isspace(c));
+ return c;
+}
+
+static void take(void)
+{+ toktype = TOK_NONE;
+}
+
+static void accumchar(char c, int *pi)
+{+ buf[(*pi)++] = c;
+ if (*pi >= (int)(sizeof(buf)-1))
+ lerror("read: error: token too long\n");+}
+
+static int read_token(FILE *f, char c)
+{+ int i=0, ch, escaped=0;
+
+ ungetc(c, f);
+ while (1) {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ c = (char)ch;
+ if (c == '|') {+ escaped = !escaped;
+ }
+ else if (c == '\\') {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ accumchar((char)ch, &i);
+ }
+ else if (!escaped && !symchar(c)) {+ break;
+ }
+ else {+ accumchar(c, &i);
+ }
+ }
+ ungetc(c, f);
+ terminate:
+ buf[i++] = '\0';
+ return i;
+}
+
+static u_int32_t peek(FILE *f)
+{+ char c, *end;
+ number_t x;
+
+ if (toktype != TOK_NONE)
+ return toktype;
+ c = nextchar(f);
+ if (feof(f)) return TOK_NONE;
+ if (c == '(') {+ toktype = TOK_OPEN;
+ }
+ else if (c == ')') {+ toktype = TOK_CLOSE;
+ }
+ else if (c == '\'') {+ toktype = TOK_QUOTE;
+ }
+ else if (isdigit(c) || c=='-') {+ read_token(f, c);
+ if (buf[0] == '-' && !isdigit(buf[1])) {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ else {+ x = strtol(buf, &end, 10);
+ if (*end != '\0')
+ lerror("read: error: invalid integer constant\n");+ toktype = TOK_NUM;
+ tokval = number(x);
+ }
+ }
+ else {+ read_token(f, c);
+ if (!strcmp(buf, ".")) {+ toktype = TOK_DOT;
+ }
+ else {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ }
+ return toktype;
+}
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void read_list(FILE *f, value_t *pval)
+{+ value_t c, *pc;
+ u_int32_t t;
+
+ PUSH(NIL);
+ pc = &Stack[SP-1]; // to keep track of current cons cell
+ t = peek(f);
+ while (t != TOK_CLOSE) {+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ c = mk_cons(); car_(c) = cdr_(c) = NIL;
+ if (iscons(*pc))
+ cdr_(*pc) = c;
+ else
+ *pval = c;
+ *pc = c;
+ c = read_sexpr(f); // must be on separate lines due to undefined
+ car_(*pc) = c; // evaluation order
+
+ t = peek(f);
+ if (t == TOK_DOT) {+ take();
+ c = read_sexpr(f);
+ cdr_(*pc) = c;
+ t = peek(f);
+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ if (t != TOK_CLOSE)
+ lerror("read: error: expected ')'\n");+ }
+ }
+ take();
+ POP();
+}
+
+value_t read_sexpr(FILE *f)
+{+ value_t v;
+
+ switch (peek(f)) {+ case TOK_CLOSE:
+ take();
+ lerror("read: error: unexpected ')'\n");+ case TOK_DOT:
+ take();
+ lerror("read: error: unexpected '.'\n");+ case TOK_SYM:
+ case TOK_NUM:
+ take();
+ return tokval;
+ case TOK_QUOTE:
+ take();
+ v = read_sexpr(f);
+ PUSH(v);
+ v = cons_("E, cons(&Stack[SP-1], &NIL));
+ POPN(2);
+ return v;
+ case TOK_OPEN:
+ take();
+ PUSH(NIL);
+ read_list(f, &Stack[SP-1]);
+ return POP();
+ }
+ return NIL;
+}
+
+// print ----------------------------------------------------------------------
+
+void print(FILE *f, value_t v)
+{+ value_t cd;
+
+ switch (tag(v)) {+ case TAG_NUM: fprintf(f, "%d", numval(v)); break;
+ case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
+ case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
+ builtin_names[intval(v)]); break;
+ case TAG_CONS:
+ fprintf(f, "(");+ while (1) {+ print(f, car_(v));
+ cd = cdr_(v);
+ if (!iscons(cd)) {+ if (cd != NIL) {+ fprintf(f, " . ");
+ print(f, cd);
+ }
+ fprintf(f, ")");
+ break;
+ }
+ fprintf(f, " ");
+ v = cd;
+ }
+ break;
+ }
+}
+
+// eval -----------------------------------------------------------------------
+
+static inline void argcount(char *fname, int nargs, int c)
+{+ if (nargs != c)
+ lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");+}
+
+#define eval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env))
+
+value_t eval_sexpr(value_t e, value_t *penv)
+{+ value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
+ value_t *rest;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e)
+ return cdr_(bind);
+ v = cdr_(v);
+ }
+ if ((v = sym->binding) == UNBOUND)
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ f = eval(car_(e), penv);
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 1;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v))
+ lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ v = cdr_(v);
+ PUSH(car(v));
+ argsyms = &Stack[SP-1];
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
+ cons(argsyms, cons(body, penv)));
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v)); // name
+ pv = &Stack[SP-1];
+ PUSH(car(cdr_(v))); // function
+ body = &Stack[SP-1];
+ *body = eval(*body, penv); // evaluate lambda
+ v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v, penv) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ v = eval(v, penv);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ if ((v=eval(c->car, penv)) != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ while (iscons(*pv)) {+ v = eval(car_(*pv), penv);
+ *pv = cdr_(*pv);
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ while (iscons(*pv)) {+ if ((v=eval(car_(*pv), penv)) == NIL)
+ break;
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ if ((v=eval(car_(*pv), penv)) != NIL)
+ break;
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_WHILE:
+ PUSH(car(cdr(cdr_(Stack[saveSP]))));
+ body = &Stack[SP-1];
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL); pv = &Stack[SP-1];
+ while (eval(*cond, penv) != NIL)
+ *pv = eval(*body, penv);
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ v = eval(car_(*pv), penv);
+ *pv = cdr_(*pv);
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e) {+ cdr_(bind) = (v=Stack[SP-1]);
+ SP=saveSP; return v;
+ }
+ v = cdr_(v);
+ }
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1)
+ lerror("-: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1)
+ lerror("/: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0)
+ lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
+ v = T;
+ else
+ v = NIL;
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = eval(Stack[SP-1], &NIL);
+ break;
+ case F_PRINT:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i]);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1)
+ lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+1];
+ break;
+ case F_APPLY:
+ // unpack a list onto the stack
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ }
+ // apply lambda or macro expression
+ PUSH(cdr(cdr(cdr_(f))));
+ lenv = &Stack[SP-1];
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ PUSH(car_(cdr_(cdr_(f))));
+ body = &Stack[SP-1];
+ if (labl) {+ // add label binding to environment
+ PUSH(labl);
+ PUSH(car_(cdr_(labl)));
+ *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
+ POPN(3);
+ v = Stack[saveSP]; // refetch arglist
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ else if (headsym != LAMBDA)
+ lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (!issymbol(asym))
+ lerror("apply: error: formal argument not a symbol\n");+ v = car_(v);
+ if (!noeval) v = eval(v, penv);
+ PUSH(v);
+ *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
+ POPN(2);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ if (noeval) {+ *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
+ }
+ else {+ PUSH(NIL);
+ PUSH(NIL);
+ rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ SP = saveSP; // free temporary stack space
+ PUSH(*lenv); // preserve environment on stack
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ POP();
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO)
+ return eval(v, penv);
+ return v;
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
+
+// repl -----------------------------------------------------------------------
+
+static char *infile = NULL;
+
+value_t load_file(char *fname)
+{+ value_t e, v=NIL;
+ char *lastfile = infile;
+ FILE *f = fopen(fname, "r");
+ infile = fname;
+ if (f == NULL) lerror("file not found\n");+ while (1) {+ e = read_sexpr(f);
+ if (feof(f)) break;
+ v = eval(e, &NIL);
+ }
+ infile = lastfile;
+ fclose(f);
+ return v;
+}
+
+int main(int argc, char* argv[])
+{+ value_t v;
+
+ stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
+ lisp_init();
+ if (setjmp(toplevel)) {+ SP = 0;
+ fprintf(stderr, "\n");
+ if (infile) {+ fprintf(stderr, "error loading file \"%s\"\n", infile);
+ infile = NULL;
+ }
+ goto repl;
+ }
+ load_file("system.lsp");+ if (argc > 1) { load_file(argv[1]); return 0; }+ printf("Welcome to femtoLisp ----------------------------------------------------------\n");+ repl:
+ while (1) {+ printf("> ");+ v = read_sexpr(stdin);
+ if (feof(stdin)) break;
+ print(stdout, v=eval(v, &NIL));
+ set(symbol("that"), v);+ printf("\n\n");+ }
+ return 0;
+}
--- /dev/null
+++ b/tiny/lisp.c
@@ -1,0 +1,1029 @@
+/*
+ femtoLisp
+
+ a minimal interpreter for a minimal lisp dialect
+
+ this lisp dialect uses lexical scope and self-evaluating lambda.
+ it supports 30-bit integers, symbols, conses, and full macros.
+ it is case-sensitive.
+ it features a simple compacting copying garbage collector.
+ it uses a Scheme-style evaluation rule where any expression may appear in
+ head position as long as it evaluates to a function.
+ it uses Scheme-style varargs (dotted formal argument lists)
+ lambdas can have only 1 body expression; use (progn ...) for multiple
+ expressions. this is due to the closure representation
+ (lambda args body . env)
+
+ by Jeff Bezanson
+ Public Domain
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <ctype.h>
+#include <sys/types.h>
+
+typedef u_int32_t value_t;
+typedef int32_t number_t;
+
+typedef struct {+ value_t car;
+ value_t cdr;
+} cons_t;
+
+typedef struct _symbol_t {+ value_t binding; // global value binding
+ value_t constant; // constant binding (used only for builtins)
+ struct _symbol_t *left;
+ struct _symbol_t *right;
+ char name[1];
+} symbol_t;
+
+#define TAG_NUM 0x0
+#define TAG_BUILTIN 0x1
+#define TAG_SYM 0x2
+#define TAG_CONS 0x3
+#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
+#define tag(x) ((x)&0x3)
+#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
+#define tagptr(p,t) (((value_t)(p)) | (t))
+#define number(x) ((value_t)((x)<<2))
+#define numval(x) (((number_t)(x))>>2)
+#define intval(x) (((int)(x))>>2)
+#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isnumber(x) (tag(x) == TAG_NUM)
+#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v),"car")->car)
+#define cdr(v) (tocons((v),"cdr")->cdr)
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
+
+enum {+ // special forms
+ F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
+ F_PROGN,
+ // functions
+ F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
+ F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
+ F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
+};
+#define isspecial(v) (intval(v) <= (int)F_PROGN)
+
+static char *builtin_names[] =
+ { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",+ "progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
+ "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
+ "prog1", "apply", "rplaca", "rplacd", "boundp" };
+
+static char *stack_bottom;
+#define PROCESS_STACK_SIZE (2*1024*1024)
+#define N_STACK 49152
+static value_t Stack[N_STACK];
+static u_int32_t SP = 0;
+#define PUSH(v) (Stack[SP++] = (v))
+#define POP() (Stack[--SP])
+#define POPN(n) (SP-=(n))
+
+value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
+
+value_t read_sexpr(FILE *f);
+void print(FILE *f, value_t v);
+value_t eval_sexpr(value_t e, value_t *penv);
+value_t load_file(char *fname);
+
+// error utilities ------------------------------------------------------------
+
+jmp_buf toplevel;
+
+void lerror(char *format, ...)
+{+ va_list args;
+ va_start(args, format);
+ vfprintf(stderr, format, args);
+ va_end(args);
+ longjmp(toplevel, 1);
+}
+
+void type_error(char *fname, char *expected, value_t got)
+{+ fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
+ print(stderr, got); lerror("\n");+}
+
+// safe cast operators --------------------------------------------------------
+
+#define SAFECAST_OP(type,ctype,cnvt) \
+ctype to##type(value_t v, char *fname) \
+{ \+ if (is##type(v)) \
+ return (ctype)cnvt(v); \
+ type_error(fname, #type, v); \
+ return (ctype)0; \
+}
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol,symbol_t*,ptr)
+SAFECAST_OP(number,number_t, numval)
+
+// symbol table ---------------------------------------------------------------
+
+static symbol_t *symtab = NULL;
+
+static symbol_t *mk_symbol(char *str)
+{+ symbol_t *sym;
+
+ sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
+ sym->left = sym->right = NULL;
+ sym->constant = sym->binding = UNBOUND;
+ strcpy(&sym->name[0], str);
+ return sym;
+}
+
+static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
+{+ int x;
+
+ while(*ptree != NULL) {+ x = strcmp(str, (*ptree)->name);
+ if (x == 0)
+ return ptree;
+ if (x < 0)
+ ptree = &(*ptree)->left;
+ else
+ ptree = &(*ptree)->right;
+ }
+ return ptree;
+}
+
+value_t symbol(char *str)
+{+ symbol_t **pnode;
+
+ pnode = symtab_lookup(&symtab, str);
+ if (*pnode == NULL)
+ *pnode = mk_symbol(str);
+ return tagptr(*pnode, TAG_SYM);
+}
+
+// initialization -------------------------------------------------------------
+
+static unsigned char *fromspace;
+static unsigned char *tospace;
+static unsigned char *curheap;
+static unsigned char *lim;
+static u_int32_t heapsize = 64*1024;//bytes
+
+void lisp_init(void)
+{+ int i;
+
+ fromspace = malloc(heapsize);
+ tospace = malloc(heapsize);
+ curheap = fromspace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ NIL = symbol("nil"); setc(NIL, NIL);+ T = symbol("t"); setc(T, T);+ LAMBDA = symbol("lambda");+ MACRO = symbol("macro");+ LABEL = symbol("label");+ QUOTE = symbol("quote");+ for (i=0; i < (int)N_BUILTINS; i++)
+ setc(symbol(builtin_names[i]), builtin(i));
+ setc(symbol("princ"), builtin(F_PRINT));+}
+
+// conses ---------------------------------------------------------------------
+
+void gc(void);
+
+static value_t mk_cons(void)
+{+ cons_t *c;
+
+ if (curheap > lim)
+ gc();
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+static value_t cons_(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ return c;
+}
+
+value_t *cons(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ PUSH(c);
+ return &Stack[SP-1];
+}
+
+// collector ------------------------------------------------------------------
+
+static value_t relocate(value_t v)
+{+ value_t a, d, nc;
+
+ if (!iscons(v))
+ return v;
+ if (car_(v) == UNBOUND)
+ return cdr_(v);
+ nc = mk_cons();
+ a = car_(v); d = cdr_(v);
+ car_(v) = UNBOUND; cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ cdr_(nc) = relocate(d);
+ return nc;
+}
+
+static void trace_globals(symbol_t *root)
+{+ while (root != NULL) {+ root->binding = relocate(root->binding);
+ trace_globals(root->left);
+ root = root->right;
+ }
+}
+
+void gc(void)
+{+ static int grew = 0;
+ unsigned char *temp;
+ u_int32_t i;
+
+ curheap = tospace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ for (i=0; i < SP; i++)
+ Stack[i] = relocate(Stack[i]);
+ trace_globals(symtab);
+#ifdef VERBOSEGC
+ printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);+#endif
+ temp = tospace;
+ tospace = fromspace;
+ fromspace = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if (grew || ((lim-curheap) < (int)(heapsize/5))) {+ temp = realloc(tospace, grew ? heapsize : heapsize*2);
+ if (temp == NULL)
+ lerror("out of memory\n");+ tospace = temp;
+ if (!grew)
+ heapsize*=2;
+ grew = !grew;
+ }
+ if (curheap > lim) // all data was live
+ gc();
+}
+
+// read -----------------------------------------------------------------------
+
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
+};
+
+static int symchar(char c)
+{+ static char *special = "()';\\|";
+ return (!isspace(c) && !strchr(special, c));
+}
+
+static u_int32_t toktype = TOK_NONE;
+static value_t tokval;
+static char buf[256];
+
+static char nextchar(FILE *f)
+{+ char c;
+ int ch;
+
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ c = (char)ch;
+ if (c == ';') {+ // single-line comment
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ } while ((char)ch != '\n');
+ c = (char)ch;
+ }
+ } while (isspace(c));
+ return c;
+}
+
+static void take(void)
+{+ toktype = TOK_NONE;
+}
+
+static void accumchar(char c, int *pi)
+{+ buf[(*pi)++] = c;
+ if (*pi >= (int)(sizeof(buf)-1))
+ lerror("read: error: token too long\n");+}
+
+// return: 1 for dot token, 0 for symbol
+static int read_token(FILE *f, char c)
+{+ int i=0, ch, escaped=0, dot=(c=='.'), totread=0;
+
+ ungetc(c, f);
+ while (1) {+ ch = fgetc(f); totread++;
+ if (ch == EOF)
+ goto terminate;
+ c = (char)ch;
+ if (c == '|') {+ escaped = !escaped;
+ }
+ else if (c == '\\') {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ accumchar((char)ch, &i);
+ }
+ else if (!escaped && !symchar(c)) {+ break;
+ }
+ else {+ accumchar(c, &i);
+ }
+ }
+ ungetc(c, f);
+ terminate:
+ buf[i++] = '\0';
+ return (dot && (totread==2));
+}
+
+static u_int32_t peek(FILE *f)
+{+ char c, *end;
+ number_t x;
+
+ if (toktype != TOK_NONE)
+ return toktype;
+ c = nextchar(f);
+ if (feof(f)) return TOK_NONE;
+ if (c == '(') {+ toktype = TOK_OPEN;
+ }
+ else if (c == ')') {+ toktype = TOK_CLOSE;
+ }
+ else if (c == '\'') {+ toktype = TOK_QUOTE;
+ }
+ else if (isdigit(c) || c=='-' || c=='+') {+ read_token(f, c);
+ x = strtol(buf, &end, 0);
+ if (*end != '\0') {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ else {+ toktype = TOK_NUM;
+ tokval = number(x);
+ }
+ }
+ else {+ if (read_token(f, c)) {+ toktype = TOK_DOT;
+ }
+ else {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ }
+ return toktype;
+}
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void read_list(FILE *f, value_t *pval)
+{+ value_t c, *pc;
+ u_int32_t t;
+
+ PUSH(NIL);
+ pc = &Stack[SP-1]; // to keep track of current cons cell
+ t = peek(f);
+ while (t != TOK_CLOSE) {+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ c = mk_cons(); car_(c) = cdr_(c) = NIL;
+ if (iscons(*pc))
+ cdr_(*pc) = c;
+ else
+ *pval = c;
+ *pc = c;
+ c = read_sexpr(f); // must be on separate lines due to undefined
+ car_(*pc) = c; // evaluation order
+
+ t = peek(f);
+ if (t == TOK_DOT) {+ take();
+ c = read_sexpr(f);
+ cdr_(*pc) = c;
+ t = peek(f);
+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ if (t != TOK_CLOSE)
+ lerror("read: error: expected ')'\n");+ }
+ }
+ take();
+ POP();
+}
+
+value_t read_sexpr(FILE *f)
+{+ value_t v;
+
+ switch (peek(f)) {+ case TOK_CLOSE:
+ take();
+ lerror("read: error: unexpected ')'\n");+ case TOK_DOT:
+ take();
+ lerror("read: error: unexpected '.'\n");+ case TOK_SYM:
+ case TOK_NUM:
+ take();
+ return tokval;
+ case TOK_QUOTE:
+ take();
+ v = read_sexpr(f);
+ PUSH(v);
+ v = cons_("E, cons(&Stack[SP-1], &NIL));
+ POPN(2);
+ return v;
+ case TOK_OPEN:
+ take();
+ PUSH(NIL);
+ read_list(f, &Stack[SP-1]);
+ return POP();
+ }
+ return NIL;
+}
+
+// print ----------------------------------------------------------------------
+
+void print(FILE *f, value_t v)
+{+ value_t cd;
+
+ switch (tag(v)) {+ case TAG_NUM: fprintf(f, "%d", numval(v)); break;
+ case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
+ case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
+ builtin_names[intval(v)]); break;
+ case TAG_CONS:
+ fprintf(f, "(");+ while (1) {+ print(f, car_(v));
+ cd = cdr_(v);
+ if (!iscons(cd)) {+ if (cd != NIL) {+ fprintf(f, " . ");
+ print(f, cd);
+ }
+ fprintf(f, ")");
+ break;
+ }
+ fprintf(f, " ");
+ v = cd;
+ }
+ break;
+ }
+}
+
+// eval -----------------------------------------------------------------------
+
+static inline void argcount(char *fname, int nargs, int c)
+{+ if (nargs != c)
+ lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");+}
+
+#define eval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env))
+#define tail_eval(xpr, env) do { SP = saveSP; \+ if (tag(xpr)<0x2) { return (xpr); } \+ else { e=(xpr); *penv=(env); goto eval_top; } } while (0)+
+value_t eval_sexpr(value_t e, value_t *penv)
+{+ value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
+ value_t *rest;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ eval_top:
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e)
+ return cdr_(bind);
+ v = cdr_(v);
+ }
+ if ((v = sym->binding) == UNBOUND)
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ PUSH(*penv);
+ f = eval(car_(e), penv);
+ *penv = Stack[saveSP+1];
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ *penv = Stack[saveSP+1];
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 2;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v))
+ lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ v = cdr_(v);
+ PUSH(car(v));
+ argsyms = &Stack[SP-1];
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
+ cons(argsyms, cons(body, penv)));
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v)); // name
+ pv = &Stack[SP-1];
+ PUSH(car(cdr_(v))); // function
+ body = &Stack[SP-1];
+ *body = eval(*body, penv); // evaluate lambda
+ v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v, penv) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ tail_eval(v, Stack[saveSP+1]);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ v = eval(c->car, penv);
+ *penv = Stack[saveSP+1];
+ if (v != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv), penv);
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv), penv)) == NIL) {+ SP = saveSP; return NIL;
+ }
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv), penv)) != NIL) {+ SP = saveSP; return v;
+ }
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ case F_WHILE:
+ PUSH(cdr(cdr_(Stack[saveSP])));
+ body = &Stack[SP-1];
+ PUSH(*body);
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL);
+ pv = &Stack[SP-1];
+ while (eval(*cond, penv) != NIL) {+ *penv = Stack[saveSP+1];
+ *body = Stack[SP-2];
+ while (iscons(*body)) {+ *pv = eval(car_(*body), penv);
+ *penv = Stack[saveSP+1];
+ *body = cdr_(*body);
+ }
+ }
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv), penv);
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e) {+ cdr_(bind) = (v=Stack[SP-1]);
+ SP=saveSP; return v;
+ }
+ v = cdr_(v);
+ }
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ sym = tosymbol(Stack[SP-1], "boundp");
+ if (sym->binding == UNBOUND && sym->constant == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+2; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1)
+ lerror("-: error: too few arguments\n");+ i = saveSP+2;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+2; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1)
+ lerror("/: error: too few arguments\n");+ i = saveSP+2;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0)
+ lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
+ v = T;
+ else
+ v = NIL;
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = Stack[SP-1];
+ tail_eval(v, NIL);
+ break;
+ case F_PRINT:
+ for (i=saveSP+2; i < (int)SP; i++)
+ print(stdout, v=Stack[i]);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1)
+ lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+2];
+ break;
+ case F_APPLY:
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ // unpack arglist onto the stack
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ }
+ // apply lambda or macro expression
+ PUSH(cdr(cdr(cdr_(f))));
+ lenv = &Stack[SP-1];
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ PUSH(car_(cdr_(cdr_(f))));
+ body = &Stack[SP-1];
+ if (labl) {+ // add label binding to environment
+ PUSH(labl);
+ PUSH(car_(cdr_(labl)));
+ *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
+ POPN(3);
+ v = Stack[saveSP]; // refetch arglist
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ else if (headsym != LAMBDA)
+ lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (!issymbol(asym))
+ lerror("apply: error: formal argument not a symbol\n");+ v = car_(v);
+ if (!noeval) {+ v = eval(v, penv);
+ *penv = Stack[saveSP+1];
+ }
+ PUSH(v);
+ *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
+ POPN(2);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ if (noeval) {+ *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
+ }
+ else {+ PUSH(NIL);
+ PUSH(NIL);
+ rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ *penv = Stack[saveSP+1];
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ noeval = 0;
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO) {+ SP = saveSP;
+ PUSH(*lenv);
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ tail_eval(v, *penv);
+ }
+ else {+ tail_eval(*body, *lenv);
+ }
+ // not reached
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
+
+// repl -----------------------------------------------------------------------
+
+static char *infile = NULL;
+
+value_t toplevel_eval(value_t expr)
+{+ value_t v;
+ u_int32_t saveSP = SP;
+ PUSH(NIL);
+ v = eval(expr, &Stack[SP-1]);
+ SP = saveSP;
+ return v;
+}
+
+value_t load_file(char *fname)
+{+ value_t e, v=NIL;
+ char *lastfile = infile;
+ FILE *f = fopen(fname, "r");
+ infile = fname;
+ if (f == NULL) lerror("file not found\n");+ while (1) {+ e = read_sexpr(f);
+ if (feof(f)) break;
+ v = toplevel_eval(e);
+ }
+ infile = lastfile;
+ fclose(f);
+ return v;
+}
+
+int main(int argc, char* argv[])
+{+ value_t v;
+
+ stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
+ lisp_init();
+ if (setjmp(toplevel)) {+ SP = 0;
+ fprintf(stderr, "\n");
+ if (infile) {+ fprintf(stderr, "error loading file \"%s\"\n", infile);
+ infile = NULL;
+ }
+ goto repl;
+ }
+ load_file("system.lsp");+ if (argc > 1) { load_file(argv[1]); return 0; }+ printf("Welcome to femtoLisp ----------------------------------------------------------\n");+ repl:
+ while (1) {+ printf("> ");+ v = read_sexpr(stdin);
+ if (feof(stdin)) break;
+ print(stdout, v=toplevel_eval(v));
+ set(symbol("that"), v);+ printf("\n\n");+ }
+ return 0;
+}
--- /dev/null
+++ b/tiny/lisp2.c
@@ -1,0 +1,1434 @@
+/*
+ femtoLisp
+
+ a minimal interpreter for a minimal lisp dialect
+
+ this lisp dialect uses lexical scope and self-evaluating lambda.
+ it supports 30-bit integers, symbols, conses, and full macros.
+ it is case-sensitive.
+ it features a simple compacting copying garbage collector.
+ it uses a Scheme-style evaluation rule where any expression may appear in
+ head position as long as it evaluates to a function.
+ it uses Scheme-style varargs (dotted formal argument lists)
+ lambdas can have only 1 body expression; use (progn ...) for multiple
+ expressions. this is due to the closure representation
+ (lambda args body . env)
+
+ This is a fork of femtoLisp with advanced reading and printing facilities:
+ * circular structure can be printed and read
+ * #. read macro for eval-when-read and correctly printing builtins
+ * read macros for backquote
+ * symbol character-escaping printer
+
+ * new print algorithm
+ 1. traverse & tag all conses to be printed. when you encounter a cons
+ that is already tagged, add it to a table to give it a #n# index
+ 2. untag a cons when printing it. if cons is in the table, print
+ "#n=" before it in the car, " . #n=" in the cdr. if cons is in the
+ table but already untagged, print #n# in car or " . #n#" in the cdr.
+ * read macros for #n# and #n= using the same kind of table
+ * also need a table of read labels to translate from input indexes to
+ normalized indexes (0 for first label, 1 for next, etc.)
+ * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq"
+
+ The value of this extra complexity, and what makes this fork worthy of
+ the femtoLisp brand, is that the interpreter is fully "closed" in the
+ sense that all representable values can be read and printed.
+
+ by Jeff Bezanson
+ Public Domain
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <ctype.h>
+#include <sys/types.h>
+
+typedef u_int32_t value_t;
+typedef int32_t number_t;
+
+typedef struct {+ value_t car;
+ value_t cdr;
+} cons_t;
+
+typedef struct _symbol_t {+ value_t binding; // global value binding
+ value_t constant; // constant binding (used only for builtins)
+ struct _symbol_t *left;
+ struct _symbol_t *right;
+ char name[1];
+} symbol_t;
+
+#define TAG_NUM 0x0
+#define TAG_BUILTIN 0x1
+#define TAG_SYM 0x2
+#define TAG_CONS 0x3
+#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
+#define tag(x) ((x)&0x3)
+#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
+#define tagptr(p,t) (((value_t)(p)) | (t))
+#define number(x) ((value_t)((x)<<2))
+#define numval(x) (((number_t)(x))>>2)
+#define intval(x) (((int)(x))>>2)
+#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isnumber(x) (tag(x) == TAG_NUM)
+#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v),"car")->car)
+#define cdr(v) (tocons((v),"cdr")->cdr)
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
+
+enum {+ // special forms
+ F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
+ F_PROGN,
+ // functions
+ F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
+ F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
+ F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, F_ERROR, F_EXIT, F_PRINC, F_CONSP,
+ F_ASSOC, N_BUILTINS
+};
+#define isspecial(v) (intval(v) <= (number_t)F_PROGN)
+
+static char *builtin_names[] =
+ { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",+ "progn",
+ "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
+ "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
+ "prog1", "apply", "rplaca", "rplacd", "boundp", "error", "exit", "princ",
+ "consp", "assoc" };
+
+static char *stack_bottom;
+#define PROCESS_STACK_SIZE (2*1024*1024)
+#define N_STACK 98304
+static value_t Stack[N_STACK];
+static u_int32_t SP = 0;
+#define PUSH(v) (Stack[SP++] = (v))
+#define POP() (Stack[--SP])
+#define POPN(n) (SP-=(n))
+
+value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
+value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
+
+value_t read_sexpr(FILE *f);
+void print(FILE *f, value_t v, int princ);
+value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend);
+value_t load_file(char *fname);
+value_t toplevel_eval(value_t expr);
+
+#include "flutils.c"
+
+typedef struct _readstate_t {+ ltable_t labels;
+ ltable_t exprs;
+ struct _readstate_t *prev;
+} readstate_t;
+static readstate_t *readstate = NULL;
+
+// error utilities ------------------------------------------------------------
+
+jmp_buf toplevel;
+
+void lerror(char *format, ...)
+{+ va_list args;
+ va_start(args, format);
+
+ while (readstate) {+ free(readstate->labels.items);
+ free(readstate->exprs.items);
+ readstate = readstate->prev;
+ }
+
+ vfprintf(stderr, format, args);
+ va_end(args);
+ longjmp(toplevel, 1);
+}
+
+void type_error(char *fname, char *expected, value_t got)
+{+ fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
+ print(stderr, got, 0); lerror("\n");+}
+
+// safe cast operators --------------------------------------------------------
+
+#define SAFECAST_OP(type,ctype,cnvt) \
+ctype to##type(value_t v, char *fname) \
+{ \+ if (is##type(v)) \
+ return (ctype)cnvt(v); \
+ type_error(fname, #type, v); \
+ return (ctype)0; \
+}
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol,symbol_t*,ptr)
+SAFECAST_OP(number,number_t, numval)
+
+// symbol table ---------------------------------------------------------------
+
+static symbol_t *symtab = NULL;
+
+static symbol_t *mk_symbol(char *str)
+{+ symbol_t *sym;
+
+ sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
+ sym->left = sym->right = NULL;
+ sym->constant = sym->binding = UNBOUND;
+ strcpy(&sym->name[0], str);
+ return sym;
+}
+
+static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
+{+ int x;
+
+ while(*ptree != NULL) {+ x = strcmp(str, (*ptree)->name);
+ if (x == 0)
+ return ptree;
+ if (x < 0)
+ ptree = &(*ptree)->left;
+ else
+ ptree = &(*ptree)->right;
+ }
+ return ptree;
+}
+
+value_t symbol(char *str)
+{+ symbol_t **pnode;
+
+ pnode = symtab_lookup(&symtab, str);
+ if (*pnode == NULL)
+ *pnode = mk_symbol(str);
+ return tagptr(*pnode, TAG_SYM);
+}
+
+// initialization -------------------------------------------------------------
+
+static unsigned char *fromspace;
+static unsigned char *tospace;
+static unsigned char *curheap;
+static unsigned char *lim;
+static u_int32_t heapsize = 128*1024;//bytes
+static u_int32_t *consflags;
+static ltable_t printconses;
+
+void lisp_init(void)
+{+ int i;
+
+ fromspace = malloc(heapsize);
+ tospace = malloc(heapsize);
+ curheap = fromspace;
+ lim = curheap+heapsize-sizeof(cons_t);
+ consflags = mk_bitvector(heapsize/sizeof(cons_t));
+
+ ltable_init(&printconses, 32);
+
+ NIL = symbol("nil"); setc(NIL, NIL);+ T = symbol("t"); setc(T, T);+ LAMBDA = symbol("lambda");+ MACRO = symbol("macro");+ LABEL = symbol("label");+ QUOTE = symbol("quote");+ BACKQUOTE = symbol("backquote");+ COMMA = symbol("*comma*");+ COMMAAT = symbol("*comma-at*");+ COMMADOT = symbol("*comma-dot*");+ for (i=0; i < (int)N_BUILTINS; i++)
+ setc(symbol(builtin_names[i]), builtin(i));
+}
+
+// conses ---------------------------------------------------------------------
+
+void gc(int mustgrow);
+
+static value_t mk_cons(void)
+{+ cons_t *c;
+
+ if (curheap > lim)
+ gc(0);
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+// allocate n consecutive conses
+static value_t cons_reserve(int n)
+{+ cons_t *first;
+
+ n--;
+ if ((cons_t*)curheap > ((cons_t*)lim)-n) {+ gc(0);
+ while ((cons_t*)curheap > ((cons_t*)lim)-n) {+ gc(1);
+ }
+ }
+ first = (cons_t*)curheap;
+ curheap += ((n+1)*sizeof(cons_t));
+ return tagptr(first, TAG_CONS);
+}
+
+#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace))
+#define ismarked(c) bitvector_get(consflags, cons_index(c))
+#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
+#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
+
+// collector ------------------------------------------------------------------
+
+static value_t relocate(value_t v)
+{+ value_t a, d, nc, first, *pcdr;
+
+ if (!iscons(v))
+ return v;
+ // iterative implementation allows arbitrarily long cons chains
+ pcdr = &first;
+ do {+ if ((a=car_(v)) == UNBOUND) {+ *pcdr = cdr_(v);
+ return first;
+ }
+ *pcdr = nc = mk_cons();
+ d = cdr_(v);
+ car_(v) = UNBOUND; cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ pcdr = &cdr_(nc);
+ v = d;
+ } while (iscons(v));
+ *pcdr = d;
+
+ return first;
+}
+
+static void trace_globals(symbol_t *root)
+{+ while (root != NULL) {+ root->binding = relocate(root->binding);
+ trace_globals(root->left);
+ root = root->right;
+ }
+}
+
+void gc(int mustgrow)
+{+ static int grew = 0;
+ void *temp;
+ u_int32_t i;
+ readstate_t *rs;
+
+ curheap = tospace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ for (i=0; i < SP; i++)
+ Stack[i] = relocate(Stack[i]);
+ trace_globals(symtab);
+ rs = readstate;
+ while (rs) {+ for(i=0; i < rs->exprs.n; i++)
+ rs->exprs.items[i] = relocate(rs->exprs.items[i]);
+ rs = rs->prev;
+ }
+#ifdef VERBOSEGC
+ printf("gc found %d/%d live conses\n",+ (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t));
+#endif
+ temp = tospace;
+ tospace = fromspace;
+ fromspace = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {+ temp = realloc(tospace, grew ? heapsize : heapsize*2);
+ if (temp == NULL)
+ lerror("out of memory\n");+ tospace = temp;
+ if (!grew) {+ heapsize*=2;
+ }
+ else {+ temp = bitvector_resize(consflags, heapsize/sizeof(cons_t));
+ if (temp == NULL)
+ lerror("out of memory\n");+ consflags = (u_int32_t*)temp;
+ }
+ grew = !grew;
+ }
+ if (curheap > lim) // all data was live
+ gc(0);
+}
+
+// read -----------------------------------------------------------------------
+
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
+ TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
+ TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE
+};
+
+// defines which characters are ordinary symbol characters.
+// the only exception is '.', which is an ordinary symbol character
+// unless it is the only character in the symbol.
+static int symchar(char c)
+{+ static char *special = "()';`,\\|";
+ return (!isspace(c) && !strchr(special, c));
+}
+
+static u_int32_t toktype = TOK_NONE;
+static value_t tokval;
+static char buf[256];
+
+static char nextchar(FILE *f)
+{+ int ch;
+ char c;
+
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ c = (char)ch;
+ if (c == ';') {+ // single-line comment
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ } while ((char)ch != '\n');
+ c = (char)ch;
+ }
+ } while (isspace(c));
+ return c;
+}
+
+static void take(void)
+{+ toktype = TOK_NONE;
+}
+
+static void accumchar(char c, int *pi)
+{+ buf[(*pi)++] = c;
+ if (*pi >= (int)(sizeof(buf)-1))
+ lerror("read: error: token too long\n");+}
+
+// return: 1 for dot token, 0 for symbol
+static int read_token(FILE *f, char c, int digits)
+{+ int i=0, ch, escaped=0, dot=(c=='.'), totread=0;
+
+ ungetc(c, f);
+ while (1) {+ ch = fgetc(f); totread++;
+ if (ch == EOF)
+ goto terminate;
+ c = (char)ch;
+ if (c == '|') {+ escaped = !escaped;
+ }
+ else if (c == '\\') {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ accumchar((char)ch, &i);
+ }
+ else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {+ break;
+ }
+ else {+ accumchar(c, &i);
+ }
+ }
+ ungetc(c, f);
+ terminate:
+ buf[i++] = '\0';
+ return (dot && (totread==2));
+}
+
+static u_int32_t peek(FILE *f)
+{+ char c, *end;
+ number_t x;
+ int ch;
+
+ if (toktype != TOK_NONE)
+ return toktype;
+ c = nextchar(f);
+ if (feof(f)) return TOK_NONE;
+ if (c == '(') {+ toktype = TOK_OPEN;
+ }
+ else if (c == ')') {+ toktype = TOK_CLOSE;
+ }
+ else if (c == '\'') {+ toktype = TOK_QUOTE;
+ }
+ else if (c == '`') {+ toktype = TOK_BQ;
+ }
+ else if (c == '#') {+ ch = fgetc(f);
+ if (ch == EOF)
+ lerror("read: error: invalid read macro\n");+ if ((char)ch == '.') {+ toktype = TOK_SHARPDOT;
+ }
+ else if ((char)ch == '\'') {+ toktype = TOK_SHARPQUOTE;
+ }
+ else if ((char)ch == '\\') {+ u_int32_t cval = u8_fgetc(f);
+ toktype = TOK_NUM;
+ tokval = number(cval);
+ }
+ else if (isdigit((char)ch)) {+ read_token(f, (char)ch, 1);
+ c = (char)fgetc(f);
+ if (c == '#')
+ toktype = TOK_BACKREF;
+ else if (c == '=')
+ toktype = TOK_LABEL;
+ else
+ lerror("read: error: invalid label\n");+ x = strtol(buf, &end, 10);
+ tokval = number(x);
+ }
+ else {+ lerror("read: error: unknown read macro\n");+ }
+ }
+ else if (c == ',') {+ toktype = TOK_COMMA;
+ ch = fgetc(f);
+ if (ch == EOF)
+ return toktype;
+ if ((char)ch == '@')
+ toktype = TOK_COMMAAT;
+ else if ((char)ch == '.')
+ toktype = TOK_COMMADOT;
+ else
+ ungetc((char)ch, f);
+ }
+ else if (isdigit(c) || c=='-' || c=='+') {+ read_token(f, c, 0);
+ x = strtol(buf, &end, 0);
+ if (*end != '\0') {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ else {+ toktype = TOK_NUM;
+ tokval = number(x);
+ }
+ }
+ else {+ if (read_token(f, c, 0)) {+ toktype = TOK_DOT;
+ }
+ else {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ }
+ return toktype;
+}
+
+static value_t do_read_sexpr(FILE *f, int fixup);
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void read_list(FILE *f, value_t *pval, int fixup)
+{+ value_t c, *pc;
+ u_int32_t t;
+
+ PUSH(NIL);
+ pc = &Stack[SP-1]; // to keep track of current cons cell
+ t = peek(f);
+ while (t != TOK_CLOSE) {+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ c = mk_cons(); car_(c) = cdr_(c) = NIL;
+ if (iscons(*pc)) {+ cdr_(*pc) = c;
+ }
+ else {+ *pval = c;
+ if (fixup != -1)
+ readstate->exprs.items[fixup] = c;
+ }
+ *pc = c;
+ c = do_read_sexpr(f,-1); // must be on separate lines due to undefined
+ car_(*pc) = c; // evaluation order
+
+ t = peek(f);
+ if (t == TOK_DOT) {+ take();
+ c = do_read_sexpr(f,-1);
+ cdr_(*pc) = c;
+ t = peek(f);
+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ if (t != TOK_CLOSE)
+ lerror("read: error: expected ')'\n");+ }
+ }
+ take();
+ POP();
+}
+
+// fixup is the index of the label we'd like to fix up with this read
+static value_t do_read_sexpr(FILE *f, int fixup)
+{+ value_t v, *head;
+ u_int32_t t, l;
+ int i;
+
+ t = peek(f);
+ take();
+ switch (t) {+ case TOK_CLOSE:
+ lerror("read: error: unexpected ')'\n");+ case TOK_DOT:
+ lerror("read: error: unexpected '.'\n");+ case TOK_SYM:
+ case TOK_NUM:
+ return tokval;
+ case TOK_COMMA:
+ head = &COMMA; goto listwith;
+ case TOK_COMMAAT:
+ head = &COMMAAT; goto listwith;
+ case TOK_COMMADOT:
+ head = &COMMADOT; goto listwith;
+ case TOK_BQ:
+ head = &BACKQUOTE; goto listwith;
+ case TOK_QUOTE:
+ head = "E;
+ listwith:
+ v = cons_reserve(2);
+ car_(v) = *head;
+ cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS);
+ car_(cdr_(v)) = cdr_(cdr_(v)) = NIL;
+ PUSH(v);
+ if (fixup != -1)
+ readstate->exprs.items[fixup] = v;
+ v = do_read_sexpr(f,-1);
+ car_(cdr_(Stack[SP-1])) = v;
+ return POP();
+ case TOK_SHARPQUOTE:
+ // femtoLisp doesn't need symbol-function, so #' does nothing
+ return do_read_sexpr(f, fixup);
+ case TOK_OPEN:
+ PUSH(NIL);
+ read_list(f, &Stack[SP-1], fixup);
+ return POP();
+ case TOK_SHARPDOT:
+ // eval-when-read
+ // evaluated expressions can refer to existing backreferences, but they
+ // cannot see pending labels. in other words:
+ // (... #2=#.#0# ... ) OK
+ // (... #2=#.(#2#) ... ) DO NOT WANT
+ v = do_read_sexpr(f,-1);
+ return toplevel_eval(v);
+ case TOK_LABEL:
+ // create backreference label
+ l = numval(tokval);
+ if (ltable_lookup(&readstate->labels, l) != NOTFOUND)
+ lerror("read: error: label %d redefined\n", l);+ ltable_insert(&readstate->labels, l);
+ i = readstate->exprs.n;
+ ltable_insert(&readstate->exprs, UNBOUND);
+ v = do_read_sexpr(f,i);
+ readstate->exprs.items[i] = v;
+ return v;
+ case TOK_BACKREF:
+ // look up backreference
+ l = numval(tokval);
+ i = ltable_lookup(&readstate->labels, l);
+ if (i == NOTFOUND || i >= (int)readstate->exprs.n ||
+ readstate->exprs.items[i] == UNBOUND)
+ lerror("read: error: undefined label %d\n", l);+ return readstate->exprs.items[i];
+ }
+ return NIL;
+}
+
+value_t read_sexpr(FILE *f)
+{+ value_t v;
+ readstate_t state;
+ state.prev = readstate;
+ ltable_init(&state.labels, 16);
+ ltable_init(&state.exprs, 16);
+ readstate = &state;
+
+ v = do_read_sexpr(f, -1);
+
+ readstate = state.prev;
+ free(state.labels.items);
+ free(state.exprs.items);
+ return v;
+}
+
+// print ----------------------------------------------------------------------
+
+static void print_traverse(value_t v)
+{+ while (iscons(v)) {+ if (ismarked(v)) {+ ltable_adjoin(&printconses, v);
+ return;
+ }
+ mark_cons(v);
+ print_traverse(car_(v));
+ v = cdr_(v);
+ }
+}
+
+static void print_symbol(FILE *f, char *name)
+{+ int i, escape=0, charescape=0;
+
+ if (name[0] == '\0') {+ fprintf(f, "||");
+ return;
+ }
+ if (name[0] == '.' && name[1] == '\0') {+ fprintf(f, "|.|");
+ return;
+ }
+ if (name[0] == '#')
+ escape = 1;
+ i=0;
+ while (name[i]) {+ if (!symchar(name[i])) {+ escape = 1;
+ if (name[i]=='|' || name[i]=='\\') {+ charescape = 1;
+ break;
+ }
+ }
+ i++;
+ }
+ if (escape) {+ if (charescape) {+ fprintf(f, "|");
+ i=0;
+ while (name[i]) {+ if (name[i]=='|' || name[i]=='\\')
+ fprintf(f, "\\%c", name[i]);
+ else
+ fprintf(f, "%c", name[i]);
+ i++;
+ }
+ fprintf(f, "|");
+ }
+ else {+ fprintf(f, "|%s|", name);
+ }
+ }
+ else {+ fprintf(f, "%s", name);
+ }
+}
+
+static void do_print(FILE *f, value_t v, int princ)
+{+ value_t cd;
+ int label;
+ char *name;
+
+ switch (tag(v)) {+ case TAG_NUM: fprintf(f, "%d", numval(v)); break;
+ case TAG_SYM:
+ name = ((symbol_t*)ptr(v))->name;
+ if (princ)
+ fprintf(f, "%s", name);
+ else
+ print_symbol(f, name);
+ break;
+ case TAG_BUILTIN: fprintf(f, "#.%s", builtin_names[intval(v)]); break;
+ case TAG_CONS:
+ if ((label=ltable_lookup(&printconses,v)) != NOTFOUND) {+ if (!ismarked(v)) {+ fprintf(f, "#%d#", label);
+ return;
+ }
+ fprintf(f, "#%d=", label);
+ }
+ fprintf(f, "(");+ while (1) {+ unmark_cons(v);
+ do_print(f, car_(v), princ);
+ cd = cdr_(v);
+ if (!iscons(cd)) {+ if (cd != NIL) {+ fprintf(f, " . ");
+ do_print(f, cd, princ);
+ }
+ fprintf(f, ")");
+ break;
+ }
+ else {+ if ((label=ltable_lookup(&printconses,cd)) != NOTFOUND) {+ fprintf(f, " . ");
+ do_print(f, cd, princ);
+ fprintf(f, ")");
+ break;
+ }
+ }
+ fprintf(f, " ");
+ v = cd;
+ }
+ break;
+ }
+}
+
+void print(FILE *f, value_t v, int princ)
+{+ ltable_clear(&printconses);
+ print_traverse(v);
+ do_print(f, v, princ);
+}
+
+// eval -----------------------------------------------------------------------
+
+static inline void argcount(char *fname, int nargs, int c)
+{+ if (nargs != c)
+ lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");+}
+
+// return a cons element of v whose car is item
+static value_t assoc(value_t item, value_t v)
+{+ value_t bind;
+
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == item)
+ return bind;
+ v = cdr_(v);
+ }
+ return NIL;
+}
+
+#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0,envend))
+#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1,SP))
+#define tail_eval(xpr) do { SP = saveSP; \+ if (tag(xpr)<0x2) { return (xpr); } \+ else { e=(xpr); goto eval_top; } } while (0)+
+/* stack setup on entry:
+ n n+1 ...
+ +-----+-----+-----+-----+-----+-----+-----+-----+
+ | SYM | VAL | SYM | VAL | CLO | | | |
+ +-----+-----+-----+-----+-----+-----+-----+-----+
+ ^ ^ ^
+ | | |
+ penv envend SP (who knows where)
+
+ sym is an argument name and val is its binding. CLO is a closed-up
+ environment list (which can be empty, i.e. NIL).
+ CLO is always there, but there might be zero SYM/VAL pairs.
+
+ if tail==1, you are allowed (indeed encouraged) to overwrite this
+ environment, otherwise you have to put any new environment on the top
+ of the stack.
+*/
+value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
+{+ value_t f, v, headsym, asym, *pv, *argsyms, *body, *lenv, *argenv;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ eval_top:
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ while (issymbol(*penv)) { // 1. try lookup in argument env+ if (*penv == NIL)
+ goto get_global;
+ if (*penv == e)
+ return penv[1];
+ penv+=2;
+ }
+ if ((v=assoc(e,*penv)) != NIL) // 2. closure env
+ return cdr_(v);
+ get_global:
+ if ((v = sym->binding) == UNBOUND) // 3. global env
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ v = car_(e);
+ if (tag(v)<0x2) f = v;
+ else if (issymbol(v) && (f=((symbol_t*)ptr(v))->constant)!=UNBOUND) ;
+ else f = eval_sexpr(v, penv, 0, envend);
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v));
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 1;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v)) lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ // build a closure (lambda args body . env)
+ if (issymbol(*penv) && *penv != NIL) {+ // cons up and save temporary environment
+ PUSH(Stack[envend-1]); // passed-in CLOENV
+ // find out how many new conses we need
+ nargs = ((int)(&Stack[envend] - penv - 1))>>1;
+ if (nargs) {+ lenv = penv;
+ Stack[SP-1] = cons_reserve(nargs*2);
+ c = (cons_t*)ptr(Stack[SP-1]);
+ while (1) {+ c->car = tagptr(c+1, TAG_CONS);
+ (c+1)->car = penv[0];
+ (c+1)->cdr = penv[1];
+ nargs--;
+ if (nargs==0) break;
+ penv+=2;
+ c->cdr = tagptr(c+2, TAG_CONS);
+ c += 2;
+ }
+ // final cdr points to existing cloenv
+ c->cdr = Stack[envend-1];
+ // environment representation changed; install
+ // the new representation so everybody can see it
+ *lenv = Stack[SP-1];
+ }
+ }
+ else {+ PUSH(*penv); // env has already been captured; share
+ }
+ v = cdr_(Stack[saveSP]);
+ PUSH(car(v));
+ PUSH(car(cdr_(v)));
+ c = (cons_t*)ptr(v=cons_reserve(3));
+ c->car = (intval(f)==F_LAMBDA ? LAMBDA : MACRO);
+ c->cdr = tagptr(c+1, TAG_CONS); c++;
+ c->car = Stack[SP-2]; //argsyms
+ c->cdr = tagptr(c+1, TAG_CONS); c++;
+ c->car = Stack[SP-1]; //body
+ c->cdr = Stack[SP-3]; //env
+ break;
+ case F_LABEL:
+ // the syntax of label is (label name (lambda args body))
+ // nothing else is guaranteed to work
+ v = cdr_(Stack[saveSP]);
+ PUSH(car(v));
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ *body = eval(*body); // evaluate lambda
+ c = (cons_t*)ptr(cons_reserve(2));
+ c->car = Stack[SP-2]; // name
+ c->cdr = v = *body; c++;
+ c->car = tagptr(c-1, TAG_CONS);
+ f = cdr(cdr(v));
+ c->cdr = cdr(f);
+ // add (name . fn) to front of function's environment
+ cdr_(f) = tagptr(c, TAG_CONS);
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ tail_eval(v);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ v = eval(c->car);
+ if (v != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv));
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv))) == NIL) {+ SP = saveSP; return NIL;
+ }
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv))) != NIL) {+ SP = saveSP; return v;
+ }
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ case F_WHILE:
+ PUSH(cdr(cdr_(Stack[saveSP])));
+ body = &Stack[SP-1];
+ PUSH(*body);
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL);
+ pv = &Stack[SP-1];
+ while (eval(*cond) != NIL) {+ *body = Stack[SP-2];
+ while (iscons(*body)) {+ *pv = eval(car_(*body));
+ *body = cdr_(*body);
+ }
+ }
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv));
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ while (issymbol(*penv)) {+ if (*penv == NIL)
+ goto set_global;
+ if (*penv == e) {+ penv[1] = Stack[SP-1];
+ SP=saveSP; return penv[1];
+ }
+ penv+=2;
+ }
+ if ((v=assoc(e,*penv)) != NIL) {+ cdr_(v) = (e=Stack[SP-1]);
+ SP=saveSP; return e;
+ }
+ set_global:
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ sym = tosymbol(Stack[SP-1], "boundp");
+ if (sym->binding == UNBOUND && sym->constant == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_CONSP:
+ argcount("consp", nargs, 1);+ v = (iscons(Stack[SP-1]) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1) lerror("-: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1) lerror("/: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0) lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ // this implements generic comparison for all atoms
+ // strange comparisons (for example with builtins) are resolved
+ // arbitrarily but consistently.
+ // ordering: number < builtin < symbol < cons
+ if (tag(Stack[SP-2]) != tag(Stack[SP-1])) {+ v = (tag(Stack[SP-2]) < tag(Stack[SP-1]) ? T : NIL);
+ }
+ else {+ switch (tag(Stack[SP-2])) {+ case TAG_NUM:
+ v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL;
+ break;
+ case TAG_SYM:
+ v = (strcmp(((symbol_t*)ptr(Stack[SP-2]))->name,
+ ((symbol_t*)ptr(Stack[SP-1]))->name) < 0) ?
+ T : NIL;
+ break;
+ case TAG_BUILTIN:
+ v = (intval(Stack[SP-2]) < intval(Stack[SP-1])) ? T : NIL;
+ break;
+ case TAG_CONS:
+ lerror("<: error: expected atom\n");+ }
+ }
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = Stack[SP-1];
+ if (tag(v)<0x2) { SP=saveSP; return v; }+ if (tail) {+ *penv = NIL;
+ envend = SP = (u_int32_t)(penv-&Stack[0]) + 1;
+ e=v; goto eval_top;
+ }
+ else {+ PUSH(NIL);
+ v = eval_sexpr(v, &Stack[SP-1], 1, SP);
+ }
+ break;
+ case F_PRINT:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 0);
+ fprintf(stdout, "\n");
+ break;
+ case F_PRINC:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 1);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_EXIT:
+ exit(0);
+ break;
+ case F_ERROR:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stderr, Stack[i], 1);
+ lerror("\n");+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1) lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+1];
+ break;
+ case F_ASSOC:
+ argcount("assoc", nargs, 2);+ v = assoc(Stack[SP-2], Stack[SP-1]);
+ break;
+ case F_APPLY:
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ // unpack arglist onto the stack
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ // apply lambda or macro expression
+ PUSH(cdr(cdr_(f)));
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ argenv = &Stack[SP]; // argument environment starts now
+ if (headsym == MACRO)
+ noeval = 1;
+ //else if (headsym != LAMBDA)
+ // lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (asym==NIL || iscons(asym))
+ lerror("apply: error: invalid formal argument\n");+ v = car_(v);
+ if (!noeval) {+ v = eval(v);
+ }
+ PUSH(asym);
+ PUSH(v);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ PUSH(*argsyms);
+ if (noeval) {+ PUSH(Stack[saveSP]);
+ }
+ else {+ // this version uses collective allocation. about 7-10%
+ // faster for lists with > 2 elements, but uses more
+ // stack space
+ PUSH(NIL);
+ i = SP;
+ while (iscons(Stack[saveSP])) {+ PUSH(eval(car_(Stack[saveSP])));
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ nargs = SP-i;
+ if (nargs) {+ Stack[i-1] = cons_reserve(nargs);
+ c = (cons_t*)ptr(Stack[i-1]);
+ for(; i < (int)SP; i++) {+ c->car = Stack[i];
+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
+ }
+ (c-1)->cdr = NIL;
+ POPN(nargs);
+ }
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ noeval = 0;
+ lenv = &Stack[saveSP+1];
+ PUSH(cdr(*lenv)); // add cloenv to new environment
+ e = car_(Stack[saveSP+1]);
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO) {+ if (tag(e)<0x2) ;
+ else e = eval_sexpr(e, argenv, 1, SP);
+ SP = saveSP;
+ if (tag(e)<0x2) return(e);
+ goto eval_top;
+ }
+ else {+ if (tag(e)<0x2) { SP=saveSP; return(e); }+ if (tail) {+ // ok to overwrite environment
+ nargs = (int)(&Stack[SP] - argenv);
+ for(i=0; i < nargs; i++)
+ penv[i] = argenv[i];
+ envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]);
+ goto eval_top;
+ }
+ else {+ v = eval_sexpr(e, argenv, 1, SP);
+ SP = saveSP;
+ return v;
+ }
+ }
+ // not reached
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
+
+// repl -----------------------------------------------------------------------
+
+static char *infile = NULL;
+
+value_t toplevel_eval(value_t expr)
+{+ value_t v;
+ u_int32_t saveSP = SP;
+ PUSH(NIL);
+ v = topeval(expr, &Stack[SP-1]);
+ SP = saveSP;
+ return v;
+}
+
+value_t load_file(char *fname)
+{+ value_t e, v=NIL;
+ char *lastfile = infile;
+ FILE *f = fopen(fname, "r");
+ infile = fname;
+ if (f == NULL) lerror("file not found\n");+ while (1) {+ e = read_sexpr(f);
+ if (feof(f)) break;
+ v = toplevel_eval(e);
+ }
+ infile = lastfile;
+ fclose(f);
+ return v;
+}
+
+int main(int argc, char* argv[])
+{+ value_t v;
+
+ stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
+ lisp_init();
+ if (setjmp(toplevel)) {+ SP = 0;
+ fprintf(stderr, "\n");
+ if (infile) {+ fprintf(stderr, "error loading file \"%s\"\n", infile);
+ infile = NULL;
+ }
+ goto repl;
+ }
+ load_file("system.lsp");+ if (argc > 1) { load_file(argv[1]); return 0; }+ printf("; _ \n");+ printf("; |_ _ _ |_ _ | . _ _ 2\n");+ printf("; | (-||||_(_)|__|_)|_)\n");+ printf(";-------------------|----------------------------------------------------------\n\n");+ repl:
+ while (1) {+ printf("> ");+ v = read_sexpr(stdin);
+ if (feof(stdin)) break;
+ print(stdout, v=toplevel_eval(v), 0);
+ set(symbol("that"), v);+ printf("\n\n");+ }
+ return 0;
+}
--- /dev/null
+++ b/tiny/lisp2.c.bak
@@ -1,0 +1,1448 @@
+/*
+ femtoLisp
+
+ a minimal interpreter for a minimal lisp dialect
+
+ this lisp dialect uses lexical scope and self-evaluating lambda.
+ it supports 30-bit integers, symbols, conses, and full macros.
+ it is case-sensitive.
+ it features a simple compacting copying garbage collector.
+ it uses a Scheme-style evaluation rule where any expression may appear in
+ head position as long as it evaluates to a function.
+ it uses Scheme-style varargs (dotted formal argument lists)
+ lambdas can have only 1 body expression; use (progn ...) for multiple
+ expressions. this is due to the closure representation
+ (lambda args body . env)
+
+ This is a fork of femtoLisp with advanced reading and printing facilities:
+ * circular structure can be printed and read
+ * #. read macro for eval-when-read and correctly printing builtins
+ * read macros for backquote
+ * symbol character-escaping printer
+
+ * new print algorithm
+ 1. traverse & tag all conses to be printed. when you encounter a cons
+ that is already tagged, add it to a table to give it a #n# index
+ 2. untag a cons when printing it. if cons is in the table, print
+ "#n=" before it in the car, " . #n=" in the cdr. if cons is in the
+ table but already untagged, print #n# in car or " . #n#" in the cdr.
+ * read macros for #n# and #n= using the same kind of table
+ * also need a table of read labels to translate from input indexes to
+ normalized indexes (0 for first label, 1 for next, etc.)
+ * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq"
+
+ The value of this extra complexity, and what makes this fork worthy of
+ the femtoLisp brand, is that the interpreter is fully "closed" in the
+ sense that all representable values can be read and printed.
+
+ by Jeff Bezanson
+ Public Domain
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <ctype.h>
+#include <sys/types.h>
+
+typedef u_int32_t value_t;
+typedef int32_t number_t;
+
+typedef struct {+ value_t car;
+ value_t cdr;
+} cons_t;
+
+typedef struct _symbol_t {+ value_t binding; // global value binding
+ value_t constant; // constant binding (used only for builtins)
+ struct _symbol_t *left;
+ struct _symbol_t *right;
+ char name[1];
+} symbol_t;
+
+#define TAG_NUM 0x0
+#define TAG_BUILTIN 0x1
+#define TAG_SYM 0x2
+#define TAG_CONS 0x3
+#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
+#define tag(x) ((x)&0x3)
+#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
+#define tagptr(p,t) (((value_t)(p)) | (t))
+#define number(x) ((value_t)((x)<<2))
+#define numval(x) (((number_t)(x))>>2)
+#define intval(x) (((int)(x))>>2)
+#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isnumber(x) (tag(x) == TAG_NUM)
+#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v),"car")->car)
+#define cdr(v) (tocons((v),"cdr")->cdr)
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
+
+enum {+ // special forms
+ F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
+ F_PROGN,
+ // functions
+ F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
+ F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
+ F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, F_ERROR, F_EXIT, F_PRINC, F_CONSP,
+ F_ASSOC, N_BUILTINS
+};
+#define isspecial(v) (intval(v) <= (number_t)F_PROGN)
+
+static char *builtin_names[] =
+ { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",+ "progn",
+ "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
+ "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
+ "prog1", "apply", "rplaca", "rplacd", "boundp", "error", "exit", "princ",
+ "consp", "assoc" };
+
+static char *stack_bottom;
+#define PROCESS_STACK_SIZE (2*1024*1024)
+#define N_STACK 98304
+static value_t Stack[N_STACK];
+static u_int32_t SP = 0;
+#define PUSH(v) (Stack[SP++] = (v))
+#define POP() (Stack[--SP])
+#define POPN(n) (SP-=(n))
+
+value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
+value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
+
+value_t read_sexpr(FILE *f);
+void print(FILE *f, value_t v, int princ);
+value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend);
+value_t load_file(char *fname);
+value_t toplevel_eval(value_t expr);
+
+#include "flutils.c"
+
+typedef struct _readstate_t {+ ltable_t labels;
+ ltable_t exprs;
+ struct _readstate_t *prev;
+} readstate_t;
+static readstate_t *readstate = NULL;
+
+// error utilities ------------------------------------------------------------
+
+jmp_buf toplevel;
+
+void lerror(char *format, ...)
+{+ va_list args;
+ va_start(args, format);
+
+ while (readstate) {+ free(readstate->labels.items);
+ free(readstate->exprs.items);
+ readstate = readstate->prev;
+ }
+
+ vfprintf(stderr, format, args);
+ va_end(args);
+ longjmp(toplevel, 1);
+}
+
+void type_error(char *fname, char *expected, value_t got)
+{+ fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
+ print(stderr, got, 0); lerror("\n");+}
+
+// safe cast operators --------------------------------------------------------
+
+#define SAFECAST_OP(type,ctype,cnvt) \
+ctype to##type(value_t v, char *fname) \
+{ \+ if (is##type(v)) \
+ return (ctype)cnvt(v); \
+ type_error(fname, #type, v); \
+ return (ctype)0; \
+}
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol,symbol_t*,ptr)
+SAFECAST_OP(number,number_t, numval)
+
+// symbol table ---------------------------------------------------------------
+
+static symbol_t *symtab = NULL;
+
+static symbol_t *mk_symbol(char *str)
+{+ symbol_t *sym;
+
+ sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
+ sym->left = sym->right = NULL;
+ sym->constant = sym->binding = UNBOUND;
+ strcpy(&sym->name[0], str);
+ return sym;
+}
+
+static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
+{+ int x;
+
+ while(*ptree != NULL) {+ x = strcmp(str, (*ptree)->name);
+ if (x == 0)
+ return ptree;
+ if (x < 0)
+ ptree = &(*ptree)->left;
+ else
+ ptree = &(*ptree)->right;
+ }
+ return ptree;
+}
+
+value_t symbol(char *str)
+{+ symbol_t **pnode;
+
+ pnode = symtab_lookup(&symtab, str);
+ if (*pnode == NULL)
+ *pnode = mk_symbol(str);
+ return tagptr(*pnode, TAG_SYM);
+}
+
+// initialization -------------------------------------------------------------
+
+static unsigned char *fromspace;
+static unsigned char *tospace;
+static unsigned char *curheap;
+static unsigned char *lim;
+static u_int32_t heapsize = 128*1024;//bytes
+static u_int32_t *consflags;
+static ltable_t printconses;
+
+void lisp_init(void)
+{+ int i;
+
+ fromspace = malloc(heapsize);
+ tospace = malloc(heapsize);
+ curheap = fromspace;
+ lim = curheap+heapsize-sizeof(cons_t);
+ consflags = mk_bitvector(heapsize/sizeof(cons_t));
+
+ ltable_init(&printconses, 32);
+
+ NIL = symbol("nil"); setc(NIL, NIL);+ T = symbol("t"); setc(T, T);+ LAMBDA = symbol("lambda");+ MACRO = symbol("macro");+ LABEL = symbol("label");+ QUOTE = symbol("quote");+ BACKQUOTE = symbol("backquote");+ COMMA = symbol("*comma*");+ COMMAAT = symbol("*comma-at*");+ COMMADOT = symbol("*comma-dot*");+ for (i=0; i < (int)N_BUILTINS; i++)
+ setc(symbol(builtin_names[i]), builtin(i));
+}
+
+// conses ---------------------------------------------------------------------
+
+void gc(int mustgrow);
+
+static value_t mk_cons(void)
+{+ cons_t *c;
+
+ if (curheap > lim)
+ gc(0);
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+// allocate and link n consecutive conses
+// warning: only cdrs are initialized
+static value_t cons_reserve(int n)
+{+ cons_t *c, *first;
+
+ n--;
+ if ((cons_t*)curheap > ((cons_t*)lim)-n) {+ gc(0);
+ while ((cons_t*)curheap > ((cons_t*)lim)-n) {+ gc(1);
+ }
+ }
+ c = first = (cons_t*)curheap;
+ for(; n > 0; n--) {+ c->cdr = tagptr(c+1, TAG_CONS);
+ c++;
+ }
+ c->cdr = NIL;
+ curheap = (unsigned char*)(c+1);
+ return tagptr(first, TAG_CONS);
+}
+
+value_t *cons(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ PUSH(c);
+ return &Stack[SP-1];
+}
+
+#define cons_index(c) (((cons_t*)ptr(c))-((cons_t*)fromspace))
+#define ismarked(c) bitvector_get(consflags, cons_index(c))
+#define mark_cons(c) bitvector_set(consflags, cons_index(c), 1)
+#define unmark_cons(c) bitvector_set(consflags, cons_index(c), 0)
+
+// collector ------------------------------------------------------------------
+
+static value_t relocate(value_t v)
+{+ value_t a, d, nc, first, *pcdr;
+
+ if (!iscons(v))
+ return v;
+ // iterative implementation allows arbitrarily long cons chains
+ pcdr = &first;
+ do {+ if ((a=car_(v)) == UNBOUND) {+ *pcdr = cdr_(v);
+ return first;
+ }
+ *pcdr = nc = mk_cons();
+ d = cdr_(v);
+ car_(v) = UNBOUND; cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ pcdr = &cdr_(nc);
+ v = d;
+ } while (iscons(v));
+ *pcdr = d;
+
+ return first;
+}
+
+static void trace_globals(symbol_t *root)
+{+ while (root != NULL) {+ root->binding = relocate(root->binding);
+ trace_globals(root->left);
+ root = root->right;
+ }
+}
+
+void gc(int mustgrow)
+{+ static int grew = 0;
+ unsigned char *temp;
+ u_int32_t i;
+ readstate_t *rs;
+
+ curheap = tospace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ for (i=0; i < SP; i++)
+ Stack[i] = relocate(Stack[i]);
+ trace_globals(symtab);
+ rs = readstate;
+ while (rs) {+ for(i=0; i < rs->exprs.n; i++)
+ rs->exprs.items[i] = relocate(rs->exprs.items[i]);
+ rs = rs->prev;
+ }
+#ifdef VERBOSEGC
+ printf("gc found %d/%d live conses\n",+ (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t));
+#endif
+ temp = tospace;
+ tospace = fromspace;
+ fromspace = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {+ temp = realloc(tospace, grew ? heapsize : heapsize*2);
+ if (temp == NULL)
+ lerror("out of memory\n");+ tospace = temp;
+ if (!grew) {+ heapsize*=2;
+ }
+ else {+ temp = (char*)bitvector_resize(consflags, heapsize/sizeof(cons_t));
+ if (temp == NULL)
+ lerror("out of memory\n");+ consflags = (u_int32_t*)temp;
+ }
+ grew = !grew;
+ }
+ if (curheap > lim) // all data was live
+ gc(0);
+}
+
+// read -----------------------------------------------------------------------
+
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
+ TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
+ TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE
+};
+
+static int symchar(char c)
+{+ static char *special = "()';`,\\|";
+ return (!isspace(c) && !strchr(special, c));
+}
+
+static u_int32_t toktype = TOK_NONE;
+static value_t tokval;
+static char buf[256];
+
+static char nextchar(FILE *f)
+{+ char c;
+ int ch;
+
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ c = (char)ch;
+ if (c == ';') {+ // single-line comment
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ } while ((char)ch != '\n');
+ c = (char)ch;
+ }
+ } while (isspace(c));
+ return c;
+}
+
+static void take(void)
+{+ toktype = TOK_NONE;
+}
+
+static void accumchar(char c, int *pi)
+{+ buf[(*pi)++] = c;
+ if (*pi >= (int)(sizeof(buf)-1))
+ lerror("read: error: token too long\n");+}
+
+// return: 1 for dot token, 0 for symbol
+static int read_token(FILE *f, char c, int digits)
+{+ int i=0, ch, escaped=0, dot=(c=='.'), totread=0;
+
+ ungetc(c, f);
+ while (1) {+ ch = fgetc(f); totread++;
+ if (ch == EOF)
+ goto terminate;
+ c = (char)ch;
+ if (c == '|') {+ escaped = !escaped;
+ }
+ else if (c == '\\') {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ accumchar((char)ch, &i);
+ }
+ else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {+ break;
+ }
+ else {+ accumchar(c, &i);
+ }
+ }
+ ungetc(c, f);
+ terminate:
+ buf[i++] = '\0';
+ return (dot && (totread==2));
+}
+
+static u_int32_t peek(FILE *f)
+{+ char c, *end;
+ number_t x;
+ int ch;
+
+ if (toktype != TOK_NONE)
+ return toktype;
+ c = nextchar(f);
+ if (feof(f)) return TOK_NONE;
+ if (c == '(') {+ toktype = TOK_OPEN;
+ }
+ else if (c == ')') {+ toktype = TOK_CLOSE;
+ }
+ else if (c == '\'') {+ toktype = TOK_QUOTE;
+ }
+ else if (c == '`') {+ toktype = TOK_BQ;
+ }
+ else if (c == '#') {+ ch = fgetc(f);
+ if (ch == EOF)
+ lerror("read: error: invalid read macro\n");+ if ((char)ch == '.') {+ toktype = TOK_SHARPDOT;
+ }
+ else if ((char)ch == '\'') {+ toktype = TOK_SHARPQUOTE;
+ }
+ else if (isdigit((char)ch)) {+ read_token(f, (char)ch, 1);
+ c = fgetc(f);
+ if (c == '#')
+ toktype = TOK_BACKREF;
+ else if (c == '=')
+ toktype = TOK_LABEL;
+ else
+ lerror("read: error: invalid label\n");+ x = strtol(buf, &end, 10);
+ tokval = number(x);
+ }
+ else {+ lerror("read: error: unknown read macro\n");+ }
+ }
+ else if (c == ',') {+ toktype = TOK_COMMA;
+ ch = fgetc(f);
+ if (ch == EOF)
+ return toktype;
+ if ((char)ch == '@')
+ toktype = TOK_COMMAAT;
+ else if ((char)ch == '.')
+ toktype = TOK_COMMADOT;
+ else
+ ungetc((char)ch, f);
+ }
+ else if (isdigit(c) || c=='-') {+ read_token(f, c, 0);
+ if (buf[0] == '-' && !isdigit(buf[1])) {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ else {+ x = strtol(buf, &end, 10);
+ if (*end != '\0')
+ lerror("read: error: invalid integer constant\n");+ toktype = TOK_NUM;
+ tokval = number(x);
+ }
+ }
+ else {+ if (read_token(f, c, 0)) {+ toktype = TOK_DOT;
+ }
+ else {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ }
+ return toktype;
+}
+
+static value_t do_read_sexpr(FILE *f, int fixup);
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void read_list(FILE *f, value_t *pval, int fixup)
+{+ value_t c, *pc;
+ u_int32_t t;
+
+ PUSH(NIL);
+ pc = &Stack[SP-1]; // to keep track of current cons cell
+ t = peek(f);
+ while (t != TOK_CLOSE) {+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ c = mk_cons(); car_(c) = cdr_(c) = NIL;
+ if (iscons(*pc)) {+ cdr_(*pc) = c;
+ }
+ else {+ *pval = c;
+ if (fixup != -1)
+ readstate->exprs.items[fixup] = c;
+ }
+ *pc = c;
+ c = do_read_sexpr(f,-1); // must be on separate lines due to undefined
+ car_(*pc) = c; // evaluation order
+
+ t = peek(f);
+ if (t == TOK_DOT) {+ take();
+ c = do_read_sexpr(f,-1);
+ cdr_(*pc) = c;
+ t = peek(f);
+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ if (t != TOK_CLOSE)
+ lerror("read: error: expected ')'\n");+ }
+ }
+ take();
+ POP();
+}
+
+// fixup is the index of the label we'd like to fix up with this read
+static value_t do_read_sexpr(FILE *f, int fixup)
+{+ value_t v, *head;
+ u_int32_t t, l;
+ int i;
+
+ t = peek(f);
+ take();
+ switch (t) {+ case TOK_CLOSE:
+ lerror("read: error: unexpected ')'\n");+ case TOK_DOT:
+ lerror("read: error: unexpected '.'\n");+ case TOK_SYM:
+ case TOK_NUM:
+ return tokval;
+ case TOK_COMMA:
+ head = &COMMA; goto listwith;
+ case TOK_COMMAAT:
+ head = &COMMAAT; goto listwith;
+ case TOK_COMMADOT:
+ head = &COMMADOT; goto listwith;
+ case TOK_BQ:
+ head = &BACKQUOTE; goto listwith;
+ case TOK_QUOTE:
+ head = "E;
+ listwith:
+ cons(head, cons(&NIL, &NIL));
+ if (fixup != -1)
+ readstate->exprs.items[fixup] = Stack[SP-1];
+ v = do_read_sexpr(f,-1);
+ car_(Stack[SP-2]) = v;
+ v = Stack[SP-1];
+ POPN(2);
+ return v;
+ case TOK_SHARPQUOTE:
+ // femtoLisp doesn't need symbol-function, so #' does nothing
+ return do_read_sexpr(f, fixup);
+ case TOK_OPEN:
+ PUSH(NIL);
+ read_list(f, &Stack[SP-1], fixup);
+ return POP();
+ case TOK_SHARPDOT:
+ // eval-when-read
+ // evaluated expressions can refer to existing backreferences, but they
+ // cannot see pending labels. in other words:
+ // (... #2=#.#0# ... ) OK
+ // (... #2=#.(#2#) ... ) DO NOT WANT
+ v = do_read_sexpr(f,-1);
+ return toplevel_eval(v);
+ case TOK_LABEL:
+ // create backreference label
+ l = numval(tokval);
+ if (ltable_lookup(&readstate->labels, l) != NOTFOUND)
+ lerror("read: error: label %d redefined\n", l);+ ltable_insert(&readstate->labels, l);
+ i = readstate->exprs.n;
+ ltable_insert(&readstate->exprs, UNBOUND);
+ v = do_read_sexpr(f,i);
+ readstate->exprs.items[i] = v;
+ return v;
+ case TOK_BACKREF:
+ // look up backreference
+ l = numval(tokval);
+ i = ltable_lookup(&readstate->labels, l);
+ if (i == NOTFOUND || i >= (int)readstate->exprs.n ||
+ readstate->exprs.items[i] == UNBOUND)
+ lerror("read: error: undefined label %d\n", l);+ return readstate->exprs.items[i];
+ }
+ return NIL;
+}
+
+value_t read_sexpr(FILE *f)
+{+ value_t v;
+ readstate_t state;
+ state.prev = readstate;
+ ltable_init(&state.labels, 16);
+ ltable_init(&state.exprs, 16);
+ readstate = &state;
+
+ v = do_read_sexpr(f, -1);
+
+ readstate = state.prev;
+ free(state.labels.items);
+ free(state.exprs.items);
+ return v;
+}
+
+// print ----------------------------------------------------------------------
+
+static void print_traverse(value_t v)
+{+ while (iscons(v)) {+ if (ismarked(v)) {+ ltable_adjoin(&printconses, v);
+ return;
+ }
+ mark_cons(v);
+ print_traverse(car_(v));
+ v = cdr_(v);
+ }
+}
+
+static void print_symbol(FILE *f, char *name)
+{+ int i, escape=0, charescape=0;
+
+ if (name[0] == '\0') {+ fprintf(f, "||");
+ return;
+ }
+ if (name[0] == '.' && name[1] == '\0') {+ fprintf(f, "|.|");
+ return;
+ }
+ if (name[0] == '#')
+ escape = 1;
+ i=0;
+ while (name[i]) {+ if (!symchar(name[i])) {+ escape = 1;
+ if (name[i]=='|' || name[i]=='\\') {+ charescape = 1;
+ break;
+ }
+ }
+ i++;
+ }
+ if (escape) {+ if (charescape) {+ fprintf(f, "|");
+ i=0;
+ while (name[i]) {+ if (name[i]=='|' || name[i]=='\\')
+ fprintf(f, "\\%c", name[i]);
+ else
+ fprintf(f, "%c", name[i]);
+ i++;
+ }
+ fprintf(f, "|");
+ }
+ else {+ fprintf(f, "|%s|", name);
+ }
+ }
+ else {+ fprintf(f, "%s", name);
+ }
+}
+
+static void do_print(FILE *f, value_t v, int princ)
+{+ value_t cd;
+ int label;
+ char *name;
+
+ switch (tag(v)) {+ case TAG_NUM: fprintf(f, "%d", numval(v)); break;
+ case TAG_SYM:
+ name = ((symbol_t*)ptr(v))->name;
+ if (princ)
+ fprintf(f, "%s", name);
+ else
+ print_symbol(f, name);
+ break;
+ case TAG_BUILTIN: fprintf(f, "#.%s", builtin_names[intval(v)]); break;
+ case TAG_CONS:
+ if ((label=ltable_lookup(&printconses,v)) != NOTFOUND) {+ if (!ismarked(v)) {+ fprintf(f, "#%d#", label);
+ return;
+ }
+ fprintf(f, "#%d=", label);
+ }
+ fprintf(f, "(");+ while (1) {+ unmark_cons(v);
+ do_print(f, car_(v), princ);
+ cd = cdr_(v);
+ if (!iscons(cd)) {+ if (cd != NIL) {+ fprintf(f, " . ");
+ do_print(f, cd, princ);
+ }
+ fprintf(f, ")");
+ break;
+ }
+ else {+ if ((label=ltable_lookup(&printconses,cd)) != NOTFOUND) {+ fprintf(f, " . ");
+ do_print(f, cd, princ);
+ fprintf(f, ")");
+ break;
+ }
+ }
+ fprintf(f, " ");
+ v = cd;
+ }
+ break;
+ }
+}
+
+void print(FILE *f, value_t v, int princ)
+{+ ltable_clear(&printconses);
+ print_traverse(v);
+ do_print(f, v, princ);
+}
+
+// eval -----------------------------------------------------------------------
+
+static inline void argcount(char *fname, int nargs, int c)
+{+ if (nargs != c)
+ lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");+}
+
+// return a cons element of v whose car is item
+static value_t assoc(value_t item, value_t v)
+{+ value_t bind;
+
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == item)
+ return bind;
+ v = cdr_(v);
+ }
+ return NIL;
+}
+
+#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0,envend))
+#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1,SP))
+#define tail_eval(xpr) do { SP = saveSP; \+ if (tag(xpr)<0x2) { return (xpr); } \+ else { e=(xpr); goto eval_top; } } while (0)+
+/* stack setup on entry:
+ n n+1 ...
+ +-----+-----+-----+-----+-----+-----+-----+-----+
+ | SYM | VAL | SYM | VAL | CLO | | | |
+ +-----+-----+-----+-----+-----+-----+-----+-----+
+ ^ ^ ^
+ | | |
+ penv envend SP (who knows where)
+
+ sym is an argument name and val is its binding. CLO is a closed-up
+ environment list (which can be empty, i.e. NIL).
+ CLO is always there, but there might be zero SYM/VAL pairs.
+
+ if tail==1, you are allowed (indeed encouraged) to overwrite this
+ environment, otherwise you have to put any new environment on the top
+ of the stack.
+*/
+value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
+{+ value_t f, v, headsym, asym, labl, *pv, *argsyms, *body, *lenv, *argenv;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ eval_top:
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ while (issymbol(*penv)) { // 1. try lookup in argument env+ if (*penv == NIL)
+ goto get_global;
+ if (*penv == e)
+ return penv[1];
+ penv+=2;
+ }
+ if ((v=assoc(e,*penv)) != NIL) // 2. closure env
+ return cdr_(v);
+ get_global:
+ if ((v = sym->binding) == UNBOUND) // 3. global env
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ v = car_(e);
+ if (tag(v)<0x2) f = v;
+ else if (issymbol(v) && (f=((symbol_t*)ptr(v))->constant)!=UNBOUND) ;
+ else f = eval_sexpr(v, penv, 0, envend);
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v));
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 1;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v)) lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ if (issymbol(*penv)) {+ // cons up and save temporary environment
+ PUSH(Stack[envend-1]); // passed-in CLOENV
+ // find out how many new conses we need
+ nargs = ((int)(&Stack[envend] - penv - 1))>>1;
+ if (nargs) {+ lenv = penv;
+ v = Stack[SP-1] = cons_reserve(nargs*2);
+ while (1) {+ e = cdr_(cdr_(v));
+ car_(v) = cdr_(v);
+ car_(cdr_(v)) = penv[0];
+ cdr_(cdr_(v)) = penv[1];
+ nargs--;
+ if (nargs==0) break;
+ penv+=2;
+ cdr_(v) = e;
+ v = e;
+ }
+ // final cdr points to existing cloenv
+ cdr_(v) = Stack[envend-1];
+ // environment representation changed; install
+ // the new representation so everybody can see it
+ *lenv = Stack[SP-1];
+ }
+ }
+ else {+ PUSH(*penv); // env has already been captured; recapture
+ }
+ v = cdr_(Stack[saveSP]);
+ PUSH(car(v));
+ PUSH(car(cdr_(v)));
+ v = cons_reserve(3);
+ car_(v) = (intval(f)==F_LAMBDA ? LAMBDA : MACRO); f = cdr_(v);
+ car_(f) = Stack[SP-2]; f = cdr_(f); //argsyms
+ car_(f) = Stack[SP-1]; //body
+ cdr_(f) = Stack[SP-3]; //env
+ }
+ else {+ v = Stack[saveSP];
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v));
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ *body = eval(*body); // evaluate lambda
+ v = f = cons_reserve(3);
+ car_(f) = LABEL; f = cdr_(f);
+ car_(f) = Stack[SP-2]; f = cdr_(f); // name
+ car_(f) = *body; // lambda expr
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ tail_eval(v);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ v = eval(c->car);
+ if (v != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv));
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv))) == NIL) {+ SP = saveSP; return NIL;
+ }
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv))) != NIL) {+ SP = saveSP; return v;
+ }
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+ case F_WHILE:
+ PUSH(cdr(cdr_(Stack[saveSP])));
+ body = &Stack[SP-1];
+ PUSH(*body);
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL);
+ pv = &Stack[SP-1];
+ while (eval(*cond) != NIL) {+ *body = Stack[SP-2];
+ while (iscons(*body)) {+ *pv = eval(car_(*body));
+ *body = cdr_(*body);
+ }
+ }
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv));
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv));
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ while (issymbol(*penv)) {+ if (*penv == NIL)
+ goto set_global;
+ if (*penv == e) {+ penv[1] = Stack[SP-1];
+ SP=saveSP; return penv[1];
+ }
+ penv+=2;
+ }
+ if ((v=assoc(e,*penv)) != NIL) {+ cdr_(v) = (e=Stack[SP-1]);
+ SP=saveSP; return e;
+ }
+ set_global:
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ sym = tosymbol(Stack[SP-1], "boundp");
+ if (sym->binding == UNBOUND && sym->constant == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_CONSP:
+ argcount("consp", nargs, 1);+ v = (iscons(Stack[SP-1]) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1) lerror("-: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+1; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1) lerror("/: error: too few arguments\n");+ i = saveSP+1;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0) lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ // this implements generic comparison for all atoms
+ // strange comparisons (for example with builtins) are resolved
+ // arbitrarily but consistently.
+ // ordering: number < builtin < symbol < cons
+ if (tag(Stack[SP-2]) != tag(Stack[SP-1])) {+ v = (tag(Stack[SP-2]) < tag(Stack[SP-1]) ? T : NIL);
+ }
+ else {+ switch (tag(Stack[SP-2])) {+ case TAG_NUM:
+ v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL;
+ break;
+ case TAG_SYM:
+ v = (strcmp(((symbol_t*)ptr(Stack[SP-2]))->name,
+ ((symbol_t*)ptr(Stack[SP-1]))->name) < 0) ?
+ T : NIL;
+ break;
+ case TAG_BUILTIN:
+ v = (intval(Stack[SP-2]) < intval(Stack[SP-1])) ? T : NIL;
+ break;
+ case TAG_CONS:
+ lerror("<: error: expected atom\n");+ }
+ }
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = Stack[SP-1];
+ if (tag(v)<0x2) { SP=saveSP; return v; }+ if (tail) {+ *penv = NIL;
+ envend = SP = (u_int32_t)(penv-&Stack[0]) + 1;
+ e=v; goto eval_top;
+ }
+ else {+ PUSH(NIL);
+ v = eval_sexpr(v, &Stack[SP-1], 1, SP);
+ }
+ break;
+ case F_PRINT:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 0);
+ fprintf(stdout, "\n");
+ break;
+ case F_PRINC:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stdout, v=Stack[i], 1);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_EXIT:
+ exit(0);
+ break;
+ case F_ERROR:
+ for (i=saveSP+1; i < (int)SP; i++)
+ print(stderr, Stack[i], 1);
+ lerror("\n");+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1) lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+1];
+ break;
+ case F_ASSOC:
+ argcount("assoc", nargs, 2);+ v = assoc(Stack[SP-2], Stack[SP-1]);
+ break;
+ case F_APPLY:
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ // unpack arglist onto the stack
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ } else labl=0;
+ // apply lambda or macro expression
+ PUSH(cdr(cdr_(f)));
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ argenv = &Stack[SP]; // argument environment starts now
+ if (labl) {+ // add label binding to environment
+ PUSH(car_(cdr_(labl)));
+ PUSH(labl);
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ //else if (headsym != LAMBDA)
+ // lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (asym==NIL || iscons(asym))
+ lerror("apply: error: invalid formal argument\n");+ v = car_(v);
+ if (!noeval) {+ v = eval(v);
+ }
+ PUSH(asym);
+ PUSH(v);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ PUSH(*argsyms);
+ if (noeval) {+ PUSH(Stack[saveSP]);
+ }
+ else {+ // this version uses collective allocation. about 7-10%
+ // faster for lists with > 2 elements, but uses more
+ // stack space
+ PUSH(NIL);
+ i = SP;
+ while (iscons(Stack[saveSP])) {+ PUSH(eval(car_(Stack[saveSP])));
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ nargs = SP-i;
+ if (nargs) {+ Stack[i-1] = v = cons_reserve(nargs);
+ for(; i < (int)SP; i++) {+ car_(v) = Stack[i];
+ v = cdr_(v);
+ }
+ POPN(nargs);
+ }
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ noeval = 0;
+ lenv = &Stack[saveSP+1];
+ PUSH(cdr(*lenv)); // add cloenv to new environment
+ e = car_(Stack[saveSP+1]);
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO) {+ if (tag(e)<0x2) ;
+ else e = eval_sexpr(e, argenv, 1, SP);
+ SP = saveSP;
+ if (tag(e)<0x2) return(e);
+ goto eval_top;
+ }
+ else {+ if (tag(e)<0x2) { SP=saveSP; return(e); }+ if (tail) {+ // ok to overwrite environment
+ nargs = (int)(&Stack[SP] - argenv);
+ for(i=0; i < nargs; i++)
+ penv[i] = argenv[i];
+ envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]);
+ goto eval_top;
+ }
+ else {+ v = eval_sexpr(e, argenv, 1, SP);
+ SP = saveSP;
+ return v;
+ }
+ }
+ // not reached
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
+
+// repl -----------------------------------------------------------------------
+
+static char *infile = NULL;
+
+value_t toplevel_eval(value_t expr)
+{+ value_t v;
+ PUSH(NIL);
+ v = topeval(expr, &Stack[SP-1]);
+ POP();
+ return v;
+}
+
+value_t load_file(char *fname)
+{+ value_t e, v=NIL;
+ char *lastfile = infile;
+ FILE *f = fopen(fname, "r");
+ infile = fname;
+ if (f == NULL) lerror("file not found\n");+ while (1) {+ e = read_sexpr(f);
+ if (feof(f)) break;
+ v = toplevel_eval(e);
+ }
+ infile = lastfile;
+ fclose(f);
+ return v;
+}
+
+int main(int argc, char* argv[])
+{+ value_t v;
+
+ stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
+ lisp_init();
+ if (setjmp(toplevel)) {+ SP = 0;
+ fprintf(stderr, "\n");
+ if (infile) {+ fprintf(stderr, "error loading file \"%s\"\n", infile);
+ infile = NULL;
+ }
+ goto repl;
+ }
+ load_file("system.lsp");+ if (argc > 1) { load_file(argv[1]); return 0; }+ printf("; _ \n");+ printf("; |_ _ _ |_ _ | . _ _ 2\n");+ printf("; | (-||||_(_)|__|_)|_)\n");+ printf(";-------------------|----------------------------------------------------------\n\n");+ repl:
+ while (1) {+ printf("> ");+ v = read_sexpr(stdin);
+ if (feof(stdin)) break;
+ print(stdout, v=toplevel_eval(v), 0);
+ set(symbol("that"), v);+ printf("\n\n");+ }
+ return 0;
+}
--- /dev/null
+++ b/tiny/lispf.c
@@ -1,0 +1,1043 @@
+/*
+ femtoLisp
+
+ a minimal interpreter for a minimal lisp dialect
+
+ this lisp dialect uses lexical scope and self-evaluating lambda.
+ it supports 30-bit integers, symbols, conses, and full macros.
+ it is case-sensitive.
+ it features a simple compacting copying garbage collector.
+ it uses a Scheme-style evaluation rule where any expression may appear in
+ head position as long as it evaluates to a function.
+ it uses Scheme-style varargs (dotted formal argument lists)
+ lambdas can have only 1 body expression; use (progn ...) for multiple
+ expressions. this is due to the closure representation
+ (lambda args body . env)
+
+ lispf is a fork that provides an #ifdef FLOAT option to use single-precision
+ floating point numbers instead of integers, albeit with even less precision
+ than usual---only 21 significant mantissa bits!
+
+ it is now also being used to test a tail-recursive evaluator.
+
+ by Jeff Bezanson
+ Public Domain
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <ctype.h>
+#include <sys/types.h>
+
+typedef u_int32_t value_t;
+#ifdef FLOAT
+typedef float number_t;
+#else
+typedef int32_t number_t;
+#endif
+
+typedef struct {+ value_t car;
+ value_t cdr;
+} cons_t;
+
+typedef struct _symbol_t {+ value_t binding; // global value binding
+ value_t constant; // constant binding (used only for builtins)
+ struct _symbol_t *left;
+ struct _symbol_t *right;
+ char name[1];
+} symbol_t;
+
+#define TAG_NUM 0x0
+#define TAG_BUILTIN 0x1
+#define TAG_SYM 0x2
+#define TAG_CONS 0x3
+#define UNBOUND ((value_t)TAG_SYM) // an invalid symbol pointer
+#define tag(x) ((x)&0x3)
+#define ptr(x) ((void*)((x)&(~(value_t)0x3)))
+#define tagptr(p,t) (((value_t)(p)) | (t))
+#ifdef FLOAT
+#define number(x) ((*(value_t*)&(x))&~0x3)
+#define numval(x) (*(number_t*)&(x))
+#define NUM_FORMAT "%f"
+extern float strtof(const char *nptr, char **endptr);
+#define strtonum(s, e) strtof(s, e)
+#else
+#define number(x) ((value_t)((x)<<2))
+#define numval(x) (((number_t)(x))>>2)
+#define NUM_FORMAT "%d"
+#define strtonum(s, e) strtol(s, e, 10)
+#endif
+#define intval(x) (((int)(x))>>2)
+#define builtin(n) tagptr((((int)n)<<2), TAG_BUILTIN)
+#define iscons(x) (tag(x) == TAG_CONS)
+#define issymbol(x) (tag(x) == TAG_SYM)
+#define isnumber(x) (tag(x) == TAG_NUM)
+#define isbuiltin(x) (tag(x) == TAG_BUILTIN)
+// functions ending in _ are unsafe, faster versions
+#define car_(v) (((cons_t*)ptr(v))->car)
+#define cdr_(v) (((cons_t*)ptr(v))->cdr)
+#define car(v) (tocons((v),"car")->car)
+#define cdr(v) (tocons((v),"cdr")->cdr)
+#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
+#define setc(s, v) (((symbol_t*)ptr(s))->constant = (v))
+
+enum {+ // special forms
+ F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_MACRO, F_LABEL,
+ F_PROGN,
+ // functions
+ F_EQ, F_ATOM, F_CONS, F_CAR, F_CDR, F_READ, F_EVAL, F_PRINT, F_SET, F_NOT,
+ F_LOAD, F_SYMBOLP, F_NUMBERP, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_PROG1,
+ F_APPLY, F_RPLACA, F_RPLACD, F_BOUNDP, N_BUILTINS
+};
+#define isspecial(v) (intval(v) <= (int)F_PROGN)
+
+static char *builtin_names[] =
+ { "quote", "cond", "if", "and", "or", "while", "lambda", "macro", "label",+ "progn", "eq", "atom", "cons", "car", "cdr", "read", "eval", "print",
+ "set", "not", "load", "symbolp", "numberp", "+", "-", "*", "/", "<",
+ "prog1", "apply", "rplaca", "rplacd", "boundp" };
+
+static char *stack_bottom;
+#define PROCESS_STACK_SIZE (2*1024*1024)
+#define N_STACK 49152
+static value_t Stack[N_STACK];
+static u_int32_t SP = 0;
+#define PUSH(v) (Stack[SP++] = (v))
+#define POP() (Stack[--SP])
+#define POPN(n) (SP-=(n))
+
+value_t NIL, T, LAMBDA, MACRO, LABEL, QUOTE;
+
+value_t read_sexpr(FILE *f);
+void print(FILE *f, value_t v);
+value_t eval_sexpr(value_t e, value_t *penv);
+value_t load_file(char *fname);
+
+// error utilities ------------------------------------------------------------
+
+jmp_buf toplevel;
+
+void lerror(char *format, ...)
+{+ va_list args;
+ va_start(args, format);
+ vfprintf(stderr, format, args);
+ va_end(args);
+ longjmp(toplevel, 1);
+}
+
+void type_error(char *fname, char *expected, value_t got)
+{+ fprintf(stderr, "%s: error: expected %s, got ", fname, expected);
+ print(stderr, got); lerror("\n");+}
+
+// safe cast operators --------------------------------------------------------
+
+#define SAFECAST_OP(type,ctype,cnvt) \
+ctype to##type(value_t v, char *fname) \
+{ \+ if (is##type(v)) \
+ return (ctype)cnvt(v); \
+ type_error(fname, #type, v); \
+ return (ctype)0; \
+}
+SAFECAST_OP(cons, cons_t*, ptr)
+SAFECAST_OP(symbol,symbol_t*,ptr)
+SAFECAST_OP(number,number_t, numval)
+
+// symbol table ---------------------------------------------------------------
+
+static symbol_t *symtab = NULL;
+
+static symbol_t *mk_symbol(char *str)
+{+ symbol_t *sym;
+
+ sym = (symbol_t*)malloc(sizeof(symbol_t) + strlen(str));
+ sym->left = sym->right = NULL;
+ sym->constant = sym->binding = UNBOUND;
+ strcpy(&sym->name[0], str);
+ return sym;
+}
+
+static symbol_t **symtab_lookup(symbol_t **ptree, char *str)
+{+ int x;
+
+ while(*ptree != NULL) {+ x = strcmp(str, (*ptree)->name);
+ if (x == 0)
+ return ptree;
+ if (x < 0)
+ ptree = &(*ptree)->left;
+ else
+ ptree = &(*ptree)->right;
+ }
+ return ptree;
+}
+
+value_t symbol(char *str)
+{+ symbol_t **pnode;
+
+ pnode = symtab_lookup(&symtab, str);
+ if (*pnode == NULL)
+ *pnode = mk_symbol(str);
+ return tagptr(*pnode, TAG_SYM);
+}
+
+// initialization -------------------------------------------------------------
+
+static unsigned char *fromspace;
+static unsigned char *tospace;
+static unsigned char *curheap;
+static unsigned char *lim;
+static u_int32_t heapsize = 64*1024;//bytes
+
+void lisp_init(void)
+{+ int i;
+
+ fromspace = malloc(heapsize);
+ tospace = malloc(heapsize);
+ curheap = fromspace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ NIL = symbol("nil"); setc(NIL, NIL);+ T = symbol("t"); setc(T, T);+ LAMBDA = symbol("lambda");+ MACRO = symbol("macro");+ LABEL = symbol("label");+ QUOTE = symbol("quote");+ for (i=0; i < (int)N_BUILTINS; i++)
+ setc(symbol(builtin_names[i]), builtin(i));
+ setc(symbol("princ"), builtin(F_PRINT));+}
+
+// conses ---------------------------------------------------------------------
+
+void gc(void);
+
+static value_t mk_cons(void)
+{+ cons_t *c;
+
+ if (curheap > lim)
+ gc();
+ c = (cons_t*)curheap;
+ curheap += sizeof(cons_t);
+ return tagptr(c, TAG_CONS);
+}
+
+static value_t cons_(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ return c;
+}
+
+value_t *cons(value_t *pcar, value_t *pcdr)
+{+ value_t c = mk_cons();
+ car_(c) = *pcar; cdr_(c) = *pcdr;
+ PUSH(c);
+ return &Stack[SP-1];
+}
+
+// collector ------------------------------------------------------------------
+
+static value_t relocate(value_t v)
+{+ value_t a, d, nc;
+
+ if (!iscons(v))
+ return v;
+ if (car_(v) == UNBOUND)
+ return cdr_(v);
+ nc = mk_cons(); car_(nc) = NIL;
+ a = car_(v); d = cdr_(v);
+ car_(v) = UNBOUND; cdr_(v) = nc;
+ car_(nc) = relocate(a);
+ cdr_(nc) = relocate(d);
+ return nc;
+}
+
+static void trace_globals(symbol_t *root)
+{+ while (root != NULL) {+ root->binding = relocate(root->binding);
+ trace_globals(root->left);
+ root = root->right;
+ }
+}
+
+void gc(void)
+{+ static int grew = 0;
+ unsigned char *temp;
+ u_int32_t i;
+
+ curheap = tospace;
+ lim = curheap+heapsize-sizeof(cons_t);
+
+ for (i=0; i < SP; i++)
+ Stack[i] = relocate(Stack[i]);
+ trace_globals(symtab);
+#ifdef VERBOSEGC
+ printf("gc found %d/%d live conses\n", (curheap-tospace)/8, heapsize/8);+#endif
+ temp = tospace;
+ tospace = fromspace;
+ fromspace = temp;
+
+ // if we're using > 80% of the space, resize tospace so we have
+ // more space to fill next time. if we grew tospace last time,
+ // grow the other half of the heap this time to catch up.
+ if (grew || ((lim-curheap) < (int)(heapsize/5))) {+ temp = realloc(tospace, grew ? heapsize : heapsize*2);
+ if (temp == NULL)
+ lerror("out of memory\n");+ tospace = temp;
+ if (!grew)
+ heapsize*=2;
+ grew = !grew;
+ }
+ if (curheap > lim) // all data was live
+ gc();
+}
+
+// read -----------------------------------------------------------------------
+
+enum {+ TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM
+};
+
+static int symchar(char c)
+{+ static char *special = "()';\\|";
+ return (!isspace(c) && !strchr(special, c));
+}
+
+static u_int32_t toktype = TOK_NONE;
+static value_t tokval;
+static char buf[256];
+
+static char nextchar(FILE *f)
+{+ char c;
+ int ch;
+
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ c = (char)ch;
+ if (c == ';') {+ // single-line comment
+ do {+ ch = fgetc(f);
+ if (ch == EOF)
+ return 0;
+ } while ((char)ch != '\n');
+ c = (char)ch;
+ }
+ } while (isspace(c));
+ return c;
+}
+
+static void take(void)
+{+ toktype = TOK_NONE;
+}
+
+static void accumchar(char c, int *pi)
+{+ buf[(*pi)++] = c;
+ if (*pi >= (int)(sizeof(buf)-1))
+ lerror("read: error: token too long\n");+}
+
+static int read_token(FILE *f, char c)
+{+ int i=0, ch, escaped=0;
+
+ ungetc(c, f);
+ while (1) {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ c = (char)ch;
+ if (c == '|') {+ escaped = !escaped;
+ }
+ else if (c == '\\') {+ ch = fgetc(f);
+ if (ch == EOF)
+ goto terminate;
+ accumchar((char)ch, &i);
+ }
+ else if (!escaped && !symchar(c)) {+ break;
+ }
+ else {+ accumchar(c, &i);
+ }
+ }
+ ungetc(c, f);
+ terminate:
+ buf[i++] = '\0';
+ return i;
+}
+
+static u_int32_t peek(FILE *f)
+{+ char c, *end;
+ number_t x;
+
+ if (toktype != TOK_NONE)
+ return toktype;
+ c = nextchar(f);
+ if (feof(f)) return TOK_NONE;
+ if (c == '(') {+ toktype = TOK_OPEN;
+ }
+ else if (c == ')') {+ toktype = TOK_CLOSE;
+ }
+ else if (c == '\'') {+ toktype = TOK_QUOTE;
+ }
+ else if (isdigit(c) || c=='-') {+ read_token(f, c);
+ if (buf[0] == '-' && !isdigit(buf[1])) {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ else {+ x = strtonum(buf, &end);
+ if (*end != '\0')
+ lerror("read: error: invalid constant\n");+ toktype = TOK_NUM;
+ tokval = number(x);
+ }
+ }
+ else {+ read_token(f, c);
+ if (!strcmp(buf, ".")) {+ toktype = TOK_DOT;
+ }
+ else {+ toktype = TOK_SYM;
+ tokval = symbol(buf);
+ }
+ }
+ return toktype;
+}
+
+// build a list of conses. this is complicated by the fact that all conses
+// can move whenever a new cons is allocated. we have to refer to every cons
+// through a handle to a relocatable pointer (i.e. a pointer on the stack).
+static void read_list(FILE *f, value_t *pval)
+{+ value_t c, *pc;
+ u_int32_t t;
+
+ PUSH(NIL);
+ pc = &Stack[SP-1]; // to keep track of current cons cell
+ t = peek(f);
+ while (t != TOK_CLOSE) {+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ c = mk_cons(); car_(c) = cdr_(c) = NIL;
+ if (iscons(*pc))
+ cdr_(*pc) = c;
+ else
+ *pval = c;
+ *pc = c;
+ c = read_sexpr(f); // must be on separate lines due to undefined
+ car_(*pc) = c; // evaluation order
+
+ t = peek(f);
+ if (t == TOK_DOT) {+ take();
+ c = read_sexpr(f);
+ cdr_(*pc) = c;
+ t = peek(f);
+ if (feof(f))
+ lerror("read: error: unexpected end of input\n");+ if (t != TOK_CLOSE)
+ lerror("read: error: expected ')'\n");+ }
+ }
+ take();
+ POP();
+}
+
+value_t read_sexpr(FILE *f)
+{+ value_t v;
+
+ switch (peek(f)) {+ case TOK_CLOSE:
+ take();
+ lerror("read: error: unexpected ')'\n");+ case TOK_DOT:
+ take();
+ lerror("read: error: unexpected '.'\n");+ case TOK_SYM:
+ case TOK_NUM:
+ take();
+ return tokval;
+ case TOK_QUOTE:
+ take();
+ v = read_sexpr(f);
+ PUSH(v);
+ v = cons_("E, cons(&Stack[SP-1], &NIL));
+ POPN(2);
+ return v;
+ case TOK_OPEN:
+ take();
+ PUSH(NIL);
+ read_list(f, &Stack[SP-1]);
+ return POP();
+ }
+ return NIL;
+}
+
+// print ----------------------------------------------------------------------
+
+void print(FILE *f, value_t v)
+{+ value_t cd;
+
+ switch (tag(v)) {+ case TAG_NUM: fprintf(f, NUM_FORMAT, numval(v)); break;
+ case TAG_SYM: fprintf(f, "%s", ((symbol_t*)ptr(v))->name); break;
+ case TAG_BUILTIN: fprintf(f, "#<builtin %s>",
+ builtin_names[intval(v)]); break;
+ case TAG_CONS:
+ fprintf(f, "(");+ while (1) {+ print(f, car_(v));
+ cd = cdr_(v);
+ if (!iscons(cd)) {+ if (cd != NIL) {+ fprintf(f, " . ");
+ print(f, cd);
+ }
+ fprintf(f, ")");
+ break;
+ }
+ fprintf(f, " ");
+ v = cd;
+ }
+ break;
+ }
+}
+
+// eval -----------------------------------------------------------------------
+
+static inline void argcount(char *fname, int nargs, int c)
+{+ if (nargs != c)
+ lerror("%s: error: too %s arguments\n", fname, nargs<c ? "few":"many");+}
+
+#define eval(e, penv) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv))
+#define tail_eval(xpr, env) do { SP = saveSP; \+ if (tag(xpr)<0x2) { return (xpr); } \+ else { e=(xpr); *penv=(env); goto eval_top; } } while (0)+
+value_t eval_sexpr(value_t e, value_t *penv)
+{+ value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
+ value_t *rest;
+ cons_t *c;
+ symbol_t *sym;
+ u_int32_t saveSP;
+ int i, nargs, noeval=0;
+ number_t s, n;
+
+ eval_top:
+ if (issymbol(e)) {+ sym = (symbol_t*)ptr(e);
+ if (sym->constant != UNBOUND) return sym->constant;
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e)
+ return cdr_(bind);
+ v = cdr_(v);
+ }
+ if ((v = sym->binding) == UNBOUND)
+ lerror("eval: error: variable %s has no value\n", sym->name);+ return v;
+ }
+ if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
+ lerror("eval: error: stack overflow\n");+ saveSP = SP;
+ PUSH(e);
+ PUSH(*penv);
+ f = eval(car_(e), penv);
+ *penv = Stack[saveSP+1];
+ if (isbuiltin(f)) {+ // handle builtin function
+ if (!isspecial(f)) {+ // evaluate argument list, placing arguments on stack
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ *penv = Stack[saveSP+1];
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ }
+ apply_builtin:
+ nargs = SP - saveSP - 2;
+ switch (intval(f)) {+ // special forms
+ case F_QUOTE:
+ v = cdr_(Stack[saveSP]);
+ if (!iscons(v))
+ lerror("quote: error: expected argument\n");+ v = car_(v);
+ break;
+ case F_MACRO:
+ case F_LAMBDA:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ // build a closure (lambda args body . env)
+ v = cdr_(v);
+ PUSH(car(v));
+ argsyms = &Stack[SP-1];
+ PUSH(car(cdr_(v)));
+ body = &Stack[SP-1];
+ v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
+ cons(argsyms, cons(body, penv)));
+ }
+ break;
+ case F_LABEL:
+ v = Stack[saveSP];
+ if (*penv != NIL) {+ v = cdr_(v);
+ PUSH(car(v)); // name
+ pv = &Stack[SP-1];
+ PUSH(car(cdr_(v))); // function
+ body = &Stack[SP-1];
+ *body = eval(*body, penv); // evaluate lambda
+ v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
+ }
+ break;
+ case F_IF:
+ v = car(cdr_(Stack[saveSP]));
+ if (eval(v, penv) != NIL)
+ v = car(cdr_(cdr_(Stack[saveSP])));
+ else
+ v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
+ tail_eval(v, Stack[saveSP+1]);
+ break;
+ case F_COND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ while (iscons(*pv)) {+ c = tocons(car_(*pv), "cond");
+ v = eval(c->car, penv);
+ *penv = Stack[saveSP+1];
+ if (v != NIL) {+ *pv = cdr_(car_(*pv));
+ // evaluate body forms
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv), penv);
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ }
+ *pv = cdr_(*pv);
+ }
+ break;
+ case F_AND:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = T;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv), penv)) == NIL) {+ SP = saveSP; return NIL;
+ }
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ case F_OR:
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ if ((v=eval(car_(*pv), penv)) != NIL) {+ SP = saveSP; return v;
+ }
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+ case F_WHILE:
+ PUSH(car(cdr(cdr_(Stack[saveSP]))));
+ body = &Stack[SP-1];
+ Stack[saveSP] = car_(cdr_(Stack[saveSP]));
+ value_t *cond = &Stack[saveSP];
+ PUSH(NIL); pv = &Stack[SP-1];
+ while (eval(*cond, penv) != NIL) {+ *penv = Stack[saveSP+1];
+ *pv = eval(*body, penv);
+ *penv = Stack[saveSP+1];
+ }
+ v = *pv;
+ break;
+ case F_PROGN:
+ // return last arg
+ Stack[saveSP] = cdr_(Stack[saveSP]);
+ pv = &Stack[saveSP]; v = NIL;
+ if (iscons(*pv)) {+ while (iscons(cdr_(*pv))) {+ v = eval(car_(*pv), penv);
+ *penv = Stack[saveSP+1];
+ *pv = cdr_(*pv);
+ }
+ tail_eval(car_(*pv), *penv);
+ }
+ break;
+
+ // ordinary functions
+ case F_SET:
+ argcount("set", nargs, 2);+ e = Stack[SP-2];
+ v = *penv;
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == e) {+ cdr_(bind) = (v=Stack[SP-1]);
+ SP=saveSP; return v;
+ }
+ v = cdr_(v);
+ }
+ tosymbol(e, "set")->binding = (v=Stack[SP-1]);
+ break;
+ case F_BOUNDP:
+ argcount("boundp", nargs, 1);+ if (tosymbol(Stack[SP-1], "boundp")->binding == UNBOUND)
+ v = NIL;
+ else
+ v = T;
+ break;
+ case F_EQ:
+ argcount("eq", nargs, 2);+ v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
+ break;
+ case F_CONS:
+ argcount("cons", nargs, 2);+ v = mk_cons();
+ car_(v) = Stack[SP-2];
+ cdr_(v) = Stack[SP-1];
+ break;
+ case F_CAR:
+ argcount("car", nargs, 1);+ v = car(Stack[SP-1]);
+ break;
+ case F_CDR:
+ argcount("cdr", nargs, 1);+ v = cdr(Stack[SP-1]);
+ break;
+ case F_RPLACA:
+ argcount("rplaca", nargs, 2);+ car(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_RPLACD:
+ argcount("rplacd", nargs, 2);+ cdr(v=Stack[SP-2]) = Stack[SP-1];
+ break;
+ case F_ATOM:
+ argcount("atom", nargs, 1);+ v = ((!iscons(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_SYMBOLP:
+ argcount("symbolp", nargs, 1);+ v = ((issymbol(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_NUMBERP:
+ argcount("numberp", nargs, 1);+ v = ((isnumber(Stack[SP-1])) ? T : NIL);
+ break;
+ case F_ADD:
+ s = 0;
+ for (i=saveSP+2; i < (int)SP; i++) {+ n = tonumber(Stack[i], "+");
+ s += n;
+ }
+ v = number(s);
+ break;
+ case F_SUB:
+ if (nargs < 1)
+ lerror("-: error: too few arguments\n");+ i = saveSP+2;
+ s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "-");
+ s -= n;
+ }
+ v = number(s);
+ break;
+ case F_MUL:
+ s = 1;
+ for (i=saveSP+2; i < (int)SP; i++) {+ n = tonumber(Stack[i], "*");
+ s *= n;
+ }
+ v = number(s);
+ break;
+ case F_DIV:
+ if (nargs < 1)
+ lerror("/: error: too few arguments\n");+ i = saveSP+2;
+ s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
+ for (; i < (int)SP; i++) {+ n = tonumber(Stack[i], "/");
+ if (n == 0)
+ lerror("/: error: division by zero\n");+ s /= n;
+ }
+ v = number(s);
+ break;
+ case F_LT:
+ argcount("<", nargs, 2);+ if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
+ v = T;
+ else
+ v = NIL;
+ break;
+ case F_NOT:
+ argcount("not", nargs, 1);+ v = ((Stack[SP-1] == NIL) ? T : NIL);
+ break;
+ case F_EVAL:
+ argcount("eval", nargs, 1);+ v = Stack[SP-1];
+ tail_eval(v, NIL);
+ break;
+ case F_PRINT:
+ for (i=saveSP+2; i < (int)SP; i++)
+ print(stdout, v=Stack[i]);
+ break;
+ case F_READ:
+ argcount("read", nargs, 0);+ v = read_sexpr(stdin);
+ break;
+ case F_LOAD:
+ argcount("load", nargs, 1);+ v = load_file(tosymbol(Stack[SP-1], "load")->name);
+ break;
+ case F_PROG1:
+ // return first arg
+ if (nargs < 1)
+ lerror("prog1: error: too few arguments\n");+ v = Stack[saveSP+2];
+ break;
+ case F_APPLY:
+ argcount("apply", nargs, 2);+ v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
+ f = Stack[SP-2]; // first arg is new function
+ POPN(2); // pop apply's args
+ if (isbuiltin(f)) {+ if (isspecial(f))
+ lerror("apply: error: cannot apply special operator "+ "%s\n", builtin_names[intval(f)]);
+ // unpack arglist onto the stack
+ while (iscons(v)) {+ PUSH(car_(v));
+ v = cdr_(v);
+ }
+ goto apply_builtin;
+ }
+ noeval = 1;
+ goto apply_lambda;
+ }
+ SP = saveSP;
+ return v;
+ }
+ else {+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ apply_lambda:
+ if (iscons(f)) {+ headsym = car_(f);
+ if (headsym == LABEL) {+ // (label name (lambda ...)) behaves the same as the lambda
+ // alone, except with name bound to the whole label expression
+ labl = f;
+ f = car(cdr(cdr_(labl)));
+ headsym = car(f);
+ }
+ // apply lambda or macro expression
+ PUSH(cdr(cdr(cdr_(f))));
+ lenv = &Stack[SP-1];
+ PUSH(car_(cdr_(f)));
+ argsyms = &Stack[SP-1];
+ PUSH(car_(cdr_(cdr_(f))));
+ body = &Stack[SP-1];
+ if (labl) {+ // add label binding to environment
+ PUSH(labl);
+ PUSH(car_(cdr_(labl)));
+ *lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
+ POPN(3);
+ v = Stack[saveSP]; // refetch arglist
+ }
+ if (headsym == MACRO)
+ noeval = 1;
+ else if (headsym != LAMBDA)
+ lerror("apply: error: head must be lambda, macro, or label\n");+ // build a calling environment for the lambda
+ // the environment is the argument binds on top of the captured
+ // environment
+ while (iscons(v)) {+ // bind args
+ if (!iscons(*argsyms)) {+ if (*argsyms == NIL)
+ lerror("apply: error: too many arguments\n");+ break;
+ }
+ asym = car_(*argsyms);
+ if (!issymbol(asym))
+ lerror("apply: error: formal argument not a symbol\n");+ v = car_(v);
+ if (!noeval) {+ v = eval(v, penv);
+ *penv = Stack[saveSP+1];
+ }
+ PUSH(v);
+ *lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
+ POPN(2);
+ *argsyms = cdr_(*argsyms);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if (*argsyms != NIL) {+ if (issymbol(*argsyms)) {+ if (noeval) {+ *lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
+ }
+ else {+ PUSH(NIL);
+ PUSH(NIL);
+ rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v), penv);
+ *penv = Stack[saveSP+1];
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ *lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
+ }
+ }
+ else if (iscons(*argsyms)) {+ lerror("apply: error: too few arguments\n");+ }
+ }
+ noeval = 0;
+ // macro: evaluate expansion in the calling environment
+ if (headsym == MACRO) {+ SP = saveSP;
+ PUSH(*lenv);
+ lenv = &Stack[SP-1];
+ v = eval(*body, lenv);
+ tail_eval(v, *penv);
+ }
+ else {+ tail_eval(*body, *lenv);
+ }
+ // not reached
+ }
+ type_error("apply", "function", f);+ return NIL;
+}
+
+// repl -----------------------------------------------------------------------
+
+static char *infile = NULL;
+
+value_t toplevel_eval(value_t expr)
+{+ value_t v;
+ PUSH(NIL);
+ v = eval(expr, &Stack[SP-1]);
+ POP();
+ return v;
+}
+
+value_t load_file(char *fname)
+{+ value_t e, v=NIL;
+ char *lastfile = infile;
+ FILE *f = fopen(fname, "r");
+ infile = fname;
+ if (f == NULL) lerror("file not found\n");+ while (1) {+ e = read_sexpr(f);
+ if (feof(f)) break;
+ v = toplevel_eval(e);
+ }
+ infile = lastfile;
+ fclose(f);
+ return v;
+}
+
+int main(int argc, char* argv[])
+{+ value_t v;
+
+ stack_bottom = ((char*)&v) - PROCESS_STACK_SIZE;
+ lisp_init();
+ if (setjmp(toplevel)) {+ SP = 0;
+ fprintf(stderr, "\n");
+ if (infile) {+ fprintf(stderr, "error loading file \"%s\"\n", infile);
+ infile = NULL;
+ }
+ goto repl;
+ }
+ load_file("system.lsp");+ if (argc > 1) { load_file(argv[1]); return 0; }+ printf("Welcome to femtoLisp ----------------------------------------------------------\n");+ repl:
+ while (1) {+ printf("> ");+ v = read_sexpr(stdin);
+ if (feof(stdin)) break;
+ print(stdout, v=toplevel_eval(v));
+ set(symbol("that"), v);+ printf("\n\n");+ }
+ return 0;
+}
--- /dev/null
+++ b/tiny/scrap.c
@@ -1,0 +1,107 @@
+// code to relocate cons chains iteratively
+ pcdr = &cdr_(nc);
+ while (iscons(d)) {+ if (car_(d) == FWD) {+ *pcdr = cdr_(d);
+ return first;
+ }
+ *pcdr = nc = mk_cons();
+ a = car_(d); v = cdr_(d);
+ car_(d) = FWD; cdr_(d) = nc;
+ car_(nc) = relocate(a);
+ pcdr = &cdr_(nc);
+ d = v;
+ }
+ *pcdr = d;
+
+/*
+ f = *rest;
+ *rest = NIL;
+ while (iscons(f)) { // nreverse!+ v = cdr_(f);
+ cdr_(f) = *rest;
+ *rest = f;
+ f = v;
+ }*/
+
+int favailable(FILE *f)
+{+ fd_set set;
+ struct timeval tv = {0, 0};+ int fd = fileno(f);
+
+ FD_ZERO(&set);
+ FD_SET(fd, &set);
+ return (select(fd+1, &set, NULL, NULL, &tv)!=0);
+}
+
+static void print_env(value_t *penv)
+{+ printf("<[ ");+ while (issymbol(*penv) && *penv!=NIL) {+ print(stdout, *penv, 0);
+ printf(" ");+ penv++;
+ print(stdout, *penv, 0);
+ printf(" ");+ penv++;
+ }
+ printf("] ");+ print(stdout, *penv, 0);
+ printf(">\n");+}
+
+#else
+ PUSH(NIL);
+ PUSH(NIL);
+ value_t *rest = &Stack[SP-1];
+ // build list of rest arguments
+ // we have to build it forwards, which is tricky
+ while (iscons(v)) {+ v = eval(car_(v));
+ PUSH(v);
+ v = cons_(&Stack[SP-1], &NIL);
+ POP();
+ if (iscons(*rest))
+ cdr_(*rest) = v;
+ else
+ Stack[SP-2] = v;
+ *rest = v;
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ POP();
+#endif
+ // this version uses collective allocation. about 7-10%
+ // faster for lists with > 2 elements, but uses more
+ // stack space
+ i = SP;
+ while (iscons(v)) {+ v = eval(car_(v));
+ PUSH(v);
+ v = Stack[saveSP] = cdr_(Stack[saveSP]);
+ }
+ if ((int)SP==i) {+ PUSH(NIL);
+ }
+ else {+ e = v = cons_reserve(nargs=(SP-i));
+ for(; i < (int)SP; i++) {+ car_(v) = Stack[i];
+ v = cdr_(v);
+ }
+ POPN(nargs);
+ PUSH(e);
+ }
+
+value_t list_to_vector(value_t l)
+{+ value_t v;
+ size_t n = llength(l), i=0;
+ v = alloc_vector(n, 0);
+ while (iscons(l)) {+ vector_elt(v,i) = car_(l);
+ i++;
+ l = cdr_(l);
+ }
+ return v;
+}
--- /dev/null
+++ b/tiny/system.lsp
@@ -1,0 +1,426 @@
+; femtoLisp standard library
+; by Jeff Bezanson
+; Public Domain
+
+(set 'list (lambda args args))
+
+(set 'setq (macro (name val)
+ (list set (list quote name) val)))
+
+(setq sp '| |)
+(setq nl '|
+|)
+
+; convert a sequence of body statements to a single expression.
+; this allows define, defun, defmacro, let, etc. to contain multiple
+; body expressions as in Common Lisp.
+(setq f-body (lambda (e)
+ (cond ((atom e) e)
+ ((eq (cdr e) ()) (car e))
+ (t (cons progn e)))))
+
+(setq defmacro
+ (macro (name args . body)
+ (list 'setq name (list 'macro args (f-body body)))))
+
+; support both CL defun and Scheme-style define
+(defmacro defun (name args . body)
+ (list 'setq name (list 'lambda args (f-body body))))
+
+(defmacro define (name . body)
+ (if (symbolp name)
+ (list 'setq name (car body))
+ (cons 'defun (cons (car name) (cons (cdr name) body)))))
+
+(defun identity (x) x)
+(setq null not)
+(defun consp (x) (not (atom x)))
+
+(defun map (f lst)
+ (if (atom lst) lst
+ (cons (f (car lst)) (map f (cdr lst)))))
+
+(defmacro let (binds . body)
+ (cons (list 'lambda (map car binds) (f-body body))
+ (map cadr binds)))
+
+(defun nconc lsts
+ (cond ((null lsts) ())
+ ((null (cdr lsts)) (car lsts))
+ (t ((lambda (l d) (if (null l) d
+ (prog1 l
+ (while (consp (cdr l)) (set 'l (cdr l)))
+ (rplacd l d))))
+ (car lsts) (apply nconc (cdr lsts))))))
+
+(defun append lsts
+ (cond ((null lsts) ())
+ ((null (cdr lsts)) (car lsts))
+ (t ((label append2 (lambda (l d)
+ (if (null l) d
+ (cons (car l)
+ (append2 (cdr l) d)))))
+ (car lsts) (apply append (cdr lsts))))))
+
+(defun member (item lst)
+ (cond ((atom lst) ())
+ ((eq (car lst) item) lst)
+ (t (member item (cdr lst)))))
+
+(defun macrop (e) (and (consp e) (eq (car e) 'macro) e))
+(defun macrocallp (e) (and (symbolp (car e))
+ (boundp (car e))
+ (macrop (eval (car e)))))
+(defun macroapply (m args) (apply (cons 'lambda (cdr m)) args))
+
+(defun macroexpand-1 (e)
+ (if (atom e) e
+ (let ((f (macrocallp e)))
+ (if f (macroapply f (cdr e))
+ e))))
+
+; convert to proper list, i.e. remove "dots", and append
+(defun append.2 (l tail)
+ (cond ((null l) tail)
+ ((atom l) (cons l tail))
+ (t (cons (car l) (append.2 (cdr l) tail)))))
+
+(defun macroexpand (e)
+ ((label mexpand
+ (lambda (e env f)
+ (progn
+ (while (and (consp e)
+ (not (member (car e) env))
+ (set 'f (macrocallp e)))
+ (set 'e (macroapply f (cdr e))))
+ (if (and (consp e)
+ (not (or (eq (car e) 'quote)
+ (eq (car e) quote))))
+ (let ((newenv
+ (if (and (or (eq (car e) 'lambda) (eq (car e) 'macro))
+ (consp (cdr e)))
+ (append.2 (cadr e) env)
+ env)))
+ (map (lambda (x) (mexpand x newenv nil)) e))
+ e))))
+ e nil nil))
+
+; uncomment this to macroexpand functions at definition time.
+; makes typical code ~25% faster, but only works for defun expressions
+; at the top level.
+;(defmacro defun (name args . body)
+; (list 'setq name (list 'lambda args (macroexpand (f-body body)))))
+
+; same thing for macros. enabled by default because macros are usually
+; defined at the top level.
+(defmacro defmacro (name args . body)
+ (list 'setq name (list 'macro args (macroexpand (f-body body)))))
+
+(setq = eq)
+(setq eql eq)
+(define (/= a b) (not (eq a b)))
+(define != /=)
+(define (> a b) (< b a))
+(define (<= a b) (not (< b a)))
+(define (>= a b) (not (< a b)))
+(define (mod x y) (- x (* (/ x y) y)))
+(define (abs x) (if (< x 0) (- x) x))
+(define (truncate x) x)
+(setq K prog1) ; K combinator ;)
+(define (funcall f . args) (apply f args))
+(define (symbol-function sym) (eval sym))
+(define (symbol-value sym) (eval sym))
+
+(define (caar x) (car (car x)))
+(define (cadr x) (car (cdr x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (car (cdr x))))
+(define (cadar x) (car (cdr (car x))))
+(define (caddr x) (car (cdr (cdr x))))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (car (cdr x))))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+
+(define (equal a b)
+ (if (and (consp a) (consp b))
+ (and (equal (car a) (car b))
+ (equal (cdr a) (cdr b)))
+ (eq a b)))
+
+; compare imposes an ordering on all values. yields -1 for a<b,
+; 0 for a==b, and 1 for a>b. lists are compared up to the first
+; point of difference.
+(defun compare (a b)
+ (cond ((eq a b) 0)
+ ((or (atom a) (atom b)) (if (< a b) -1 1))
+ (t (let ((c (compare (car a) (car b))))
+ (if (not (eq c 0))
+ c
+ (compare (cdr a) (cdr b)))))))
+
+(defun every (pred lst)
+ (or (atom lst)
+ (and (pred (car lst))
+ (every pred (cdr lst)))))
+
+(defun any (pred lst)
+ (and (consp lst)
+ (or (pred (car lst))
+ (any pred (cdr lst)))))
+
+(defun listp (a) (or (eq a ()) (consp a)))
+
+(defun length (l)
+ (if (null l) 0
+ (+ 1 (length (cdr l)))))
+
+(defun nthcdr (n lst)
+ (if (<= n 0) lst
+ (nthcdr (- n 1) (cdr lst))))
+
+(defun list-ref (lst n)
+ (car (nthcdr n lst)))
+
+(defun list* l
+ (if (atom (cdr l))
+ (car l)
+ (cons (car l) (apply list* (cdr l)))))
+
+(defun nlist* l
+ (if (atom (cdr l))
+ (car l)
+ (rplacd l (apply nlist* (cdr l)))))
+
+(defun lastcdr (l)
+ (if (atom l) l
+ (lastcdr (cdr l))))
+
+(defun last (l)
+ (cond ((atom l) l)
+ ((atom (cdr l)) l)
+ (t (last (cdr l)))))
+
+(defun map! (f lst)
+ (prog1 lst
+ (while (consp lst)
+ (rplaca lst (f (car lst)))
+ (set 'lst (cdr lst)))))
+
+(defun mapcar (f . lsts)
+ ((label mapcar-
+ (lambda (lsts)
+ (cond ((null lsts) (f))
+ ((atom (car lsts)) (car lsts))
+ (t (cons (apply f (map car lsts))
+ (mapcar- (map cdr lsts)))))))
+ lsts))
+
+(defun transpose (M) (apply mapcar (cons list M)))
+
+(defun filter (pred lst)
+ (cond ((null lst) ())
+ ((not (pred (car lst))) (filter pred (cdr lst)))
+ (t (cons (car lst) (filter pred (cdr lst))))))
+
+(define (foldr f zero lst)
+ (if (null lst) zero
+ (f (car lst) (foldr f zero (cdr lst)))))
+
+(define (foldl f zero lst)
+ (if (null lst) zero
+ (foldl f (f (car lst) zero) (cdr lst))))
+
+(define (reverse lst) (foldl cons nil lst))
+
+(define (reduce0 f zero lst)
+ (if (null lst) zero
+ (reduce0 f (f zero (car lst)) (cdr lst))))
+
+(defun reduce (f lst)
+ (reduce0 f (car lst) (cdr lst)))
+
+(define (copy-list l) (map identity l))
+(define (copy-tree l)
+ (if (atom l) l
+ (cons (copy-tree (car l))
+ (copy-tree (cdr l)))))
+
+(define (assoc item lst)
+ (cond ((atom lst) ())
+ ((eq (caar lst) item) (car lst))
+ (t (assoc item (cdr lst)))))
+
+(define (nreverse l)
+ (let ((prev nil))
+ (while (consp l)
+ (set 'l (prog1 (cdr l)
+ (rplacd l (prog1 prev
+ (set 'prev l))))))
+ prev))
+
+(defmacro let* (binds . body)
+ (cons (list 'lambda (map car binds)
+ (cons progn
+ (nconc (map (lambda (b) (cons 'setq b)) binds)
+ body)))
+ (map (lambda (x) nil) binds)))
+
+(defmacro labels (binds . body)
+ (cons (list 'lambda (map car binds)
+ (cons progn
+ (nconc (map (lambda (b)
+ (list 'setq (car b) (cons 'lambda (cdr b))))
+ binds)
+ body)))
+ (map (lambda (x) nil) binds)))
+
+(defmacro when (c . body) (list if c (f-body body) nil))
+(defmacro unless (c . body) (list if c nil (f-body body)))
+
+(defmacro dotimes (var . body)
+ (let ((v (car var))
+ (cnt (cadr var)))
+ (list 'let (list (list v 0))
+ (list while (list < v cnt)
+ (list prog1 (f-body body) (list 'setq v (list + v 1)))))))
+
+(defun map-int (f n)
+ (let ((acc nil))
+ (dotimes (i n)
+ (setq acc (cons (f i) acc)))
+ (nreverse acc)))
+
+; property lists
+(setq *plists* nil)
+
+(defun symbol-plist (sym)
+ (cdr (or (assoc sym *plists*) '(()))))
+
+(defun set-symbol-plist (sym lst)
+ (let ((p (assoc sym *plists*)))
+ (if (null p) ; sym has no plist yet
+ (setq *plists* (cons (cons sym lst) *plists*))
+ (rplacd p lst))))
+
+(defun get (sym prop)
+ (let ((pl (symbol-plist sym)))
+ (if pl
+ (let ((pr (member prop pl)))
+ (if pr (cadr pr) nil))
+ nil)))
+
+(defun put (sym prop val)
+ (let ((p (assoc sym *plists*)))
+ (if (null p) ; sym has no plist yet
+ (setq *plists* (cons (list sym prop val) *plists*))
+ (let ((pr (member prop p)))
+ (if (null pr) ; sym doesn't have this property yet
+ (rplacd p (cons prop (cons val (cdr p))))
+ (rplaca (cdr pr) val)))))
+ val)
+
+; setf
+; expands (setf (place x ...) v) to (mutator (f x ...) v)
+; (mutator (identity x ...) v) is interpreted as (mutator x ... v)
+(setq *setf-place-list*
+ ; place mutator f
+ '((car rplaca identity)
+ (cdr rplacd identity)
+ (caar rplaca car)
+ (cadr rplaca cdr)
+ (cdar rplacd car)
+ (cddr rplacd cdr)
+ (caaar rplaca caar)
+ (caadr rplaca cadr)
+ (cadar rplaca cdar)
+ (caddr rplaca cddr)
+ (cdaar rplacd caar)
+ (cdadr rplacd cadr)
+ (cddar rplacd cdar)
+ (cdddr rplacd cddr)
+ (get put identity)
+ (aref aset identity)
+ (symbol-function set identity)
+ (symbol-value set identity)
+ (symbol-plist set-symbol-plist identity)))
+
+(defun setf-place-mutator (place val)
+ (if (symbolp place)
+ (list 'setq place val)
+ (let ((mutator (assoc (car place) *setf-place-list*)))
+ (if (null mutator)
+ (error '|setf: error: unknown place | (car place))
+ (if (eq (caddr mutator) 'identity)
+ (cons (cadr mutator) (append (cdr place) (list val)))
+ (list (cadr mutator)
+ (cons (caddr mutator) (cdr place))
+ val))))))
+
+(defmacro setf args
+ (f-body
+ ((label setf-
+ (lambda (args)
+ (if (null args)
+ nil
+ (cons (setf-place-mutator (car args) (cadr args))
+ (setf- (cddr args))))))
+ args)))
+
+(defun revappend (l1 l2) (nconc (reverse l1) l2))
+(defun nreconc (l1 l2) (nconc (nreverse l1) l2))
+
+(defun builtinp (x)
+ (and (atom x)
+ (not (symbolp x))
+ (not (numberp x))))
+
+(defun self-evaluating-p (x)
+ (or (eq x nil)
+ (eq x t)
+ (and (atom x)
+ (not (symbolp x)))))
+
+; backquote
+(defmacro backquote (x) (bq-process x))
+
+(defun splice-form-p (x)
+ (or (and (consp x) (or (eq (car x) '*comma-at*)
+ (eq (car x) '*comma-dot*)))
+ (eq x '*comma*)))
+
+(defun bq-process (x)
+ (cond ((self-evaluating-p x) x)
+ ((atom x) (list quote x))
+ ((eq (car x) 'backquote) (bq-process (bq-process (cadr x))))
+ ((eq (car x) '*comma*) (cadr x))
+ ((not (any splice-form-p x))
+ (let ((lc (lastcdr x))
+ (forms (map bq-bracket1 x)))
+ (if (null lc)
+ (cons 'list forms)
+ (nconc (cons 'nlist* forms) (list (bq-process lc))))))
+ (t (let ((p x) (q '()))
+ (while (and (consp p)
+ (not (eq (car p) '*comma*)))
+ (setq q (cons (bq-bracket (car p)) q))
+ (setq p (cdr p)))
+ (cons 'nconc
+ (cond ((consp p) (nreconc q (list (cadr p))))
+ ((null p) (nreverse q))
+ (t (nreconc q (list (bq-process p))))))))))
+
+(defun bq-bracket (x)
+ (cond ((atom x) (list cons (bq-process x) nil))
+ ((eq (car x) '*comma*) (list cons (cadr x) nil))
+ ((eq (car x) '*comma-at*) (list 'copy-list (cadr x)))
+ ((eq (car x) '*comma-dot*) (cadr x))
+ (t (list cons (bq-process x) nil))))
+
+; bracket without splicing
+(defun bq-bracket1 (x)
+ (if (and (consp x) (eq (car x) '*comma*))
+ (cadr x)
+ (bq-process x)))
--- /dev/null
+++ b/todo
@@ -1,0 +1,1199 @@
+* setf
+* plists
+* backquote
+* symbol< (make < generic), generic compare function
+? (cdr nil) should be nil
+* multiple-argument mapcar
+? multi-argument apply. for builtins, just push them. for lambdas, must
+ cons together the evaluated arguments.
+? option *print-shared*. if nil, it still handles circular references
+ but does not specially print non-circular shared structure
+? option *print-circle*
+* read support for #' for compatibility
+* #\c read character as code (including UTF-8 support!)
+* #| |# block comments
+? here-data for binary serialization. proposed syntax:
+ #>size:data, e.g. #>6:000000
+? better read syntax for packed arrays, e.g. #double[3 1 4]
+* use syntax environment concept for user-defined macros to plug
+ that hole in the semantics
+* make more builtins generic. if typecheck fails, call out to the
+ generic version to try supporting more types.
+ compare/equal
+ +-*/< for all numeric types
+ length for all sequences
+ ? aref/aset for all sequences (vector, list, c-array)
+ ? copy
+* fixnump, all numeric types should pass numberp
+- make sure all uses of symbols don't assume symbols are unmovable without
+ checking ismanaged()
+* eliminate compiler warnings
+* fix printing nan and inf
+* move to "2.5-bit" type tags
+? builtin abs()
+* try adding optional arguments, (lambda (x (opt 0)) ...), see if performance
+ is acceptable
+* (syntax-environment) to return it as an assoc list
+* (environment) for variables, constantp
+* prettier printing
+
+* readable gensyms and #:
+ . #:n reads similar to #n=#.(gensym) the first time, and #n# after
+* circular equal
+* integer/truncate function
+? car-circularp, cdr-circularp, circularp
+- hashtable. plan as equal-hash, over three stages:
+ 1. first support symbol and fixnum keys, use ptrhash. only values get
+ relocated on GC.
+ 2. create a version of ptrhash that uses equal() and hash(). if a key is
+ inserted requiring this, switch vtable pointer to use these functions.
+ both keys and values get relocated on GC.
+ 3. write hash() for pairs and vectors. now everything works.
+- expose eq-hashtable to user
+- other backquote optimizations:
+ * (nconc x) => x for any x
+ . (copy-list (list|append|nconc ...)) => (list|append|nconc ...)
+ * (apply vector (list ...)) => (vector ...)
+ * (nconc (cons x nil) y) => (cons x y)
+* let form without initializers (let (a b) ...), defaults to nil
+* print (quote a) as 'a, same for ` etc.
+
+- template keyword arguments. you write
+(template (:test eq) (:key caar)
+ (defun assoc (item lst)
+ (cond ((atom lst) ())
+ ((:test (:key lst) item) (car lst))
+ (t (assoc item (cdr lst))))))
+
+This writes assoc as a macro that produces a call to a pre-specialized
+version of the function. For example
+ (assoc x l :test equal)
+first tries to look up the variant '(equal caar) in the dictionary for assoc.
+If it doesn't exist it gets generated and stored. The result is a lambda
+expression.
+The macro returns ((lambda (item lst) <code for assoc>) x l).
+We might have to require different syntax for template invocations inside
+template definitions, such as
+ ((t-instance assoc eq :key) item lst)
+which passes along the same key but always uses eq.
+Alternatively, we could use the keysyms without colons to name the values
+of the template arguments, so the keysyms are always used as markers and
+never appear to have values:
+(template (:test eq) (:key caar)
+ (defun assoc? (item lst)
+ (cond ((atom lst) ())
+ ((test (key lst) item) ...
+ ...
+ (assoc x y :test test :key key)
+This would be even easier if the keyword syntax were something like
+ (: test eq)
+
+
+possible optimizations:
+* delay environment creation. represent environment on the stack as
+ alternating symbols/values, or if cons instead of symbol then traverse
+ as assoc list. only explicitly cons the whole thing when making a closure
+* cons_reserve(n) interface, guarantees n conses available without gc.
+ it could even link them together for you more efficiently
+* assoc builtin
+* special check for constant symbol when evaluating head since that's likely
+* remove the loop from cons_reserve. move all initialization to the loops
+ that follow calls to cons_reserve.
+- case of lambda expression in head (as produced by let), can just modify
+ env in-place in tail position
+- allocate memory by mmap'ing a large uncommitted block that we cut
+ in half. then each half heap can be grown without moving addresses.
+* try making (list ...) a builtin by moving the list-building code to
+ a static function, see if vararg call performance is affected.
+- try making foldl a builtin, implement table iterator as table.foldl
+ . not great, since then it can't be CPS converted
+* represent lambda environment as a vector (in lispv)
+x setq builtin (didn't help)
+* list builtin, to use cons_reserve
+unconventional interpreter builtins that can be used as a compilation
+target without moving away from s-expressions:
+- (*global* . a) ; special form, don't look in local env first
+- (*local* . 2) ; direct stackframe access
+for internal use:
+* a special version of apply that takes arguments on the stack, to avoid
+ consing when implementing "call-with" style primitives like trycatch,
+ hashtable-foreach, or the fl_apply API
+- partial_apply, reapply interface so other iterators can use the same
+ fast mechanism as for
+* try this environment representation:
+ for all kinds of functions (except maybe builtin special forms) push
+ all arguments on the stack, either evaluated or not.
+ for lambdas, push the lambda list and next-env pointers.
+ to capture, save the n+2 pointers to a vector
+ . this uses n+2 heap or stack words per environment instead of 2n+1 words
+ . argument handling is more uniform which could lead to simplifications,
+ and a more efficient apply() entry point
+ . disadvantage is looking through the lambda list on every lookup. maybe
+ improve by making lambda lists vectors somehow?
+* fast builtin bounded iteration construct (for lo hi (lambda (x) ...))
+* represent guest function as a tagged function pointer; allocate nothing
+- when an instance of (array type n) is requested, use (array type)
+ instead, unless the value is part of an aggregate (e.g. struct).
+ . this avoids allocating a new type for every size.
+ . and/or add function array.alloc
+x preallocate all byte,int8,uint8 values, and some wchars (up to 0x31B7?)
+ . this made no difference in a string.map microbenchmark
+- use faster hash/compare in tables where the keys are eq-comparable
+- a way to do open-input-string without copying
+
+bugs:
+* with the fully recursive (simpler) relocate(), the size of cons chains
+ is limited by the process stack size. with the iterative version we can
+ have unlimited cdr-deep structures.
+* in #n='e, the case that makes the cons for 'e needs to use label fixup
+* symbol token |.| does not work
+* ltable realloc not multiplying by sizeof(unsigned long)
+* not relocating final cdr in iterative version if it is a vector
+- (setf (car x) y) doesn't return y
+* reader needs to check errno in isnumtok
+* prettyprint size measuring is not utf-8 correct
+* stack is too limited.
+ . add extra heap-allocated stack segments as needed.
+* argument list length is too limited.
+ need to fix it for: +,-,*,/,&,|,$,list,vector,apply,string,array
+ . for builtins, make Nth argument list of rest args
+ . write a function to evaluate directly from list to list, use it for
+ Nth arg and for user function rest args
+ . modify vararg builtins accordingly
+* filter should be stable. right now it reverses.
+
+
+femtoLisp3...with symbolic C interface
+
+c values are builtins with value > N_BUILTINS
+((u_int32_t*)cvalue)[0] & 0x3 must always be 2 to distinguish from vectors
+
+typedef struct _cvtable_t {+ void (*relocate)(struct _cvalue_t *);
+ void (*free)(struct _cvalue_t *);
+ void (*print)(struct _cvalue_t *, FILE *);
+} cvtable_t;
+
+c type representations:
+symbols void, [u]int[8,16,32,64], float, double, [u]char, [u]short,
+[u]int, [u]long, lispvalue
+(c-function ret-type (argtype ...))
+(array type[ N])
+(struct ((name type) (name type) ...))
+(union ((name type) (name type) ...))
+(mlayout ((name type offset) (name type offset) ...))
+(enum (name1 name2 ...))
+(pointer type)
+
+constructors:
+([u]int[8,16] n)
+([u]int32 hi lo)
+([u]int64 b3 b2 b1 b0)
+(float hi lo) or (float "3.14")
+(double b3 b2 b1 b0) or (double "3.14")
+(array ctype val ...)
+(struct ((name type) ...) val ...)
+(pointer ctype) ; null pointer
+(pointer cvalue) ; constructs pointer to the given value
+ ; same as (pointer (typeof x) x)
+(pointer ctype cvalue) ; pointer of given type, to given value
+(pointer ctype cvalue addr) ; (ctype*)((char*)cvalue + addr)
+(c-function ret-type (argtype ...) ld-symbol-name)
+
+? struct/enum tag:
+ (struct 'tag <initializer>) or (pointer (struct tag))
+ where tag is a global var with a value ((name type) ...)
+
+
+representing c data from lisp is the tricky part to make really elegant and
+efficient. the most elegant but too inefficient option is not to have opaque
+C values at all and always marshal to/from native lisp values like #int16[10].
+the next option is to have opaque values "sometimes", for example returning
+them from C functions but printing them using their lisp representations.
+the next option is to relax the idea that C values of a certain type have a
+specific lisp structure, and use a coercion system that "tries" to translate
+a lisp value to a specified C type. for example [0 1 2], (0 1 2),
+#string[0 1 2], etc. might all be accepted by a C function taking int8_t*.
+you could say (c-coerce <lispvalue> <typedesc>) and get a cvalue back or
+an error if the conversion fails.
+
+the final option is to have cvalues be the only officially-sanctioned
+representation of c data, and make them via constructors, like
+(int32 hi lo) returns an int32 cvalue
+(struct '((name type) (name type) ...) a b ...) makes a struct
+there is a constructor function for each primitive C type.
+you can print these by brute force as e.g. #.(int32 hi lo)
+then all checking just looks like functions checking their arguments
+
+this option seems almost ideal. what's wrong with it?
+. to construct cvalues from lisp you have to build code instead of data
+. it seems like it should take more explicit advantage of tagged vectors
+. should you accept multiple forms? for example
+ (array 'int8 0 1 2) or (array 'int8 [0 1 2])
+ if you're going to be that permissive, why not allow [0 1 2] to be passed
+ directly to a function that expects int8_t* and do the conversion
+ implicitly?
+ . even if these c-primitive-constructor functions exist, you can still
+ write things like c-coerce (in lisp, even) and hack in implicit
+ conversion attempts when something other than a cvalue is passed.
+. the printing code is annoying, because it's not enough to print readably,
+ you have to print evaluably.
+ . solution: constructor notation, #int32(hi lo)
+
+in any case, "opaque" cvalues will not really be opaque because we want to
+know their types and be able to take them apart on the byte level from lisp.
+C code can get references to lisp values and manipulate them using lisp
+operations like car, so to be fair it should work vice-versa; give
+c references to lisp code and let it use c operations like * on them.
+you can write lisp in c and c in lisp, though of course you don't usually
+want to. however, c written in lisp can be generated by a macro, printed,
+and fed to TCC for compilation.
+
+
+for a struct the names and types are parameters of the type, not the
+constructor, so it seems more correct to do
+
+((struct (name type) (name type) ...) (val val ...))
+
+where struct returns a constructor. but this isn't practical because it
+can't be printed in constructor notation and the type is a lambda rather
+than a more sensible expression.
+
+
+notice constructor calls and type representations are "similar". they
+should be related formally:
+
+(define (new type)
+ (if (symbolp type) (apply (eval type) ())
+ (apply (eval (car type)) (cdr type))))
+
+NOTE: this relationship is no longer true. we don't want to have to
+construct 1 cvalue from 1 lisp value every time, since that could
+require allocating a totally redundant list or vector. it should be
+possible to make a cvalue from a series of lisp arguments. for
+example there are now 2 different ways to make an array:
+
+1) from series of arguments: (array type val0 val1 ...)
+2) from 1 (optional) value: (c-value '(array int8[ size])[ V])
+
+constructors will internally use the second form to initialize elements
+of aggregates. e.g. 'array' in the first case will conceptually call
+ (c-value type val0)
+ (c-value type val1)
+ ...
+
+
+for aggregate types, you can keep a variable referring to the relevant
+piece:
+
+(setq point '((x int) (y int)))
+(struct point 2 3) ; looks like c declaration 'struct point x;'
+
+a type is a function, so something similar to typedef is achieved by:
+
+(define (point_t vals) (struct point vals))
+
+design points:
+. type constructors will all be able to take 1 or 0 arguments, so i could say
+ (new (typeof val)) ; construct similar
+ (define (new type)
+ (if (symbolp type) (apply (eval type) ())
+ (apply (eval (car type)) (cdr type))))
+. values can be marked as autorelease (1) if user says so, (2) if we can
+ prove that it's ok (e.g. we only allocated the value using malloc because
+ it is too large to move on every GC).
+ in the future you should be able to specify an arbitrary finalization
+ function, not just free().
+. when calling a C function, a value of type_t can be passed to something
+ expecting a type_t* by taking the address of the representation. BUT
+ this is dangerous if the C function might save a reference.
+ a type_t* can be passed as a type_t by copying the representation.
+. you can use (pointer v) to switch v to "malloc'd representation", in
+ which case the value is no longer autoreleased, but you can do whatever
+ you want with the pointer. (other option is to COPY v when making a
+ pointer to it, but this still doesn't prevent C from holding a reference
+ too long)
+
+
+add a cfunction binding to symbols. you register in C simply by setting
+this binding to a function pointer, then
+
+(defun open (path flags)
+ ; could insert type checks here
+ (ccall 'int32 'open path flags))
+
+(setq fd (open "path" 0))
+
+using libdl you could even omit the registration step and extra binding
+
+this is possible:
+(defun malloc (size)
+ (ccall `(array int8 ,size) 'malloc size))
+ ;ret type ;f name ; . args
+
+
+vtable:
+we'd like to be able to define new lisp "types", like vectors
+and hash tables, using this. there needs to be a standard value interface
+you can implement in C and attach a vtable to some c values.
+interface: relocate, finalize, print(, copy)
+
+implementation plan:
+- write cvalue constructors
+- if a head evaluates to a cvalue, call the pointer directly with the arg array
+ . this is the "guest function" interface, a C function written specifically
+ to the femtolisp API. its type must be
+ '(c-function lispvalue ((pointer lispvalue) uint32))
+ which corresponds to
+ value_t func(value_t *args, u_int32_t nargs);
+ . this interface is useful for writing additional builtins, types,
+ interpreter extensions, etc. more efficient.
+ . one of these functions could also be called with
+ (defun func args
+ (ccall 'func 'lispvalue (array 'lispvalue args) (length args)))
+ - these functions are effectively builtins and should have names so they
+ can be printed as such.
+ . have a registration function
+ void guest_function(value_t (*f)(value_t*,u_int32_t), const char *name);
+ so at least the function type can be checked from C
+ . set a flags bit for functions registered this way so we can identify
+ them quickly
+
+- ccall lisp builtin, (ccall rettype name . args). if name has no cfunc
+ binding, looks it up lazily with dlsym and stores the result.
+ this is a guest function that handles type checking, translation, and
+ invocation of foreign c functions.
+
+- you could register builtins from lisp like this:
+ (defun dlopen (name flags) (ccall '(pointer void) 'dlopen name flags))
+ (defun dlsym (handle name type) (ccall type 'dlsym handle name))
+ (define lisp-process (dlopen nil 0))
+ (define vector-sym
+ (dlsym lisp-process 'int_vector
+ '(function lispvalue (pointer lispvalue) uint32)))
+ (ccall 'void 'guest_function vector-sym 'vector)
+
+- write c extensions cref, cset, typeof, sizeof, cvaluep
+* read, print, vectorp methods for vectors
+- quoted string "" reading, produces #(c c c c ...)
+* get rid of primitive builtins read,print,princ,load,exit,
+ implement using ccall
+
+
+other possible design:
+- just add two builtins, call and ccall.
+ (call 'name arg arg arg) lisp guest function interface
+ we can say e.g.
+ (defmacro vector args `(call 'vector ,.args))
+- basically the question is whether to introduce a new kind of callable
+ object or to do everything through the existing builtin mechanism
+ . macros cannot be applied, so without a new kind of callable 'vector'
+ would have to be a lisp function, entailing argument consing...
+ (defun builtin (name)
+ (guest-function name
+ (dlsym lisp-process name '(function value (pointer value) uint32))))
+ then you can print a guest function as e.g.
+ #.(builtin 'vector)
+
+#name(x y z) reads as a tagged vector
+#(x y z) is the same as #vector(x y z)
+should be internally the same as well, so non-taggedness does not formally
+exist.
+
+
+then we can write the vector clause in backquote as e.g.
+
+(if (vectorp x)
+ (let ((body (bq-process (vector-to-list x))))
+ (if (eq (tag x) 'vector)
+ (list 'list-to-vector body)
+ (list 'apply 'tagged-vector
+ (list cons (list quote (tag x)) body))))
+ (list quote x))
+
+
+setup plan:
+* create source directory and svn repository, move llt sources into it
+* write femtolisp.h, definitions for extensions to #include
+- add fl_ prefix to all exported functions
+* port read and print to llt iostreams
+* get rid of flutils; use ptrhash instead
+* builtinp needs to be a builtin ;) to distinguish lisp builtins from cvalues
+* allocation and gc for cvalues
+- interface functions fl_list(...), fl_apply
+ e.g. fl_apply(fl_eval(fl_symbol("+")), fl_list(fl_number(2),fl_number(3)))+ and fl_symval("+"), fl_cons, etc.+
+-----------------------------------------------------------------------------
+
+vector todo:
+* compare for vectors
+- (aref v i j k) does (reduce aref v '(i j k)); therefore (aref v) => v
+- (aref v ... [1 2 3] ...) vectorized indexing
+- make (setf (aref v i j k) x) expand to (aset (aref v i j) k x)
+these should be done using the ccall interface:
+- concatenate
+- copy-vec
+- (range i j step) to make integer ranges
+- (rref v start stop), plus make it settable! (rset v start stop rhs)
+lower priority:
+- find (strstr)
+
+functions to be generic over vec/list:
+* compare, equal, length
+
+constructor notation:
+
+#func(a b c) does (apply func '(a b c))
+
+-----------------------------------------------------------------------------
+
+how we will allocate cvalues
+
+a vector's size will be a lisp-value number. we will set bit 0x2 to indicate
+a resize request, and bit 0x1 to indicate that it's actually a cvalue.
+
+every cvalue will have the following fields, followed by some number of
+words according to how much space is needed:
+
+ value_t size; // | 0x2
+ cvtable_t *vtable;
+ struct {+#ifdef BITS64
+ unsigned pad:32;
+#endif
+ unsigned whatever:27;
+ unsigned mark:1;
+ unsigned hasparent:1;
+ unsigned islispfunction:1;
+ unsigned autorelease:1;
+ unsigned inlined:1;
+ } flags;
+ value_t type;
+ size_t len; // length of *data in bytes
+ //void *data; // present if !inlined
+ //value_t parent; // present if hasparent
+
+size/vtable have the same meaning as vector size/elt[0] for relocation
+obviously we only relocate parent and type. if vtable->relocate is present,
+we call it at the end of the relocate process, and it must touch every
+lisp value reachable from it.
+
+when a cvalue is created with a finalizer, its address is added to a special
+list. before GC, everything in that list has its mark bit set. when
+we relocate a cvalue, clear the bit. then go through the list to call
+finalizers on dead values. this is O(n+m) where n is amt of live data and m
+is # of values needing finalization. we expect m << heapsize.
+
+-----------------------------------------------------------------------------
+
+Goal: bootstrap a lisp system where we can do "anything" purely in lisp
+starting with the minimal builtins needed for successive levels of
+completeness:
+
+1. Turing completeness
+quote, if, lambda, eq, atom, cons, car, cdr
+
+2. Naming
+set
+
+3. Control flow
+progn, prog1, apply, eval
+call/cc needed for true completeness, but we'll have attempt, raise
+
+4. Predicate completeness
+symbolp, numberp, builtinp
+
+5. Syntax
+macro
+
+6. I/O completeness
+read, print
+
+7. Mutable state
+rplaca, rplacd
+
+8. Arithmetic completeness
++, -, *, /, <
+
+9. The missing data structure(s): vector
+alloc, aref, aset, vectorp, length
+
+10. Real-world completeness (escape hatch)
+ccall
+
+---
+11. Misc unnecessary
+while, label, cond, and, or, not, boundp, vector
+
+-----------------------------------------------------------------------------
+
+exception todo:
+
+* silence 'in file' errors when user frame active
+* add more useful data to builtin exception types:
+ (UnboundError x)
+ (BoundsError vec index)
+ (TypeError fname expected got)
+ (Error v1 v2 v3 ...)
+* attempt/raise, rewrite (error) in lisp
+* more intelligent exception printers in toplevel handler
+
+-----------------------------------------------------------------------------
+
+lisp variant ideas
+
+- get rid of separate predicates and give every value the same structure
+ ala mathematica
+ . (tag 'a) => symbol
+ (tag '(a b)) => a
+ (tag 'symbol 'a) => a
+ (tag 'blah 3) => (blah 3)
+- have only vectors, not cons cells (sort of like julia)
+ . could have a separate tag field as above
+
+- easiest way to add vectors:
+ . allocate in same heap with conses, have a tag, size, then elements
+ (each elt must be touched on GC for relocation anyway, so might as well
+ copy collect it)
+ . tag pointers as builtins, we identify them as builtins with big values
+ . write (vector) in C, use it from read and eval
+
+8889314663 comcast net #
+
+-----------------------------------------------------------------------------
+
+cvalues reserves the following global symbols:
+
+int8, uint8, int16, uint16, int32, uint32, int64, uint64
+char, uchar, wchar, short, ushort, int, uint, long, ulong
+float, double
+struct, array, enum, union, function, void, pointer, lispvalue
+
+it defines (but doesn't reserve) the following:
+
+typeof, sizeof, autorelease, guestfunction, ccall
+
+
+user-defined types and typedefs:
+
+the rule is that a type should be viewed as a self-evaluating constant
+like a number. if i define a complex_t type of two doubles, then
+'complex_t is not a type any more than the symbol 'x could be added to
+something just because it happened to have the value 2.
+
+; typedefs from lisp
+(define wchar_t 'uint32)
+(define complex_t '(struct ((re double) (im double))))
+
+; use them
+(new complex_t)
+(new `(array ,complex_t 10))
+(array complex_t 10)
+
+BUT
+
+(array 'int32 10)
+
+because the primitive types *are* symbols. the fact that they have values is
+just a convenient coincidence that lets you do e.g. (int32 0)
+
+
+; size-annotate a pointer
+(setq p (ccall #c-function((pointer void) (ulong) malloc) n)
+(setq a (deref p `(array int8 ,n)))
+
+cvalues todo:
+
+* use uint32_t instead of wchar_t in C code
+- make sure empty arrays and 0-byte types really work
+* allow int constructors to accept other int cvalues
+* array constructor should accept any cvalue of the right size
+* make sure cvalues participate well in circular printing
+* float, double
+- struct, union (may want to start with more general layout type)
+- pointer type, function type
+* finalizers
+- functions autorelease, guestfunction
+- cref/cset/byteref/byteset
+* wchar type, wide character strings as (array wchar)
+* printing and reading strings
+- ccall
+- anonymous unions
+* fix princ for cvalues
+* make header size for primitives <= 8 bytes, even on 64-bit arch
+- more efficient read for #array(), so it doesn't need to build a pairlist
+? lispvalue type
+ . keep track of whether a cvalue leads to any lispvalues, so they can
+ be automatically relocated (?)
+
+* string constructor/concatenator:
+(string 'sym #char(65) #wchar(945) "blah" 23)
+ ; gives "symA\u03B1blah23"
+"ccc" reads to (array char)
+
+low-level functions:
+; these are type/bounds-checked accesses
+- (cref cvalue key) ; key is field name or index. access by reference.
+- (aref cvalue key) ; access by value, returns fixnums where possible
+- (cset cvalue key value) ; key is field name, index, or struct offset
+ . write&use conv_from_long to put fixnums into typed locations
+ . aset is the same
+* (copy cv)
+- (offset type|cvalue field [field ...])
+- (eltype type field [field ...])
+- (memcpy dest-cv src-cv)
+- (memcpy dest doffs src soffs nbytes)
+- (bswap cvalue)
+- (c2lisp cvalue) ; convert to sexpr form
+* (typeof cvalue)
+* (sizeof cvalue|type)
+- (autorelease cvalue) ; mark cvalue as free-on-gc
+- (deref pointer[, type]) ; convert an arbitrary pointer to a cvalue
+ ; this is the unsafe operation
+
+; (sizeof '(pointer type)) == sizeof(void*)
+; (sizeof '(array type N)) == N * sizeof(type)
+
+(define (reinterpret-cast cv type)
+ (if (= (sizeof cv) (sizeof type))
+ (deref (pointer 'void cv) type)
+ (error "Invalid cast")))
+
+a[n].x looks like (cref (cref a n) 'x), (reduce cref head subs)
+
+things you can do with cvalues:
+
+. call native C functions from lisp code without wrappers
+. wrap C functions in pure lisp, automatically inheriting some degree
+ of type safety
+. use lisp functions as callbacks from C code
+. use the lisp garbage collector to reclaim malloc'd storage
+. annotate C pointers with size information for bounds checking
+. attach symbolic type information to a C data structure, allowing it to
+ inherit lisp services such as printing a readable representation
+. add datatypes like strings to lisp
+. use more efficient represenations for your lisp programs' data
+
+
+family of cvalue representations.
+relevant attributes:
+ . large -- needs full size_t to represent size
+ . inline -- allocated along with metadata
+ . prim -- no stored type; uses primtype bits in flags
+ . hasdeps -- depends on other values to stay alive
+
+these attributes have the following dependencies:
+ . large -> !inline
+ . prim -> !hasdeps && !large
+
+so we have the following possibilities:
+
+large inline prim hasdeps rep#
+ 0 0 0 0 0
+ 0 0 0 1 1
+
+ 0 0 1 0 2
+ 0 1 0 0 3
+ 0 1 0 1 4
+ 0 1 1 0 5
+
+ 1 0 0 0 6
+ 1 0 0 1 7
+
+we need to be able to un-inline data, so we need:
+change 3 -> 0 (easy; write pointer over data)
+change 4 -> 1
+change 5 -> 2 (also easy)
+
+
+rep#0&1: (!large && !inline && !prim)
+typedef struct {+ cvflags_t flags;
+ value_t type;
+ value_t deps;
+ void *data; /* points to malloc'd buffer */
+} cvalue_t;
+
+rep#3&4: (!large && inline && !prim)
+typedef struct {+ cvflags_t flags;
+ value_t type;
+ value_t deps;
+ /* data goes here inlined */
+} cvalue_t;
+
+
+rep#2: (prim && !inline)
+typedef struct {+ cvflags_t flags;
+ void *data; /* points to (tiny!) malloc'd buffer */
+} cvalue_t;
+
+rep#5: (prim && inline)
+typedef struct {+ cvflags_t flags;
+ /* data goes here inlined */
+} cvalue_t;
+
+
+rep#6&7: (large)
+typedef struct {+ cvflags_t flags;
+ value_t type;
+ value_t deps;
+ void *data; /* points to malloc'd buffer */
+ size_t len;
+} cvalue_t;
+
+-----------------------------------------------------------------------------
+
+times for lispv:
+
+color 2.286s
+sort 0.181s
+fib34 5.205s
+mexpa 0.329s
+
+-----------------------------------------------------------------------------
+
+finalization algorithm that allows finalizers written in lisp:
+
+right after GC, go through finalization list (a weak list) and find objects
+that didn't move. relocate them (bring them back to life) and push them
+all onto the stack. remove all from finalization list.
+
+call finalizer for each value.
+
+optional: after calling a finalizer, make sure the object didn't get put
+back on the finalization list, remove if it did.
+if you don't do this, you can make an unkillable object by registering a
+finalizer that re-registers itself. this could be considered a feature though.
+
+pop dead values off stack.
+
+
+-----------------------------------------------------------------------------
+
+femtolisp semantics
+
+eval* is an internal procedure of 2 arguments, expr and env, invoked
+implicitly on input.
+The user-visible procedure eval performs eval* e Env ()
+
+eval* Symbol s E => lookup* s E
+eval* Atom a E => a
+... special forms ... quote arg, if a b c, other symbols from syntax env.
+eval* Cons f args E =>
+
+First the head expression, f, is evaluated, yielding f-.
+Then control is passed to #.apply f- args
+ #.apply is the user-visible apply procedure.
+ (here we imagine there is a user-invisible environment where f- is
+ bound to the value of the car and args is bound to the cdr of the input)
+
+
+Now (apply b lst) where b is a procedure (i.e. satisfies functionp) is
+identical to
+(eval (map (lambda (e) `',e) (cons b lst)))
+
+-----------------------------------------------------------------------------
+
+design of new toplevel
+
+system.lsp contains definitions of (load) and (toplevel) and is loaded
+from *install-dir* by a bootstrap loader in C. at the end of system.lsp,
+we check whether (load) is builtin. if it is, we redefine it and reload
+system.lsp with the new loader. the C code then invokes (toplevel).
+
+(toplevel) either runs a script or a repl using (while T (trycatch ...))
+
+(load) reads and evaluates every form, keeping track of defined functions
+and macros (at the top level), and grabs a (main ...) form if it sees
+one. it applies optimizations to every definition, then invokes main.
+
+an error E during load should rethrow `(load-error ,filename ,E)
+such exceptions can be printed recursively
+
+lerror() should make a lisp string S from the result of sprintf, then
+raise `(,e ,S). first argument e should be a symbol.
+
+
+new expansion process:
+
+get rid of macroexpanding versions of define and define-macro
+macroexpand doesn't expand (define ...)
+ macroexpand implements let-syntax
+add lambda-expand which applies f-body to the bodies of lambdas, then
+ converts defines to set!
+call expand on every form before evaluating
+ (define (expand x) (lambda-expand (macroexpand x)))
+(define (eval x) (%eval (expand x)))
+reload system.lsp with the new eval
+
+-----------------------------------------------------------------------------
+
+String API
+
+*string - append/construct
+*string.inc - (string.inc s i [nchars])
+*string.dec
+*string.count - # of chars between 2 byte offsets
+*string.char - char at byte offset
+*string.sub - substring between 2 byte offsets
+*string.split - (string.split s sep-chars)
+*string.trim - (string.trim s chars-at-start chars-at-end)
+*string.reverse
+*string.find - (string.find s str|char [offs]), or nil if not found
+ string.rfind
+*string.encode - to utf8
+*string.decode - from utf8 to UCS
+*string.width - # columns
+*string.map - (string.map f s)
+
+
+IOStream API
+
+*read - (read[ stream]) ; get next sexpr from stream
+*princ
+*file
+ iostream - (stream[ cvalue-as-bytestream])
+*buffer
+ fifo
+ socket
+*io.eof?
+*io.flush
+*io.close
+*io.discardbuffer
+*io.write - (io.write s cvalue [start [count]])
+*io.read - (io.read s ctype [len])
+*io.getc - get utf8 character
+*io.putc
+ io.peekc
+*io.readline
+*io.readuntil
+*io.copy - (io.copy to from [nbytes])
+*io.copyuntil - (io.copy to from byte)
+ io.pos - (io.pos s [set-pos])
+ io.seek - (io.seek s offset)
+ io.seekend - move to end of stream
+ io.trunc
+ io.read! - destructively take data
+*io.tostring!
+*io.readlines
+*io.readall
+*print-to-string
+*princ-to-string
+
+
+*path.exists?
+ path.dir?
+ path.combine
+ path.parts
+ path.absolute
+ path.simplify
+ path.tempdir
+ path.tempname
+ path.homedir
+*path.cwd
+
+
+*time.now
+ time.parts
+ time.fromparts
+*time.string
+*time.fromstring
+
+
+*os.name
+*os.getenv
+*os.setenv
+ os.execv
+
+
+*rand
+*randn
+*rand.uint32
+*rand.uint64
+*rand.double
+*rand.float
+
+-----------------------------------------------------------------------------
+
+ * new print algorithm
+ 1. traverse & tag all conses to be printed. when you encounter a cons
+ that is already tagged, add it to a table to give it a #n# index
+ 2. untag a cons when printing it. if cons is in the table, print
+ "#n=" before it in the car, " . #n=" in the cdr. if cons is in the
+ table but already untagged, print #n# in car or " . #n#" in the cdr.
+ * read macros for #n# and #n= using the same kind of table
+ * also need a table of read labels to translate from input indexes to
+ normalized indexes (0 for first label, 1 for next, etc.)
+ * read macro #. for eval-when-read. use for printing builtins, e.g. "#.eq"
+
+-----------------------------------------------------------------------------
+
+prettyprint notes
+
+* if head of list causes VPOS to increase and HPOS is a bit large, then
+switch to miser mode, otherwise default is ok, for example:
+
+> '((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y))
+((lambda (x y)
+ (if (< x y) x y)) (a b c)
+ (d e f) 2 3
+ (r t y))
+
+* (if a b c) should always put newlines before b and c
+
+* write try_predict_len that gives a length for easy cases like
+ symbols, else -1. use it to avoid wrapping symbols around lines
+
+* print defun, defmacro, label, for more like lambda (2 spaces)
+
+* *print-pretty* to control it
+
+* if indent gets too large, dedent back to left edge
+
+-----------------------------------------------------------------------------
+
+consolidated todo list as of 7/8:
+* new cvalues, types representation
+* use the unused tag for TAG_PRIM, add smaller prim representation
+* finalizers in gc
+* hashtable
+* generic aref/aset
+* expose io stream object
+* new toplevel
+
+* make raising a memory error non-consing
+* eliminate string copy in lerror() when possible
+* fix printing lists of short strings
+
+* evaluator improvements, perf & debugging (below)
+* fix make-system-image to save aliases of builtins
+* reading named characters, e.g. #\newline etc.
+- #+, #- reader macros
+- printing improvements: *print-length*, keep track of horiz. position
+ per-stream so indenting works across print calls
+- remaining c types
+- remaining cvalues functions
+- finish ios
+* optional arguments
+* keyword arguments
+- some kind of record, struct, or object system
+- improve test coverage
+
+expansion process bugs:
+* expand default expressions for opt/keyword args (as if lexically in body)
+* make bound identifiers (lambda and toplevel) shadow macro keywords
+* to expand a body:
+ 1. splice begins
+ 2. add defined vars to env
+ 3. expand nondefinitions in the new env
+ . if one expands to a definition, add the var to the env
+ 4. expand RHSes of definitions
+- add different spellings for builtin versions of core forms, like
+ $begin, $define, and $set!. they can be replaced when found during expansion,
+ and used when the compiler needs to generate them with known meanings.
+
+- special efficient reader for #array
+- reimplement vectors as (array lispvalue)
+- implement fast subvectors and subarrays
+
+-----------------------------------------------------------------------------
+
+cvalues redesign
+
+goals:
+. allow custom types with vtables
+. use less space, share types more
+. simplify access to important metadata like length
+. unify vectors and arrays
+
+typedef struct {+ fltype_t *type;
+ void *data;
+ size_t len; // length of *data in bytes
+ union {+ value_t parent; // optional
+ char _space[1]; // variable size
+ };
+} cvalue_t;
+
+#define owned(cv) ((cv)->type & 0x1)
+#define hasparent(cv) ((cv)->type & 0x2)
+#define isinlined(cv) ((cv)->data == &(cv)->_space[0])
+#define cv_class(cv) ((fltype_t*)(((uptrint_t)(cv)->type)&~3))
+#define cv_type(cv) (cv_class(cv)->type)
+#define cv_len(cv) ((cv)->len)
+#define cv_data(cv) ((cv)->data)
+#define cv_numtype(cv) (cv_class(cv)->numtype)
+
+typedef struct _fltype_t {+ value_t type;
+ int numtype;
+ size_t sz;
+ size_t elsz;
+ cvtable_t *vtable;
+ struct _fltype_t *eltype; // for arrays
+ struct _fltype_t *artype; // (array this)
+ int marked;
+} fltype_t;
+
+-----------------------------------------------------------------------------
+
+new evaluator todo:
+
+* need builtin = to handle nans properly, fix equal? on nans
+* builtin quasi-opaque function type
+ fields: signature, maxstack, bcode, vals, cloenv
+ function->vector
+* make (for ...) a special form
+* trycatch should require 2nd arg to be a lambda expression
+* immediate load int8 instruction
+* unlimited lambda lists
+ . need 32-bit argument versions of loada, seta, loadc, setc
+ . largs instruction to move args after MAX_ARGS from list to stack
+* maxstack calculation, make Stack growable
+ * stack traces and better debugging support
+* improve internal define
+* try removing MAX_ARGS trickery
+? apply optimization, avoid redundant list copying calling vararg fns
+- let eversion
+- variable analysis - avoid holding references to values in frames
+ captured by closures but not used inside them
+* lambda lifting
+* let optimization
+* fix equal? on functions
+* store function name
+* have macroexpand use its own global syntax table
+* be able to create/load an image file
+* fix trace and untrace
+* opcodes LOADA0, LOADA1, LOADC00, LOADC01
+- opcodes CAAR, CADR, CDAR, CDDR
+- EQTO N, compare directly to stored datum N
+- peephole opt
+ done:
+ not brf => brt
+ eq brf => brne
+ null brf => brnn
+ null brt => brn
+ null not brf => brn
+ cdr car => cadr
+
+ not yet:
+ not brt => brf
+ constant+pop => nothing, e.g. 2-arg 'if' in statement position
+ loadt+brf => nothing
+ loadf+brt => nothing
+ loadt+brt => jmp
+ loadf+brf => jmp
+
+-----------------------------------------------------------------------------
+
+new stack organization:
+
+func
+arg1
+...
+argn
+cloenv |
+prev |
+nargs |
+ip |
+captured |
+
+to call:
+push func and arguments
+args[nargs+3] = ip // save my state in my frame
+assign nargs
+goto top
+
+on entry:
+push cloenv
+push curr_frame (a global initialized to 0)
+push nargs
+SP += 1
+curr_frame = SP
+
+to return:
+v = POP();
+SP = curr_frame
+curr_frame = Stack[SP-4]
+if (args == top_args) return v;
+SP -= (5+nargs);
+move Stack[curr_frame-...] back into locals
+Stack[SP-1] = v
+goto next_op
+
+to relocate stack:
+for each segment {+ curr_top = SP
+ f = curr_frame
+ while (1) {+ for i=f, i<curr_top, i++
+ relocate stack[i]
+ if (f == 0) break;
+ curr_top = f - 4
+ f = stack[f - 4]
+ }
+}
+
+typedef struct {+ value_t *Stack;
+ uint32_t size;
+ uint32_t SP;
+ uint32_t curr_frame;
+} stackseg_t;
+
+-----------------------------------------------------------------------------
+
+optional and keyword args:
+
+check nargs >= #required
+grow frame by ntotal-nargs ; ntotal = #req+#opt+#kw
+(sort keyword args into their places)
+branch if arg bound around initializer for each opt arg
+
+example: (lambda (a (b 0) (c b)))
+
+minargs 1
+framesize 3
+brbound 1 L1
+load0
+seta 0
+L1:
+brbound 2 L2
+loada 1
+seta 2
+L2:
+
+-----------------------------------------------------------------------------
+
+what needs more test coverage:
+
+- more error cases, lerrorf() cases
+- printing gensyms
+- gensyms with bindings
+- listn(), isnumber(), list*, boolean?, function?, add2+ovf, >2arg add,div
+- large functions, requiring long versions of branch opcodes
+- setal, loadvl, (long arglist and lots of vals cases)
+- aref/aset on c array
+- printing everything
+- reading floats, escaped symbols, multiline comment, octal chars in strs
+- equal? on functions
+- all cvalue ctors, string_from_cstrn()
+- typeof, copy, podp, builtin()
+- bitwise and logical ops
+- making a closure in a default value expression for an optional arg
+- gc during a catch block, then get stack trace
+
+-----------------------------------------------------------------------------
+
+5/4/10 todo:
+
+- flush and close open files on exit
+* make function versions of opcode builtins by wrapping in a lambda,
+ stored in a table indexed by opcode. use in _applyn
--- /dev/null
+++ b/todo-scrap
@@ -1,0 +1,41 @@
+- readable gensyms. have uninterned symbols, but have all same-named
+ gensyms read to the same (eq) symbol within an expression.
+- fat pointers, i.e. 64 bits on 32-bit platforms. we could have full 32-bit
+ integers too. the mind boggles at the possibilities.
+ (it would be great if everybody decided that pointer types should forever
+ be wider than address spaces, with some bits reserved for application use)
+- any way at all to provide O(1) computed lookups (i.e. indexing).
+ CL uses vectors for this. once you have it, it's sufficient to get
+ efficient hash tables and everything else.
+ - could be done just by generalizing cons cells to have more than
+ car, cdr: c2r, c3r, etc. maybe (1 . 2 . 3 . 4 . ...)
+ all you need is a tag+size on the front of the object so the collector
+ knows how to deal with it.
+ (car x) == (ref x 0), etc.
+ (rplaca x v) == (rplac x 0 v), etc.
+ (size (cons 1 2)) == 2, etc.
+ - one possibility: if we see a cons whose CAR is tagptr(0x10,TAG_SYM),
+ then the CDR is the size and the following words are the elements.
+ . this approach is especially good if vectors are separate types from
+ conses
+ - another: add u_int32_t size to cons_t, making them all 50% bigger.
+ access is simpler and more uniform, without fully doubling the size like
+ we'd get with fat pointers.
+
+Notice that the size is one byte more than the number of characters in
+the string. This is because femtoLisp adds a NUL terminator to make its
+strings compatible with C. No effort is made to hide this fact.
+But since femtoLisp tracks the sizes of cvalues, it doesn't need the
+terminator itself. Therefore it treats zero bytes specially as rarely
+as possible. In particular, zeros are only special in values whose type
+is exactly <tt>(array char)</tt>, and are only interpreted in the
+following cases:
+<ul>
+<li>When printing strings, a final NUL is never printed. NULs in the
+middle of a string are printed though.
+<li>String constructors NUL-terminate their output.
+<li>Explicit string functions (like <tt>strlen</tt>) treat NULs the same
+way equivalent C functions would.
+</ul>
+Arrays of uchar, int8, etc. are treated as raw data and zero bytes are
+never special.
--- /dev/null
+++ b/types.c
@@ -1,0 +1,99 @@
+#include "equalhash.h"
+
+fltype_t *get_type(value_t t)
+{+ fltype_t *ft;
+ if (issymbol(t)) {+ ft = ((symbol_t*)ptr(t))->type;
+ if (ft != NULL)
+ return ft;
+ }
+ void **bp = equalhash_bp(&TypeTable, (void*)t);
+ if (*bp != HT_NOTFOUND)
+ return *bp;
+
+ int align, isarray=(iscons(t) && car_(t) == arraysym && iscons(cdr_(t)));
+ size_t sz;
+ if (isarray && !iscons(cdr_(cdr_(t)))) {+ // special case: incomplete array type
+ sz = 0;
+ }
+ else {+ sz = ctype_sizeof(t, &align);
+ }
+
+ ft = (fltype_t*)malloc(sizeof(fltype_t));
+ ft->type = t;
+ if (issymbol(t)) {+ ft->numtype = sym_to_numtype(t);
+ ((symbol_t*)ptr(t))->type = ft;
+ }
+ else {+ ft->numtype = N_NUMTYPES;
+ }
+ ft->size = sz;
+ ft->vtable = NULL;
+ ft->artype = NULL;
+ ft->marked = 1;
+ ft->elsz = 0;
+ ft->eltype = NULL;
+ ft->init = NULL;
+ if (iscons(t)) {+ if (isarray) {+ fltype_t *eltype = get_type(car_(cdr_(t)));
+ if (eltype->size == 0) {+ free(ft);
+ lerror(ArgError, "invalid array element type");
+ }
+ ft->elsz = eltype->size;
+ ft->eltype = eltype;
+ ft->init = &cvalue_array_init;
+ eltype->artype = ft;
+ }
+ else if (car_(t) == enumsym) {+ ft->numtype = T_INT32;
+ ft->init = &cvalue_enum_init;
+ }
+ }
+ *bp = ft;
+ return ft;
+}
+
+fltype_t *get_array_type(value_t eltype)
+{+ fltype_t *et = get_type(eltype);
+ if (et->artype != NULL)
+ return et->artype;
+ return get_type(fl_list2(arraysym, eltype));
+}
+
+fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab,
+ cvinitfunc_t init)
+{+ fltype_t *ft = (fltype_t*)malloc(sizeof(fltype_t));
+ ft->type = sym;
+ ft->size = sz;
+ ft->numtype = N_NUMTYPES;
+ ft->vtable = vtab;
+ ft->artype = NULL;
+ ft->eltype = NULL;
+ ft->elsz = 0;
+ ft->marked = 1;
+ ft->init = init;
+ return ft;
+}
+
+void relocate_typetable()
+{+ htable_t *h = &TypeTable;
+ size_t i;
+ void *nv;
+ for(i=0; i < h->size; i+=2) {+ if (h->table[i] != HT_NOTFOUND) {+ nv = (void*)relocate((value_t)h->table[i]);
+ h->table[i] = nv;
+ if (h->table[i+1] != HT_NOTFOUND)
+ ((fltype_t*)h->table[i+1])->type = (value_t)nv;
+ }
+ }
+}