├── .cvsignore ├── .hgtags ├── LICENSE ├── Makefile ├── TODO ├── auxiliary.scm ├── bench ├── bench-all.sh ├── bench-cps.log ├── bench-cps.script ├── bench-direct.log ├── bench-direct.script ├── bench-pgg.log ├── bench-pgg.script ├── bench-similix.log └── bench-similix.script ├── cogen-abssyn.scm ├── cogen-anf-compile.scm ├── cogen-batch.scm ├── cogen-boxops.scm ├── cogen-completer.scm ├── cogen-construct-genext.scm ├── cogen-ctors.scm ├── cogen-direct-anf.scm ├── cogen-directives.scm ├── cogen-distributed-utils.scm ├── cogen-driver.scm ├── cogen-effect.scm ├── cogen-env.scm ├── cogen-eq-flow.scm ├── cogen-gensym.scm ├── cogen-globals.scm ├── cogen-input-syntax ├── cogen-job ├── cogen-labset-bylist.scm ├── cogen-labset.scm ├── cogen-library.scm ├── cogen-macro.scm ├── cogen-memo-client.scm ├── cogen-memo-master.scm ├── cogen-memo-standard.scm ├── cogen-oca.scm ├── cogen-reach.scm ├── cogen-record.scm ├── cogen-residual.scm ├── cogen-scheme.scm ├── cogen-skeleton.scm ├── cogen-spec-server.scm ├── cogen-specialize.scm ├── cogen-terminate.scm ├── cogen-typesig.scm ├── cogen-wrapping.scm ├── cps-mcogen ├── distributed-genext-packages.scm ├── doc ├── pgg-manual.ist └── pgg-manual.tex ├── dummy-gensym.scm ├── examples ├── 2lazy-support.scm ├── 2lazy.scm ├── app.scm ├── apply.scm ├── arity.scm ├── artificial.scm ├── c-based.scm ├── counter.scm ├── cps-lr-sim.sim ├── cps-lr.scm ├── ctors.adt ├── ctors.scm ├── cyclic.scm ├── defmemo.scm ├── direct-lr-cps.scm ├── direct-lr-pgg.scm ├── direct-lr-sim.sim ├── direct-lr-support.scm ├── dotprod.scm ├── gpscheme.scm ├── imp.scm ├── int.scm ├── lambda-int.scm ├── lambda.scm ├── lambda.sim ├── lazy │ ├── com-int-int.scm │ ├── com-int.scm │ ├── com-support.scm │ ├── evens.com │ └── primes.com ├── list.dat ├── ll-parser │ ├── grammar.scm │ ├── ll1-parser.scm │ ├── packages.scm │ ├── scc-union.scm │ └── toy-grammars.scm ├── mixwell │ ├── map4-cbv.mwr │ ├── mw-int-int.scm │ └── mw-int.scm ├── modint-base.scm ├── modint-dynamic.scm ├── modint-examples.scm ├── modint-mutual.scm ├── modint.scm ├── object.scm ├── optimal.scm ├── pm-input.scm ├── pm.scm ├── poly-rec.scm ├── poly.scm ├── power.scm ├── pure-arith.scm ├── reach.scm ├── sample_modules_session.scm ├── scheme1-pgg.scm ├── scheme1-support.scm ├── termination │ ├── closure.scm │ ├── fo-func.scm │ ├── fo.scm │ ├── goto-while.scm │ ├── goto.scm │ ├── ho-cbn.scm │ ├── ho-cps.scm │ ├── ho-func.scm │ ├── ho-let.scm │ ├── ho-letrec.scm │ ├── ho.scm │ ├── kmp.scm │ └── myflatten.scm ├── triv.scm ├── unify-aux.scm └── unify.scm ├── genext-packages.scm ├── pgg-packages.scm ├── scheme-desugar.scm ├── scheme-standard-macros.scm ├── scheme-standard-vector-ops.scm ├── shift-reset.scm ├── smurf-queue.scm └── strong-updates ├── a-normal-form.scm ├── analysis.scm ├── anf-convert.scm ├── config.scm ├── cxxxxr.scm ├── finite-map.scm └── toplevel.scm /.cvsignore: -------------------------------------------------------------------------------- 1 | batch.image 2 | cogen-load-gambit.scm 3 | cogen-load-s48.scm 4 | genext-1.0.tar.gz 5 | pgg.image 6 | -------------------------------------------------------------------------------- /.hgtags: -------------------------------------------------------------------------------- 1 | 08659c55bbd6230a0dbf9a32a6b0d823cdf59212 cbpg-benchmark 2 | 0a0cb6bbd79405e4e841e65e6611f3d19726c220 start 3 | 1a5e81595f90fdf63f1d74cd2bba4788a545b21d release-1.4 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2005, Peter Thiemann 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 17 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 18 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 19 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 20 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 22 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | 24 | The views and conclusions contained in the software and documentation are those 25 | of the authors and should not be interpreted as representing official policies, 26 | either expressed or implied, of their employers. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | SHELL = /bin/sh 2 | BATCH_IMAGE = batch.image 3 | INTERACTIVE_IMAGE = pgg.image 4 | COGEN_VERSION = 1.4 5 | DISTRIBUTION = pgg-$(COGEN_VERSION).tar.gz 6 | GENEXT_DISTRIBUTION = genext-$(COGEN_VERSION).tar.gz 7 | prefix = /usr/local 8 | INSTALL_ROOT = /home/proglang/packages 9 | INSTALL_DIR = $(INSTALL_ROOT)/pgg-$(COGEN_VERSION) 10 | LIBDIR = $(INSTALL_DIR)/lib 11 | BINDIR = $(INSTALL_DIR)/bin 12 | EXAMPLEDIR = $(INSTALL_DIR)/examples 13 | EXECUTABLE = pgg.sh 14 | SCHEME48 = scheme48 15 | INSTALL = install -c 16 | INTERACTIVE_HEAPSIZE = 10000000 17 | BATCH_HEAPSIZE = 6000000 18 | BATCH_ENTRYPOINT = cogen-main 19 | 20 | TARGETHOST= nakalele.informatik.uni-freiburg.de 21 | TARGETDIR= /home/proglang/www/events/kps2004 22 | TARGET= $(TARGETHOST):$(TARGETDIR) 23 | TARGETGROUP= proglang 24 | TARGETPERM= 664 25 | 26 | HTTPDIR = /home/proglang/www/software/pgg 27 | FTPDIR = /usr/local/ftp/iif/thiemann/pgg 28 | 29 | all: $(INTERACTIVE_IMAGE) 30 | 31 | distribution: $(DISTRIBUTION) 32 | genext-distribution: $(GENEXT_DISTRIBUTION) 33 | 34 | export: $(DISTRIBUTION) 35 | ssh $(TARGETHOST) rm -f $(HTTPDIR)/$< 36 | scp -q $< $(TARGETHOST):$(HTTPDIR) 37 | ssh $(TARGETHOST) chgrp $(TARGETGROUP) $(HTTPDIR)/$< 38 | ssh $(TARGETHOST) chmod $(TARGETPERM) $(HTTPDIR)/$< 39 | ssh $(TARGETHOST) rm -f $(FTPDIR)/$< 40 | scp -q $< $(TARGETHOST):$(FTPDIR) 41 | ssh $(TARGETHOST) chgrp $(TARGETGROUP) $(FTPDIR)/$< 42 | ssh $(TARGETHOST) chmod $(TARGETPERM) $(FTPDIR)/$< 43 | 44 | install: $(INTERACTIVE_IMAGE) $(EXECUTABLE) 45 | mkdir -p $(LIBDIR) $(BINDIR) $(EXAMPLEDIR) 46 | $(INSTALL) -m 644 $(INTERACTIVE_IMAGE) $(LIBDIR) 47 | $(INSTALL) -m 755 $(EXECUTABLE) $(BINDIR) 48 | $(INSTALL) -m 644 $(cogen_examples) $(EXAMPLEDIR) 49 | 50 | $(EXECUTABLE): Makefile 51 | echo "#!/bin/sh" > $(EXECUTABLE) 52 | echo '$(SCHEME48) -h $(INTERACTIVE_HEAPSIZE) -i $(LIBDIR)/$(INTERACTIVE_IMAGE) $$@' >> $(EXECUTABLE) 53 | 54 | cogen_packages = pgg-residual pgg 55 | cogen_generate_packages = pgg signals 56 | cogen_specialize_packages = auxiliary pgg-library pgg-specialize cogen-memo-standard pp 57 | batch_packages = signals handle i/o conditions extended-ports 58 | genext_base_files = \ 59 | auxiliary.scm \ 60 | cogen-gensym.scm \ 61 | cogen-boxops.scm \ 62 | cogen-globals.scm \ 63 | cogen-specialize.scm \ 64 | cogen-library.scm \ 65 | shift-reset.scm \ 66 | cogen-residual.scm \ 67 | cogen-completer.scm \ 68 | cogen-record.scm \ 69 | cogen-memo-standard.scm \ 70 | cogen-ctors.scm 71 | pgg_base_files = \ 72 | cogen-abssyn.scm \ 73 | cogen-construct-genext.scm \ 74 | cogen-driver.scm \ 75 | cogen-effect.scm \ 76 | cogen-env.scm \ 77 | cogen-eq-flow.scm \ 78 | cogen-labset-bylist.scm \ 79 | cogen-macro.scm \ 80 | cogen-oca.scm \ 81 | cogen-scheme.scm \ 82 | cogen-skeleton.scm \ 83 | cogen-terminate.scm \ 84 | cogen-typesig.scm \ 85 | scheme-standard-macros.scm 86 | 87 | cogen_base_files = $(genext_base_files) $(pgg_base_files) 88 | 89 | cogen_cps_files = cogen-cps.scm 90 | cogen_ds_files = cogen-direct-anf.scm 91 | cogen_combinator_files = $(cogen_ds_files) 92 | 93 | genext_files = $(genext_base_files) $(cogen_combinator_files) 94 | cogen_files = $(cogen_base_files) $(cogen_combinator_files) 95 | 96 | batch_files = tiny-format.scm fname.scm command-line.scm cogen-batch.scm 97 | 98 | gambit_shift_reset = shift-reset-r4rs.scm 99 | gambit_generic_syntax = cogen-ctors-defmacro.scm cogen-record-defmacro.scm 100 | 101 | s48_shift_reset = shift-reset.scm 102 | s48_generic_syntax = cogen-ctors.scm cogen-record.scm 103 | 104 | genext_config_files = genext-packages.scm 105 | pgg_config_files = pgg-packages.scm 106 | config_files = $(genext_config_files) $(pgg_config_files) 107 | cogen_examples = \ 108 | examples/2lazy-support.scm \ 109 | examples/2lazy.scm \ 110 | examples/app.scm \ 111 | examples/apply.scm \ 112 | examples/cyclic.scm \ 113 | examples/dotprod.scm \ 114 | examples/int.scm \ 115 | examples/list.dat \ 116 | examples/object.scm \ 117 | examples/pm-input.scm \ 118 | examples/pm.scm \ 119 | examples/power.scm \ 120 | examples/pure-arith.scm \ 121 | examples/unify-aux.scm \ 122 | examples/unify.scm \ 123 | examples/modint.scm \ 124 | examples/modint-base.scm \ 125 | examples/modint-dynamic.scm \ 126 | examples/modint-mutual.scm \ 127 | examples/modint-examples.scm \ 128 | examples/sample_modules_session.scm \ 129 | examples/optimal.scm \ 130 | examples/poly.scm \ 131 | examples/poly-rec.scm 132 | additional_files = Makefile 133 | 134 | cogen-load-gambit.scm : Makefile 135 | (echo "(load \"$(gambit_shift_reset)\")" ; \ 136 | for f in $(gambit_generic_syntax) ; do \ 137 | echo "(load \"$$f\")" ; \ 138 | done ; \ 139 | for f in $(cogen_base_files) ; do \ 140 | echo "(load \"$$f\")" ; \ 141 | done ; \ 142 | for f in $(cogen_combinator_files) ; do \ 143 | echo "(load \"$$f\")" ; \ 144 | done \ 145 | ) > $@ 146 | 147 | $(BATCH_IMAGE) : $(cogen_files) $(batch_files) cogen-load-s48.scm 148 | (echo ",batch on"; \ 149 | echo ",bench on"; \ 150 | echo ";; ,flush source maps"; \ 151 | for package in $(cogen_packages) ; do \ 152 | echo ",load-package $$package"; \ 153 | done ; \ 154 | echo ",open $(cogen_generate_packages)"; \ 155 | echo ",open $(cogen_specialize_packages)"; \ 156 | echo ",open $(batch_packages)"; \ 157 | echo ",load $(batch_files)"; \ 158 | echo ";; ,flush"; \ 159 | echo ",collect"; \ 160 | echo ",dump $(BATCH_IMAGE) \"(PGG-$(COGEN_VERSION) made by $$LOGNAME on `date`)\""; \ 161 | echo ",exit" ) \ 162 | | $(SCHEME48) -h $(BATCH_HEAPSIZE) 163 | 164 | $(INTERACTIVE_IMAGE) : $(cogen_files) $(config_files) 165 | (echo ",bench on"; \ 166 | echo ",config,load $(config_files)"; \ 167 | for package in $(cogen_packages) ; do \ 168 | echo ",load-package $$package"; \ 169 | done ; \ 170 | echo ",open $(cogen_generate_packages)"; \ 171 | echo ",open $(cogen_specialize_packages)"; \ 172 | echo ",collect"; \ 173 | echo ",dump $(INTERACTIVE_IMAGE) \"(PGG-$(COGEN_VERSION) made by $$LOGNAME `date`)\""; \ 174 | echo ",exit" ) \ 175 | | $(SCHEME48) -h $(INTERACTIVE_HEAPSIZE) 176 | 177 | $(DISTRIBUTION): $(cogen_files) $(config_files) $(cogen_examples) $(additional_files) LICENSE 178 | tar cvhzf $(DISTRIBUTION) $(cogen_files) $(config_files) $(cogen_examples) $(additional_files) LICENSE 179 | 180 | $(GENEXT_DISTRIBUTION): $(genext_files) $(genext_config_files) LICENSE 181 | tar cvhzf $(GENEXT_DISTRIBUTION) $(genext_files) $(genext_config_files) LICENSE 182 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - admit static memoization 2 | + implement static mutable vectors: 3 | x cogen-abssyn.scm:(define (annIsRef? e) 4 | x cogen-abssyn.scm: ((annIsRef? e) 5 | x cogen-abssyn.scm: ((annIsRef? e) 6 | x cogen-abssyn.scm: ((annIsRef? e) 7 | x cogen-effect.scm: ((annIsRef? e) 8 | x cogen-effect.scm: ((annIsRef? e) 9 | x cogen-eq-flow.scm: ((annIsRef? e) 10 | x cogen-eq-flow.scm: ((annIsRef? e) 11 | x cogen-eq-flow.scm: ((annIsRef? e) 12 | x cogen-eq-flow.scm: ((annIsRef? e) 13 | x cogen-eq-flow.scm: ((annIsRef? e) 14 | x cogen-oca.scm: ((annIsRef? e) 15 | cogen-reach.scm: ((annIsRef? e) 16 | cogen-reach.scm: ((annIsRef? e) 17 | cogen-reach.scm: ((annIsRef? e) 18 | cogen-reach.scm: ((annIsRef? e) 19 | cogen-reach.scm: ((annIsRef? e) 20 | cogen-reach.scm: ((annIsRef? e) 21 | x cogen-skeleton.scm: ((annIsRef? e) 22 | cogen-terminate.scm: ((annIsRef? e) 23 | cogen-terminate.scm: ((annIsRef? e) 24 | x pgg-packages.scm: annIsRef? 25 | x cogen-library.scm 26 | x cogen-direct-anf.scm 27 | x cogen-construct-genext.scm 28 | 29 | + insert memoization points more cleverly: only the outermost lam-D or if-D 30 | + implement coarity raising 31 | - extend the top-level such that arbitrary Scheme programs (including 32 | non-functional definitions) are allowed 33 | + implement BACKQUOTE, UNQUOTE, UNQUOTE-SPLICING 34 | + use the proposed macro mechanism of R4RS to implement non-primitive forms 35 | - automatically insert representation coercions for (partially) static 36 | top-level arguments (from the standard representation to the memoized one) 37 | - revise symbol handling to pairs of (symbol, version number) 38 | - change the way static skeletons are represented: include information 39 | on sharing of dynamic values by replacing them in a consistent way 40 | - change the way static and dynamic parts are projected: process only one 41 | value/btime pair at once 42 | + analyze which lambdas and ctors are really memoized 43 | + incorporate the residual program in the goal function 44 | + make a macro out of the (_ i ...) functions 45 | + put type annotations to work: enforce types of primitives in bta-eq-flow 46 | - type annotation for arity of operators 47 | + inspect the lambda lifter (dependency analysis?) 48 | - insert LET only if the variable appears more than once in the body 49 | + reconsider LET insertion strategy (constructor arguments!) 50 | - how many memoization points are really necessary? 51 | you may want to read Malmkjaer's PEPM'93 paper 52 | + support for EVAL 53 | + complete the above (preprocessor, bta, skeleton) 54 | + check whether it still performs continuation-based reduction :-) 55 | + really generate LAMBDA_MEMO and friends 56 | + control memoization 57 | + handle (begin ...) 58 | + handle nested (define ...) 59 | - specialize project-static, project-dynamic, and friends 60 | + use delay/force in project-* functions 61 | + write the library functions in direct style using shift/reset to 62 | achieve continuation-based reduction 63 | + printout mechanism for bt analyzed program? 64 | + use introspection/reflective facilities to obtain the values of the 65 | free variables 66 | - support variadic procedures (by considering argument lists as a 67 | special partially static datatype) 68 | - the code generating functions return two results, the generated code 69 | and a synthesized attribute which indicates the "seriousness" of the 70 | code. The idea is that functions with non-serious body are unfolded 71 | on the fly. 72 | - post unfolding: keep track of # calls in the memo table by storing 73 | an indirection to the call in the residual program. After generation 74 | of the residual program we traverse the memo table once, performing 75 | the unfoldings. 76 | - allow user control over caching. 77 | - implement more a efficient caching mechanism. 78 | - implement parameterized abstract syntax: first define some macros, 79 | then define ast accessors and constructors using them. How about 80 | using some record facility? 81 | + add record support 82 | - replace the symtab by environments (cogen-env) 83 | - let the spec transform the residual program to CPS in order to 84 | memoize partially static values (alternative: use call-with-values) 85 | - handle load-time evaluations properly. define load+spec function? 86 | + type of a top-level value might be a poly, does not seem to be 87 | propagated to application site 88 | -------------------------------------------------------------------------------- /auxiliary.scm: -------------------------------------------------------------------------------- 1 | ;;; copyright by Peter Thiemann 1998, 1999 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; identity 5 | (define (id x) x) ;big-util: identity 6 | ;;; successor 7 | (define (succ x) (+ x 1)) 8 | (define (pred x) (- x 1)) 9 | ;;; unit of the continuation monad 10 | (define (result-c v) (lambda (k) (k v))) 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | (define any->symbol ;big-util: concatenate-symbol 14 | (lambda args 15 | (string->symbol 16 | (apply string-append 17 | (map (lambda (arg) 18 | (cond 19 | ((symbol? arg) (symbol->string arg)) 20 | ((string? arg) arg) 21 | ((number? arg) (number->string arg)))) 22 | args))))) 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | (define trim-symbol 25 | (lambda (sym) 26 | (let ((s (symbol->string sym))) 27 | (let loop ((i (- (string-length s) 1))) 28 | (if (< i 0) 29 | sym 30 | (let ((c (string-ref s i))) 31 | (case (string-ref s i) 32 | ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\_) 33 | (loop (- i 1))) 34 | (else 35 | (substring s 0 (+ i 1)))))))))) 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | ;;; auxiliary 38 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 39 | ;;; list of n results of applying thunk 40 | 41 | (define (nlist n thunk) 42 | (let loop ((n n)) 43 | (if (zero? n) 44 | '() 45 | (cons (thunk) (loop (- n 1)))))) 46 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 | ;;; sets rep. by sets without repeated elements; compared w/ eq? 48 | 49 | (define (set-include s e) 50 | (if (null? s) 51 | (list e) 52 | (if (memq e s) 53 | s 54 | (cons e s)))) 55 | 56 | (define (set-union s1 s2) 57 | (if (null? s1) s2 58 | (if (memq (car s1) s2) 59 | (set-union (cdr s1) s2) 60 | (cons (car s1) (set-union (cdr s1) s2))))) 61 | 62 | (define (set-intersection s1 s2) 63 | (if (null? s1) 64 | '() 65 | (if (memq (car s1) s2) 66 | (cons (car s1) (set-intersection (cdr s1) s2)) 67 | (set-intersection (cdr s1) s2)))) 68 | 69 | (define (set-subtract s e) 70 | (if (null? s) 71 | '() 72 | (if (eq? e (car s)) 73 | (cdr s) 74 | (cons (car s) (set-subtract (cdr s) e))))) 75 | 76 | (define (set-difference s1 s2) 77 | (if (null? s1) 78 | '() 79 | (let ((el (car s1)) 80 | (rest (set-difference (cdr s1) s2))) 81 | (if (memq el s2) 82 | rest 83 | (cons el rest))))) 84 | 85 | (define (set-union* . sets) 86 | (if (null? sets) 87 | '() 88 | (set-union (car sets) (apply set-union* (cdr sets))))) 89 | 90 | (define (set-equal? xs ys) 91 | (and (and-map (lambda (x) (member x ys)) xs) 92 | (and-map (lambda (y) (member y xs)) ys))) 93 | 94 | (define (and-map p? xs) 95 | (or (null? xs) 96 | (and (p? (car xs)) 97 | (and-map p? (cdr xs))))) 98 | 99 | (define (and-map2 p? xs ys) 100 | (or (null? xs) 101 | (and (p? (car xs) (car ys)) 102 | (and-map2 p? (cdr xs) (cdr ys))))) 103 | 104 | (define (strict-and-map p? xs) 105 | (or (null? xs) 106 | (let ((h (p? (car xs))) 107 | (t (strict-and-map p? (cdr xs)))) 108 | (and h t)))) 109 | 110 | (define (strict-or-map p? xs) 111 | (and (pair? xs) 112 | (let ((h (p? (car xs))) 113 | (t (strict-or-map p? (cdr xs)))) 114 | (or h t)))) 115 | 116 | (define (or-map p? xs) 117 | (and (pair? xs) 118 | (or (p? (car xs)) 119 | (or-map p? (cdr xs))))) 120 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 121 | (define (generic-sort leq x*) 122 | (let loop ((x* x*) (result '())) 123 | (if (null? x*) 124 | result 125 | (loop (cdr x*) (generic-insert leq (car x*) result))))) 126 | 127 | (define (generic-insert leq x x*) 128 | (let loop ((x* x*)) 129 | (if (null? x*) 130 | (list x) 131 | (let ((x1 (car x*))) 132 | (if (leq x x1) 133 | (cons x x*) 134 | (cons x1 (loop (cdr x*)))))))) 135 | 136 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 137 | (define (filter p xs) ;big-util 138 | (if (null? xs) 139 | '() 140 | (if (p (car xs)) 141 | (cons (car xs) (filter p (cdr xs))) 142 | (filter p (cdr xs))))) 143 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 144 | (define (remove-duplicates l) ;big-util 145 | (let loop ((l l) (u '())) 146 | (if (null? l) 147 | u 148 | (let ((e (car l))) 149 | (if (member e u) 150 | (loop (cdr l) u) 151 | (loop (cdr l) (cons e u))))))) 152 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 153 | (define (countq e l) 154 | (let loop ((l l) (r 0)) 155 | (if (pair? l) 156 | (if (eq? (car l) e) 157 | (loop (cdr l) (+ r 1)) 158 | (loop (cdr l) r)) 159 | r))) 160 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 161 | (define (list-or l) 162 | (and (pair? l) 163 | (or (car l) (list-or (cdr l))))) 164 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 165 | (define (take n l) 166 | (let loop ((n n) (l l) (acc '())) 167 | (if (or (zero? n) (null? l)) 168 | (reverse acc) 169 | (loop (- n 1) (cdr l) (cons (car l) acc))))) 170 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 171 | (define (thread-map f in xs) 172 | (if (null? xs) 173 | in 174 | (let ((out (f (car xs) in))) 175 | (thread-map f out (cdr xs))))) 176 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 177 | (define-syntax load-program 178 | (syntax-rules () 179 | ((_ prg) (eval `(BEGIN ,@prg) (interaction-environment))))) 180 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 181 | ;;; I/O: read a list of Scheme objects 182 | (define (file->list filename) 183 | (with-input-from-file filename 184 | (lambda () 185 | (let loop ((obj (read))) 186 | (if (eof-object? obj) 187 | '() 188 | (cons obj (loop (read)))))))) 189 | ;;; write a list of Scheme objects 190 | (define (writelpp l filename) 191 | (with-output-to-file filename 192 | (lambda () 193 | (for-each p l)))) 194 | 195 | (define (writel l filename) 196 | (with-output-to-file filename 197 | (lambda () 198 | (for-each write l)))) 199 | 200 | (define (count-cells x) 201 | (if (pair? x) 202 | (+ 1 (count-cells (car x)) (count-cells (cdr x))) 203 | 1)) 204 | ;;; 205 | (define (display-line . objs) 206 | (for-each display objs) 207 | (newline)) 208 | (define display-return 209 | (lambda (x) (display-line "returning " x) x)) 210 | (define display-list 211 | (lambda (l) (for-each (lambda (x) (display x) (display " ")) l))) 212 | (define (spaces n) 213 | (make-string n #\space)) 214 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 215 | (define (strip-path-prefix path) 216 | (let ((l (string-length path))) 217 | (let loop ((s 0) (i 0)) 218 | (cond 219 | ((= i l) 220 | (substring path s l)) 221 | ((eq? (string-ref path i) #\/) 222 | (loop (+ i 1) (+ i 1))) 223 | (else 224 | (loop s (+ i 1))))))) 225 | 226 | (define (strip-path-suffix path) 227 | (let ((l (string-length path))) 228 | (let loop ((e l) (i 0)) 229 | (cond 230 | ((= i l) 231 | (substring path 0 e)) 232 | ((eq? (string-ref path i) #\.) 233 | (loop i (+ i 1))) 234 | ((eq? (string-ref path i) #\/) 235 | (loop l (+ i 1))) 236 | (else 237 | (loop e (+ i 1))))))) 238 | 239 | (define fixnum-limit (expt 2 27)) ; leave some room for intermediate calculations 240 | 241 | (define (assimilate-hash hash adjustment) 242 | (modulo (+ (* 2 hash) adjustment) fixnum-limit)) 243 | 244 | (define (equal?-hash x) 245 | (let recur ((x x) 246 | (budget 16)) 247 | (cond 248 | ((<= budget 0) 22222222) 249 | ((string? x) (string-hash x)) 250 | ((pair? x) 251 | (assimilate-hash (recur (car x) (quotient budget 2)) 252 | (recur (cdr x) (- budget 1)))) 253 | ((vector? x) 254 | (let ((n (vector-length x))) 255 | (cond 256 | ((zero? n) 67890123) 257 | ((= n 1) 258 | (assimilate-hash (recur (vector-ref x 0) (- budget 1)) 259 | 67890123)) 260 | ((= n 2) 261 | (assimilate-hash (recur (vector-ref x 0) (quotient budget 2)) 262 | (assimilate-hash (recur (vector-ref x 1) (quotient budget 2)) 263 | 67890123))) 264 | (else 265 | (let ((budget (quotient budget 3))) 266 | (assimilate-hash (recur (vector-ref x 0) budget) 267 | (assimilate-hash (recur (vector-ref x 1) budget) 268 | (assimilate-hash (recur (vector-ref x 2) budget) 269 | 67890123)))))))) 270 | ((symbol? x) 271 | (assimilate-hash (string-hash (symbol->string x)) ; can probably be tuned later 272 | 78901234)) 273 | ((number? x) 274 | (if (exact? x) 275 | (cond ((integer? x) 276 | (assimilate-hash (modulo (abs x) fixnum-limit) 56789012)) 277 | ((rational? x) 278 | (assimilate-hash (recur (numerator x) (- budget 1)) 279 | (assimilate-hash (recur (denominator x) (- budget 1)) 280 | 89012345))) 281 | ((real? x) 21212121) ; would be strange 282 | ((complex? x) 283 | (assimilate-hash (recur (real-part x) (- budget 1)) 284 | (assimilate-hash (recur (imag-part x) (- budget 1)) 285 | 90123456))) 286 | 287 | (else 21212121)) 288 | (cond ((rational? x) 289 | (assimilate-hash (recur (inexact->exact (numerator x)) (- budget 1)) 290 | (assimilate-hash (recur (inexact->exact (denominator x)) (- budget 1)) 291 | 12345601))) 292 | ((real? x) 21212121) ; NaN, infinity 293 | ((complex? x) 294 | (assimilate-hash (recur (real-part x) (- budget 1)) 295 | (assimilate-hash (recur (imag-part x) (- budget 1)) 296 | 23456012))) 297 | 298 | 299 | (else 21212121)))) 300 | ((char? x) 301 | (assimilate-hash (char->integer x) 345670123)) 302 | ((string? x) 303 | (assimilate-hash (string-hash x) 456789012)) 304 | ((eq? x #t) 305 | (assimilate-hash 1 112223344)) 306 | ((not x) 307 | (assimilate-hash 2 112223344)) 308 | ((null? x) 309 | (assimilate-hash 3 112223344)) 310 | ((procedure? x) 443322110) 311 | (else 332211005)))) 312 | -------------------------------------------------------------------------------- /bench/bench-all.sh: -------------------------------------------------------------------------------- 1 | heap=4000000 2 | prefix=$1 3 | shift 4 | 5 | for style in $* 6 | do 7 | 8 | echo benchmarking $style 9 | out=bench/bench$prefix-$style.log 10 | echo "scheme48 -h $heap" > $out 11 | cat bench/bench-$style.script bench/bench-pgg.script | scheme48 -h $heap >> $out 12 | 13 | done 14 | -------------------------------------------------------------------------------- /bench/bench-cps.log: -------------------------------------------------------------------------------- 1 | scheme48 -h 4000000 2 | Welcome to Scheme 48 0.44 (made by sperber on Mon Jul 29 12:04:51 MST 1996). 3 | Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 4 | Copyright (c) 1996 by NEC Research Institute, Inc. 5 | Please report bugs to scheme-48-bugs@martigny.ai.mit.edu. 6 | Type ,? (comma question-mark) for help. 7 | > Will compile some calls in line 8 | > > cogen-load-cps.scm 9 | loading program-generator generator 10 | cogen-record.scm pp.scm auxiliary.scm cogen-env.scm cogen-abssyn.scm cogen-scheme.scm cogen-oca.scm cogen-skeleton.scm cogen-eq-flow.scm cogen-ctors.scm cogen-library.scm cogen-cps.scm cogen-residual.scm cogen-driver.scm > > > > > > > > > > > ----------------------------------------------------------------------> 11 | > PGG (app) :> 12 | > > Before: 485392 words free in semispace 13 | After: 1516754 words free in semispace 14 | > Run time: 5.59 seconds; Elapsed time: 5.84 seconds 15 | '#{Unspecific} 16 | > (^^^ preprocessing time * 100)> 17 | > > !!!compiling> 18 | > > > Before: 700116 words free in semispace 19 | After: 1515225 words free in semispace 20 | > Run time: 0.14 seconds; Elapsed time: 0.13 seconds 21 | '#{Unspecific} 22 | > (^^^ specialization time * 100)> 23 | > > > > > > Before: 1359677 words free in semispace 24 | After: 1515400 words free in semispace 25 | > > > ----------------------------------------------------------------------> 26 | > PGG (ctors) :> 27 | > > Before: 1506309 words free in semispace 28 | After: 1515301 words free in semispace 29 | > Run time: 13.32 seconds; Elapsed time: 13.99 seconds 30 | '#{Unspecific} 31 | > (^^^ preprocessing time * 100)> 32 | > > !!!compiling> 33 | > > > Before: 739987 words free in semispace 34 | After: 1506659 words free in semispace 35 | > Run time: 0.31 seconds; Elapsed time: 0.32 seconds 36 | '#{Unspecific} 37 | > (^^^ specialization time * 100)> 38 | > > > > > > Before: 1190660 words free in semispace 39 | After: 1506330 words free in semispace 40 | > > > ----------------------------------------------------------------------> 41 | > PGG (lambda) :> 42 | > > Before: 1497194 words free in semispace 43 | After: 1506231 words free in semispace 44 | > Run time: 10.98 seconds; Elapsed time: 11.47 seconds 45 | '#{Unspecific} 46 | > (^^^ preprocessing * 100)> 47 | > > !!!compiling> 48 | > > > Before: 56225 words free in semispace 49 | After: 1502390 words free in semispace 50 | > Run time: 0.54 seconds; Elapsed time: 0.56 seconds 51 | '#{Unspecific} 52 | > (^^^ specialization time * 100)> 53 | > > > > > > Before: 1038468 words free in semispace 54 | After: 1502686 words free in semispace 55 | > > > ----------------------------------------------------------------------> 56 | > PGG (direct-lr) :> 57 | > > > Before: 1491941 words free in semispace 58 | After: 1502587 words free in semispace 59 | > Run time: 2.48 seconds; Elapsed time: 2.68 seconds 60 | '#{Unspecific} 61 | > (^^^ preprocessing * 1)> 62 | > > > examples/direct-lr-support.scm > ../lr-essence/examples/grammars.scm > !!!compiling> 63 | > > > Before: 991336 words free in semispace 64 | After: 1437000 words free in semispace 65 | > Run time: 3.97 seconds; Elapsed time: 4.13 seconds 66 | '#{Unspecific} 67 | > (^^^ specialization time * 1)> 68 | > > > > > > Before: 527582 words free in semispace 69 | After: 1438275 words free in semispace 70 | > > > ----------------------------------------------------------------------> 71 | > PGG (cps-lr) :> 72 | > > Before: 1429184 words free in semispace 73 | After: 1438176 words free in semispace 74 | > Run time: 1.01 seconds; Elapsed time: 1.05 seconds 75 | #t 76 | > (^^^ preprocessing time * 1)> 77 | > > > examples/direct-lr-support.scm > ../lr-essence/examples/grammars.scm > > Before: 1046568 words free in semispace 78 | After: 1427834 words free in semispace 79 | > Run time: 3.36 seconds; Elapsed time: 3.53 seconds 80 | #t 81 | > (^^^ specialization time * 1)> 82 | > > > > > > > > ----------------------------------------------------------------------> 83 | > PGG (cps-lr, 3 levels) :> 84 | > > Before: 1071812 words free in semispace 85 | After: 1426600 words free in semispace 86 | > Run time: 1.05 seconds; Elapsed time: 1.09 seconds 87 | #t 88 | > (^^^ preprocessing time * 1)> 89 | > > > > Before: 1341565 words free in semispace 90 | After: 1414729 words free in semispace 91 | > Run time: 0.09 seconds; Elapsed time: 0.09 seconds 92 | #t 93 | > (^^^ generation time * 1)> 94 | > > > > examples/direct-lr-support.scm > ../lr-essence/examples/grammars.scm > Before: 434433 words free in semispace 95 | After: 1397886 words free in semispace 96 | > Run time: 3.33 seconds; Elapsed time: 3.50 seconds 97 | #t 98 | > (^^^ specialization time 1 * 1)> 99 | > > > > > > > ----------------------------------------------------------------------> 100 | > PGG (scheme1) :> 101 | > > Before: 1159405 words free in semispace 102 | After: 1410645 words free in semispace 103 | > Run time: 10.08 seconds; Elapsed time: 10.50 seconds 104 | #t 105 | > (^^^ preprocessing time * 1)> 106 | > > > > examples/scheme1-support.scm > ../../int/examples.scm > Before: 562460 words free in semispace 107 | After: 1199366 words free in semispace 108 | > 109 | dynamic conditional: (if (22 null? (23 . x)) (24 apply (25 . c) (26 . z)) (27 call a (28 cdr (29 . x)) (30 . z) (31 lambda ((32 . xz)) (33 apply (34 . c) (35 cons (36 car (37 . x)) (38 . xz)))))) 110 | 111 | dynamic conditional: (if (22 null? (23 . x)) (24 apply (25 . c) (26 . z)) (27 call a (28 cdr (29 . x)) (30 . z) (31 lambda ((32 . xz)) (33 apply (34 . c) (35 cons (36 car (37 . x)) (38 . xz)))))) 112 | 113 | dynamic conditional: (if (22 null? (23 . x)) (24 apply (25 . c) (26 . z)) (27 call a (28 cdr (29 . x)) (30 . z) (31 lambda ((32 . xz)) (33 apply (34 . c) (35 cons (36 car (37 . x)) (38 . xz)))))) 114 | Run time: 0.39 seconds; Elapsed time: 0.43 seconds 115 | #t 116 | > (^^^ specialization time * 1)> 117 | > > > -------------------------------------------------------------------------------- /bench/bench-cps.script: -------------------------------------------------------------------------------- 1 | ,bench on 2 | ,open escapes signals 3 | ,load cogen-load-cps.scm 4 | (define direct-lr-input-files '("examples/direct-lr-cps.scm" "examples/direct-lr-pgg.scm")) -------------------------------------------------------------------------------- /bench/bench-direct.log: -------------------------------------------------------------------------------- 1 | scheme48 -h 4000000 2 | Welcome to Scheme 48 0.44 (made by sperber on Mon Jul 29 12:04:51 MST 1996). 3 | Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 4 | Copyright (c) 1996 by NEC Research Institute, Inc. 5 | Please report bugs to scheme-48-bugs@martigny.ai.mit.edu. 6 | Type ,? (comma question-mark) for help. 7 | > Will compile some calls in line 8 | > > cogen-load.scm 9 | loading program-generator generator 10 | cogen-record.scm pp.scm auxiliary.scm cogen-env.scm cogen-abssyn.scm cogen-scheme.scm cogen-oca.scm cogen-skeleton.scm cogen-eq-flow.scm cogen-ctors.scm cogen-library.scm cogen-residual.scm shift-reset.scm cogen-direct-syntax.scm cogen-driver.scm > > > > > > > > > > > ----------------------------------------------------------------------> 11 | > PGG (app) :> 12 | > > Before: 180399 words free in semispace 13 | After: 1488933 words free in semispace 14 | > Run time: 5.58 seconds; Elapsed time: 5.86 seconds 15 | '#{Unspecific} 16 | > (^^^ preprocessing time * 100)> 17 | > > !!!compiling> 18 | > > > Before: 654437 words free in semispace 19 | After: 1488091 words free in semispace 20 | > Run time: 0.10 seconds; Elapsed time: 0.10 seconds 21 | '#{Unspecific} 22 | > (^^^ specialization time * 100)> 23 | > > > > > > Before: 1395368 words free in semispace 24 | After: 1488170 words free in semispace 25 | > > > ----------------------------------------------------------------------> 26 | > PGG (ctors) :> 27 | > > Before: 1478883 words free in semispace 28 | After: 1488134 words free in semispace 29 | > Run time: 13.32 seconds; Elapsed time: 13.96 seconds 30 | '#{Unspecific} 31 | > (^^^ preprocessing time * 100)> 32 | > > !!!compiling> 33 | > > > Before: 659895 words free in semispace 34 | After: 1481248 words free in semispace 35 | > Run time: 0.50 seconds; Elapsed time: 0.54 seconds 36 | '#{Unspecific} 37 | > (^^^ specialization time * 100)> 38 | > > > > > > Before: 997487 words free in semispace 39 | After: 1481478 words free in semispace 40 | > > > ----------------------------------------------------------------------> 41 | > PGG (lambda) :> 42 | > > Before: 1472387 words free in semispace 43 | After: 1481379 words free in semispace 44 | > Run time: 10.93 seconds; Elapsed time: 11.47 seconds 45 | '#{Unspecific} 46 | > (^^^ preprocessing * 100)> 47 | > > !!!compiling> 48 | > > > Before: 1467112 words free in semispace 49 | After: 1478468 words free in semispace 50 | > Run time: 0.64 seconds; Elapsed time: 0.67 seconds 51 | '#{Unspecific} 52 | > (^^^ specialization time * 100)> 53 | > > > > > > Before: 880358 words free in semispace 54 | After: 1478719 words free in semispace 55 | > > > ----------------------------------------------------------------------> 56 | > PGG (direct-lr) :> 57 | > > > Before: 1467822 words free in semispace 58 | After: 1478617 words free in semispace 59 | > wft-apply-property 60 | Run time: 2.47 seconds; Elapsed time: 2.59 seconds 61 | '#{Unspecific} 62 | > (^^^ preprocessing * 1)> 63 | > > > examples/direct-lr-support.scm > ../lr-essence/examples/grammars.scm > !!!compiling> 64 | > wft-apply-property 65 | > > Before: 1224002 words free in semispace 66 | After: 1429551 words free in semispace 67 | > Run time: 3.97 seconds; Elapsed time: 4.14 seconds 68 | '#{Unspecific} 69 | > (^^^ specialization time * 1)> 70 | > > > > > > Before: 580219 words free in semispace 71 | After: 1429764 words free in semispace 72 | > > > ----------------------------------------------------------------------> 73 | > PGG (cps-lr) :> 74 | > > Before: 1420575 words free in semispace 75 | After: 1429665 words free in semispace 76 | > Run time: 1.03 seconds; Elapsed time: 1.06 seconds 77 | #t 78 | > (^^^ preprocessing time * 1)> 79 | > > > examples/direct-lr-support.scm > ../lr-essence/examples/grammars.scm > > Before: 1189329 words free in semispace 80 | After: 1425690 words free in semispace 81 | > Run time: 3.37 seconds; Elapsed time: 3.54 seconds 82 | #t 83 | > (^^^ specialization time * 1)> 84 | > > > > > > > > ----------------------------------------------------------------------> 85 | > PGG (cps-lr, 3 levels) :> 86 | > > Before: 1105666 words free in semispace 87 | After: 1423766 words free in semispace 88 | > Run time: 1.07 seconds; Elapsed time: 1.10 seconds 89 | #t 90 | > (^^^ preprocessing time * 1)> 91 | > > > > Before: 11998 words free in semispace 92 | After: 1408950 words free in semispace 93 | > Run time: 0.11 seconds; Elapsed time: 0.11 seconds 94 | #t 95 | > (^^^ generation time * 1)> 96 | > > > > examples/direct-lr-support.scm > ../lr-essence/examples/grammars.scm > Before: 453032 words free in semispace 97 | After: 1395756 words free in semispace 98 | > Run time: 3.39 seconds; Elapsed time: 3.55 seconds 99 | #t 100 | > (^^^ specialization time 1 * 1)> 101 | > > > > > > > ----------------------------------------------------------------------> 102 | > PGG (scheme1) :> 103 | > > Before: 1122021 words free in semispace 104 | After: 1403914 words free in semispace 105 | > Run time: 10.04 seconds; Elapsed time: 10.52 seconds 106 | #t 107 | > (^^^ preprocessing time * 1)> 108 | > > > > examples/scheme1-support.scm > ../../int/examples.scm > Before: 281548 words free in semispace 109 | After: 1286924 words free in semispace 110 | > 111 | dynamic conditional: (if (22 null? (23 . x)) (24 apply (25 . c) (26 . z)) (27 call a (28 cdr (29 . x)) (30 . z) (31 lambda ((32 . xz)) (33 apply (34 . c) (35 cons (36 car (37 . x)) (38 . xz)))))) 112 | 113 | dynamic conditional: (if (22 null? (23 . x)) (24 apply (25 . c) (26 . z)) (27 call a (28 cdr (29 . x)) (30 . z) (31 lambda ((32 . xz)) (33 apply (34 . c) (35 cons (36 car (37 . x)) (38 . xz)))))) 114 | 115 | dynamic conditional: (if (22 null? (23 . x)) (24 apply (25 . c) (26 . z)) (27 call a (28 cdr (29 . x)) (30 . z) (31 lambda ((32 . xz)) (33 apply (34 . c) (35 cons (36 car (37 . x)) (38 . xz)))))) 116 | Run time: 0.18 seconds; Elapsed time: 0.18 seconds 117 | #t 118 | > (^^^ specialization time * 1)> 119 | > > > -------------------------------------------------------------------------------- /bench/bench-direct.script: -------------------------------------------------------------------------------- 1 | ,bench on 2 | ,open escapes signals 3 | ,load cogen-load.scm 4 | (define direct-lr-input-files '("examples/direct-lr-pgg.scm")) 5 | -------------------------------------------------------------------------------- /bench/bench-pgg.log: -------------------------------------------------------------------------------- 1 | scheme48 -h 4000000 2 | Welcome to Scheme 48 0.44 (made by sperber on Mon Jul 29 12:04:51 MST 1996). 3 | Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. 4 | Copyright (c) 1996 by NEC Research Institute, Inc. 5 | Please report bugs to scheme-48-bugs@martigny.ai.mit.edu. 6 | Type ,? (comma question-mark) for help. 7 | > > cogen-load.scm 8 | loading program-generator generator 9 | cogen-record.scm 10 | auxiliary.scm 11 | 12 | Undefined: (p) 13 | cogen-env.scm 14 | cogen-abssyn.scm 15 | cogen-scheme.scm 16 | 17 | Undefined: (wft-property-table wft-make-memo-property bta-make-memo-postprocessor) 18 | cogen-oca.scm 19 | cogen-skeleton.scm 20 | 21 | Undefined: (make-ge-var make-ge-const make-ge-cond make-ge-op make-ge-call make-ge-begin make-ge-let full-ecr node-fetch-type type->memo ann->bt make-ge-lambda make-ge-lambda-memo make-ge-vlambda-memo make-ge-app make-ge-app-memo make-ge-ctor make-ge-ctor-memo make-ge-sel make-ge-sel-memo make-ge-test make-ge-test-memo make-ge-lift make-ge-eval) 22 | cogen-eq-flow.scm 23 | cogen-ctors.scm 24 | cogen-library.scm 25 | 26 | Undefined: (_op project-dynamic-gen _lift0 _if _lambda _let _app) 27 | cogen-residual.scm 28 | shift-reset.scm 29 | cogen-direct-syntax.scm 30 | cogen-driver.scm 31 | 32 | > > > > > > > > > > > ----------------------------------------------------------------------> 33 | > PGG (app) :> 34 | > > Before: 186032 words free in semispace 35 | After: 1482243 words free in semispace 36 | > Run time: 7.43 seconds; Elapsed time: 7.44 seconds 37 | '#{Unspecific} 38 | > (^^^ preprocessing time * 100)> 39 | > > !!!generating compiler> 40 | > > > Before: 478799 words free in semispace 41 | After: 1480337 words free in semispace 42 | > Run time: 0.51 seconds; Elapsed time: 0.54 seconds 43 | '#{Unspecific} 44 | > (^^^ generation time * 100)> 45 | > > !!!compiling> 46 | > > > Before: 1114070 words free in semispace 47 | After: 1479537 words free in semispace 48 | > Run time: 0.21 seconds; Elapsed time: 0.20 seconds 49 | '#{Unspecific} 50 | > (^^^ specialization time * 100)> 51 | > > > > > > Before: 1359676 words free in semispace 52 | After: 1480353 words free in semispace 53 | > > > ----------------------------------------------------------------------> 54 | > PGG (ctors) :> 55 | > > Before: 1471200 words free in semispace 56 | After: 1480254 words free in semispace 57 | > Run time: 17.00 seconds; Elapsed time: 17.16 seconds 58 | '#{Unspecific} 59 | > (^^^ preprocessing time * 100)> 60 | > > !!!generating compiler> 61 | > > > Before: 365025 words free in semispace 62 | After: 1471087 words free in semispace 63 | > Run time: 0.89 seconds; Elapsed time: 0.88 seconds 64 | '#{Unspecific} 65 | > (^^^ generation time * 100)> 66 | > > !!!compiling> 67 | > > > Before: 812768 words free in semispace 68 | After: 1470083 words free in semispace 69 | > Run time: 0.40 seconds; Elapsed time: 0.40 seconds 70 | '#{Unspecific} 71 | > (^^^ specialization time * 100)> 72 | > > > > > > Before: 1217742 words free in semispace 73 | After: 1471363 words free in semispace 74 | > > > ----------------------------------------------------------------------> 75 | > PGG (lambda) :> 76 | > > Before: 1462249 words free in semispace 77 | After: 1471264 words free in semispace 78 | > Run time: 13.93 seconds; Elapsed time: 13.95 seconds 79 | '#{Unspecific} 80 | > (^^^ preprocessing * 100)> 81 | > > !!!generating compiler> 82 | > > > Before: 1330872 words free in semispace 83 | After: 1468076 words free in semispace 84 | > Run time: 1.08 seconds; Elapsed time: 1.08 seconds 85 | '#{Unspecific} 86 | > (^^^ generation time * 100)> 87 | > > !!!compiling> 88 | > > > Before: 640287 words free in semispace 89 | After: 1465868 words free in semispace 90 | > Run time: 0.81 seconds; Elapsed time: 0.81 seconds 91 | '#{Unspecific} 92 | > (^^^ specialization time * 100)> 93 | > > > > > > Before: 946365 words free in semispace 94 | After: 1468109 words free in semispace 95 | > > > ----------------------------------------------------------------------> 96 | > PGG (direct-lr) :> 97 | > > > Before: 1457337 words free in semispace 98 | After: 1468010 words free in semispace 99 | > wft-apply-property 100 | Run time: 3.29 seconds; Elapsed time: 3.29 seconds 101 | '#{Unspecific} 102 | > (^^^ preprocessing * 1)> 103 | > > !!!generating compiler> 104 | > wft-apply-property 105 | > > Before: 1105114 words free in semispace 106 | After: 1427214 words free in semispace 107 | > Run time: 0.22 seconds; Elapsed time: 0.22 seconds 108 | '#{Unspecific} 109 | > (^^^ generation time * 1)> 110 | > > examples/direct-lr-support.scm 111 | > ../lr-essence/examples/grammars.scm 112 | > !!!compiling> 113 | > > > Before: 32465 words free in semispace 114 | After: 1385342 words free in semispace 115 | > Run time: 4.44 seconds; Elapsed time: 4.44 seconds 116 | '#{Unspecific} 117 | > (^^^ specialization time * 1)> 118 | > > > > > > Before: 635379 words free in semispace 119 | After: 1405098 words free in semispace 120 | > > > ----------------------------------------------------------------------> 121 | > PGG (cps-lr) :> 122 | > > Before: 1395987 words free in semispace 123 | After: 1404999 words free in semispace 124 | > Run time: 1.32 seconds; Elapsed time: 1.36 seconds 125 | #t 126 | > (^^^ preprocessing time * 1)> 127 | > > > > Before: 31897 words free in semispace 128 | After: 1397263 words free in semispace 129 | > Run time: 0.12 seconds; Elapsed time: 0.11 seconds 130 | #t 131 | > ^^^ generation time * 1> 132 | > > > > examples/direct-lr-support.scm 133 | > ../lr-essence/examples/grammars.scm 134 | > Before: 334585 words free in semispace 135 | After: 1384187 words free in semispace 136 | > Run time: 4.57 seconds; Elapsed time: 4.61 seconds 137 | #t 138 | > (^^^ specialization time * 1)> 139 | > > > > > > > > > ----------------------------------------------------------------------> 140 | > PGG (cps-lr, 3 levels) :> 141 | > > Before: 732958 words free in semispace 142 | After: 1395206 words free in semispace 143 | > Run time: 1.39 seconds; Elapsed time: 1.39 seconds 144 | #t 145 | > (^^^ preprocessing time * 1)> 146 | > > > > Before: 1284134 words free in semispace 147 | After: 1380419 words free in semispace 148 | > Run time: 0.14 seconds; Elapsed time: 0.13 seconds 149 | #t 150 | > (^^^ generation time * 1)> 151 | > > > > Before: 509305 words free in semispace 152 | After: 1362565 words free in semispace 153 | > Run time: 0.16 seconds; Elapsed time: 0.15 seconds 154 | #t 155 | > (^^^ specialization time 1 * 1)> 156 | > > > > examples/direct-lr-support.scm 157 | > ../lr-essence/examples/grammars.scm 158 | > Before: 175531 words free in semispace 159 | After: 1348937 words free in semispace 160 | > Run time: 4.50 seconds; Elapsed time: 4.50 seconds 161 | #t 162 | > (^^^ specialization time 2 * 1)> 163 | > > > > > > > ----------------------------------------------------------------------> 164 | > PGG (scheme1) :> 165 | > > Before: 742401 words free in semispace 166 | After: 1364490 words free in semispace 167 | > Run time: 14.32 seconds; Elapsed time: 14.46 seconds 168 | #t 169 | > (^^^ preprocessing time * 1)> 170 | > > > > Before: 124096 words free in semispace 171 | After: 1210624 words free in semispace 172 | > Run time: 0.48 seconds; Elapsed time: 0.48 seconds 173 | #t 174 | > ^^^ generation time * 1> 175 | > > > > examples/scheme1-support.scm 176 | > Before: 1040275 words free in semispace 177 | After: 1101761 words free in semispace 178 | > Run time: 0.02 seconds; Elapsed time: 0.02 seconds 179 | #t 180 | > (^^^ specialization time * 1)> 181 | > > > > > -------------------------------------------------------------------------------- /bench/bench-pgg.script: -------------------------------------------------------------------------------- 1 | (define repetitions 100) 2 | (define ntimes 3 | (lambda (thunk n) 4 | (let loop ((i n)) 5 | (if (> i 0) 6 | (begin 7 | (thunk) 8 | (loop (- i 1))))))) 9 | 10 | ,in cogen-globals (set! *bta-display-level* 0) ;quiet, please 11 | ,open define-data 12 | 13 | 14 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 15 | (display "----------------------------------------------------------------------") (newline) 16 | (display "PGG (app) :") (newline) 17 | 18 | ,collect 19 | ,time (ntimes (lambda() (cogen-driver '("examples/app.scm") '(app 0 1)) #f) 1) 20 | (display (list "^^^ preprocessing time *" repetitions)) (newline) 21 | 22 | (display "!!!compiling") (newline) 23 | (define *residual-program* (cogen-driver '("examples/app.scm") '(app 0 1))) 24 | (load-program *residual-program*) 25 | ,collect 26 | ,time (ntimes (lambda () (start-memo 1 $goal '(0 1) (list '(a b c) 'YYY))) repetitions) 27 | (display (list "^^^ specialization time *" repetitions)) (newline) 28 | 29 | ;;; 30 | 31 | 32 | 33 | ,collect 34 | 35 | ;;; second run 36 | (display "----------------------------------------------------------------------") (newline) 37 | (display "PGG (ctors) :") (newline) 38 | 39 | ,collect 40 | ,time (ntimes (lambda() (cogen-driver '("examples/ctors.scm") '(main 0 1)) #f) 1) 41 | (display (list "^^^ preprocessing time *" repetitions)) (newline) 42 | 43 | (display "!!!compiling") (newline) 44 | (define *residual-program* (cogen-driver '("examples/ctors.scm") '(main 0 1))) 45 | (load-program *residual-program*) 46 | ,collect 47 | ,time (ntimes (lambda () (start-memo 1 $goal '(0 1) (list '(a b c) 'YYY))) repetitions) 48 | (display (list "^^^ specialization time *" repetitions)) (newline) 49 | 50 | ;;; 51 | 52 | 53 | 54 | ,collect 55 | 56 | ;;; third run 57 | (display "----------------------------------------------------------------------") (newline) 58 | (display "PGG (lambda) :") (newline) 59 | 60 | ,collect 61 | ,time (ntimes (lambda() (cogen-driver '("examples/lambda.scm") '(main 0 1)) #f) 1) 62 | (display (list "^^^ preprocessing *" repetitions)) (newline) 63 | 64 | (display "!!!compiling") (newline) 65 | (define *residual-program* (cogen-driver '("examples/lambda.scm") '(main 0 1))) 66 | (load-program *residual-program*) 67 | ,collect 68 | ,time (ntimes (lambda () (start-memo 1 $goal '(0 1) (list 42 'YYY))) repetitions) 69 | (display (list "^^^ specialization time *" repetitions)) (newline) 70 | 71 | ;;; 72 | 73 | 74 | 75 | ,collect 76 | 77 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | (display "----------------------------------------------------------------------") (newline) 79 | (display "PGG (direct-lr) :") (newline) 80 | (set! repetitions 1) 81 | (define direct-lr-input-files '("examples/direct-lr-pgg.scm")) 82 | 83 | ,collect 84 | ,time (ntimes (lambda() (cogen-driver direct-lr-input-files '(direct-parse-main 0 0 1)) #f) repetitions) 85 | (display (list "^^^ preprocessing *" repetitions)) (newline) 86 | 87 | 88 | (load "examples/direct-lr-support.scm") 89 | (load "../lr-essence/examples/toy-grammars.scm") 90 | (display "!!!compiling") (newline) 91 | (define *residual-program* (cogen-driver direct-lr-input-files '(direct-parse-main 0 0 1))) 92 | (load-program *residual-program*) 93 | ,collect 94 | ,time (ntimes (lambda () (start-memo 1 $goal '(0 0 1) (list g10-attrib 1 'input))) repetitions) 95 | (display (list "^^^ specialization time *" repetitions)) (newline) 96 | 97 | ;;; 98 | 99 | 100 | 101 | ,collect 102 | 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | (display "----------------------------------------------------------------------") (newline) 105 | (display "PGG (cps-lr) :") (newline) 106 | 107 | ,collect 108 | ,time (begin (cogen-driver '("examples/cps-lr.scm") '(do-parse 0 0 1)) #t) 109 | (display (list "^^^ preprocessing time * 1")) (newline) 110 | (define *residual-program* (cogen-driver '("examples/cps-lr.scm") '(do-parse 0 0 1))) 111 | (load-program *residual-program*) 112 | (load "examples/direct-lr-support.scm") 113 | (load "../lr-essence/examples/toy-grammars.scm") 114 | 115 | ,collect 116 | ,time (begin (start-memo 1 $goal '(0 0 1) (list g10-attrib 1 'input)) #t) 117 | (display (list "^^^ specialization time * 1")) (newline) 118 | 119 | ;;; 120 | 121 | 122 | 123 | 124 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 125 | (display "----------------------------------------------------------------------") (newline) 126 | (display "PGG (cps-lr, 3 levels) :") (newline) 127 | 128 | ,collect 129 | ,time (begin (cogen-driver '("examples/cps-lr.scm") '(do-parse 1 1 2)) #t) 130 | (display (list "^^^ preprocessing time * 1")) (newline) 131 | (define *residual-program* (cogen-driver '("examples/cps-lr.scm") '(do-parse 1 1 2))) 132 | (load-program *residual-program*) 133 | 134 | ,collect 135 | ,time (begin (start-memo 2 $goal '(1 1 2) (list 'grammar 'k 'input)) #t) 136 | (display (list "^^^ generation time * 1")) (newline) 137 | (define level1 (start-memo 2 $goal '(1 1 2) (list 'grammar 'k 'input))) 138 | (load-program *residual-program*) 139 | 140 | (load "examples/direct-lr-support.scm") 141 | (load "../lr-essence/examples/toy-grammars.scm") 142 | ,collect 143 | ,time (begin (nextlevel level1 (list g10-attrib 1 'input)) #t) 144 | (display (list "^^^ specialization time 1 * 1")) (newline) 145 | 146 | 147 | 148 | 149 | 150 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 151 | (display "----------------------------------------------------------------------") (newline) 152 | (display "PGG (scheme1) :") (newline) 153 | 154 | ,collect 155 | ,time (begin (cogen-driver '("examples/scheme1-pgg.scm") '(s1-2int-skeleton 0 0 1)) #t) 156 | (display (list "^^^ preprocessing time * 1")) (newline) 157 | (define *residual-program* (cogen-driver '("examples/scheme1-pgg.scm") '(s1-2int-skeleton 0 0 1))) 158 | (load-program *residual-program*) 159 | 160 | (load "examples/scheme1-support.scm") 161 | (load "../../int/examples.scm") 162 | ,collect 163 | ,time (begin (start-memo 1 $goal '(0 0 1) (list ex5 '(f (aaa bbb ccc) ***) '***)) #t) 164 | (display (list "^^^ specialization time * 1")) (newline) 165 | 166 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 167 | ,exit 168 | -------------------------------------------------------------------------------- /bench/bench-similix.script: -------------------------------------------------------------------------------- 1 | (define repetitions 100) 2 | (verbose-prep-off) 3 | (postprocess-off) 4 | (define (good-cogen) (postprocess-on) (cogen 1) (postprocess-off)) 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ;;; first run on append 7 | (display "Similix (app) :") (newline) 8 | ;;; 9 | (display "!!!preprocessing") (newline) 10 | (preprocess! 'app '(s d) "examples/app") 11 | ,time (ntimes (lambda () (preprocess! 'app '(s d) "examples/app")) 12 | repetitions) 13 | (display (list "^^^preprocessing time *" repetitions)) (newline) 14 | (display "!!!generating compiler") (newline) 15 | (cogen 1) 16 | ,time (cogen repetitions) 17 | (display (list "^^^generation time *" repetitions)) (newline) 18 | (display "!!!compiling") (newline) 19 | (good-cogen) 20 | (comp '((a b c) ***)) 21 | ,time (begin (comp '((a b c) ***) repetitions) #t) 22 | (display (list "^^^compilation time *" repetitions)) (newline) 23 | (display "!!!specializing") (newline) 24 | ,time (begin (similix '((a b c) ***) repetitions) #f) 25 | (display (list "^^^specialization time *" repetitions)) (newline) 26 | 27 | ;;; second run with partially static data 28 | (display "----------------------------------------------------------------------") (newline) 29 | (display "Similix (ctors) :") (newline) 30 | ;;; 31 | (display "!!!preprocessing") (newline) 32 | (preprocess! 'main '(s d) "examples/ctors") 33 | ,time (ntimes (lambda () (preprocess! 'main '(s d) "examples/ctors")) 34 | repetitions) 35 | (display (list "^^^preprocessing time *" repetitions)) (newline) 36 | 37 | (display "!!!generating compiler") (newline) 38 | (cogen 1) 39 | ,time (cogen repetitions) 40 | (display (list "^^^generation time *" repetitions)) (newline) 41 | 42 | (display "!!!compiling") (newline) 43 | (good-cogen) 44 | (comp '((a b c) ***)) 45 | ,time (begin (comp '((a b c) ***) repetitions) #t) 46 | (display (list "^^^compilation time *" repetitions)) (newline) 47 | 48 | (display "!!!specializing") (newline) 49 | ,time (begin (similix '((a b c) ***) repetitions) #f) 50 | (display (list "^^^specialization time *" repetitions)) (newline) 51 | 52 | ;;; third run with partially static functions 53 | (display "----------------------------------------------------------------------") (newline) 54 | (display "Similix (lambda) :") (newline) 55 | ;;; 56 | (display "!!!preprocessing") (newline) 57 | (preprocess! 'main '(s d) "examples/lambda") 58 | ,time (ntimes (lambda () (preprocess! 'main '(s d) "examples/lambda")) 59 | repetitions) 60 | (display (list "^^^preprocessing time *" repetitions)) (newline) 61 | 62 | (display "!!!generating compiler") (newline) 63 | (cogen 1) 64 | ,time (cogen repetitions) 65 | (display (list "^^^generation time *" repetitions)) (newline) 66 | 67 | (display "!!!generating compiler") (newline) 68 | (display "!!!compiling") (newline) 69 | (good-cogen) 70 | (comp (list 42 '***)) 71 | ,time (begin (comp (list 42 '***) repetitions) #t) 72 | (display (list "^^^compilation time *" repetitions)) (newline) 73 | 74 | (display "!!!specializing") (newline) 75 | ,time (begin (similix (list 42 '**) repetitions) #f) 76 | (display (list "^^^specialization time *" repetitions)) (newline) 77 | 78 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 79 | (define repetitions 1) 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | (display "----------------------------------------------------------------------") (newline) 82 | (display "Similix (direct-lr) :") (newline) 83 | (load "../lr-essence/examples/grammars.scm") 84 | ;;; 85 | (display "!!!preprocessing") (newline) 86 | (preprocess! 'direct-parse-main '(s s d) "examples/direct-lr-sim") 87 | ,collect 88 | ,time (ntimes (lambda () (preprocess! 'direct-parse-main '(s s d) "examples/direct-lr-sim")) 89 | repetitions) 90 | (display (list "^^^preprocessing time *" repetitions)) (newline) 91 | 92 | (display "!!!generating compiler") (newline) 93 | (cogen 1) 94 | ,collect 95 | ,time (cogen repetitions) 96 | (display (list "^^^generation time *" repetitions)) (newline) 97 | 98 | (display "!!!compiling") (newline) 99 | (good-cogen) 100 | (comp (list g10-attrib 1 '***)) 101 | ,collect 102 | ,time (begin (comp (list g10-attrib 1 '***) repetitions) #t) 103 | (display (list "^^^compilation time *" repetitions)) (newline) 104 | 105 | (display "!!!specializing") (newline) 106 | ,collect 107 | ,time (begin (similix (list g10-attrib 1 '**) repetitions) #f) 108 | (display (list "^^^specialization time *" repetitions)) (newline) 109 | 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | (display "----------------------------------------------------------------------") (newline) 112 | (display "Similix (cps-lr) :") (newline) 113 | (load "../lr-essence/examples/grammars.scm") 114 | ;;; 115 | (display "!!!preprocessing") (newline) 116 | (preprocess! 'do-parse '(s s d) "examples/cps-lr-sim") 117 | ,collect 118 | ,time (ntimes (lambda () (preprocess! 'do-parse '(s s d) "examples/cps-lr-sim")) 119 | repetitions) 120 | (display (list "^^^preprocessing time *" repetitions)) (newline) 121 | 122 | (display "!!!generating compiler") (newline) 123 | (cogen 1) 124 | ,collect 125 | ,time (cogen repetitions) 126 | (display (list "^^^generation time *" repetitions)) (newline) 127 | (display "!!!compiling") (newline) 128 | (good-cogen) 129 | (comp (list g10-attrib 1 '***)) 130 | ,collect 131 | ,time (begin (comp (list g10-attrib 1 '***) repetitions) #t) 132 | (display (list "^^^compilation time *" repetitions)) (newline) 133 | 134 | (display "!!!specializing") (newline) 135 | ,collect 136 | ,time (begin (similix (list g10-attrib 1 '**) repetitions) #f) 137 | (display (list "^^^specialization time *" repetitions)) (newline) 138 | 139 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 140 | ,exit 141 | -------------------------------------------------------------------------------- /cogen-abssyn.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-abssyn.scm -------------------------------------------------------------------------------- /cogen-anf-compile.scm: -------------------------------------------------------------------------------- 1 | ;;; $Id$ 2 | ;;; direct style version of the continuation-based multi-level 3 | ;;; compiler generator (with control operators) 4 | ;;; 5 | ;;; includes the conversion of the residual code to A-normal form 6 | ;;; hence performs full context propagation 7 | ;;; 8 | 9 | (set-scheme->abssyn-let-insertion! #f) 10 | (set-memo-optimize! #f) 11 | 12 | (define-syntax _app 13 | (syntax-rules () 14 | ((_app 0 e ...) 15 | (e ...)) 16 | ((_app 1 e ...) 17 | (_complete-serious (make-residual-call e ...))) 18 | ((_app lv e ...) 19 | (_complete `(_APP ,(pred lv) ,e ...))))) 20 | 21 | (define-syntax _app_memo 22 | (syntax-rules () 23 | ((_app_memo 0 f arg ...) 24 | ((f 'VALUE) arg ...)) 25 | ;; this is wrong 26 | ((_app_memo 1 e ...) 27 | (_complete-serious (make-residual-call e ...))))) 28 | 29 | (define-syntax _lambda 30 | (syntax-rules () 31 | ((_lambda 0 vars body) 32 | (lambda vars body)) 33 | ((_lambda lv vars body) 34 | (_lambda-internal lv 'vars (lambda vars body))))) 35 | 36 | (define (_lambda-internal lv arity f) 37 | (let* ((vars (map gensym-local arity)) 38 | (body (reset (apply f vars))) 39 | (l (pred lv)) 40 | (generate-lambda 41 | (if (zero? l) 42 | (lambda () 43 | (make-residual-closed-lambda vars 'FREE body)) 44 | (lambda () 45 | (make-residual-generator-vve '_LAMBDA l vars body))))) 46 | (if *lambda-is-pure* 47 | (generate-lambda) 48 | (_complete ;don't duplicate, experimental 49 | (generate-lambda))))) 50 | 51 | (define-syntax _lambda_memo 52 | (syntax-rules () 53 | ((_ 0 arity label vvs bts f) 54 | (static-constructor label f vvs bts)) 55 | ((_ arg ...) 56 | (_lambda_memo-internal arg ...)))) 57 | 58 | (define (_lambda_memo-internal lv arity label vvs bts f) 59 | ;; the let* bindings are identical to cogen-direct-anf ---msp 60 | (let* ((formals (map gensym-local arity)) 61 | (lambda-pp (cons label vvs)) 62 | (dynamics (top-project-dynamic lambda-pp bts)) 63 | (compressed-dynamics (map remove-duplicates dynamics)) 64 | (actual-fvs (apply append compressed-dynamics)) 65 | (clone-map (map (lambda (arg) 66 | (cons arg (if (symbol? arg) 67 | (gensym-local arg) 68 | (gensym-local 'clone)))) 69 | actual-fvs)) 70 | (cloned-pp (top-clone-with clone-map lambda-pp bts)) 71 | (cloned-vvs (cdr cloned-pp)) 72 | (new-bts (map pred (map cdr compressed-dynamics))) 73 | (formal-fvs (map cdr clone-map))) 74 | ;; this only works in the two-level case for (= lv 1) 75 | ;; pjt: this is wrong 76 | (make-residual-closed-lambda formals 77 | actual-fvs 78 | (reset (apply (apply f vvs) formals))))) 79 | 80 | 81 | (define (_vlambda lv arity var f) 82 | (let* ((vars (map gensym-local arity)) 83 | (vvar (gensym-local var)) 84 | (fun `(LAMBDA ,(append vars vvar) 85 | ,(reset (apply f vars))))) ;unclear what to do with vvar 86 | (if (= lv 1) 87 | fun 88 | `(_VLAMBDA ,(pred lv) ',arity ',var ,fun)))) 89 | 90 | (define-syntax _begin 91 | (syntax-rules () 92 | ((_ 0 bl e1 e2) 93 | (begin e1 e2)) 94 | ((_ 1 bl e1 e2) 95 | (shift k (make-residual-begin e1 (reset (k e2))))) 96 | ((_ lv bl e1 e2) 97 | (shift k `(_BEGIN ,(pred lv) 0 ,e1 ,(reset (k e2))))))) 98 | 99 | (define-syntax _ctor_memo 100 | (syntax-rules () 101 | ((_ 0 bts ctor arg ...) 102 | (static-constructor 'ctor ctor (list arg ...) 'bts)) 103 | ((_ 1 (bt ...) ctor arg ...) 104 | (_complete-serious 105 | (make-residual-call (make-residual-var 'ctor) arg ...))))) 106 | 107 | (define-syntax _s_t_memo 108 | (syntax-rules () 109 | ((_ 0 sel v) 110 | (sel (v 'VALUE))) 111 | ((_sel_memo 1 sel v) 112 | (_complete-serious 113 | (make-residual-call (make-residual-var 'sel) v))))) 114 | 115 | (define-syntax _if 116 | (syntax-rules () 117 | ((_if 0 e1 e2 e3) 118 | (if e1 e2 e3)) 119 | ((_if 1 e1 e2 e3) 120 | (shift k (make-residual-if e1 (reset (k e2)) (reset (k e3))))) 121 | ((_if lv e1 e2 e3) 122 | (shift k `(_IF ,(pred lv) 0 123 | ,e1 124 | ,(reset (k e2)) 125 | ,(reset (k e3))))))) 126 | 127 | (define-syntax _op 128 | (syntax-rules (apply _define_data) 129 | ((_op lv _define_data arg) 'lose) 130 | ((_op 0 op arg ...) 131 | (op arg ...)) 132 | ((_op 1 apply f arg ...) 133 | (_complete-serious (make-residual-primop 'apply f arg ...))) 134 | ((_op 1 op arg ...) 135 | (_complete (make-residual-primop 'op arg ...))) 136 | ((_op lv op arg ...) 137 | (_complete `(_OP ,(pred lv) op ,arg ...))))) 138 | 139 | (define-syntax _op_serious 140 | (syntax-rules (_define_data) 141 | ((_ lv _define_data arg) 'lose) 142 | ((_ 0 op arg ...) 143 | (op arg ...)) 144 | ((_ 1 op arg ...) 145 | (_complete-serious (make-residual-call (make-residual-var 'op) arg ...))) 146 | ((_ lv op arg ...) 147 | (_complete `(_OP_SERIOUS ,(pred lv) op ,arg ...))))) 148 | 149 | (define-syntax _lift0 150 | (syntax-rules () 151 | ((_ 1 val) 152 | (make-residual-literal val)) 153 | ((_ lv val) 154 | `(_LIFT0 ,(pred lv) ',val)))) 155 | 156 | (define-syntax _lift 157 | (syntax-rules () 158 | ((_ 0 diff value) 159 | (_lift0 diff value)) 160 | ((_ 1 diff value) 161 | `(_LIFT0 ,diff ,value)) 162 | ((_ lv diff value) 163 | `(_LIFT ,(pred lv) ,diff ,value)))) 164 | 165 | (define-syntax _eval 166 | (syntax-rules () 167 | ((_ 0 0 body) 168 | (eval body (interaction-environment))) 169 | ((_ 0 1 body) 170 | (_complete body)) 171 | ((_ 0 diff body) 172 | (_complete `(_EVAL 0 ,(pred diff) ',body))) 173 | ((_ 1 0 body) 174 | (_complete `(EVAL ,body (INTERACTION-ENVIRONMENT)))) 175 | ((_ 1 1 body) 176 | body) ;;;?????????? _complete ?????????? 177 | ((_ lv diff body) 178 | (_complete `(_EVAL ,(pred lv) ,diff ,body))))) 179 | -------------------------------------------------------------------------------- /cogen-batch.scm: -------------------------------------------------------------------------------- 1 | ;; cogen-batch.scm: 2 | ;; Run the cogen and generating extensions in batch mode 3 | ;; needs big-scheme, i/o, handle, conditions 4 | ;; pp, and fname.scm (or scsh, for that matter ...) 5 | 6 | (define cogen-usage-text 7 | '("Usage:" 8 | "Explain me:" 9 | "cps-mcogen ( --help | -h )" 10 | "" 11 | "just create a generating extension:" 12 | "cps-mcogen ( -c callpat | --call-pattern=callpat )" 13 | " [ -o outfile ] [ --output=outfile ]" 14 | " [ -v ] [ --verbose ]" 15 | " subjectfile ..." 16 | "" 17 | "do everything:" 18 | "cps-mcogen ( -c callpat | --call-pattern=callpat )" 19 | " ( -i infile | --input=infile )" 20 | " [ -p goalproc ] [ --goal-proc=goalproc ]" 21 | " [ -s supportfile+ ] [ --support=supportfile+ ]" 22 | " [ -o outfile ] [ --output=outfile ]" 23 | " [ -v ] [ --verbose ]" 24 | " subjectfile ..." 25 | "" 26 | "specialize with pre-fabricated generating extension or later stage:" 27 | "cps-mcogen ( -i infile | --input=infile )" 28 | " [ -p goalproc ] [ --goal-proc=goalproc ]" 29 | " [ -s supportfile+ ] [ --support=supportfile+ ]" 30 | " [ -o outfile ] [ --output=outfile ]" 31 | " [ -v ] [ --verbose ]" 32 | " genextfile ...")) 33 | 34 | (define (cogen-display-usage) 35 | (for-each (lambda (line) 36 | (display line) (newline)) 37 | cogen-usage-text)) 38 | 39 | (define cogen-options 40 | '(("help" "h" help) 41 | ("v" "verbose" verbose) 42 | ("c" "call-pattern" parameter call-pattern) 43 | ("i" "input" parameter accumulates splits input) 44 | ("o" "output" parameter output) 45 | ("p" "goal-proc" parameter goal-proc) 46 | ("s" "support" parameter accumulates splits support))) 47 | 48 | (define scheme-file-suffixes '(".scm" ".ss")) 49 | (define input-file-suffixes '(".dat")) 50 | (define cogen-generating-extension-file-suffix "-genext") 51 | 52 | (define cogen-stage-prefix ";; ") 53 | 54 | (define (canonical-genext-name name) 55 | (call-with-values 56 | (lambda () 57 | (parse-file-name name)) 58 | (lambda (dir base suffix) 59 | (string-append dir base cogen-generating-extension-file-suffix suffix)))) 60 | 61 | (define (maybe-sans-suffix string suffix) 62 | (let ((length (string-length string)) 63 | (suffix-length (string-length suffix))) 64 | (if (and (>= length suffix-length) 65 | (string=? (substring string 66 | (- length suffix-length) length) 67 | suffix)) 68 | (substring string 0 (- length suffix-length)) 69 | string))) 70 | 71 | (define (canonical-residual-name name inputs) 72 | (call-with-values 73 | (lambda () 74 | (parse-file-name name)) 75 | (lambda (dir base suffix) 76 | (let ((base (maybe-sans-suffix 77 | base cogen-generating-extension-file-suffix))) 78 | (string-append 79 | dir base 80 | (apply string-append 81 | (map (lambda (input) 82 | (string-append 83 | "-" 84 | (file-name-sans-extension 85 | (file-name-nondirectory input)))) 86 | inputs)) 87 | suffix))))) 88 | 89 | (define (read-line . arg) 90 | (let* ((port (if (null? arg) (current-input-port) (car arg))) 91 | (char (read-char port))) 92 | (if (eof-object? char) 93 | char 94 | (do ((char char (read-char port)) 95 | (clist '() (cons char clist))) 96 | ((or (eof-object? char) (char=? #\newline char)) 97 | (list->string (reverse clist))))))) 98 | 99 | (define (read-memo-info) 100 | (let* ((line (read-line)) 101 | (line-length (string-length line)) 102 | (prefix-length (string-length cogen-stage-prefix))) 103 | 104 | (if (or (< line-length prefix-length) 105 | (not (string=? cogen-stage-prefix (substring line 0 prefix-length)))) 106 | (error "invalid memo template: ~a" line)) 107 | 108 | (let* ((memo-stuff (substring line prefix-length line-length)) 109 | (port (make-string-input-port memo-stuff)) 110 | (id (read port)) 111 | (stuff (read port))) 112 | (values id stuff)))) 113 | 114 | (define (pp-list l . args) 115 | (for-each (lambda (x) 116 | (apply pp x args)) 117 | l)) 118 | 119 | (define (cogen-make-generating-extension files pattern) 120 | (let ((residual-program (cogen-driver files pattern))) 121 | (values residual-program 122 | *support-code*))) 123 | 124 | (define (cogen-run-generating-extension pattern input-parameters) 125 | (let ((template 126 | (start-memo-internal 127 | 1 128 | '$goal 129 | (eval '$goal (interaction-environment)) 130 | pattern 131 | input-parameters))) 132 | (values 133 | template 134 | *residual-program* 135 | *support-code*))) 136 | 137 | (define (cogen-run-later-stage memo-template input-parameters) 138 | (let ((next-memo-template 139 | (nextlevel memo-template input-parameters))) 140 | (values 141 | next-memo-template 142 | *residual-program* 143 | *support-code*))) 144 | 145 | (define (cogen-main argv) 146 | (call-with-current-continuation 147 | (lambda (exit) 148 | 149 | (with-handler 150 | 151 | (lambda (condition decline) 152 | (decline) 153 | (if (error? condition) 154 | (apply format (current-error-port) (condition-stuff condition))) 155 | (exit 1)) 156 | 157 | (lambda () 158 | (call-with-values 159 | (lambda () 160 | (with-handler 161 | ;; we expect only errors here ... 162 | (lambda (condition decline) 163 | (apply format (current-error-port) (condition-stuff condition)) 164 | (cogen-display-usage) 165 | (exit 1)) 166 | (lambda () 167 | (get-options cogen-options argv)))) 168 | 169 | (lambda (options files) 170 | 171 | ;; mode 0 172 | (if (assq 'help options) 173 | (begin 174 | (cogen-display-usage) 175 | (exit 0))) 176 | 177 | (if (null? files) 178 | (error "No input files specified.~%")) 179 | 180 | (let ((verbose? (assq 'verbose options)) 181 | (the-genext #f) 182 | (the-memo-template #f) 183 | (the-bt-pattern #f)) 184 | 185 | (define (maybe-format . l) 186 | (if verbose? 187 | (begin 188 | (apply format #t l) 189 | (force-output (current-output-port))))) 190 | 191 | ;; mode 1 or 2---make a generating extension 192 | (if (assq 'call-pattern options) 193 | (begin 194 | (maybe-format "Creating a generating extension~%") 195 | (let* ((pattern-string 196 | (cdr (assq 'call-pattern options))) 197 | (pattern 198 | (read (make-string-input-port pattern-string)))) 199 | 200 | (call-with-values 201 | (lambda () 202 | (maybe-format "Computing the generating extension~%") 203 | (cogen-make-generating-extension files pattern)) 204 | (lambda (genext support-code) 205 | (if (assq 'input options) 206 | ;; specialize also---later 207 | (begin 208 | (set! the-genext (append genext support-code)) 209 | (set! the-bt-pattern (cdr pattern))) 210 | ;; just write out the generating extension 211 | (let ((genext-name 212 | (if (assq 'output options) 213 | (cdr (assq 'output options)) 214 | (canonical-genext-name (car files))))) 215 | (maybe-format "Writing generating extension into ~A~%" 216 | genext-name) 217 | (with-output-to-file 218 | genext-name 219 | (lambda () 220 | (format #t "~a~a ~s~%~%" 221 | cogen-stage-prefix 222 | 'bt-pattern 223 | (cdr pattern)) 224 | (pp-list genext) 225 | (if (not (null? support-code)) 226 | (format #t "~%;; Supporting definitions:~%")) 227 | (pp-list support-code)))))))))) 228 | 229 | ;; mode 2 or 3---specialize something 230 | (if (assq 'input options) 231 | (let ((input-files (cdr (assq 'input options)))) 232 | 233 | (maybe-format "Running a generating extension~%") 234 | 235 | (if (assq 'support options) 236 | (begin 237 | (maybe-format "Loading support code~%") 238 | (for-each (lambda (support-file) 239 | (maybe-format "Loading ~A~%" support-file) 240 | (load support-file)) 241 | (cdr (assq 'support options))))) 242 | 243 | (maybe-format "Loading generating extension ") 244 | (if (assq 'call-pattern options) 245 | ;; we have one in memory 246 | (begin 247 | (maybe-format "from memory~%") 248 | (load-program the-genext)) 249 | (begin 250 | (maybe-format "from files~%") 251 | (call-with-values 252 | (lambda () 253 | (with-input-from-file 254 | (car files) 255 | read-memo-info)) 256 | (lambda (id stuff) 257 | (if (eq? 'bt-pattern id) 258 | (set! the-bt-pattern stuff) 259 | (set! the-memo-template stuff)))) 260 | (for-each (lambda (file) 261 | (maybe-format "Loading ~A~%" file) 262 | (load file)) 263 | files))) 264 | 265 | (let ((input-parameters 266 | (begin 267 | (maybe-format "Parsing input from files~%") 268 | (let loop ((input-files input-files)) 269 | (if (null? input-files) 270 | '() 271 | (begin 272 | (maybe-format "Parsing ~A~%" (car input-files)) 273 | (append (file->list (car input-files)) 274 | (loop (cdr input-files)))))))) 275 | (goal (if (assq 'goal-proc options) 276 | (cdr (assq 'goal-proc options)) 277 | '$goal)) 278 | (residual-program-name 279 | (if (assq 'output options) 280 | (cdr (assq 'output options)) 281 | (canonical-residual-name (car files) input-files)))) 282 | 283 | (maybe-format "Specializing with goal ~A~%" goal) 284 | (call-with-values 285 | (lambda () 286 | (if the-bt-pattern 287 | (cogen-run-generating-extension the-bt-pattern 288 | input-parameters) 289 | (cogen-run-later-stage the-bt-pattern 290 | input-parameters))) 291 | (lambda (memo-template code support-code) 292 | (maybe-format "Writing residual program into ~A~%" 293 | residual-program-name) 294 | (with-output-to-file 295 | residual-program-name 296 | (lambda () 297 | (format #t "~a~a ~s~%~%" 298 | cogen-stage-prefix 299 | 'memo-template 300 | memo-template) 301 | (pp-list code) 302 | (if (not (null? support-code)) 303 | (format #t "~%;; Supporting definitions:~%")) 304 | (pp-list support-code)))))))) 305 | 306 | (exit 0))))))))) 307 | -------------------------------------------------------------------------------- /cogen-boxops.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-boxops.scm -------------------------------------------------------------------------------- /cogen-completer.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-completer.scm -------------------------------------------------------------------------------- /cogen-construct-genext.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-construct-genext.scm -------------------------------------------------------------------------------- /cogen-ctors.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-ctors.scm -------------------------------------------------------------------------------- /cogen-direct-anf.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-direct-anf.scm -------------------------------------------------------------------------------- /cogen-directives.scm: -------------------------------------------------------------------------------- 1 | (define-syntax define-without-memoization 2 | (syntax-rules () 3 | ((define-without-memoization bla ...) 4 | (define bla ...)))) 5 | 6 | (define-syntax define-memo 7 | (syntax-rules () 8 | ((define-memo name level) 9 | (define (name x) x)))) 10 | 11 | (define-syntax define-primitive 12 | (syntax-rules () 13 | ((define-primitive o t k) 14 | (begin 15 | (display "defined primitive ") (display o) 16 | (newline))))) 17 | -------------------------------------------------------------------------------- /cogen-distributed-utils.scm: -------------------------------------------------------------------------------- 1 | ;;; utilities 2 | (define (encap proc) 3 | (let ((aspace (local-aspace))) 4 | (lambda args 5 | (apply remote-apply aspace proc args)))) 6 | 7 | (define (with-lock lock thunk) 8 | (obtain-lock lock) 9 | (let ((value (thunk))) 10 | (release-lock lock) 11 | value)) 12 | 13 | -------------------------------------------------------------------------------- /cogen-driver.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-driver.scm -------------------------------------------------------------------------------- /cogen-effect.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-effect.scm -------------------------------------------------------------------------------- /cogen-env.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-env.scm -------------------------------------------------------------------------------- /cogen-eq-flow.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-eq-flow.scm -------------------------------------------------------------------------------- /cogen-gensym.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-gensym.scm -------------------------------------------------------------------------------- /cogen-globals.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-globals.scm -------------------------------------------------------------------------------- /cogen-input-syntax: -------------------------------------------------------------------------------- 1 | E ::= K | (quote A) | (quasiquote A) | V | (if E E E) | (cond (E E)* (else E)?) | 2 | (O E*) | (P E*) | (begin E*) 3 | (let ((V E)*) D0* E*) | (let* ((V E)*) D0* E*) | 4 | (letrec ((V (lambda (V*) E*))*) D0* E*) | 5 | (let P ((V E)*) D0* E*) | 6 | (do ((V E E)*) (E E*) E*) | 7 | (case E ((A*) E*)* (else E*)?) | 8 | (let-syntax ((P (syntax-rules (V*) R)))) | 9 | (letrec-syntax ((P (syntax-rules (V*) R))*)) | 10 | (lambda (V*) D0* E*) | (E E*) | 11 | [ (lambda V D0* E*) | (lambda (V* . V) D0* E*) | ] 12 | (C E*) | (Ci E) | (C? E) | % ctors, selectors, tests 13 | (M E) | % memoization point 14 | (set! V E) | (make-cell E) | (cell-ref E) | (cell-set! E E) 15 | A ::= of R4RS 16 | D0 ::= (define (P V*) D0* E*) | 17 | (define P E) | 18 | (define-without-memoization (P V*) D0* E*) | 19 | (define-without-memoization P E) 20 | D ::= D0 | 21 | (begin D*) | 22 | (load ) | 23 | (define-data TC (C Ci*)+) | 24 | (define-type (P B*) B) | 25 | (define-primitive O T [dynamic|error|opaque|pure|apply]) | 26 | (define-memo M ) | 27 | (define-macro P (syntax-rules (V*) R)) 28 | R ::= of R5RS 29 | T ::= - | T0 30 | T0 ::= (all TV T0) | (rec TV T0) | (TC T0*) | TV 31 | TV type variable (must be bound by rec or all) 32 | TC type constructor 33 | B ::= * | d | - 34 | prg ::= D+ 35 | 36 | S ::= (P G*) % syntax of the skeleton call 37 | G ::= * | - | d | s | | ((C G*)*) % binding times in the skeleton 38 | 39 | -------------------------------------------------------------------------------- /cogen-job: -------------------------------------------------------------------------------- 1 | examples/ctors.scm 2 | -------------------------------------------------------------------------------- /cogen-labset-bylist.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-labset-bylist.scm -------------------------------------------------------------------------------- /cogen-labset.scm: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;; a simple implementation of labset, should be replaced by a bitset impl 3 | ;;; (define (labset-first? e l)) 4 | (define (set-labset-size! n) 5 | (set! *labset-size* n) 6 | (set! empty-labset (new-labset))) 7 | (define *labset-size* 'undefined-labset-size) 8 | (define (new-labset) (make-string *labset-size* #\0)) 9 | 10 | (define empty-labset 'undefined-labset-size) 11 | 12 | (define (labset-elem? e l) 13 | (eq? (string-ref l e) #\1)) 14 | (define (labset-singleton e) 15 | (let ((l (new-labset))) 16 | (string-set! l e #\1) 17 | l)) 18 | (define (labset-intersection l1 l2) 19 | (let ((result (new-labset))) 20 | (let loop ((i 0)) 21 | (if (= *labset-size* i) 22 | result 23 | (begin 24 | (if (and (eq? (string-ref l1 i) #\1) 25 | (eq? (string-ref l2 i) #\1)) 26 | (string-set! result i #\1)) 27 | (loop (+ i 1))))))) 28 | (define (labset-empty? l) 29 | (let loop ((i 0)) 30 | (if (= *labset-size* i) 31 | #f 32 | (if (eq? (string-ref l i) #\1) 33 | #f 34 | (loop (+ i 1)))))) 35 | (define (labset-remove e l) 36 | (let ((result (new-labset))) 37 | (let loop ((i 0)) 38 | (if (= *labset-size* i) 39 | result 40 | (begin 41 | (if (not (= i e)) 42 | (string-set! result i (string-ref l i))) 43 | (loop (+ i 1))))))) 44 | (define (labset-add e l) 45 | (let ((result (new-labset))) 46 | (let loop ((i 0)) 47 | (if (= *labset-size* i) 48 | result 49 | (begin 50 | (if (= i e) 51 | (string-set! result i #\1) 52 | (string-set! result i (string-ref l i))) 53 | (loop (+ i 1))))))) 54 | (define (labset-union l1 l2) 55 | (let ((result (new-labset))) 56 | (let loop ((i 0)) 57 | (if (= *labset-size* i) 58 | result 59 | (begin 60 | (if (or (eq? (string-ref l1 i) #\1) 61 | (eq? (string-ref l2 i) #\1)) 62 | (string-set! result i #\1)) 63 | (loop (+ i 1))))))) 64 | (define (labset-union* ll) 65 | (if (null? ll) 66 | empty-labset 67 | (let loop ((ll (cdr ll)) (result (car ll))) 68 | (if (null? ll) 69 | result 70 | (loop (cdr ll) (labset-union result (car ll))))))) 71 | (define (labset-subtract l1 l2) 72 | (let ((result (new-labset))) 73 | (let loop ((i 0)) 74 | (if (= *labset-size* i) 75 | result 76 | (begin 77 | (if (and (eq? (string-ref l1 i) #\1) 78 | (not (eq? (string-ref l2 i) #\1))) 79 | (string-set! result i #\1)) 80 | (loop (+ i 1))))))) 81 | (define (labset-subset? l1 l2) 82 | (let loop ((i 0)) 83 | (if (= *labset-size* i) 84 | #t 85 | (if (and (eq? (string-ref l1 i) #\1) 86 | (not (eq? (string-ref l2 i) #\1))) 87 | #f 88 | (loop (+ i 1)))))) 89 | 90 | (define (labset-equal? l1 l2) 91 | (and (labset-subset? l1 l2) 92 | (labset-subset? l2 l1))) 93 | 94 | (define (labset-for-each proc labset) 95 | (let loop ((i 0)) 96 | (if (< i *labset-size*) 97 | (begin 98 | (if (eq? (string-ref labset i) #\1) 99 | (proc i)) 100 | (loop (+ i 1)))))) 101 | 102 | (define (labset->list labset) 103 | (let loop ((i 0) (result '())) 104 | (if (< i *labset-size*) 105 | (if (eq? (string-ref labset i) #\1) 106 | (loop (+ i 1) (cons i result)) 107 | (loop (+ i 1) result)) 108 | (reverse result)))) -------------------------------------------------------------------------------- /cogen-library.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-library.scm -------------------------------------------------------------------------------- /cogen-macro.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-macro.scm -------------------------------------------------------------------------------- /cogen-memo-standard.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-memo-standard.scm -------------------------------------------------------------------------------- /cogen-oca.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-oca.scm -------------------------------------------------------------------------------- /cogen-reach.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-reach.scm -------------------------------------------------------------------------------- /cogen-record.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-record.scm -------------------------------------------------------------------------------- /cogen-residual.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-residual.scm -------------------------------------------------------------------------------- /cogen-scheme.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-scheme.scm -------------------------------------------------------------------------------- /cogen-skeleton.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-skeleton.scm -------------------------------------------------------------------------------- /cogen-specialize.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-specialize.scm -------------------------------------------------------------------------------- /cogen-terminate.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-terminate.scm -------------------------------------------------------------------------------- /cogen-typesig.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/cogen-typesig.scm -------------------------------------------------------------------------------- /cogen-wrapping.scm: -------------------------------------------------------------------------------- 1 | ;;; proxy wrappers for program points 2 | ;;; ,open proxies closures 3 | 4 | (define (wrap-program-point program-point bts) 5 | (cons (car program-point) 6 | (wrap-values (cdr program-point) bts))) 7 | (define (wrap-values values bts) 8 | (if (null? values) 9 | '() 10 | (let ((value (car values)) 11 | (values (cdr values)) 12 | (bt (car bts)) 13 | (bts (cdr bts))) 14 | (let ((rest (wrap-values values bts))) 15 | (cons (wrap-value value bt) rest))))) 16 | (define (wrap-value value bt) 17 | ;; (display (list "wrap-value" value bt)) (newline) 18 | (if (and (= bt 0) (or (pair? value) (vector? value))) 19 | (make-proxy value) 20 | value)) 21 | 22 | (define (unwrap-program-point wrapped-pp) 23 | (let loop ((values wrapped-pp)) 24 | (if (null? values) 25 | '() 26 | (cons (unwrap-value (car values)) (loop (cdr values)))))) 27 | 28 | (define (unwrap-value value) 29 | ;; (display (list "unwrap-value" value)) (newline) 30 | (if (proxy? value) 31 | (any-proxy-value value) 32 | value)) 33 | 34 | (define (wrap-similar-program-point pp bts last-pp wrapped-pp) 35 | (cons (car pp) 36 | (wrap-similar-values (cdr pp) bts (map cons (cdr last-pp) (cdr wrapped-pp))))) 37 | ;;; could speed this up by only comparing corresponding positions 38 | (define (wrap-similar-values values bts last-values+wrapped-values) 39 | (let ((wrap-similar-value 40 | (lambda (value bt) 41 | ;; (display (list "wrap-similar-value" value bt)) (newline) 42 | (cond 43 | ((and (= bt 0) (assq value last-values+wrapped-values)) 44 | => (lambda (found) 45 | (cdr found))) 46 | (else 47 | (wrap-value value bt)))))) 48 | (let loop ((values values) (bts bts)) 49 | (if (null? values) 50 | '() 51 | (let ((value (car values)) 52 | (values (cdr values)) 53 | (bt (car bts)) 54 | (bts (cdr bts))) 55 | (cons (wrap-similar-value value bt) (loop values bts))))))) 56 | -------------------------------------------------------------------------------- /cps-mcogen: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | cogen_image=$HOME/soft/pe/cps-mcogen/batch.image 3 | heap_size=4000000 4 | (echo ",batch on"; 5 | echo "(cogen-main '(" 6 | while test "x$1" != "x"; do 7 | echo \"$1\" 8 | shift 9 | done; 10 | echo "))") | scheme48 -h $heap_size -i $cogen_image 11 | exit $? 12 | -------------------------------------------------------------------------------- /distributed-genext-packages.scm: -------------------------------------------------------------------------------- 1 | (define-structure small-big-scheme (export concatenate-symbol 2 | error breakpoint 3 | atom? null-list? neq? n= 4 | identity no-op 5 | memq? first any? any every? 6 | filter filter! filter-map partition-list partition-list! 7 | remove-duplicates delq delq! delete 8 | reverse! 9 | (destructure :syntax) 10 | (receive :syntax) 11 | format 12 | sort-list sort-list!) 13 | (open big-scheme)) 14 | 15 | (define-structure smurf-queues (compound-interface 16 | (interface-of queues) 17 | (export queue-assoc 18 | queue-any 19 | dequeue-first!)) 20 | (open scheme-level-1 define-record-types signals small-big-scheme) 21 | (files ((=scheme48 big) queue) 22 | smurf-queue) 23 | (optimize auto-integrate)) 24 | 25 | (define-structure broken-distributed-auxiliary auxiliary-interface 26 | (open auxiliary scheme) 27 | (files dummy-gensym)) 28 | 29 | (define-structure cogen-distributed-library cogen-library-interface 30 | (open scheme signals broken-distributed-auxiliary cogen-boxops) 31 | (files cogen-library)) 32 | 33 | (define-structure cogen-distributed-completers 34 | cogen-completers-interface 35 | (open scheme shift-reset cogen-residual broken-distributed-auxiliary) 36 | (files cogen-completer)) 37 | 38 | (define-structure cogen-memo-distributed 39 | (compound-interface cogen-memo-interface 40 | (export multi-memo 41 | multi-memo-no-result 42 | start-specialization 43 | collect-residual-program 44 | display-kill-counts 45 | display-elapsed-times)) 46 | (open scheme shift-reset broken-distributed-auxiliary 47 | bitwise small-big-scheme smurf-queues tables 48 | cogen-distributed-library 49 | cogen-record cogen-distributed-completers cogen-residual 50 | cogen-wrapping 51 | time 52 | message-low aspaces proxies 53 | threads threads-internal locks placeholders) 54 | (files cogen-distributed-utils 55 | cogen-spec-server 56 | cogen-memo-master)) 57 | 58 | (define-structure pgg-distributed-library 59 | (compound-interface cogen-construct-genext-interface 60 | cogen-residual-interface 61 | cogen-direct-anf-interface 62 | cogen-memo-interface) 63 | (open scheme escapes signals broken-distributed-auxiliary 64 | cogen-boxops cogen-globals cogen-distributed-library 65 | shift-reset cogen-distributed-completers cogen-memo-distributed cogen-residual) 66 | (files cogen-direct-anf)) 67 | 68 | (define-interface cogen-wrapping-interface 69 | (export wrap-program-point 70 | unwrap-program-point 71 | wrap-similar-program-point)) 72 | 73 | (define-structure cogen-wrapping cogen-wrapping-interface 74 | (open scheme aspaces closures) 75 | (files cogen-wrapping)) 76 | 77 | -------------------------------------------------------------------------------- /doc/pgg-manual.ist: -------------------------------------------------------------------------------- 1 | % MakeIndex style file pgg-manual.ist 2 | delim_0 "\\dotfill " 3 | delim_1 "\\dotfill " 4 | delim_2 "\\dotfill " 5 | -------------------------------------------------------------------------------- /dummy-gensym.scm: -------------------------------------------------------------------------------- 1 | ;;; symbol generation 2 | (define gensym (lambda (sym) sym)) 3 | (define gensym-local (lambda (sym) sym)) 4 | (define gencont (lambda () (gensym 'c))) 5 | -------------------------------------------------------------------------------- /examples/2lazy-support.scm: -------------------------------------------------------------------------------- 1 | ;;; support procedures for 2lazy.scm 2 | 3 | (define (input->nr-cvars xs*) 4 | (if (null? xs*) 5 | 0 6 | (let ((xs (car xs*)) 7 | (xs* (cdr xs*))) 8 | (if (and (pair? xs) (equal? (car xs) 'CV)) 9 | (max (cadr xs) (input->nr-cvars xs*)) 10 | (input->nr-cvars xs*))))) 11 | ;;; programs 12 | ;;; prg ::= proc* 13 | ;;; proc ::= (f x1 ... xn = e) 14 | 15 | (define (prg-lookup f prg) 16 | (if (null? prg) 17 | (static-error "function not found in program" f) 18 | (if (equal? (caar prg) f) 19 | (car prg) 20 | (prg-lookup f (cdr prg))))) 21 | 22 | (define (proc->formals proc) 23 | (let loop ((parts (cdr proc)) (formals '())) 24 | (if (or (null? parts) 25 | (equal? (car parts) '=)) 26 | (reverse formals) 27 | (loop (cdr parts) (cons (car parts) formals))))) 28 | 29 | (define (proc->expr proc) 30 | (let loop ((parts (cdr proc))) 31 | (if (null? parts) 32 | (static-error "syntax error in" proc) 33 | (if (equal? (car parts) '=) 34 | (cadr parts) 35 | (loop (cdr parts)))))) 36 | 37 | (define operator-list '(+ - * / cons bin-car bin-cdr equal?)) 38 | (define (static-ext op arg1 arg2) 39 | (case op 40 | ((+) (+ arg1 arg2)) 41 | ((-) (- arg1 arg2)) 42 | ((*) (* arg1 arg2)) 43 | ((/) (/ arg1 arg2)) 44 | ((cons) (cons arg1 arg2)) 45 | ((bin-car) (car arg1)) 46 | ((bin-cdr) (cdr arg1)) 47 | ((equal?) (equal? arg1 arg2)) 48 | (else 'undefined-primitive))) 49 | 50 | ;;; syntax accessors 51 | (define (var-expr? e) 52 | (symbol? e)) 53 | (define (var->name e) 54 | e) 55 | (define (constant-expr? e) 56 | (or (number? e) 57 | (boolean? e) 58 | (string? e) 59 | (and (pair? e) (eq? (car e) 'QUOTE)))) 60 | (define (constant->value e) 61 | (if (pair? e) 62 | (cadr e) 63 | e)) 64 | (define (cond-expr? e) 65 | (and (pair? e) (eq? (car e) 'IF))) 66 | (define (binop-expr? e) 67 | (and (pair? e) (memq (car e) operator-list))) 68 | (define (funcall-expr? e) 69 | (and (pair? e) (symbol? (car e)))) 70 | (define (static-error . args) 71 | (apply error args)) 72 | 73 | ;;; example programs 74 | (define lazy1 75 | '((f x = (g x (loop x))) 76 | (g x y = (+ x x)) 77 | (loop x = (loop x)))) 78 | 79 | (define lazy2 80 | '((f x y z = (g x (+ y z) (- y z))) 81 | (g x y z = (if x (+ y y) (* z z))))) -------------------------------------------------------------------------------- /examples/2lazy.scm: -------------------------------------------------------------------------------- 1 | (define-data desc 2 | (const const->value) 3 | (cvar cvar->number) 4 | (static-susp static-susp->ref-sum) ; (value + unit -> value) ref 5 | (dyn-susp dyn-static->ref-sum dyn-susp->ref-sum)) 6 | (define-data xpair 7 | (xcons xcar xcdr) 8 | (xnil)) 9 | (define-data values 10 | (basic basic->value) 11 | (fail)) 12 | (define-data maybe 13 | (just just->one) 14 | (nothing)) 15 | (define-data sum 16 | (make-value sum->value) 17 | (make-thunk sum->thunk)) 18 | 19 | (define (lazy-2int prg goal xs* xd*) 20 | (let* ((goal-proc (prg-lookup goal prg)) 21 | (formals (proc->formals goal-proc)) 22 | (denv (input->desc-env formals xs*)) 23 | (nr-cvars (input->nr-cvars xs*)) 24 | (cenv (input->cvenv xd* nr-cvars)) 25 | (expr (proc->expr goal-proc))) 26 | (lazy-2eval prg denv cenv expr))) 27 | 28 | (define (lazy-2eval prg denv cenv expr) 29 | 30 | (define (static-eval denv expr) 31 | ;;(display (list "static-eval" denv expr)) (newline) 32 | (cond 33 | ((constant-expr? expr) 34 | (basic (constant->value expr))) 35 | ((var-expr? expr) 36 | (let ((desc (apply-denv denv (var->name expr)))) 37 | (cond 38 | ((const? desc) 39 | (basic (const->value desc))) 40 | ((static-susp? desc) 41 | (let* ((ref (static-susp->ref-sum desc)) 42 | (sum (cell-ref ref))) 43 | (if (make-value? sum) 44 | (sum->value sum) 45 | (let ((new-value ((sum->thunk sum)))) 46 | (cell-set! ref (make-value new-value)) 47 | new-value)))) 48 | ((dyn-susp? desc) 49 | (let* ((sref (dyn-static->ref-sum desc)) 50 | (ssum (cell-ref sref))) 51 | (if (make-value? ssum) 52 | (sum->value ssum) 53 | (let ((new-svalue ((sum->thunk ssum)))) 54 | (cell-set! sref (make-value new-svalue)) 55 | new-svalue)))) 56 | ;; remaining cases are dynamic: [dyn-susp], cvar 57 | (else 58 | (fail))))) 59 | ((cond-expr? expr) 60 | (let ((value (static-eval denv (cadr expr)))) 61 | (if (fail? value) 62 | (fail) 63 | (if (basic->value value) 64 | (static-eval denv (caddr expr)) 65 | (static-eval denv (cadddr expr)))))) 66 | ((binop-expr? expr) 67 | (let ((op (car expr))) 68 | (let ((value1 (static-eval denv (cadr expr)))) 69 | (if (fail? value1) 70 | (fail) 71 | (let ((value2 (static-eval denv (caddr expr)))) 72 | (if (fail? value2) 73 | (fail) 74 | (basic (static-ext op 75 | (basic->value value1) 76 | (basic->value value2))))))))) 77 | ((funcall-expr? expr) 78 | (let* ((f (car expr)) 79 | (args (cdr expr)) 80 | (f-proc (prg-lookup f prg)) 81 | (formals (proc->formals f-proc)) 82 | (body (proc->expr f-proc))) 83 | (let ((maybe-denv (static-construct-denv denv formals args))) 84 | (if (nothing? maybe-denv) 85 | (fail) 86 | (static-eval (just->one maybe-denv) body))))) 87 | (else 88 | (static-error "syntax error: illegal expression" 89 | expr)))) 90 | 91 | (define (static-construct-denv denv formals args) 92 | (let loop ((formals formals) (args args)) 93 | (if (null? args) 94 | (just (initial-denv)) 95 | (let ((expr (car args)) 96 | (name (car formals)) 97 | (args (cdr args)) 98 | (formals (cdr formals))) 99 | (let ((maybe-denv (loop formals args))) 100 | (if (nothing? maybe-denv) 101 | (nothing) 102 | (let ((new-denv (just->one maybe-denv)) 103 | (entry 104 | (cond 105 | ((var-expr? expr) 106 | (apply-denv denv (var->name expr))) 107 | ((constant-expr? expr) 108 | (const (constant->value expr))) 109 | (else 110 | (static-susp 111 | (make-cell 112 | (make-thunk (lambda () (static-eval denv expr))))))))) 113 | (just (enter-denv name entry new-denv))))))))) 114 | 115 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 116 | 117 | (define (dynamic-eval denv cenv expr) 118 | (cond 119 | ((constant-expr? expr) 120 | (constant->value expr)) 121 | ((var-expr? expr) 122 | (let ((desc (apply-denv denv (var->name expr)))) 123 | (cond 124 | ((const? desc) 125 | (const->value desc)) 126 | ((dyn-susp? desc) 127 | (let* ((sref (dyn-static->ref-sum desc)) 128 | (ssum (cell-ref sref)) 129 | (svalue 130 | (if (make-value? ssum) 131 | (sum->value ssum) 132 | (let ((new-svalue ((sum->thunk ssum)))) 133 | (cell-set! sref (make-value new-svalue)) 134 | new-svalue)))) 135 | (if (basic? svalue) 136 | (basic->value svalue) 137 | (let* ((ref (dyn-susp->ref-sum desc)) 138 | (sum (cell-ref ref))) 139 | (if (make-value? sum) 140 | (sum->value sum) 141 | (let ((new-value ((sum->thunk sum)))) 142 | (cell-set! ref (make-value new-value)) 143 | new-value)))))) 144 | ((cvar? desc) 145 | (apply-cenv cenv (cvar->number desc)))))) 146 | ((cond-expr? expr) 147 | (let ((value (static-eval denv (cadr expr)))) 148 | (if (basic? value) 149 | (if (basic->value value) 150 | (dynamic-eval denv cenv (caddr expr)) 151 | (dynamic-eval denv cenv (cadddr expr))) 152 | ;; static evaluation of the condition fails, try dynamically 153 | (if (dynamic-eval denv cenv (cadr expr)) 154 | (lazy-2eval prg denv cenv (caddr expr)) 155 | (lazy-2eval prg denv cenv (cadddr expr)))))) 156 | ((binop-expr? expr) 157 | (ext (car expr) 158 | (lazy-2eval prg denv cenv (cadr expr)) 159 | (lazy-2eval prg denv cenv (caddr expr)))) 160 | ((funcall-expr? expr) 161 | (let* ((f (car expr)) 162 | (args (cdr expr)) 163 | (f-proc (prg-lookup f prg)) 164 | (formals (proc->formals f-proc)) 165 | (body (proc->expr f-proc))) 166 | (let loop ((formals formals) 167 | (args args) 168 | (new-denv (initial-denv))) 169 | (if (null? formals) 170 | (lazy-2eval prg new-denv cenv body) 171 | (let ((name (car formals)) 172 | (formals (cdr formals)) 173 | (expr (car args)) 174 | (args (cdr args))) 175 | (let ((entry 176 | (cond 177 | ((var-expr? expr) 178 | (apply-denv denv (var->name expr))) 179 | ((constant-expr? expr) 180 | (const (constant->value expr))) 181 | (else 182 | (dyn-susp 183 | (make-cell 184 | (make-thunk 185 | (lambda () (static-eval denv expr)))) 186 | (make-cell 187 | (make-thunk 188 | (lambda () (lazy-2eval prg denv cenv expr))))))))) 189 | (loop formals args (enter-denv name entry new-denv)))))))) 190 | (else 191 | (static-error "syntax error: illegal expression" 192 | expr)))) 193 | 194 | (let ((static-result (static-eval denv expr))) 195 | (if (fail? static-result) 196 | (dynamic-eval denv cenv expr) 197 | (basic->value static-result)))) 198 | 199 | (define (input->desc-env names xs*) 200 | (if (null? xs*) 201 | (initial-denv) 202 | (let ((xs (car xs*)) 203 | (name (car names)) 204 | (xs* (cdr xs*)) 205 | (names (cdr names))) 206 | (let ((desc-env (input->desc-env names xs*))) 207 | (if (and (pair? xs) (equal? (car xs) 'CV)) 208 | (enter-denv name (cvar (cadr xs)) desc-env) 209 | (enter-denv name (const xs) desc-env)))))) 210 | 211 | 212 | 213 | (define (input->cvenv xd* nr) 214 | (if (zero? nr) 215 | (initial-cenv) 216 | (let loop ((i 1) (xd* xd*) (cenv (initial-cenv))) 217 | (cond 218 | ((= i nr) 219 | (enter-cenv i (car xd*) cenv)) 220 | (else 221 | (loop (+ i 1) (cdr xd*) (enter-cenv i (car xd*) cenv))))))) 222 | 223 | (define (initial-denv) (xnil)) 224 | (define (enter-denv key value xenv) 225 | (xcons (xcons key value) xenv)) 226 | (define (apply-denv xenv key) 227 | (let loop ((xenv xenv)) 228 | (if (xnil? xenv) 229 | (static-error "key not found" key) 230 | (let* ((entry (xcar xenv))) 231 | (if (equal? (xcar entry) key) 232 | (xcdr entry) 233 | (loop (xcdr xenv))))))) 234 | 235 | (define (initial-cenv) (xnil)) 236 | (define (enter-cenv key value xenv) 237 | (xcons (xcons key value) xenv)) 238 | (define (apply-cenv xenv key) 239 | (let loop ((xenv xenv)) 240 | (if (xnil? xenv) 241 | (static-error "key not found" key) 242 | (let* ((entry (xcar xenv))) 243 | (if (equal? (xcar entry) key) 244 | (xcdr entry) 245 | (loop (xcdr xenv))))))) 246 | 247 | (define (ext op arg1 arg2) 248 | (case op 249 | ((+) (+ arg1 arg2)) 250 | ((-) (- arg1 arg2)) 251 | ((*) (* arg1 arg2)) 252 | ((/) (/ arg1 arg2)) 253 | ((cons) (cons arg1 arg2)) 254 | ((bin-car) (car arg1)) 255 | ((bin-cdr) (cdr arg1)) 256 | ((equal?) (equal? arg1 arg2)) 257 | (else 'undefined-primitive))) -------------------------------------------------------------------------------- /examples/app.scm: -------------------------------------------------------------------------------- 1 | (define (app x y) 2 | (if (null? x) 3 | y 4 | (cons (car x) (app (cdr x) y)))) 5 | 6 | (define (rapp y x) 7 | (app x y)) 8 | -------------------------------------------------------------------------------- /examples/apply.scm: -------------------------------------------------------------------------------- 1 | (define-primitive apply - apply) 2 | (define-primitive cons - pure) 3 | (define-primitive car - pure) 4 | 5 | (define (main s d) 6 | (let loop ((s s) (d d) (r '())) 7 | (if (null? s) 8 | (apply (lambda z z) r) 9 | (loop (cdr s) (cdr d) (cons (car d) r))))) 10 | -------------------------------------------------------------------------------- /examples/arity.scm: -------------------------------------------------------------------------------- 1 | (define (sum psl) 2 | (if (my-nil? psl) 3 | 0 4 | (+ (my-car psl) 5 | (sum (my-cdr psl))))) 6 | -------------------------------------------------------------------------------- /examples/artificial.scm: -------------------------------------------------------------------------------- 1 | ;;; checks the optimized treatment of variables in lambda_memos 2 | 3 | (define (main a x y) 4 | (foo a (lambda (d) 5 | (if d 6 | (lambda (z) (z x y)) 7 | (lambda () x))))) 8 | 9 | (define (foo a success-fail) 10 | (if a 11 | ((success-fail #t) (lambda (x y) (+ x y))) 12 | ((success-fail #f)))) 13 | -------------------------------------------------------------------------------- /examples/c-based.scm: -------------------------------------------------------------------------------- 1 | (define (f0 d) (+ (let ((x d)) 1) 2 | (let ((y d)) 2))) 3 | 4 | (define-data alist (anil) (acons acar acdr)) 5 | (define (f1 d) (acons (let ((x d)) 'head) 6 | (let ((y d)) 'tail))) 7 | 8 | (define (f2 d) (f1 (f1 d))) 9 | 10 | (define (f3 s d) (acdr (acons s d))) 11 | (define (f4 s d) (acar (acons s d))) 12 | -------------------------------------------------------------------------------- /examples/counter.scm: -------------------------------------------------------------------------------- 1 | (define-data counter (counter set get add)) 2 | 3 | (define (counter-class) 4 | (let* ((slot 0) 5 | (mset (lambda (x) (set! slot x))) 6 | (mget (lambda () slot)) 7 | (madd (lambda (x) (set! slot (+ slot x))))) 8 | (counter mset mget madd))) 9 | 10 | (define (main s) 11 | (let ((cnt (counter-class))) 12 | ((set cnt) s) 13 | ((add cnt) ((get cnt))) 14 | ((get cnt)))) 15 | -------------------------------------------------------------------------------- /examples/cps-lr-sim.sim: -------------------------------------------------------------------------------- 1 | (loadt "../lr-essence/common/grammar.adt") 2 | (loads "examples/cps-lr.scm") 3 | -------------------------------------------------------------------------------- /examples/cps-lr.scm: -------------------------------------------------------------------------------- 1 | ;; Essential LR parsing (continuation-based) 2 | ;; ========================================= 3 | 4 | (define (parse grammar k first-map state continuations input) 5 | (if (and (final? state grammar) 6 | (equal? '$ (car input))) 7 | 'accept 8 | (let ((closure (compute-closure state grammar k first-map))) 9 | 10 | (define (shift-nonterminal nonterminal input) 11 | (the-trick 12 | nonterminal (next-nonterminals closure grammar) 13 | (lambda (symbol) 14 | (let ((next-state (goto closure symbol))) 15 | (parse grammar k first-map 16 | next-state 17 | (cons shift-nonterminal 18 | (chop (- (active next-state) 1) 19 | continuations)) 20 | input))) 21 | (lambda () 22 | 'you-cannot-see-me))) 23 | 24 | (define (shift-terminal terminal input fail) 25 | (the-trick 26 | terminal (next-terminals closure grammar) 27 | (lambda (symbol) 28 | (let ((next-state (goto closure symbol))) 29 | (parse grammar k first-map 30 | next-state 31 | (cons shift-nonterminal 32 | (chop (- (active next-state) 1) 33 | continuations)) 34 | input))) 35 | fail)) 36 | 37 | (let ((accept-items (accept closure))) 38 | (shift-terminal 39 | (car input) (cdr input) 40 | (lambda () 41 | (select-lookahead-item-the-trick 42 | accept-items k input 43 | (lambda (item) 44 | ((list-ref (cons shift-nonterminal continuations) 45 | (length (item-rhs item))) 46 | (item-lhs item) input)) 47 | (lambda () 'error)))))))) 48 | 49 | ;; ~~~~~~~~~~~~ 50 | 51 | (define (do-parse source-grammar k input) 52 | (let* ((grammar (source-grammar->grammar source-grammar k)) 53 | (start-production 54 | (car (grammar-productions grammar)))) 55 | (parse grammar 56 | k 57 | (compute-first grammar k) 58 | (list (make-item start-production 59 | 0 60 | (cdr (production-rhs start-production)))) 61 | '() 62 | (append input (make-$ k))))) 63 | 64 | ;; ~~~~~~~~~~~~ 65 | 66 | (define (the-trick element set cont fail) 67 | (let loop ((set set)) 68 | (if (null? set) 69 | (fail) 70 | (if (equal? element (car set)) 71 | (cont (car set)) 72 | (loop (cdr set)))))) 73 | 74 | (define (select-lookahead-item-the-trick item-set k input cont fail) 75 | (let ((input-front (chop k input))) 76 | (let loop ((item-set item-set)) 77 | (if (null? item-set) 78 | (fail) 79 | (let ((item (car item-set))) 80 | (if (equal? input-front (item-lookahead item)) 81 | (cont item) 82 | (loop (cdr item-set)))))))) 83 | 84 | (define (chop n l) 85 | (if (zero? n) 86 | '() 87 | (cons (car l) (chop (- n 1) (cdr l))))) 88 | -------------------------------------------------------------------------------- /examples/ctors.adt: -------------------------------------------------------------------------------- 1 | (defconstr (my-nil) (my-cons my-car my-cdr)) 2 | -------------------------------------------------------------------------------- /examples/ctors.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (my-nil) (my-cons my-car my-cdr)) 2 | (define (main ss dd) 3 | (my-length (list->my-list-by ss dd))) 4 | (define (main2 d1 d2 d3) 5 | (my-length (my-cons d1 (my-nil)))) 6 | (define (list->my-list-by ss dd) 7 | (cond 8 | ((null? ss) 9 | (my-nil)) 10 | ;;; ((= 1 (length ss)) 11 | ;;; (my-cons (car dd) 12 | ;;; (my-nil))) 13 | (else 14 | (my-cons (car dd) 15 | (list->my-list-by (cdr ss) (cdr dd)))))) 16 | (define (my-length l) 17 | (if (my-nil? l) 18 | 0 19 | (+ 1 (my-length (my-cdr l))))) 20 | -------------------------------------------------------------------------------- /examples/cyclic.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (my-nil) (my-cons my-car my-cdr)) 2 | (define (main d) 3 | (let ((cycle (my-cons 1 (make-cell (my-nil))))) 4 | (cell-set! (my-cdr cycle) cycle) 5 | (zip d cycle))) 6 | (define (zip d s) 7 | (if (null? d) 8 | '() 9 | (cons (cons (car d) (my-car s)) 10 | (zip (cdr d) (cell-ref (my-cdr s)))))) 11 | 12 | -------------------------------------------------------------------------------- /examples/defmemo.scm: -------------------------------------------------------------------------------- 1 | (defmemo _sim-memoize only) 2 | (define (app x y) 3 | (_sim-memoize 1 4 | (if (null? x) 5 | y 6 | (cons (car x) (app (cdr x) y))))) 7 | -------------------------------------------------------------------------------- /examples/direct-lr-cps.scm: -------------------------------------------------------------------------------- 1 | (define-primitive eval (all t t) dynamic) 2 | (define-primitive apply (all t t) dynamic) 3 | -------------------------------------------------------------------------------- /examples/direct-lr-pgg.scm: -------------------------------------------------------------------------------- 1 | ; Essential LR parsing in direct style 2 | ; ==================================== 3 | 4 | ;;; requires direct-lr-support.scm 5 | 6 | (define-primitive _sim-error - error) 7 | (define-primitive apply - apply) 8 | 9 | (define-data mylist (mynil) (mycons mycar mycdr)) 10 | 11 | ;;; step 1: plain parser 12 | ;;; step 2: attribute evaluation 13 | 14 | ;;; primitives 15 | 16 | 17 | ;;; handle attribute stack 18 | (define (empty-stack) '()) 19 | (define (push elem stack) 20 | (cons elem stack)) 21 | (define (top->mylist n stack) 22 | (cond 23 | ((zero? n) (mynil)) 24 | ((= n 1) (mycons (car stack) (mynil))) 25 | (else (mycons (car stack) (top->mylist (- n 1) (cdr stack)))))) 26 | (define (reverse-mylist xs) 27 | (let loop ((xs xs) (acc (mynil))) 28 | (if (mynil? xs) 29 | acc 30 | (loop (mycdr xs) (mycons (mycar xs) acc))))) 31 | (define (my-list->list l) 32 | (if (mynil? l) 33 | '() 34 | (cons (mycar l) 35 | (my-list->list (mycdr l))))) 36 | 37 | ;;; utilities 38 | 39 | (define (filter-2 pred? list) 40 | (filter-20 pred? list '())) 41 | (define (filter-20 pred? rest result) 42 | (if (null? rest) 43 | (reverse result) 44 | (filter-20 pred? 45 | (cdr rest) 46 | (if (pred? (car rest)) 47 | (cons (car rest) result) 48 | result)))) 49 | 50 | ;; the trick need be applied to all calls of parse-bar! 51 | 52 | (define (direct-parse grammar k first-map state 53 | attribute-stack input) 54 | 55 | 56 | 57 | ;; body of direct-parse 58 | 59 | (if (final? state grammar) 60 | (if (equal? '$ (input-char (stream-car input))) 61 | (car attribute-stack) 62 | (_sim-error 'direct-parse "expecting eof" 63 | (input-char (stream-car input)))) 64 | 65 | (let* ((closure (compute-closure state grammar k first-map)) 66 | (ts (next-terminals closure grammar)) 67 | (ts (if (final? state grammar) 68 | (filter-2 (lambda (t) (not (equal? t '$))) ts) 69 | ts)) 70 | (accept-items (accept closure))) 71 | 72 | ;;; local definitions 73 | 74 | (define (select-lookahead-item item-set k input) 75 | (let loop ((trie (items->trie item-set k)) (pos 0) (input input)) 76 | (if (null? trie) 77 | (continue #f) 78 | (if (= pos k) 79 | (continue trie) 80 | (let ((ch (stream-car input))) 81 | (let inner-loop ((trie trie)) 82 | (if (null? trie) 83 | (continue #f) 84 | (if (let loop ((la-set (caar trie))) 85 | (or (equal? ch (car la-set)) 86 | (if (null? (cdr la-set)) 87 | #f 88 | (loop (cdr la-set))))) 89 | (loop (cdar trie) 90 | (+ pos 1) 91 | (if (= (+ pos 1) k) '() (stream-cdr input))) 92 | (inner-loop (cdr trie)))))))))) 93 | 94 | (define (continue production) 95 | (if (not production) 96 | ;; shift-terminal 97 | (let* ((p (stream-car input)) 98 | (ch (input-char p))) 99 | (let loop ((ts ts)) 100 | (if (null? ts) 101 | (_sim-error 'direct-parse "can't shift on" ch) 102 | (if (equal? (car ts) ch) 103 | (parse-bar grammar k first-map closure (car ts) 104 | (input-attr p) attribute-stack (stream-cdr input)) 105 | (loop (cdr ts)))))) 106 | (let* ((rhs-length (length (production-rhs production))) 107 | (lhs (production-lhs production)) 108 | (attribution (production-attribution production)) 109 | (attribute-value (apply 110 | (eval attribution (interaction-environment)) 111 | (my-list->list 112 | (reverse-mylist 113 | (top->mylist rhs-length attribute-stack)))))) 114 | 115 | ;; reduce, then shift on lhs 116 | (if (zero? rhs-length) 117 | ;; shift-nonterminal 118 | (parse-bar grammar k first-map closure lhs 119 | attribute-value attribute-stack input) 120 | (parse-result lhs rhs-length attribute-value input))))) 121 | 122 | ;;; body of let* 123 | 124 | (if (null? accept-items) 125 | ;; shift-terminal 126 | (let* ((p (stream-car input)) 127 | (ch (input-char p))) 128 | (let loop ((ts ts)) 129 | (if (null? ts) 130 | (_sim-error 'direct-parse "can't shift on" ch) 131 | (if (equal? (car ts) ch) 132 | (parse-bar grammar k first-map closure (car ts) 133 | (input-attr p) attribute-stack (stream-cdr input)) 134 | (loop (cdr ts)))))) 135 | (select-lookahead-item accept-items k input))))) 136 | 137 | (define (parse-bar grammar k first-map closure sym 138 | attribute-value attribute-stack input) 139 | (let* ((next-state (goto closure sym)) 140 | (result (direct-parse grammar k first-map next-state 141 | (push attribute-value attribute-stack) 142 | input))) 143 | (if (final? next-state grammar) 144 | result 145 | (let* ((the-lhs (result-lhs result)) 146 | (the-dot (result-dot result)) 147 | (the-att (result-att result)) 148 | (the-inp (result-inp result)) 149 | (nts (next-nonterminals closure grammar))) 150 | (if (null? nts) 151 | (parse-result the-lhs (- the-dot 1) the-att the-inp) 152 | (if (< 1 the-dot) 153 | (parse-result the-lhs (- the-dot 1) the-att the-inp) 154 | (let loop ((nts nts)) 155 | (if (null? (cdr nts)) 156 | (parse-bar grammar k first-map closure (car nts) 157 | the-att attribute-stack the-inp) 158 | (if (equal? (car nts) the-lhs) 159 | (parse-bar grammar k first-map closure (car nts) 160 | the-att attribute-stack the-inp) 161 | (loop (cdr nts))))))))))) 162 | 163 | (define (direct-parse-main source-grammar k input) 164 | (let* ((grammar (source-grammar->grammar source-grammar k)) 165 | (start-production (car (grammar-productions grammar)))) 166 | (direct-parse grammar 167 | k 168 | (compute-first grammar k) 169 | (list 170 | (make-item start-production 171 | 0 172 | (cdr (production-rhs start-production)))) 173 | '() 174 | input))) 175 | 176 | 177 | -------------------------------------------------------------------------------- /examples/direct-lr-sim.sim: -------------------------------------------------------------------------------- 1 | ; Essential LR parsing in direct style 2 | ; ==================================== 3 | 4 | (loadt "../lr-essence/common/util.adt") 5 | (loadt "../lr-essence/common/grammar.adt") 6 | (loadt "../lr-essence/common/stream.adt") 7 | 8 | 9 | ;(define-primitive _sim-error - error) 10 | ;(define-primitive apply - apply) 11 | 12 | (defprim (parse-result the-lhs the-dot the-attr the-inp) 13 | (vector the-lhs the-dot the-inp)) 14 | (defprim (result-lhs result) 15 | (vector-ref result 0)) 16 | (defprim (result-dot result) 17 | (vector-ref result 1)) 18 | (defprim (result-att result) 19 | (vector-ref result 2)) 20 | (defprim (result-inp result) 21 | (vector-ref result 3)) 22 | 23 | (defprim-dynamic (prim-eval expr) 24 | (eval expr (interaction-environment))) 25 | (defprim-dynamic (prim-apply f args) 26 | (apply f args)) 27 | 28 | (defprim (input-char ch) (car ch)) 29 | (defprim (input-attr ch) (cdr ch)) 30 | ;;; step 1: plain parser 31 | ;;; step 2: attribute evaluation 32 | 33 | ;;; primitives 34 | 35 | 36 | ;;; handle attribute stack 37 | (define (empty-stack) '()) 38 | (define (push elem stack) 39 | (cons elem stack)) 40 | (define (top->mylist n stack) 41 | (cond 42 | ((zero? n) (mynil)) 43 | ((= n 1) (mycons (car stack) (mynil))) 44 | (else (mycons (car stack) (top->mylist (- n 1) (cdr stack)))))) 45 | (define (reverse-mylist xs) 46 | (let loop ((xs xs) (acc (mynil))) 47 | (if (mynil? xs) 48 | acc 49 | (loop (mycdr xs) (mycons (mycar xs) acc))))) 50 | (define (my-list->list l) 51 | (if (mynil? l) 52 | '() 53 | (cons (mycar l) 54 | (my-list->list (mycdr l))))) 55 | 56 | ;;; utilities 57 | 58 | (define (filter-2 pred? list) 59 | (filter-20 pred? list '())) 60 | (define (filter-20 pred? rest result) 61 | (if (null? rest) 62 | (reverse result) 63 | (filter-20 pred? 64 | (cdr rest) 65 | (if (pred? (car rest)) 66 | (cons (car rest) result) 67 | result)))) 68 | 69 | ;; the trick need be applied to all calls of parse-bar! 70 | 71 | (define (direct-parse grammar k first-map state 72 | attribute-stack input) 73 | 74 | 75 | 76 | ;; body of direct-parse 77 | 78 | (if (final? state grammar) 79 | (if (equal? '$ (input-char (stream-car input))) 80 | (car attribute-stack) 81 | (_sim-error 'direct-parse "expecting eof" 82 | (input-char (stream-car input)))) 83 | 84 | (let* ((closure (compute-closure state grammar k first-map)) 85 | (ts (next-terminals closure grammar)) 86 | (ts (if (final? state grammar) 87 | (filter-2 (lambda (t) (not (equal? t '$))) ts) 88 | ts)) 89 | (accept-items (accept closure))) 90 | 91 | ;;; local definitions 92 | 93 | (define (select-lookahead-item item-set k input) 94 | (let loop ((trie (items->trie item-set k)) (pos 0) (input input)) 95 | (if (null? trie) 96 | (continue #f) 97 | (if (= pos k) 98 | (continue trie) 99 | (let ((ch (stream-car input))) 100 | (let inner-loop ((trie trie)) 101 | (if (null? trie) 102 | (continue #f) 103 | (if (let loop ((la-set (caar trie))) 104 | (or (equal? ch (car la-set)) 105 | (if (null? (cdr la-set)) 106 | #f 107 | (loop (cdr la-set))))) 108 | (loop (cdar trie) 109 | (+ pos 1) 110 | (if (= (+ pos 1) k) '() (stream-cdr input))) 111 | (inner-loop (cdr trie)))))))))) 112 | 113 | (define (continue production) 114 | (if (not production) 115 | ;; shift-terminal 116 | (let* ((p (stream-car input)) 117 | (ch (input-char p))) 118 | (let loop ((ts ts)) 119 | (if (null? ts) 120 | (_sim-error 'direct-parse "can't shift on" ch) 121 | (if (equal? (car ts) ch) 122 | (parse-bar grammar k first-map closure (car ts) 123 | (input-attr p) attribute-stack (stream-cdr input)) 124 | (loop (cdr ts)))))) 125 | (let* ((rhs-length (length (production-rhs production))) 126 | (lhs (production-lhs production)) 127 | (attribution (production-attribution production)) 128 | (attribute-value (prim-apply 129 | (prim-eval attribution) 130 | (my-list->list 131 | (reverse-mylist 132 | (top->mylist rhs-length attribute-stack)))))) 133 | 134 | ;; reduce, then shift on lhs 135 | (if (zero? rhs-length) 136 | ;; shift-nonterminal 137 | (parse-bar grammar k first-map closure lhs 138 | attribute-value attribute-stack input) 139 | (parse-result lhs rhs-length attribute-value input))))) 140 | 141 | ;;; body of let* 142 | 143 | (if (null? accept-items) 144 | ;; shift-terminal 145 | (let* ((p (stream-car input)) 146 | (ch (input-char p))) 147 | (let loop ((ts ts)) 148 | (if (null? ts) 149 | (_sim-error 'direct-parse "can't shift on" ch) 150 | (if (equal? (car ts) ch) 151 | (parse-bar grammar k first-map closure (car ts) 152 | (input-attr p) attribute-stack (stream-cdr input)) 153 | (loop (cdr ts)))))) 154 | (select-lookahead-item accept-items k input))))) 155 | 156 | (define (parse-bar grammar k first-map closure sym 157 | attribute-value attribute-stack input) 158 | (let* ((next-state (goto closure sym)) 159 | (result (direct-parse grammar k first-map next-state 160 | (push attribute-value attribute-stack) 161 | input))) 162 | (if (final? next-state grammar) 163 | result 164 | (let* ((the-lhs (result-lhs result)) 165 | (the-dot (result-dot result)) 166 | (the-att (result-att result)) 167 | (the-inp (result-inp result)) 168 | (nts (next-nonterminals closure grammar))) 169 | (if (null? nts) 170 | (parse-result the-lhs (- the-dot 1) the-att the-inp) 171 | (if (< 1 the-dot) 172 | (parse-result the-lhs (- the-dot 1) the-att the-inp) 173 | (let loop ((nts nts)) 174 | (if (null? (cdr nts)) 175 | (parse-bar grammar k first-map closure (car nts) 176 | the-att attribute-stack the-inp) 177 | (if (equal? (car nts) the-lhs) 178 | (parse-bar grammar k first-map closure (car nts) 179 | the-att attribute-stack the-inp) 180 | (loop (cdr nts))))))))))) 181 | 182 | (define (direct-parse-main source-grammar k input) 183 | (let* ((grammar (source-grammar->grammar source-grammar k)) 184 | (start-production (car (grammar-productions grammar)))) 185 | (direct-parse grammar 186 | k 187 | (compute-first grammar k) 188 | (list 189 | (make-item start-production 190 | 0 191 | (cdr (production-rhs start-production)))) 192 | '() 193 | input))) 194 | 195 | 196 | -------------------------------------------------------------------------------- /examples/dotprod.scm: -------------------------------------------------------------------------------- 1 | (define (dotprod n v1 v2 v3) 2 | (let loop ((n n) (v1 v1) (v2 v2) (v3 v3)) 3 | (if (zero? n) 4 | 0 5 | (+ (* (* (car v1) (car v2)) (car v3)) 6 | (loop (- n 1) (cdr v1) (cdr v2) (cdr v3)))))) 7 | -------------------------------------------------------------------------------- /examples/imp.scm: -------------------------------------------------------------------------------- 1 | ;;(define (f s d) 2 | ;; (let ((x s)) 3 | ;; (set! x (+ x x)) 4 | ;; (let ((f (lambda (y) 5 | ;; (+ x y)))) 6 | ;; (lambda (z) (f d))))) 7 | (define-data tuple3 8 | (object set get add)) 9 | 10 | (define (g s d) 11 | (let ((class 12 | (lambda () 13 | (let ((x 0)) 14 | (let ((mset (lambda (y) (set! x y))) 15 | (madd (lambda (y) (set! x (+ x y)))) 16 | (mget (lambda () x))) 17 | (let ((obj (object mset mget madd))) 18 | obj)))))) 19 | 20 | (let ((obj (class))) 21 | ((set obj) 21) 22 | ((add obj) (get obj)) 23 | ((get obj))))) 24 | -------------------------------------------------------------------------------- /examples/int.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (my-nil) (my-cons my-car my-cdr)) 2 | (define-primitive cons - pure) 3 | (define-primitive apply - apply) 4 | 5 | (define (main exp names values) 6 | (let loop ((names names) (values values) (env (my-nil))) 7 | (if (null? names) 8 | (int exp env) 9 | (loop (cdr names) (cdr values) 10 | (my-cons (my-cons (car names) (car values)) env))))) 11 | 12 | (define (int exp env) 13 | (let loop ((exp exp)) 14 | (define (int* exp*) 15 | (let recur ((exp* exp*)) 16 | (if (null? exp*) 17 | '() 18 | (cons (loop (car exp*)) 19 | (recur (cdr exp*)))))) 20 | (define (apply-prim op args) 21 | (apply (eval op (interaction-environment)) 22 | args)) 23 | (cond 24 | ((constant? exp) 25 | exp) 26 | ((not (pair? exp)) 27 | (lookup exp env)) 28 | ((eq? (car exp) 'IF) 29 | (let ((test-exp (cadr exp)) 30 | (then-exp (caddr exp)) 31 | (else-exp (cadddr exp))) 32 | (if (loop test-exp) 33 | (loop then-exp) 34 | (loop else-exp)))) 35 | ((eq? (car exp) 'LAMBDA) 36 | (lambda (y) 37 | (int (caddr exp) (my-cons (my-cons (caadr exp) y) env)))) 38 | ((eq? (car exp) 'APPLY) 39 | ((loop (cadr exp)) 40 | (loop (caddr exp)))) 41 | (else 42 | (apply-prim (car exp) (int* (cdr exp))))))) 43 | 44 | (define (constant? e) 45 | (or (boolean? e) 46 | (number? e) 47 | (and (pair? e) (eq? (car e) 'QUOTE)))) 48 | 49 | (define (lookup v env) 50 | (let loop ((env env)) 51 | (if (eq? v (my-car (my-car env))) 52 | (my-cdr (my-car env)) 53 | (loop (my-cdr env))))) 54 | 55 | -------------------------------------------------------------------------------- /examples/lambda-int.scm: -------------------------------------------------------------------------------- 1 | (define (int exp values) 2 | (evaluate exp '() values)) 3 | 4 | (define (constant? x) 5 | (or (number? x) 6 | (boolean? x) 7 | (and (pair? x) 8 | (equal? 'quote (car x))))) 9 | 10 | (define (exp->constant x) 11 | (if (pair? x) 12 | (if (equal? 'quote (car x)) 13 | (cadr x) 14 | x) 15 | x)) 16 | 17 | (define (env-lookup name env-names env-values) 18 | (if (equal? name (car env-names)) 19 | (car env-values) 20 | (env-lookup name (cdr env-names) (cdr env-values)))) 21 | 22 | (define (evaluate exp env-names env-values) 23 | (cond 24 | ((constant? exp) 25 | (exp->constant exp)) 26 | ((not (pair? exp)) 27 | (env-lookup exp env-names env-values)) 28 | ((equal? 'if (car exp)) 29 | (let ((condition (cadr exp)) 30 | (then-branch (caddr exp)) 31 | (else-branch (cadddr exp))) 32 | (if (evaluate condition env-names env-values) 33 | (evaluate then-branch env-names env-values) 34 | (evaluate else-branch env-names env-values)))) 35 | ((equal? 'lambda (car exp)) 36 | (let ((arg-name (caadr exp)) 37 | (body (caddr exp))) 38 | (lambda (x) 39 | (evaluate body 40 | (cons arg-name env-names) 41 | (cons x env-values))))) 42 | ((equal? 'apply (car exp)) 43 | (let ((operator (cadr exp)) 44 | (operand (caddr exp))) 45 | ((evaluate operator env-names env-values) 46 | (evaluate operand env-names env-values)))) 47 | (else 48 | (let ((operator (car exp)) 49 | (operands (cdr exp))) 50 | (apply-primitive operator (evaluate* operands env-names env-values)))) 51 | )) 52 | 53 | (define (evaluate* exps env-names env-values) 54 | (if (null? exps) 55 | '() 56 | (cons (evaluate (car exps) env-names env-values) 57 | (evaluate* (cdr exps) env-names env-values)))) 58 | 59 | (define (apply-primitive operator operands) 60 | (cond 61 | ((equal? 'null? operator) (null? (car operands))) 62 | ((equal? 'cons operator) (cons (car operands) 63 | (cadr operands))) 64 | ((equal? 'car operator) (car (car operands))) 65 | ((equal? 'cdr operator) (cdr (car operands))) 66 | ((equal? '+ operator) (+ (car operands) (cadr operands))) 67 | ((equal? 'equal? operator) (equal? (car operands) (cadr operands))))) 68 | 69 | 70 | 71 | 72 | 73 | -------------------------------------------------------------------------------- /examples/lambda.scm: -------------------------------------------------------------------------------- 1 | (define (main y d) 2 | (let ((f (lambda (z) (+ z y))) 3 | (g (lambda (z) (- z y)))) 4 | (cons (mymap f d) 5 | (mymap g d)))) 6 | 7 | (define (mymap f l) 8 | (if (null? l) 9 | '() 10 | (cons (f (car l)) (mymap f (cdr l))))) 11 | -------------------------------------------------------------------------------- /examples/lambda.sim: -------------------------------------------------------------------------------- 1 | (define (main y d) 2 | (let ((f (lambda (z) (+ z y))) 3 | (g (lambda (z) (- z y)))) 4 | (cons (mymap f d) 5 | (mymap g d)))) 6 | 7 | (define (mymap f l) 8 | (if (null? l) 9 | '() 10 | (cons (f (car l)) (mymap f (cdr l))))) 11 | -------------------------------------------------------------------------------- /examples/lazy/com-int-int.scm: -------------------------------------------------------------------------------- 1 | ; Similix Lazy combinator interpreter 2 | ; Copyright (C) 1993 Anders Bondorf 3 | ; Please see the file README for copyright notice, license and disclaimer. 4 | ; port to the PGG system 1996 Peter Thiemann 5 | (define-primitive save (all t t) dynamic) 6 | (define-primitive err (all t t) error) 7 | 8 | (define-primitive dynamize - dynamic) 9 | 10 | (define (generalize x) 11 | (if #t x (dynamize x))) 12 | 13 | ;----------------------------------------------------------------------------- 14 | ; P - Program 15 | ; D - Definition 16 | ; E - Expression 17 | ; C - Constant 18 | ; V - Variable 19 | ; F - FuncName 20 | ; B - Binop 21 | 22 | ; P ::= D* 23 | ; D ::= (F V* = E) 24 | ; E ::= C | V | F | (B E1 E2) | (if E1 E2 E3) | (E1 E2) 25 | 26 | ; Parsed form: 27 | ; P ::= (D*) 28 | ; D ::= (F (V*) E) 29 | ; E ::= (cst C) | (var V) | (fct F) | (binop B E1 E2) 30 | ; | (if E1 E2 E3) | (apply E1 E2) 31 | 32 | ;------------------------------------------------------------------------------ 33 | 34 | ; (loadt "com-int.adt") 35 | ; (loadt "thunk.adt") 36 | 37 | ;------------------------------------------------------------------------------ 38 | ; Values are delayed for two resons: 39 | ; (1) Environment updating is done by strict functions; therefore, 40 | ; the value argument is delayed (and then forced at lookup-time). 41 | ; (2) The interpreted language is lazy so arguments to applications 42 | ; are delayed. 43 | 44 | (define (init-fenv) 45 | (lambda (name) 46 | (err 'init-fenv "Unbound function: ~s" name))) 47 | (define (upd-fenv name value r) 48 | (lambda (name1) 49 | (if (equal? name name1) 50 | (value) ; force value 51 | (r name1)))) 52 | 53 | (define (init-venv) 54 | (lambda (name) 55 | (err 'init-venv "Unbound variable: ~s" name))) 56 | (define (upd-venv name value r) 57 | (lambda (name1) 58 | (if (equal? name name1) 59 | (value) ; force value 60 | (r name1)))) 61 | 62 | ;------------------------------------------------------------------------------ 63 | 64 | (define (_P P F v) (((fix (lambda (phi) (_D* P phi))) F) (lambda () v))) 65 | 66 | (define (_D* D* phi) 67 | (if (null? D*) 68 | (init-fenv) 69 | (let ((D (car D*)) 70 | (D* (cdr D*))) 71 | (if (and (list? D) (= 3 (length D))) 72 | (let ((F (car D)) 73 | (V* (cadr D)) 74 | (E (caddr D))) 75 | (upd-fenv F 76 | (lambda () (_V* V* E (generalize (init-venv)) phi)) ; delay value 77 | (_D* D* phi))) 78 | 79 | (err '_D* "Illegal program syntax: ~s" D*))))) 80 | 81 | (define (_V* V* E r phi) 82 | (if (not (pair? V*)) 83 | (_E E r phi) 84 | (let ((V (car V*)) 85 | (V* (cdr V*))) 86 | (lambda (s) (_V* V* E (upd-venv V (lambda () s) r) phi))))) 87 | 88 | (define (_E E r phi) 89 | (let ((tag (car E)) 90 | (args (cdr E))) 91 | (case tag 92 | ((cst) (let ((C (car args))) 93 | C)) 94 | ((var) (let ((V (car args))) 95 | ((r V)))) ; force value 96 | ((fct) (let ((F (car args))) 97 | (phi F))) 98 | ((binop) (let ((B (car args)) 99 | (E1 (cadr args)) 100 | (E2 (caddr args))) 101 | (ext B (_E E1 r phi) (_E E2 r phi)))) 102 | ((if) (let ((E1 (car args)) 103 | (E2 (cadr args)) 104 | (E3 (caddr args))) 105 | (if (_E E1 r phi) 106 | (_E E2 r phi) 107 | (_E E3 r phi)))) 108 | ((apply) (let ((E1 (car args)) 109 | (E2 (cadr args))) 110 | ((_E E1 r phi) 111 | (let ((tag (car E2)) 112 | (args (cdr E2))) 113 | (case tag 114 | ((cst) (let ((C (car args))) 115 | (lambda () C))) 116 | ((var) (let ((V (car args))) 117 | (r V))) 118 | ;;((fct) (let ((F (car args))) 119 | ;; (lambda () (phi F)))) 120 | (else 121 | (save (lambda () (_E E2 r phi))))))))) 122 | (else 123 | (err '_E "Illegal expression syntax: ~s" E))))) 124 | 125 | (define (fix f) (lambda (x) ((f (fix f)) x))) 126 | 127 | ;----------------------------------------------------------------------------- 128 | -------------------------------------------------------------------------------- /examples/lazy/com-int.scm: -------------------------------------------------------------------------------- 1 | ; Similix Lazy combinator interpreter 2 | ; Copyright (C) 1993 Anders Bondorf 3 | ; Please see the file README for copyright notice, license and disclaimer. 4 | ; port to the PGG system 1996 Peter Thiemann 5 | (define-primitive save (all t t) dynamic) 6 | (define-primitive err (all t t) error) 7 | 8 | ;----------------------------------------------------------------------------- 9 | ; P - Program 10 | ; D - Definition 11 | ; E - Expression 12 | ; C - Constant 13 | ; V - Variable 14 | ; F - FuncName 15 | ; B - Binop 16 | 17 | ; P ::= D* 18 | ; D ::= (F V* = E) 19 | ; E ::= C | V | F | (B E1 E2) | (if E1 E2 E3) | (E1 E2) 20 | 21 | ; Parsed form: 22 | ; P ::= (D*) 23 | ; D ::= (F (V*) E) 24 | ; E ::= (cst C) | (var V) | (fct F) | (binop B E1 E2) 25 | ; | (if E1 E2 E3) | (apply E1 E2) 26 | 27 | ;------------------------------------------------------------------------------ 28 | 29 | ; (loadt "com-int.adt") 30 | ; (loadt "thunk.adt") 31 | 32 | ;------------------------------------------------------------------------------ 33 | ; Values are delayed for two resons: 34 | ; (1) Environment updating is done by strict functions; therefore, 35 | ; the value argument is delayed (and then forced at lookup-time). 36 | ; (2) The interpreted language is lazy so arguments to applications 37 | ; are delayed. 38 | 39 | (define (init-fenv) 40 | (lambda (name) 41 | (err 'init-fenv "Unbound function: ~s" name))) 42 | (define (upd-fenv name value r) 43 | (lambda (name1) 44 | (if (equal? name name1) 45 | (value) ; force value 46 | (r name1)))) 47 | 48 | (define (init-venv) 49 | (lambda (name) 50 | (err 'init-venv "Unbound variable: ~s" name))) 51 | (define (upd-venv name value r) 52 | (lambda (name1) 53 | (if (equal? name name1) 54 | (value) ; force value 55 | (r name1)))) 56 | 57 | ;------------------------------------------------------------------------------ 58 | 59 | (define (_P P F v) (((fix (lambda (phi) (_D* P phi))) F) (lambda () v))) 60 | 61 | (define (_D* D* phi) 62 | (if (null? D*) 63 | (init-fenv) 64 | (let ((D (car D*)) 65 | (D* (cdr D*))) 66 | (if (and (list? D) (= 3 (length D))) 67 | (let ((F (car D)) 68 | (V* (cadr D)) 69 | (E (caddr D))) 70 | (upd-fenv F 71 | (lambda () (_V* V* E (init-venv) phi)) ; delay value 72 | (_D* D* phi))) 73 | 74 | (err '_D* "Illegal program syntax: ~s" D*))))) 75 | 76 | (define (_V* V* E r phi) 77 | (if (not (pair? V*)) 78 | (_E E r phi) 79 | (let ((V (car V*)) 80 | (V* (cdr V*))) 81 | (lambda (s) (_V* V* E (upd-venv V (lambda () s) r) phi))))) 82 | 83 | (define (_E E r phi) 84 | (let ((tag (car E)) 85 | (args (cdr E))) 86 | (case tag 87 | ((cst) (let ((C (car args))) 88 | C)) 89 | ((var) (let ((V (car args))) 90 | ((r V)))) ; force value 91 | ((fct) (let ((F (car args))) 92 | (phi F))) 93 | ((binop) (let ((B (car args)) 94 | (E1 (cadr args)) 95 | (E2 (caddr args))) 96 | (ext B (_E E1 r phi) (_E E2 r phi)))) 97 | ((if) (let ((E1 (car args)) 98 | (E2 (cadr args)) 99 | (E3 (caddr args))) 100 | (if (_E E1 r phi) 101 | (_E E2 r phi) 102 | (_E E3 r phi)))) 103 | ((apply) (let ((E1 (car args)) 104 | (E2 (cadr args))) 105 | ((_E E1 r phi) 106 | (let ((tag (car E2)) 107 | (args (cdr E2))) 108 | (case tag 109 | ((cst) (let ((C (car args))) 110 | (lambda () C))) 111 | ((var) (let ((V (car args))) 112 | (r V))) 113 | ;;((fct) (let ((F (car args))) 114 | ;; (lambda () (phi F)))) 115 | (else 116 | (save (lambda () (_E E2 r phi))))))))) 117 | (else 118 | (err '_E "Illegal expression syntax: ~s" E))))) 119 | 120 | (define (fix f) (lambda (x) ((f (fix f)) x))) 121 | 122 | ;----------------------------------------------------------------------------- 123 | -------------------------------------------------------------------------------- /examples/lazy/com-support.scm: -------------------------------------------------------------------------------- 1 | ; Similix parser for Lazy combinator source programs 2 | ; Copyright (C) 1993 Anders Bondorf 3 | ; Please see the file README for copyright notice, license and disclaimer. 4 | 5 | 6 | ;----------------------------------------------------------------------------- 7 | ; This program is written as a .sim-program even though we do not 8 | ; intend to partially evaluate it. 9 | ; The advantage of writing it this way is that the Similix front-end 10 | ; can be used for syntax checking. 11 | 12 | ;----------------------------------------------------------------------------- 13 | ;;; (loadt "com-defs.adt") 14 | 15 | (define (com-parse file) 16 | (define (parse-exp e vars fcts) 17 | (if (simple? e) 18 | (cond 19 | ((com-cst? e) 20 | (list 'cst (if (pair? e) (cadr e) e))) 21 | ((symbol? e) 22 | (cond 23 | ((member e vars) 24 | (list 'var e)) 25 | ((member e fcts) 26 | (list 'fct e)) 27 | (else 28 | (error 'com-parse "Unbound variable: ~s" e))))) 29 | (let ((hd (car e)) 30 | (tl (cdr e))) 31 | (cond 32 | ((com-binary-operator? hd) 33 | (list 'binop 34 | hd 35 | (parse-exp (cadr e) vars fcts) 36 | (parse-exp (caddr e) vars fcts))) 37 | ((equal? hd 'if) 38 | (list 'if 39 | (parse-exp (cadr e) vars fcts) 40 | (parse-exp (caddr e) vars fcts) 41 | (parse-exp (cadddr e) vars fcts))) 42 | (else 43 | (let ((ln (length e))) 44 | (cond 45 | ((= ln 2) 46 | (list 'apply 47 | (parse-exp (car e) vars fcts) 48 | (parse-exp (cadr e) vars fcts))) 49 | ((> ln 2) 50 | (parse-exp (cons (list (car e) (cadr e)) (cddr e)) vars fcts)) 51 | (else 52 | (error 'com-parse "Unknown expression: ~s" e))))))))) 53 | 54 | (define (simple? e) (or (com-cst? e) (symbol? e))) 55 | 56 | (define (fct-names P) 57 | (map (lambda (fct) 58 | (let ((n (car fct))) 59 | (if (symbol? n) 60 | n 61 | (error 'com-parse "Not a function name: ~s" n)))) 62 | P)) 63 | 64 | (define (com-binary-operator? b) 65 | (member b '(cons hack-car hack-cdr equal? + - * / = /= mod))) 66 | 67 | (define (com-cst? e) 68 | (or (number? e) (boolean? e) (string? e) 69 | (and (list? e) (= (length e) 2) (equal? (car e) 'quote)))) 70 | 71 | (let ((P (file->list file))) 72 | (letrec 73 | ((parse-fct 74 | (lambda (fct) 75 | (let ((Fname (car fct))) 76 | (let search ((e (cdr fct)) 77 | (c (lambda (vars body) 78 | (list Fname vars 79 | (parse-exp body vars (fct-names P)))))) 80 | (let ((hd (car e)) 81 | (tl (cdr e))) 82 | (cond 83 | ((equal? hd '=) 84 | (let ((elem (car tl))) 85 | (c '() 86 | (if (and (list? tl) (= (length tl) 1) 87 | (simple? elem)) 88 | elem 89 | tl)))) 90 | ((symbol? hd) 91 | (search tl (lambda (vars e) (c (cons hd vars) e)))) 92 | (else 93 | (error 'com-parse 94 | "Variable name or = expected: ~s" e))))))))) 95 | (map parse-fct P)))) 96 | 97 | ;----------------------------------------------------------------------------- 98 | ; Similix primitives for Lazy combinator interpreter 99 | ; Copyright (C) 1993 Anders Bondorf 100 | ; Please see the file README for copyright notice, license and disclaimer. 101 | 102 | 103 | ;----------------------------------------------------------------------------- 104 | 105 | (define (ext binop value1 value2) 106 | (case binop 107 | ((cons) (cons value1 value2)) 108 | ((hack-car) (car value1)) 109 | ((hack-cdr) (cdr value1)) 110 | ((equal?) (equal? value1 value2)) 111 | ((+) (+ value1 value2)) 112 | ((-) (- value1 value2)) 113 | ((*) (* value1 value2)) 114 | ((/) (/ value1 value2)) 115 | ((=) (= value1 value2)) 116 | ((/=) (not (= value1 value2))) 117 | ((mod) (modulo value1 value2)))) 118 | 119 | (define err error) 120 | 121 | ;----------------------------------------------------------------------------- 122 | ; Similix thunk primitive for Lazy combinator interpreter 123 | ; Copyright (C) 1993 Anders Bondorf 124 | ; Please see the file README for copyright notice, license and disclaimer. 125 | 126 | 127 | ;----------------------------------------------------------------------------- 128 | (define (save s) 129 | (let ((v '()) 130 | (tag #t)) 131 | (lambda () 132 | (if tag 133 | (begin 134 | (set! v (s)) 135 | (set! tag #f))) 136 | v))) 137 | 138 | ;----------------------------------------------------------------------------- 139 | -------------------------------------------------------------------------------- /examples/lazy/evens.com: -------------------------------------------------------------------------------- 1 | ; Similix Lazy combinator source program example 2 | ; Copyright (C) 1993 Anders Bondorf 3 | ; Please see the file README for copyright notice, license and disclaimer. 4 | ; Changes by Peter Thiemann 1996 5 | 6 | ;----------------------------------------------------------------------------- 7 | (first-n n l = if (= n 0) 8 | '() 9 | (cons (lazy-car l) (first-n (- n 1) (lazy-cdr l)))) 10 | 11 | (evens-from n = lazy-cons n (evens-from (+ n 2))) 12 | 13 | (lazy-cons x y z = z x y) 14 | (lazy-car x = x fst) 15 | (lazy-cdr x = x snd) 16 | 17 | (fst x y = x) 18 | (snd x y = y) 19 | 20 | (goal input = first-n input (evens-from 0)) 21 | 22 | ;----------------------------------------------------------------------------- 23 | -------------------------------------------------------------------------------- /examples/lazy/primes.com: -------------------------------------------------------------------------------- 1 | (stream-filter p l = stream-filter-aux p (lazy-car l) (lazy-cdr l)) 2 | (stream-filter-aux p x xs = if (p x) 3 | (lazy-cons x (stream-filter p xs)) 4 | (stream-filter p xs)) 5 | 6 | (drop-multiples xs = drop-multiples-aux (lazy-car xs) (lazy-cdr xs)) 7 | (drop-multiples-aux x xs = lazy-cons x (stream-filter (pred x) xs)) 8 | 9 | (pred p x = /= 0 (mod x p)) 10 | 11 | (from n = lazy-cons n (from (+ n 1))) 12 | 13 | (primes = drop-multiples (from 2)) 14 | 15 | (first-n n l = if (= n 0) 16 | '() 17 | (cons (lazy-car l) (first-n (- n 1) (lazy-cdr l)))) 18 | 19 | (lazy-cons x y z = z x y) 20 | (lazy-car x = x fst) 21 | (lazy-cdr x = x snd) 22 | 23 | (fst x y = x) 24 | (snd x y = y) 25 | 26 | (goal input = first-n input primes) 27 | -------------------------------------------------------------------------------- /examples/list.dat: -------------------------------------------------------------------------------- 1 | (define-data my-list (my-nil) (my-cons my-car my-cdr)) 2 | -------------------------------------------------------------------------------- /examples/ll-parser/ll1-parser.scm: -------------------------------------------------------------------------------- 1 | ;; LL (1) parser 2 | 3 | (define-memo _memo 1) 4 | (define-primitive eq? - pure) 5 | (define-primitive cdr - pure) 6 | (define-primitive memv - pure) 7 | ;; (define-primitive apply - apply) 8 | 9 | (define (parse grammar input) 10 | 11 | (define-without-memoization (parse-one symbol input) 12 | (_memo 13 | (let ((ch (car input))) 14 | (if (terminal? symbol grammar) 15 | (if (eq? (grammar-symbol->name symbol grammar) ch) 16 | (values ch (cdr input)) 17 | (error "parse error, expected: " symbol " got: " ch)) 18 | (let ((try 19 | (lambda (production) 20 | (call-with-values 21 | (lambda () 22 | (parse-sequence (production-rhs production) input)) 23 | (lambda (val* input) 24 | (values (apply (eval (production-attribution production) 25 | (interaction-environment)) 26 | val*) 27 | input)))))) 28 | (let loop ((productions (filter (lambda (production) 29 | (eq? symbol (production-lhs production))) 30 | (grammar-productions grammar)))) 31 | (cond 32 | ((null? productions) 33 | (error "parse error, unexpected symbol" ch)) 34 | ((= 1 (length productions)) 35 | (try (car productions))) 36 | ((memv ch (map (lambda (x) (car x)) 37 | (nonterminal-first symbol 1 grammar))) 38 | (try (car productions))) 39 | (else 40 | (loop (cdr productions)))))))))) 41 | 42 | (define-without-memoization (parse-sequence symbol* input) 43 | (let loop ((symbol* symbol*) (val* '()) (input input)) 44 | (if (null? symbol*) 45 | (values (reverse val*) input) 46 | (call-with-values 47 | (lambda () 48 | (parse-one (car symbol*) input)) 49 | (lambda (val input) 50 | (loop (cdr symbol*) (cons val val*) input)))))) 51 | 52 | (parse-one (grammar-start grammar) input)) 53 | -------------------------------------------------------------------------------- /examples/ll-parser/packages.scm: -------------------------------------------------------------------------------- 1 | ; Interfaces 2 | 3 | (define-interface grammar-interface 4 | (export grammar-productions grammar-nonterminals 5 | grammar-start grammar-error 6 | grammar-number-of-nonterminals 7 | grammar-productions-with-lhs 8 | grammar-fetch-property 9 | grammar-symbol->name 10 | production-lhs production-rhs production-attribution 11 | 12 | grammar-start-production 13 | terminal? nonterminal? 14 | (define-grammar :syntax) 15 | 16 | nonterminal-nullable? sequence-nullable? 17 | nonterminal-first sequence-first 18 | nonterminal-follow)) 19 | 20 | (define-interface scc-union-interface 21 | (export complete-subsets!)) 22 | 23 | (define-interface parser-interface 24 | (export parse)) 25 | 26 | (define-interface toy-grammars-interface 27 | (export g10 (g10-symbol :syntax))) 28 | 29 | ; Structures 30 | 31 | (define-structure grammar grammar-interface 32 | (open scheme big-util define-record-types enumerated scc-union) 33 | (files grammar)) 34 | 35 | (define-structure scc-union scc-union-interface 36 | (open scheme) 37 | (files scc-union)) 38 | 39 | (define-structure toy-grammars toy-grammars-interface 40 | (open scheme enumerated grammar) 41 | (files toy-grammars)) 42 | -------------------------------------------------------------------------------- /examples/ll-parser/scc-union.scm: -------------------------------------------------------------------------------- 1 | ; Digraph algorithm from Pennello/DeRemer 2 | ; ======================================= 3 | 4 | ; This function is very generic, imperative, kludgy, 5 | ; and it has too many arguments 6 | 7 | (define (complete-subsets! for-each-a a-equal? for-each-R 8 | associate-depth! depth-association 9 | overwrite! merge!) 10 | (let ((stack '()) 11 | (depth 0)) 12 | 13 | ;; #f means infinity 14 | (define (depth-min a b) 15 | (cond ((not a) b) 16 | ((not b) a) 17 | (else (min a b)))) 18 | 19 | (define (descend! a) 20 | (set! stack (cons a stack)) 21 | (set! depth (+ 1 depth)) 22 | (let ((depth depth)) 23 | (associate-depth! a depth) 24 | (for-each-R 25 | (lambda (b) 26 | (if (eqv? 0 (depth-association b)) ; can't use zero? 'cause it may be #f 27 | (descend! b)) 28 | (associate-depth! a 29 | (depth-min (depth-association a) 30 | (depth-association b))) 31 | (merge! a b)) 32 | a) 33 | 34 | (if (= (depth-association a) depth) 35 | (let loop () 36 | (let ((top (car stack))) 37 | (associate-depth! top #f) 38 | (overwrite! top a) 39 | (set! stack (cdr stack)) 40 | (if (not (a-equal? top a)) 41 | (loop))))))) 42 | 43 | (for-each-a (lambda (a) 44 | (if (eqv? 0 (depth-association a)) 45 | (descend! a)))))) 46 | -------------------------------------------------------------------------------- /examples/ll-parser/toy-grammars.scm: -------------------------------------------------------------------------------- 1 | ; Balanced parentheses 2 | 3 | (define-grammar g00 g00-symbol 4 | (S) 5 | (l) 6 | S 7 | (((S l) $1))) 8 | 9 | (define-grammar g08 g08-symbol 10 | (S T) 11 | (l r) 12 | S 13 | (((S S T) $1) 14 | ((S T) $1) 15 | ((T l S r) $1) 16 | ((T l r) $1))) 17 | 18 | ; Constant arithmetic expressions 19 | 20 | (define-grammar g10 g10-symbol 21 | (E T P) 22 | (+ - * / l r n) 23 | E 24 | (((E T) $1) 25 | ((E T + E) (+ $1 $3)) 26 | ((E T - E) (- $1 $3)) 27 | ((T P) $1) 28 | ((T P * T) (* $1 $3)) 29 | ((T P / T) (/ $1 $3)) 30 | ((P n) $1) 31 | ((P l E r) $2))) 32 | 33 | (define-grammar g10-error g10-error-symbol 34 | (E T P) 35 | (+ - * / l r n) 36 | E 37 | (((E T) $1) 38 | ((E $error) 0) 39 | ((E T + E) (+ $1 $3)) 40 | ((E T - E) (- $1 $3)) 41 | ((T P) $1) 42 | ((T P * T) (* $1 $3)) 43 | ((T P / T) (/ $1 $3)) 44 | ((P n) $1) 45 | ((P l E r) $2) 46 | ((P l $error r) 0))) 47 | 48 | (define-grammar g13 g13-symbol 49 | (S SLK NESLK SLD NESLD K P N) 50 | (comma blah dot) 51 | S 52 | (((SLK) $1) 53 | ((SLK NESLK) $1) 54 | ((NESLK N) $1) 55 | ((NESLK NESLK K N) $1) 56 | ((SLD) $1) 57 | ((SLD NESLD) $1) 58 | ((NESLD N) $1) 59 | ((NESLD NESLD P N) $1) 60 | ((S SLK) $1) 61 | ((S SLD) $1) 62 | ((K comma) $1) 63 | ((P dot) $1) 64 | ((N blah) $1))) 65 | 66 | ;; javascript example expanded 67 | 68 | (define-grammar g14 g14-symbol 69 | (S E C A OL AL ON AN) 70 | (c comma colon lcurly rcurly lbracket rbracket) 71 | S 72 | (((S E) $1) 73 | ((E c) $1) 74 | ((E lcurly OL rcurly) $1) 75 | ((E lbracket AL rcurly) $1) 76 | ((C comma) $1) 77 | ((A c colon E) $1) 78 | ((OL) $1) 79 | ((OL ON) $1) 80 | ((ON A) $1) 81 | ((ON ON C A) $1) 82 | ((AL) $1) 83 | ((AL AN) $1) 84 | ((AN E) $1) 85 | ((AN AN C E) $1))) 86 | 87 | 88 | -------------------------------------------------------------------------------- /examples/mixwell/mw-int-int.scm: -------------------------------------------------------------------------------- 1 | ; Mixwell interpreter 2 | ; Copyright (C) 1993 Anders Bondorf 3 | 4 | ;----------------------------------------------------------------------------- 5 | ; P ::= (D1 D2 ... Dn) 6 | ; D ::= (F (V1 ... Vn) = E) 7 | ; E ::= V | (quote C) 8 | ; | (car E) | (cdr E) | (atom E) | (cons E E) | (equal E E) 9 | ; | (if E E E) | (call F E1 ... En) 10 | 11 | ;------------------------------------------------------------------------------ 12 | 13 | (define-data binding 14 | (make-binding binding-name binding-value)) 15 | 16 | (define-data bindings 17 | (bindings-nil) 18 | (bindings-cons bindings-car bindings-cdr)) 19 | 20 | (define-primitive _error - error) 21 | 22 | (define-primitive dynamize - dynamic) 23 | 24 | (define (generalize x) 25 | (if #t x (dynamize x))) 26 | ;----------------------------------------------------------------------------- 27 | 28 | ;------------------------------------------------------------------------------ 29 | 30 | (define (run-mixwell p vals) 31 | (let ((vs (cadr (car p))) 32 | (e (cadddr (car p)))) 33 | (ev e 34 | (let ((arity (length vs))) 35 | (let loop ((i 0)) 36 | (if (= i arity) 37 | (init-env) 38 | (upd-env (list-ref vs i) 39 | (list-ref vals i) 40 | (loop (generalize (+ 1 i))))))) 41 | p))) 42 | 43 | (define (ev e r p) 44 | (if (or (symbol? e) 45 | (boolean? e) 46 | (number? e)) 47 | (lookup-env e r) ; e = variable v 48 | (let ((op (car e))) 49 | (cond 50 | ((or (eq? 'quote op) (eq? 'generalize op)) (cadr e)) 51 | ((eq? 'car op) (car (ev (cadr e) r p))) 52 | ((eq? 'cdr op) (cdr (ev (cadr e) r p))) 53 | ((eq? 'atom op) (not (pair? (ev (cadr e) r p)))) 54 | ((eq? 'pair? op) (pair? (ev (cadr e) r p))) 55 | ((eq? 'null? op) (null? (ev (cadr e) r p))) 56 | ((eq? 'cons op) 57 | (cons (ev (cadr e) r p) (ev (caddr e) r p))) 58 | ((eq? 'equal? op) 59 | (equal? (ev (cadr e) r p) (ev (caddr e) r p))) 60 | ((eq? 'if op) 61 | (if (ev (cadr e) r p) 62 | (ev (caddr e) r p) 63 | (ev (cadddr e) r p))) 64 | ((or (eq? 'call op) 65 | (eq? 'xcall op) 66 | (eq? 'rcall op)) 67 | (let ((d (assoc (cadr e) p))) 68 | (let ((f (car d)) 69 | (vs (cadr d))) 70 | (ev (cadddr d) 71 | (let loop ((vs vs) (es (cddr e))) 72 | (if (null? vs) 73 | (init-env) 74 | (upd-env (car vs) 75 | (ev (car es) r p) 76 | (loop (cdr vs) (cdr es))))) 77 | p)))) 78 | (else 79 | (_error "illegal expression syntax")))))) 80 | 81 | (define (init-env) (bindings-nil)) 82 | (define (upd-env V val r) (bindings-cons (make-binding V val) r)) 83 | 84 | (define (lookup-env V r) 85 | (let loop ((bs r)) 86 | (if (bindings-nil? bs) 87 | (_error "Name ~s not bound") 88 | (let ((binding (bindings-car bs))) 89 | (if (equal? V (binding-name binding)) 90 | (binding-value binding) 91 | (loop (bindings-cdr bs))))))) 92 | 93 | ;------------------------------------------------------------------------------ 94 | -------------------------------------------------------------------------------- /examples/mixwell/mw-int.scm: -------------------------------------------------------------------------------- 1 | ; Mixwell interpreter 2 | ; Copyright (C) 1993 Anders Bondorf 3 | 4 | ;----------------------------------------------------------------------------- 5 | ; P ::= (D1 D2 ... Dn) 6 | ; D ::= (F (V1 ... Vn) = E) 7 | ; E ::= V | (quote C) 8 | ; | (car E) | (cdr E) | (atom E) | (cons E E) | (equal E E) 9 | ; | (if E E E) | (call F E1 ... En) 10 | 11 | ;------------------------------------------------------------------------------ 12 | 13 | (define-data binding 14 | (make-binding binding-name binding-value)) 15 | 16 | (define-data bindings 17 | (bindings-nil) 18 | (bindings-cons bindings-car bindings-cdr)) 19 | 20 | (define-primitive _error - error) 21 | 22 | ;----------------------------------------------------------------------------- 23 | 24 | ;------------------------------------------------------------------------------ 25 | 26 | (define (run-mixwell p vals) 27 | (let ((vs (cadr (car p))) 28 | (e (cadddr (car p)))) 29 | (ev e 30 | (let ((arity (length vs))) 31 | (let loop ((i 0)) 32 | (if (= i arity) 33 | (init-env) 34 | (upd-env (list-ref vs i) 35 | (list-ref vals i) 36 | (loop (+ 1 i)))))) 37 | p))) 38 | 39 | (define (ev e r p) 40 | (if (or (symbol? e) 41 | (boolean? e) 42 | (number? e)) 43 | (lookup-env e r) ; e = variable v 44 | (let ((op (car e))) 45 | (cond 46 | ((or (eq? 'quote op) (eq? 'generalize op)) (cadr e)) 47 | ((eq? 'car op) (car (ev (cadr e) r p))) 48 | ((eq? 'cdr op) (cdr (ev (cadr e) r p))) 49 | ((eq? 'atom op) (not (pair? (ev (cadr e) r p)))) 50 | ((eq? 'pair? op) (pair? (ev (cadr e) r p))) 51 | ((eq? 'null? op) (null? (ev (cadr e) r p))) 52 | ((eq? 'cons op) 53 | (cons (ev (cadr e) r p) (ev (caddr e) r p))) 54 | ((eq? 'equal? op) 55 | (equal? (ev (cadr e) r p) (ev (caddr e) r p))) 56 | ((eq? 'if op) 57 | (if (ev (cadr e) r p) 58 | (ev (caddr e) r p) 59 | (ev (cadddr e) r p))) 60 | ((or (eq? 'call op) 61 | (eq? 'xcall op) 62 | (eq? 'rcall op)) 63 | (let ((d (assoc (cadr e) p))) 64 | (let ((f (car d)) 65 | (vs (cadr d))) 66 | (ev (cadddr d) 67 | (let loop ((vs vs) (es (cddr e))) 68 | (if (null? vs) 69 | (init-env) 70 | (upd-env (car vs) 71 | (ev (car es) r p) 72 | (loop (cdr vs) (cdr es))))) 73 | p)))) 74 | (else 75 | (_error "illegal expression syntax")))))) 76 | 77 | (define (init-env) (bindings-nil)) 78 | (define (upd-env V val r) (bindings-cons (make-binding V val) r)) 79 | 80 | (define (lookup-env V r) 81 | (let loop ((bs r)) 82 | (if (bindings-nil? bs) 83 | (_error "Name ~s not bound") 84 | (let ((binding (bindings-car bs))) 85 | (if (equal? V (binding-name binding)) 86 | (binding-value binding) 87 | (loop (bindings-cdr bs))))))) 88 | 89 | ;------------------------------------------------------------------------------ 90 | -------------------------------------------------------------------------------- /examples/modint-base.scm: -------------------------------------------------------------------------------- 1 | (define-data list 2 | (nil) (:: hd tl)) 3 | 4 | (define-data my-pair 5 | (my-pair fst snd)) 6 | 7 | (define-memo _memo 1) 8 | (define-memo _access 1 'deferred) 9 | 10 | (define-primitive zero? - pure) ; (all t t); (all x (-> (* b x) b)) 11 | (define-primitive null? - pure) 12 | (define-primitive eq? - pure) 13 | (define-primitive eqv? - pure) 14 | (define-primitive + - pure) 15 | (define-primitive - - pure) 16 | 17 | (define-primitive dyn-error (-> b b) dynamic) 18 | 19 | ;;; auxiliary 20 | 21 | (define-syntax access 22 | (syntax-rules () 23 | ((access modulename f) 24 | (let ((modulename1 modulename)) 25 | (letrec ((jump (lambda-without-memoization () 26 | (_access modulename1 27 | (lambda (mod-name mod-body) 28 | (if (null? mod-body) 29 | (dyn-error "invalid index") 30 | (if (eq? modulename1 mod-name) 31 | (f mod-name mod-body) 32 | (jump)))))))) 33 | (jump)))))) 34 | 35 | (define (split i xs) 36 | (let loop ((i i) (rxs (nil)) (xs xs)) 37 | (if (zero? i) 38 | (my-pair (reverse rxs) xs) 39 | (loop (- i 1) (:: (hd xs) rxs) (tl xs))))) 40 | 41 | (define (reverse xs) 42 | (let loop ((r (nil)) (xs xs)) 43 | (if (nil? xs) 44 | r 45 | (loop (:: (hd xs) r) (tl xs))))) 46 | 47 | (define (concat xs ys) 48 | (let loop ((xs xs)) 49 | (if (nil? xs) 50 | ys 51 | (:: (hd xs) (loop (tl xs)))))) 52 | 53 | (define (copy n l) 54 | (if (zero? n) 55 | (nil) 56 | (:: (car l) (copy (- n 1) (cdr l))))) 57 | 58 | (define-without-memoization (exec jump instrs regs) 59 | (let loop ((instrs instrs) (regs regs)) 60 | (if (null? instrs) 61 | (hd regs) 62 | (let ((instr (car instrs)) 63 | (instrs (cdr instrs))) 64 | (case (car instr) 65 | ((Incr) 66 | (let* ((regno (cadr instr)) 67 | (xxx (split regno regs)) 68 | (regs1 (fst xxx)) 69 | (regs2 (snd xxx)) 70 | (reg (hd regs2))) 71 | (loop instrs 72 | (concat regs1 (:: (+ reg 1) (tl regs2)))))) 73 | ((Decr) 74 | (let* ((regno (cadr instr)) 75 | (xxx (split regno regs)) 76 | (regs1 (fst xxx)) 77 | (regs2 (snd xxx)) 78 | (reg (hd regs2))) 79 | (loop instrs 80 | (concat regs1 (:: (- reg 1) (tl regs2)))))) 81 | ((Jz) 82 | (let* ((regno (cadr instr)) 83 | (label (caddr instr)) 84 | (xxx (split regno regs)) 85 | (reg (hd (snd xxx)))) 86 | (if (zero? reg) 87 | (jump label regs) 88 | (loop instrs regs)))) 89 | ((Jump) 90 | (let* ((label (cadr instr))) 91 | (jump label regs))) 92 | (else 93 | (error "Illegal Instruction" instr))))))) 94 | -------------------------------------------------------------------------------- /examples/modint-dynamic.scm: -------------------------------------------------------------------------------- 1 | ;;; sophisticated interpreter 2 | ;;; no declarations, no restrictions 3 | 4 | ;;; (load "modint-base.scm") 5 | 6 | ;;; jump : 0 0 1 7 | (define (jump mod+name args) 8 | (access (car mod+name) 9 | (lambda (this-modname this-mod) 10 | (let ((found (assoc (cdr mod+name) this-mod))) 11 | (if found 12 | (exec jump (cdr found) args) 13 | (error "Undefined name")))))) 14 | 15 | ;;; jump-initial: 1 1 1 16 | (define (jump-initial modulename name args) 17 | (access 18 | modulename 19 | (lambda (mod-name mod-body) 20 | (let loop ((names (map (lambda (def) (car def)) mod-body))) 21 | (if (null? names) 22 | (dyn-error "unknown name") 23 | (let ((this-name (car names))) 24 | (if (eqv? name this-name) 25 | (jump (cons mod-name this-name) args) 26 | (loop (cdr names))))))))) 27 | 28 | ;;; main : 1 1 0 1 29 | (define (main modulename name nargs initial_args) 30 | (let ((args (copy nargs initial_args))) 31 | (jump-initial modulename name args))) 32 | 33 | 34 | -------------------------------------------------------------------------------- /examples/modint-examples.scm: -------------------------------------------------------------------------------- 1 | (define exported-labels '((add . mod1) (finis . mod1) (copy . mod2))) 2 | 3 | (define module1 4 | '((add . ((jz 1 copy) 5 | (decr 1) 6 | (incr 0) 7 | (jump add))) 8 | (finis . ()))) 9 | 10 | (define module2 11 | '((copy . ((jz 2 test) 12 | (incr 1) 13 | (decr 2) 14 | (jump copy))) 15 | (test . ((jz 1 finis) 16 | (jump add))))) 17 | 18 | ;; same example with qualifying module names 19 | (define module_1 20 | '((add . ((jz 1 (mod2 . copy)) 21 | (decr 1) 22 | (incr 0) 23 | (jump (mod1 . add)))) 24 | (finis . ()))) 25 | 26 | (define module_2 27 | '((copy . ((jz 2 (mod2 . test)) 28 | (incr 1) 29 | (decr 2) 30 | (jump (mod2 . copy)))) 31 | (test . ((jz 1 (mod1 . finis)) 32 | (jump (mod1 . add)))))) 33 | 34 | -------------------------------------------------------------------------------- /examples/modint-mutual.scm: -------------------------------------------------------------------------------- 1 | ;;; an improved modular interpreter 2 | ;;; recursive modules 3 | 4 | ;;; (load "modint-base.scm") 5 | 6 | ;;; jump-global : 0 0 0 1 7 | (define (jump exported-names modname) 8 | (lambda (name args) 9 | (let* ((is-exported (assoc name exported-names)) 10 | (name+mod (or is-exported (cons name modname)))) 11 | (access (cdr name+mod) 12 | (lambda (this-modname this-mod) 13 | (let ((found (assoc name this-mod))) 14 | (if found 15 | (exec (jump exported-names 16 | this-modname) 17 | (cdr found) 18 | args) 19 | (error "Undefined name")))))))) 20 | 21 | ;;; main : 0 1 0 1 22 | (define-without-memoization (main exported-names name 23 | nargs initial_args) 24 | (let ((args (copy nargs initial_args))) 25 | (let loop ((exports exported-names)) 26 | (if (null? exports) 27 | (dyn-error "Unknown name") 28 | (let ((export (car exports))) 29 | (if (eqv? name (car export)) 30 | ((jump exported-names 'noname) 31 | (car export) args) 32 | (loop (cdr exports)))))))) 33 | 34 | -------------------------------------------------------------------------------- /examples/modint.scm: -------------------------------------------------------------------------------- 1 | ;;; very simple modular interpreter 2 | ;;; requires modules in dependency order, main module first 3 | 4 | ;;; (load "modint-base.scm") 5 | 6 | ;;; jump : 0 1 0 [1]0 7 | (define (jump-local modulename-of mod) 8 | (lambda (name args) 9 | (let ((found (assoc name mod))) 10 | (if found 11 | (_memo (exec (jump-local modulename-of mod) 12 | (cdr found) 13 | args)) 14 | (jump-global modulename-of name args))))) 15 | 16 | (define (jump-global modulename-of name args) 17 | (access (modulename-of name) 18 | (lambda (mod-name mod-body) 19 | (if (null? mod-body) 20 | (error "Undefined label") 21 | ((jump-local modulename-of mod-body) name args))))) 22 | 23 | ;;; main : 1 0 0 1 24 | (define (main modulename-of name nargs initial_args) 25 | (let ((args (copy nargs initial_args))) 26 | (jump-global modulename-of name args))) 27 | -------------------------------------------------------------------------------- /examples/object.scm: -------------------------------------------------------------------------------- 1 | (define-data tuple3 2 | (object set get add)) 3 | 4 | (define (main) 5 | (let ((counter-class 6 | (lambda () 7 | (let* ((slot 0) 8 | (mset (lambda (x) (set! slot x) x)) 9 | (mget (lambda () slot)) 10 | (madd (lambda (x) (set! slot (+ slot x)) x))) 11 | (object mset mget madd ))))) 12 | (let ((cnt (counter-class))) 13 | ((set cnt) 21) 14 | ((add cnt) ((get cnt))) 15 | ((get cnt))))) 16 | -------------------------------------------------------------------------------- /examples/optimal.scm: -------------------------------------------------------------------------------- 1 | (define-data universal 2 | (in-base ex-base) 3 | (in-fun ex-fun) 4 | (in-pair ex-pair-1 ex-pair-2) 5 | (in-error ex-error)) 6 | 7 | (define-data env 8 | (empty-env) 9 | (extend-env env->var env->val env->next)) 10 | 11 | (define-primitive force1 (all a (-> a a)) 1) 12 | 13 | ;; a program is an applied lambda expression of base type 14 | (define (run e vars vals) 15 | (let* ((rho0 (make-env vars vals)) 16 | (result (ev e rho0))) 17 | (ex-base result))) 18 | 19 | (define-without-memoization (ev e rho) 20 | (cond 21 | ((var-exp? e) 22 | (apply-env rho e)) 23 | ((const-exp? e) 24 | (in-base (const->value e))) 25 | ((if-exp? e) 26 | (if (ex-base (ev (if->cond e) rho)) 27 | (ev (if->then e) rho) 28 | (ev (if->else e) rho))) 29 | ((let-exp? e) 30 | (let ((v (ev (let->header e) rho))) 31 | (ev (let->body e) (extend-env (let->var e) v rho)))) 32 | ((op-exp? e) 33 | (let ((e* (op->args e))) 34 | (case (op->name e) 35 | ((cons) (in-pair (ev (car e*) rho) (ev (cadr e*) rho))) 36 | ((car) (ex-pair-1 (ev (car e*) rho))) 37 | ((cdr) (ex-pair-2 (ev (car e*) rho))) 38 | (else (in-error (error "unknown primitive operator")))))) 39 | ((lambda-exp? e) 40 | (in-fun (lambda-poly (v) 41 | (ev (lambda->body e) (extend-env (lambda->var e) v rho))))) 42 | ((app-exp? e) 43 | ((ex-fun (ev (app->rator e) rho)) 44 | (ev (app->rand e) rho))) 45 | (else 46 | (in-error (error "syntax error in program"))))) 47 | 48 | (define (make-env vars vals) 49 | (if (null? vars) 50 | (empty-env) 51 | (extend-env (car vars) 52 | (in-base (car vals)) 53 | (make-env (cdr vars) (cdr vals))))) 54 | 55 | (define (apply-env env var) 56 | (let loop ((env env)) 57 | (if (empty-env? env) 58 | (in-error (error "unknown variable")) 59 | (if (eqv? var (env->var env)) 60 | (env->val env) 61 | (loop (env->next env)))))) -------------------------------------------------------------------------------- /examples/pm-input.scm: -------------------------------------------------------------------------------- 1 | (define make-input-symbols '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) 2 | (define (make-input-symbol n) 3 | (list-ref make-input-symbols (remainder n 26))) 4 | (define (make-many-input-symbols n) 5 | (let loop ((nr (+ 1 (quotient n 3)))) 6 | (if (zero? nr) 7 | '() 8 | (cons `(cst ,(make-input-symbol (+ (* n 3) (* nr 5)))) 9 | (loop (- nr 1)))))) 10 | (define (make-input n) 11 | (if (zero? n) 12 | `(var zzz) 13 | `(seq ,(make-input (- n 1)) 14 | ,@(make-many-input-symbols n) 15 | ,(make-input (quotient n 2))))) 16 | -------------------------------------------------------------------------------- /examples/pm.scm: -------------------------------------------------------------------------------- 1 | ; -*- Scheme -*- 2 | ; from: 3 | ; Olivier Danvy, Semantics-Directed Compilation of Nonlinear Patterns, 4 | ; Information Processing Letters 6(37):315-322, 1991 5 | 6 | (define (match p d) ;;; Pat x Dat -> Ans 7 | ((match-hook p d (lambda (h t) (cons h t))) '() '())) 8 | 9 | (define (match-hook p d k) ;;; Pat x Dat x Cont -> Cont 10 | (case (car p) 11 | ((Cst) (let ((v (cadr p))) (if (equal? v d) k fail))) 12 | ((Var) (let ((n (cadr p))) (assoc-c n (test-and-jump d k) (extend n d k)))) 13 | ((Seq) (let ((p* (cdr p))) (match-seq p* d k))))) 14 | 15 | (define (match-seq p* d k) ;;; Pat* x Dat x Cont -> Cont 16 | (if (null? p*) 17 | (if (null? d) k fail) 18 | (let ((p (car p*)) (p* (cdr p*))) 19 | (if (pair? d) 20 | (match-hook p (car d) (match-seq p* (cdr d) k)) 21 | fail)))) 22 | 23 | (define (fail ln lv) ;;; Cont = (List(Nam) x List(Val) -> Ans) 24 | #f) 25 | 26 | (define (test-and-jump d k) ;;; Val x Cont -> Val -> Cont 27 | (lambda (v) 28 | (if (equal? d v) 29 | k 30 | fail))) 31 | 32 | (define (extend n d k) ;;; Nam x Val x Cont -> Cont 33 | (lambda (ln lv) 34 | (k (cons n ln) (cons d lv)))) 35 | 36 | (define (assoc-c n s f) ;;; Nam x (Val -> Cont) x Cont -> Cont 37 | (lambda (ln lv) 38 | (let ((offset (index n ln))) 39 | (if (negative? offset) 40 | (f ln lv) 41 | ((s (list-ref lv offset)) ln lv))))) 42 | 43 | (define (index e l) ;;; Nam x List(Nam) -> Nat + {-1} 44 | (let loop ((n 0) (l l)) 45 | (cond 46 | ((null? l) 47 | -1) 48 | ((equal? e (car l)) 49 | n) 50 | (else 51 | (loop (+ 1 n) (cdr l)))))) 52 | -------------------------------------------------------------------------------- /examples/poly-rec.scm: -------------------------------------------------------------------------------- 1 | (define main 2 | (lambda (x) 3 | (+ (g x) 1))) 4 | 5 | (define-without-memoization g 6 | (lambda-poly (x) 7 | (if (= x (+ x 1)) 1 (g x)))) 8 | 9 | ;;; use: 10 | ; (define genext (cogen-driver '("examples/poly-rec.scm") '(main 1))) 11 | ; (writelpp genext "/tmp/poly-rec0.scm") 12 | ; (prepare!) 13 | ; (reset (begin 14 | ; (load "/tmp/poly-rec0.scm") 15 | ; (specialize-after-prepare $goal '(main 1) (list 'x1)))) -------------------------------------------------------------------------------- /examples/poly.scm: -------------------------------------------------------------------------------- 1 | (define (main s1 s2 d) 2 | (let ((f (lambda-poly (x y) (+ x y)))) 3 | (* (f s1 d) 4 | (f s2 d) 5 | (f s1 d) 6 | (f s2 d) 7 | (g f (+ d d))))) 8 | 9 | (define (g f d) 10 | (+ (f 7 d) (f 11 d))) 11 | 12 | -------------------------------------------------------------------------------- /examples/power.scm: -------------------------------------------------------------------------------- 1 | (define (power x n) 2 | (if (= 0 n) 3 | 1 4 | (* x (power x (- n 1))))) 5 | -------------------------------------------------------------------------------- /examples/pure-arith.scm: -------------------------------------------------------------------------------- 1 | (define-primitive + - pure) 2 | (define-primitive - - pure) 3 | (define-primitive * - pure) 4 | (define-primitive / - pure) 5 | -------------------------------------------------------------------------------- /examples/reach.scm: -------------------------------------------------------------------------------- 1 | (define (f x) 2 | (let* ((r (make-cell x)) 3 | (d (cell-ref r)) 4 | (y (cell-set! r 5)) 5 | (s (+ (cell-ref r) (cell-ref r)))) 6 | (+ d s))) 7 | -------------------------------------------------------------------------------- /examples/sample_modules_session.scm: -------------------------------------------------------------------------------- 1 | ;; Sample PGG session for separate compilation 2 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3 | ;; see submitted paper 4 | 5 | ,open signals 6 | ,open pgg-residual 7 | ,open pp 8 | 9 | (load "examples/modint-examples.scm") 10 | 11 | ;; naive approach 12 | ;(define genext (cogen-driver '("modint-base.scm" "modint.scm") '(main 1 0 0 1))) 13 | ;(writelpp genext "regcompiler1.scm") 14 | ;(load "regcompiler1.scm") 15 | ;(specialize-$goal 'add 3) 16 | ;(writelpp *residual-program* "example1_main.scm") 17 | ;(continue 'mod1 module1) 18 | ;(writelpp *residual-program* "example1_mod1.scm") 19 | ;(continue 'mod2 module2) 20 | ;(writelpp *residual-program* "example1_mod2.scm") 21 | ;(continue 'mod1 module1) 22 | ;(writelpp *residual-program* "example1_mod1_1.scm") 23 | 24 | ;; first improvement 25 | (define genext (cogen-driver '("examples/modint-base.scm" "examples/modint-mutual.scm") '(main 0 1 0 1))) 26 | (writelpp genext "/tmp/regcompiler2.scm") 27 | (load "/tmp/regcompiler2.scm") 28 | (specialize-$goal exported-labels 3) 29 | (writelpp *residual-program* "/tmp/example2_main.scm") 30 | (continue 'mod1 module1) 31 | (writelpp *residual-program* "/tmp/example2_mod1.scm") 32 | (continue 'mod2 module2) 33 | (writelpp *residual-program* "/tmp/example2_mod2.scm") 34 | 35 | ;; second improvement 36 | (define genext (cogen-driver '("examples/modint-base.scm" "examples/modint-dynamic.scm") '(main 1 1 0 1))) 37 | (writelpp genext "/tmp/regcompiler3.scm") 38 | (load "/tmp/regcompiler3.scm") 39 | (specialize-$goal 3) 40 | (writelpp *residual-program* "/tmp/example3_main.scm") 41 | (continue 'mod1 module_1) 42 | (writelpp *residual-program* "/tmp/example3_mod1.scm") 43 | (continue 'mod2 module_2) 44 | (writelpp *residual-program* "/tmp/example3_mod2.scm") 45 | (continue 'end '()) 46 | (writelpp *residual-program* "/tmp/example3_mod3.scm") 47 | 48 | 49 | ;;; imperative versions ;;; vector support needs debugging 50 | ;; first improvement 51 | (define genext (cogen-driver '("examples/modint-imp-decls.scm" 52 | "examples/modint-imp-base.scm" 53 | "examples/modint-mutual.scm") 54 | '(main 0 1 0 1))) 55 | (writelpp genext "/tmp/impcompiler2.scm") 56 | (load "/tmp/impcompiler2.scm") 57 | (specialize-$goal exported-labels 3) 58 | (writelpp *residual-program* "/tmp/example-imp2_main.scm") 59 | (continue 'mod1 module1) 60 | (writelpp *residual-program* "/tmp/example-imp2_mod1.scm") 61 | (continue 'mod2 module2) 62 | (writelpp *residual-program* "/tmp/example-imp2_mod2.scm") 63 | 64 | ;; second improvement 65 | (define genext (cogen-driver '("examples/modint-imp-decls.scm" 66 | "examples/modint-imp-base.scm" 67 | "examples/modint-dynamic.scm") 68 | '(main 1 1 0 1))) 69 | (writelpp genext "/tmp/impcompiler3.scm") 70 | (load "/tmp/impcompiler3.scm") 71 | (specialize-$goal 3) 72 | (writelpp *residual-program* "/tmp/example-imp3_main.scm") 73 | (continue 'mod1 module_1) 74 | (writelpp *residual-program* "/tmp/example-imp3_mod1.scm") 75 | (continue 'mod2 module_2) 76 | (writelpp *residual-program* "/tmp/example-imp3_mod2.scm") 77 | (continue 'end '()) 78 | (writelpp *residual-program* "/tmp/example-imp3_mod3.scm") 79 | 80 | ,exit 81 | -------------------------------------------------------------------------------- /examples/termination/closure.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | 3 | (define (f x y) 4 | (g (lambda (z) (hd x)) y)) 5 | (define (g c y) 6 | (c y)) 7 | (define (h x) 8 | (h (f x 42))) 9 | -------------------------------------------------------------------------------- /examples/termination/fo-func.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | 3 | (define (run e p v) 4 | (int e (cons 'X (nil)) (cons v (nil)) p)) 5 | (define (int e ns vs p) 6 | (cond 7 | ((eq? (hd e) 'CONST) (hd (tl e))) 8 | ((eq? (hd e) 'VAR) (lookupvar (hd (tl e)) ns vs)) 9 | ((eq? (hd e) 'CONS) (cons (int (hd (tl e)) ns vs p) 10 | (int (hd (tl (tl e))) ns vs p))) 11 | ((eq? (hd e) 'IF) (if (int (hd (tl e)) ns vs p) 12 | (int (hd (tl (tl e))) ns vs p) 13 | (int (hd (tl (tl (tl e)))) ns vs p))) 14 | ((eq? (hd e) 'LET) (int (hd (tl (tl (tl e)))) 15 | (cons (hd (tl e)) ns) 16 | (cons (int (hd (tl (tl e))) ns vs p) vs) 17 | p)) 18 | ((eq? (hd e) 'CALL) (int (lookupbody (hd (tl e)) p) 19 | (lookupnames (hd (tl e)) p) 20 | (intlist (hd (tl (tl e))) ns vs p))) 21 | (else 'ERROR))) 22 | 23 | (define (lookupvar n ns vs) 24 | (if (eq? n (hd ns)) 25 | (hd vs) 26 | (lookupvar n (tl ns) (tl vs)))) 27 | 28 | (define (lookupbody f p) 29 | (if (eq? f (hd (hd p))) 30 | (hd (tl (tl (hd p)))) 31 | (lookupbody f (tl p)))) 32 | 33 | (define (lookupnames f p) 34 | (if (eq? f (hd (hd p))) 35 | (hd (tl (hd p))) 36 | (lookupnames f (tl p)))) 37 | 38 | (define (intlist es ns vs p) 39 | (if (nil? es) 40 | (nil) 41 | (cons (int (hd es) ns vs p) 42 | (intlist (tl es) ns vs p)))) 43 | -------------------------------------------------------------------------------- /examples/termination/fo.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | 3 | (define (run e v) 4 | (int e (lambda (m) v))) 5 | (define (int e r) 6 | (cond 7 | ((eq? (hd e) 'CONST) (hd (tl e))) 8 | ((eq? (hd e) 'VAR) (r (hd (tl e)))) 9 | ((eq? (hd e) 'CONS) (cons (int (hd (tl e)) r) 10 | (int (hd (tl (tl e))) r))) 11 | ((eq? (hd e) 'IF) (if (int (hd (tl e)) r) 12 | (int (hd (tl (tl e))) r) 13 | (int (hd (tl (tl (tl e)))) r))) 14 | ((eq? (hd e) 'LET) (int (hd (tl (tl (tl e)))) 15 | (upd (hd (tl e)) 16 | (int (hd (tl (tl e))) r) 17 | r))) 18 | (else 'ERROR))) 19 | (define (upd n v r) 20 | (lambda (m) (if (eq? n m) v (r m)))) 21 | -------------------------------------------------------------------------------- /examples/termination/goto-while.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | 3 | (define (run pgm x y) 4 | (int pgm pgm x y)) 5 | (define (int pgm e x y) 6 | (let ((hde (hd (hd e)))) 7 | (cond 8 | ((eq? hde 'Y) y) 9 | ((eq? hde 'X) x) 10 | ((eq? hde 'X=X+1) (int pgm (tl e) (cons x 1) y)) 11 | ((eq? hde 'Y=Y+1) (int pgm (tl e) x (cons y 1))) 12 | ((eq? hde 'GOTO) (int pgm (nth pgm (hd (tl (hd e)))) x y)) 13 | ((eq? hde 'GOTOX) (gotox pgm x y)) 14 | ((eq? hde 'IFX=0THEN) (if (eq? x 0) 15 | (int pgm (nth pgm (hd (tl (hd e))) x y)) 16 | (int pgm (tl e) x y))) 17 | ((eq? hde 'IFY=0THEN) (if (eq? y 0) 18 | (int pgm (nth pgm (hd (tl (hd e))) x y)) 19 | (int pgm (tl e) x y))) 20 | ((eq? hde 'WHILEX=0DO) (if (eq? x 0) 21 | (int pgm (cons (hd (tl (hd e))) e) x y) 22 | (int pgm (tl e) x y))) 23 | (else 'ERROR)))) 24 | (define (nth xs n) 25 | (if (nil? xs) 26 | xs 27 | (if (eq? n 0) 28 | xs 29 | (nth (tl xs) (- n 1))))) 30 | 31 | (define (gotox pgm x y) 32 | (gotox1 pgm pgm x y 1)) 33 | (define (gotox1 pgm ptail x y n) 34 | (if (nil? ptail) 35 | 'ERROR 36 | (if (equal? x n) 37 | (int pgm ptail x y) 38 | (gotox1 pgm (tl ptail) x y (+ n 1))))) 39 | -------------------------------------------------------------------------------- /examples/termination/goto.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | 3 | (define (run pgm x y) 4 | (int pgm pgm x y)) 5 | (define (int pgm e x y) 6 | (let ((hde (hd (hd e)))) 7 | (cond 8 | ((eq? hde 'Y) y) 9 | ((eq? hde 'X) x) 10 | ((eq? hde 'X=X+1) (int pgm (tl e) (cons x 1) y)) 11 | ((eq? hde 'Y=Y+1) (int pgm (tl e) x (cons y 1))) 12 | ((eq? hde 'GOTO) (int pgm (nth pgm (hd (tl (hd e)))) x y)) 13 | ((eq? hde 'GOTOX) (gotox pgm x y)) 14 | ((eq? hde 'IFX=0THEN) (if (eq? x 0) 15 | (int pgm (nth pgm (hd (tl (hd e))) x y)) 16 | (int pgm (tl e) x y))) 17 | ((eq? hde 'IFY=0THEN) (if (eq? y 0) 18 | (int pgm (nth pgm (hd (tl (hd e))) x y)) 19 | (int pgm (tl e) x y))) 20 | (else 'ERROR)))) 21 | (define (nth xs n) 22 | (if (nil? xs) 23 | xs 24 | (if (eq? n 0) 25 | xs 26 | (nth (tl xs) (- n 1))))) 27 | 28 | (define (gotox pgm x y) 29 | (gotox1 pgm pgm x y 1)) 30 | (define (gotox1 pgm ptail x y n) 31 | (if (nil? ptail) 32 | 'ERROR 33 | (if (equal? x n) 34 | (int pgm ptail x y) 35 | (gotox1 pgm (tl ptail) x y (+ n 1))))) 36 | -------------------------------------------------------------------------------- /examples/termination/ho-cbn.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | 3 | (define (run e v) 4 | (int e (lambda (m) v))) 5 | (define (int e r) 6 | (cond 7 | ((eq? (hd e) 'CONST) (hd (tl e))) 8 | ((eq? (hd e) 'VAR) ((r (hd (tl e))) 'FOO)) 9 | ((eq? (hd e) 'CONS) (cons (int (hd (tl e)) r) 10 | (int (hd (tl (tl e))) r))) 11 | ((eq? (hd e) 'IF) (if (int (hd (tl e)) r) 12 | (int (hd (tl (tl e))) r) 13 | (int (hd (tl (tl (tl e)))) r))) 14 | ((eq? (hd e) 'ABS) (lambda (x) (int (hd (tl (tl e))) 15 | (upd (hd (tl e)) x r)))) 16 | (else ((int (hd (tl e)) r) 17 | (lambda (foo) (int (hd (tl (tl e))) r)))))) 18 | (define (upd n v r) 19 | (lambda (m) (if (eq? n m) v (r m)))) 20 | -------------------------------------------------------------------------------- /examples/termination/ho-cps.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | 3 | (define (run e v) 4 | (int e (lambda (m) v) (lambda (z) z))) 5 | (define (int e r c) 6 | (cond 7 | ((eq? (hd e) 'CONST) (c (hd (tl e)))) 8 | ((eq? (hd e) 'VAR) (c (r (hd (tl e))))) 9 | ((eq? (hd e) 'CONS) (int (hd (tl e)) r 10 | (lambda (w1) 11 | (int (hd (tl (tl e))) r 12 | (lambda (w2) 13 | (c (cons w1 w2))))))) 14 | ((eq? (hd e) 'IF) (int (hd (tl e)) r 15 | (lambda (b) 16 | (if b 17 | (int (hd (tl (tl e))) r c) 18 | (int (hd (tl (tl (tl e)))) r c))))) 19 | ((eq? (hd e) 'ABS) (c (lambda (x) 20 | (lambda (k) 21 | (int (hd (tl (tl e))) 22 | (upd (hd (tl e)) x r) 23 | (lambda (z) (k z))))))) 24 | (else (int (hd (tl e)) r 25 | (lambda (w1) 26 | (int (hd (tl (tl e))) r 27 | (lambda (w2) 28 | ((w1 w2) (lambda (z) (c z)))))))))) 29 | (define (upd n v r) 30 | (lambda (m) (if (eq? n m) v (r m)))) 31 | -------------------------------------------------------------------------------- /examples/termination/ho-func.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | 3 | (define (run e p v) 4 | (int e (cons 'X (nil)) (cons v (nil)) p)) 5 | (define (int e ns vs p) 6 | (cond 7 | ((eq? (hd e) 'CONST) (hd (tl e))) 8 | ((eq? (hd e) 'VAR) (lookupvar (hd (tl e)) ns vs)) 9 | ((eq? (hd e) 'CONS) (cons (int (hd (tl e)) ns vs p) 10 | (int (hd (tl (tl e))) ns vs p))) 11 | ((eq? (hd e) 'IF) (if (int (hd (tl e)) ns vs p) 12 | (int (hd (tl (tl e))) ns vs p) 13 | (int (hd (tl (tl (tl e)))) ns vs p))) 14 | ((eq? (hd e) 'LET) (int (hd (tl (tl (tl e)))) 15 | (cons (hd (tl e)) ns) 16 | (cons (int (hd (tl (tl e))) ns vs p) vs) 17 | p)) 18 | ((eq? (hd e) 'CALL) (int (lookupbody (hd (tl e)) p) 19 | (lookupnames (hd (tl e)) p) 20 | (intlist (hd (tl (tl e))) ns vs p))) 21 | ((eq? (hd e) 'LAM) (lambda (x) 22 | (int (hd (tl (tl e))) 23 | (cons (hd (tl e)) ns) 24 | (cons x vs) 25 | p))) 26 | ((eq? (hd e) 'APP) ((int (hd (tl e)) ns vs p) 27 | (int (hd (tl (tl e))) ns vs p))) 28 | (else 'ERROR))) 29 | 30 | (define (lookupvar n ns vs) 31 | (if (eq? n (hd ns)) 32 | (hd vs) 33 | (lookupvar n (tl ns) (tl vs)))) 34 | 35 | (define (lookupbody f p) 36 | (if (eq? f (hd (hd p))) 37 | (hd (tl (tl (hd p)))) 38 | (lookupbody f (tl p)))) 39 | 40 | (define (lookupnames f p) 41 | (if (eq? f (hd (hd p))) 42 | (hd (tl (hd p))) 43 | (lookupnames f (tl p)))) 44 | 45 | (define (intlist es ns vs p) 46 | (if (nil? es) 47 | (nil) 48 | (cons (int (hd es) ns vs p) 49 | (intlist (tl es) ns vs p)))) 50 | -------------------------------------------------------------------------------- /examples/termination/ho-let.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | 3 | (define (run e v) 4 | (int e (lambda (m) v))) 5 | (define (int e r) 6 | (cond 7 | ((eq? (hd e) 'CONST) (hd (tl e))) 8 | ((eq? (hd e) 'VAR) (r (hd (tl e)))) 9 | ((eq? (hd e) 'CONS) (cons (int (hd (tl e)) r) 10 | (int (hd (tl (tl e))) r))) 11 | ((eq? (hd e) 'IF) (if (int (hd (tl e)) r) 12 | (int (hd (tl (tl e))) r) 13 | (int (hd (tl (tl (tl e)))) r))) 14 | ((eq? (hd e) 'ABS) (lambda (x) (int (hd (tl (tl e))) 15 | (upd (hd (tl e)) x r)))) 16 | ((eq? (hd e) 'LET) (int (hd (tl (tl (tl e)))) 17 | (upd (hd (tl e)) 18 | (int (hd (tl (tl e))) r) 19 | r))) 20 | (else ((int (hd (tl e)) r) 21 | (int (hd (tl (tl e))) r))))) 22 | (define (upd n v r) 23 | (lambda (m) (if (eq? n m) v (r m)))) 24 | -------------------------------------------------------------------------------- /examples/termination/ho-letrec.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | 3 | (define (run e v) 4 | (int e (lambda (m) v))) 5 | (define (int e r) 6 | (cond 7 | ((eq? (hd e) 'CONST) (hd (tl e))) 8 | ((eq? (hd e) 'VAR) (r (hd (tl e)))) 9 | ((eq? (hd e) 'CONS) (cons (int (hd (tl e)) r) 10 | (int (hd (tl (tl e))) r))) 11 | ((eq? (hd e) 'IF) (if (int (hd (tl e)) r) 12 | (int (hd (tl (tl e))) r) 13 | (int (hd (tl (tl (tl e)))) r))) 14 | ((eq? (hd e) 'ABS) (lambda (x) (int (hd (tl (tl e))) 15 | (upd (hd (tl e)) x r)))) 16 | ((eq? (hd e) 'LETREC) (int (hd (tl (tl (tl e)))) 17 | (fix (lambda (r1) 18 | (upd (hd (tl e)) 19 | (int (hd (tl (tl e))) r1) 20 | r))))) 21 | (else ((int (hd (tl e)) r) 22 | (int (hd (tl (tl e))) r))))) 23 | (define (upd n v r) 24 | (lambda (m) (if (eq? n m) v (r m)))) 25 | (define (fix f) 26 | (lambda (x) ((f (fix f)) x))) 27 | 28 | -------------------------------------------------------------------------------- /examples/termination/ho.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | 3 | (define (run e v) 4 | (int e (lambda (m) v))) 5 | (define (int e r) 6 | (cond 7 | ((eq? (hd e) 'CONST) (hd (tl e))) 8 | ((eq? (hd e) 'VAR) (r (hd (tl e)))) 9 | ((eq? (hd e) 'CONS) (cons (int (hd (tl e)) r) 10 | (int (hd (tl (tl e))) r))) 11 | ((eq? (hd e) 'IF) (if (int (hd (tl e)) r) 12 | (int (hd (tl (tl e))) r) 13 | (int (hd (tl (tl (tl e)))) r))) 14 | ((eq? (hd e) 'ABS) (lambda (x) (int (hd (tl (tl e))) 15 | (upd (hd (tl e)) x r)))) 16 | (else ((int (hd (tl e)) r) 17 | (int (hd (tl (tl e))) r))))) 18 | (define (upd n v r) 19 | (lambda (m) (if (eq? n m) v (r m)))) 20 | -------------------------------------------------------------------------------- /examples/termination/kmp.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | (define-data my-nat (zero) (succ pred)) 3 | 4 | (define (kmp p d) 5 | (loop p d p)) 6 | 7 | (define (loop p d pp) 8 | (cond 9 | ((nil? p) #t) 10 | ((nil? d) #f) 11 | ((eq? (hd p) (hd d)) (loop (tl p) (tl d) pp)) 12 | ((eq? p pp) (kmp p (tl d))) 13 | (else 14 | (loop1 p d pp 15 | (statickmp pp (tl pp) (add (length (tl pp)) (length p))))))) 16 | 17 | (define (loop1 p d pp np) 18 | (if (eq? np pp) 19 | (kmp pp (tl d)) 20 | (loop np d pp))) 21 | 22 | (define (statickmp p d n) 23 | (staticloop p d n p d n)) 24 | (define (staticloop p d n pp dd nn) 25 | (if (eq? n 0) 26 | (if (and (eq? nn 0) 27 | (eq? (hd p) (tl d))) 28 | (statickmp pp (tl dd) (sub1 nn)) 29 | p) 30 | (if (eq? (hd p) (hd d)) 31 | (staticloop (hd p) (hd d) (sub1 n) pp dd nn) 32 | (statickmp pp (tl dd) (sub1 n))))) 33 | (define (length xs) 34 | (if (nil? xs) 35 | zero 36 | (succ (length (tl xs))))) 37 | (define (sub1 n) 38 | (pred n)) 39 | (define (add m n) 40 | (if (zero? m) 41 | n 42 | (succ (add (pred m) n)))) 43 | -------------------------------------------------------------------------------- /examples/termination/myflatten.scm: -------------------------------------------------------------------------------- 1 | (define-data my-list (nil) (cons hd tl)) 2 | 3 | (define (flatten e) 4 | (f e (lambda (z) z))) 5 | 6 | (define (f e c) 7 | (if (nil? e) 8 | (c (nil)) 9 | (f (tl e) (lambda (z) (c (app (hd e) z)))))) 10 | 11 | (define (app xs ys) 12 | (if (nil? xs) 13 | ys 14 | (cons (hd xs) (app (tl xs) ys)))) 15 | -------------------------------------------------------------------------------- /examples/triv.scm: -------------------------------------------------------------------------------- 1 | (define (f1 s d) s) 2 | (define (f2 s d) d) 3 | (define (f3 s d) (if #f s d)) 4 | -------------------------------------------------------------------------------- /examples/unify-aux.scm: -------------------------------------------------------------------------------- 1 | ;; input syntax 2 | ;; term ::= (var ) | (cst ) | (bin ) 3 | 4 | (define (dynamic-parse-term s) 5 | (letrec ((xlookup 6 | (lambda (key keys refs) 7 | (if (null? keys) 8 | (nothing) 9 | (if (eq? key (car keys)) 10 | (just (xcar refs)) 11 | (xlookup key (cdr keys) (xcdr refs))))))) 12 | (let loop ((s s) (keys '()) (refs (xnil)) (c (lambda (z keys refs) z))) 13 | (cond 14 | ((eq? (car s) 'VAR) 15 | (let* ((n (cadr s)) 16 | (maybe-ref (xlookup n keys refs))) 17 | (if (just? maybe-ref) 18 | (c (make-var (one maybe-ref)) keys refs) 19 | (let ((newref (make-cell (nothing)))) 20 | (c (make-var newref) (cons n keys) (xcons newref refs)))))) 21 | ((eq? (car s) 'CST) 22 | (c (make-cst (cadr s)) keys refs)) 23 | (else 24 | ;; assuming (eq? (car s) 'BIN) 25 | (let ((s1 (cadr s)) 26 | (s2 (caddr s))) 27 | (loop s1 keys refs 28 | (lambda (ss1 keys refs) 29 | (loop s2 keys refs 30 | (lambda (ss2 keys refs) 31 | (c (make-bin ss1 ss2) keys refs))))))))))) 32 | 33 | (define (points-to rf term) 34 | (if (make-var? term) 35 | (let ((rft (ref term))) 36 | (or (eq? rf rft) 37 | (let ((maybe-term (cell-ref rft))) 38 | (and (just? maybe-term) 39 | (points-to rf (one maybe-term)))))) 40 | #f)) 41 | 42 | (define (dynamic-unify s t) 43 | (let ((FAIL #f) 44 | (SUCCESS #t)) 45 | (cond 46 | ((make-var? s) 47 | (let* ((ref-maybe-s (ref s)) 48 | (maybe-s (cell-ref ref-maybe-s))) 49 | (if (just? maybe-s) 50 | (dynamic-unify (one maybe-s) t) 51 | (begin 52 | (if (not (points-to ref-maybe-s t)) 53 | (cell-set! ref-maybe-s (just t))) 54 | SUCCESS)))) 55 | ((make-cst? s) 56 | (cond ((make-var? t) 57 | (let* ((ref-maybe-t (ref t)) 58 | (maybe-t (cell-ref ref-maybe-t))) 59 | (if (just? maybe-t) 60 | (dynamic-unify s (one maybe-t)) 61 | (begin 62 | (cell-set! ref-maybe-t (just (make-cst (num s)))) 63 | SUCCESS)))) 64 | ((make-cst? t) 65 | (= (num s) (num t))) 66 | (else 67 | FAIL))) 68 | ((make-bin? s) 69 | (cond ((make-var? t) 70 | (let* ((ref-maybe-t (ref t)) 71 | (maybe-t (cell-ref ref-maybe-t))) 72 | (if (just? maybe-t) 73 | (dynamic-unify s (one maybe-t)) 74 | (begin 75 | (cell-set! ref-maybe-t (just (make-bin (term1 s) (term2 s)))) 76 | SUCCESS)))) 77 | ((make-bin? t) 78 | (and (dynamic-unify (term1 s) (term1 t)) 79 | (dynamic-unify (term2 s) (term2 t)))) 80 | (else 81 | FAIL))) 82 | (else 83 | FAIL)))) 84 | -------------------------------------------------------------------------------- /examples/unify.scm: -------------------------------------------------------------------------------- 1 | (define-data maybe 2 | (just one) 3 | (nothing)) 4 | (define-data term 5 | (make-var ref) ; make-var : ref (maybe term) -> term 6 | (make-cst num) 7 | (make-bin term1 term2) 8 | (make-dyn dynterm)) 9 | (define-data pair 10 | (xcons xcar xcdr) 11 | (xnil)) 12 | 13 | (define (unify-driver s t) 14 | 15 | (let ((ref-s->ref-d (xnil)) 16 | (FAIL #f) 17 | (SUCCESS #t)) 18 | ;; unify returns #f on failure and #t on success 19 | 20 | (define (unify s t) 21 | (cond 22 | ((make-var? s) 23 | (let* ((ref-maybe-s (ref s)) 24 | (maybe-s (cell-ref ref-maybe-s))) 25 | (if (just? maybe-s) 26 | (unify (one maybe-s) t) 27 | (begin 28 | (cell-set! ref-maybe-s (just (make-dyn t))) 29 | SUCCESS)))) 30 | ((make-cst? s) 31 | (cond ((make-var? t) 32 | (let* ((ref-maybe-t (ref t)) 33 | (maybe-t (cell-ref ref-maybe-t))) 34 | (if (just? maybe-t) 35 | (unify s (one maybe-t)) 36 | (begin 37 | (cell-set! ref-maybe-t (just (make-cst (num s)))) 38 | SUCCESS)))) 39 | ((make-cst? t) 40 | (= (num s) (num t))) 41 | (else 42 | FAIL))) 43 | ((make-bin? s) 44 | (cond ((make-var? t) 45 | (let* ((ref-maybe-t (ref t)) 46 | (maybe-t (cell-ref ref-maybe-t))) 47 | (if (just? maybe-t) 48 | (unify s (one maybe-t)) 49 | (begin 50 | (cell-set! ref-maybe-t (just (make-bin (coerce (term1 s)) 51 | (coerce (term2 s))))) 52 | SUCCESS)))) 53 | ((make-bin? t) 54 | (and (unify (term1 s) (term1 t)) 55 | (unify (term2 s) (term2 t)))) 56 | (else 57 | FAIL))) 58 | ((make-dyn? s) 59 | (dynamic-unify (dynterm s) t)) 60 | (else 61 | FAIL))) 62 | 63 | (define (coerce s) ;respects sharing 64 | (let s->d ((s s)) 65 | (cond 66 | ((make-cst? s) 67 | (make-cst (num s))) 68 | ((make-bin? s) 69 | (make-bin (s->d (term1 s)) (s->d (term2 s)))) 70 | ((make-var? s) 71 | (let* ((ref-maybe-s (ref s)) 72 | (seen-before (xassq-d ref-maybe-s ref-s->ref-d))) 73 | (if (just? seen-before) 74 | (make-var (one seen-before)) 75 | (let* ((maybe-s (cell-ref ref-maybe-s)) 76 | (ref-maybe-t 77 | (if (just? maybe-s) 78 | (make-cell (just (s->d (one maybe-s)))) 79 | (make-cell (nothing))))) 80 | (set! ref-s->ref-d (xcons (xcons ref-maybe-s ref-maybe-t) ref-s->ref-d)) 81 | (make-var ref-maybe-t))))) 82 | ((make-dyn? s) 83 | (dynterm s))))) 84 | 85 | ;; main program 86 | 87 | (unify s t))) 88 | 89 | (define (xassq-d x l) 90 | (if (xnil? l) 91 | (nothing) 92 | (let* ((p (xcar l)) 93 | (y (xcar p))) 94 | (if (cell-eq? x y) 95 | (just (xcdr p)) 96 | (xassq-d x (xcdr l)))))) 97 | 98 | ;; input syntax 99 | ;; term ::= (var ) | (cst ) | (bin ) 100 | 101 | (define (parse-term s) 102 | (letrec ((xlookup 103 | (lambda (key keys refs) 104 | (if (null? keys) 105 | (nothing) 106 | (if (eq? key (car keys)) 107 | (just (xcar refs)) 108 | (xlookup key (cdr keys) (xcdr refs))))))) 109 | (let loop ((s s) (keys '()) (refs (xnil)) (c (lambda (z keys refs) z))) 110 | (cond 111 | ((eq? (car s) 'VAR) 112 | (let* ((n (cadr s)) 113 | (maybe-ref (xlookup n keys refs))) 114 | (if (just? maybe-ref) 115 | (c (make-var (one maybe-ref)) keys refs) 116 | (let ((newref (make-cell (nothing)))) 117 | (c (make-var newref) (cons n keys) (xcons newref refs)))))) 118 | ((eq? (car s) 'CST) 119 | (c (make-cst (cadr s)) keys refs)) 120 | (else 121 | ;; assuming (eq? (car s) 'BIN) 122 | (let ((s1 (cadr s)) 123 | (s2 (caddr s))) 124 | (loop s1 keys refs 125 | (lambda (ss1 keys refs) 126 | (loop s2 keys refs 127 | (lambda (ss2 keys refs) 128 | (c (make-bin ss1 ss2) keys refs))))))))))) 129 | 130 | (define (main s t) 131 | (let* ((ss (parse-term s))) 132 | (unify-driver ss t))) 133 | -------------------------------------------------------------------------------- /genext-packages.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/genext-packages.scm -------------------------------------------------------------------------------- /pgg-packages.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/pgg-packages.scm -------------------------------------------------------------------------------- /scheme-desugar.scm: -------------------------------------------------------------------------------- 1 | ;;; scheme-desugar 2 | 3 | (define *macro-source* 4 | (file->list 5 | (namestring "scheme-standard-macros.scm" 6 | (file-name-directory (%file-name%)) 7 | #f))) 8 | 9 | (define (desugar job-file/files) 10 | (let* ((source-files 11 | (if (string? job-file/files) 12 | (map symbol->string (file->list job-file/files)) 13 | job-file/files)) 14 | (full-source 15 | (cons `(BEGIN ,@*macro-source*) 16 | (map (lambda (filename) 17 | `(BEGIN ,@(file->list filename))) 18 | source-files)))) 19 | (call-with-values 20 | (lambda () 21 | (scheme-desugar full-source)) 22 | (lambda (d* rejected*) 23 | (if (not (null? rejected*)) 24 | (begin 25 | (display "Warning: desugar cannot resolve toplevel expressions") 26 | (newline) 27 | (display rejected*) 28 | (newline))) 29 | d*)))) 30 | -------------------------------------------------------------------------------- /scheme-standard-macros.scm: -------------------------------------------------------------------------------- 1 | (define-syntax and 2 | (syntax-rules () 3 | ((and) 4 | #t) 5 | ((and e) 6 | e) 7 | ((and e1 e2 ...) 8 | (if e1 (and e2 ...) #f)))) 9 | 10 | (define-syntax or 11 | (syntax-rules () 12 | ((or) 13 | #f) 14 | ((or e) 15 | e) 16 | ((or (f ...) e ...) 17 | (let ((t (f ...))) 18 | (or t e ...))) 19 | ((or t e ...) 20 | (if t t (or e ...))))) 21 | 22 | (define-syntax cond 23 | (syntax-rules (else =>) 24 | ((cond (else result1 result2 ...)) 25 | (begin result1 result2 ...)) 26 | ((cond (test => result)) 27 | (let ((temp test)) 28 | (if temp (result temp)))) 29 | ((cond (test => result) clause1 clause2 ...) 30 | (let ((temp test)) 31 | (if temp 32 | (result temp) 33 | (cond clause1 clause2 ...)))) 34 | ((cond (test)) 35 | test) 36 | ((cond (test) clause1 clause2 ...) 37 | (or test (cond clause1 clause2 ...))) 38 | ((cond (test result1 result2 ...)) 39 | (if test (begin result1 result2 ...))) 40 | ((cond (test result1 result2 ...) clause1 clause2 ...) 41 | (if test 42 | (begin result1 result2 ...) 43 | (cond clause1 clause2 ...))))) 44 | 45 | (define-syntax case 46 | (syntax-rules (else) 47 | ((case (key ...) 48 | clauses ...) 49 | (let ((atom-key (key ...))) 50 | (case atom-key clauses ...))) 51 | ((case key 52 | (else result1 result2 ...)) 53 | (begin result1 result2 ...)) 54 | ((case key 55 | ((atom ...) result1 result2 ...)) 56 | (if (case "compare" key (atom ...)) 57 | (begin result1 result2 ...))) 58 | ((case key 59 | ((atom ...) result1 result2 ...) clause1 clause2 ...) 60 | (if (case "compare" key (atom ...)) 61 | (begin result1 result2 ...) 62 | (case key clause1 clause2 ...))) 63 | ((case "compare" key ()) 64 | #f) 65 | ((case "compare" key (atom)) 66 | (eqv? key 'atom)) 67 | ((case "compare" key (atom ...)) 68 | (memv key '(atom ...))))) 69 | 70 | (define-syntax let* 71 | (syntax-rules () 72 | ((let* () body ...) 73 | (let () body ...)) 74 | ((let* ((x e) rest ...) body ...) 75 | (let ((x e)) 76 | (let* (rest ...) body ...))))) 77 | 78 | (define-syntax do 79 | (syntax-rules () 80 | ((do ((var init step ...) ...) (test exp ...) cmd ...) 81 | (let loop ((var init) ...) 82 | (cond 83 | (test exp ...) 84 | (else cmd ... 85 | (loop (do "step" var step ...) ...))))) 86 | ((do "step" x) 87 | x) 88 | ((do "step" x y) 89 | y))) 90 | -------------------------------------------------------------------------------- /scheme-standard-vector-ops.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mikesperber/pgg/620f6596e8791e4ea94103a5b8ace6a30aadc0a8/scheme-standard-vector-ops.scm -------------------------------------------------------------------------------- /shift-reset.scm: -------------------------------------------------------------------------------- 1 | ; no copyright notice 2 | 3 | ; ,open signals escapes 4 | 5 | ; Changes by jar: 6 | ; Added Uses of Scheme 48's WITH-CONTINUATION primitive, so that unreachable 7 | ; continuations can be reclaimed by the GC. 8 | ; 9 | ; Renamed reset-thunk -> *reset 10 | ; call/ct -> *shift 11 | ; 12 | ; Note: the meta-continuation ought to be thread-specific. 13 | ; Alternatively, the threads package could be defined in terms of 14 | ; shift and reset. This would have the advantage of making the threads 15 | ; package itself re-entrant. It would be nice to rehabilitate the 16 | ; runnable-threads queue, currently a piece of global state, as local 17 | ; to a particular invocation of WITH-MULTITASKING. 18 | 19 | ;Date: Wed, 29 Dec 1993 13:54:52 +0100 20 | ;From: Olivier Danvy 21 | ;To: jar@martigny.ai.mit.edu 22 | ;Subject: little Christmas gift 23 | ;Reply-To: danvy@daimi.aau.dk 24 | ; 25 | ;Hi again: 26 | ; 27 | ;Here is a contribution for the Scheme48 library: the shift and reset 28 | ;operators from "Abstracting Control" (LFP90) and "Representing Control" 29 | ;(MSCS92). In his POPL94 paper, Andrzej Filinski observed that since the 30 | ;meta-continuation is single-threaded, it can be globalized in a 31 | ;register. Andrzej has programmed this both in SML and in Scheme. I 32 | ;only have prettified the Scheme definition a wee bit. 33 | 34 | ; Thread-local version 35 | 36 | (define-syntax reset 37 | (syntax-rules () 38 | ((_ ?e) (*reset (lambda () ?e))))) 39 | 40 | (define-syntax shift 41 | (syntax-rules () 42 | ((_ ?k ?e) (*shift (lambda (?k) ?e))))) 43 | 44 | (define initial-meta-continuation 45 | (lambda (v) 46 | (error "You forgot the top-level reset..."))) 47 | 48 | (define *lock* (make-lock)) 49 | 50 | (define (atomic thunk) 51 | (obtain-lock *lock*) 52 | (let ((v (thunk))) 53 | (release-lock *lock*) 54 | v)) 55 | 56 | ; Poor man's thread-local storage ... 57 | 58 | (define *meta-continuation-table* (make-integer-table)) 59 | 60 | (define (get-meta-continuation) 61 | (or (atomic 62 | (lambda () 63 | (table-ref *meta-continuation-table* (thread-uid (current-thread))))) 64 | initial-meta-continuation)) 65 | 66 | (define (set-meta-continuation! mc) 67 | (atomic 68 | (lambda () 69 | (table-set! *meta-continuation-table* (thread-uid (current-thread)) mc)))) 70 | 71 | (define (with-fresh-meta-continuation thunk) 72 | (set-meta-continuation! initial-meta-continuation) 73 | (let ((v (thunk))) 74 | (set-meta-continuation! #f) 75 | v)) 76 | 77 | (define *abort 78 | (lambda (thunk) 79 | (with-continuation null-continuation ;JAR hack 80 | (lambda () 81 | (let ((val (thunk))) 82 | ((get-meta-continuation) val)))))) 83 | 84 | (define null-continuation #f) 85 | 86 | (define *reset 87 | (lambda (thunk) 88 | (let ((mc (get-meta-continuation))) 89 | (call-with-current-continuation 90 | (lambda (k) 91 | (set-meta-continuation! (lambda (v) 92 | (set-meta-continuation! mc) 93 | (k v))) 94 | (*abort thunk)))))) 95 | 96 | (define *shift 97 | (lambda (f) 98 | (call-with-current-continuation 99 | (lambda (k) 100 | (*abort (lambda () 101 | (f (lambda (v) 102 | (reset (k v)))))))))) 103 | 104 | ;---------- 105 | ; 106 | ;Reminder: reset specifies a control delimiter. shift grabs the current 107 | ;continuation up to the current control delimiter, and reifies it as a 108 | ;composable procedure. If the procedure is not used, shift has the 109 | ;effect of aborting up to the current control delimiter. 110 | ; 111 | ;Examples: 112 | ; 113 | ;(+ 10 (reset (+ 2 3))) 114 | ;--> 115 | ;15 116 | ; 117 | ;(+ 10 (reset (+ 2 (shift k 3)))) 118 | ;--> 119 | ;13 120 | ; 121 | ;(+ 10 (reset (+ 2 (shift k (k 3))))) 122 | ;--> 123 | ;15 124 | ; 125 | ;(+ 10 (reset (+ 2 (shift k (+ 100 (k 3)))))) 126 | ;--> 127 | ;115 128 | ; 129 | ;(+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))) 130 | ;--> 131 | ;117 132 | ; 133 | ; 134 | ;Other reminder: shift and reset are weaker than Matthias's control and 135 | ;prompt, in that they can be CPS-transformed. 136 | ; 137 | ;Have a happy holiday, 138 | ; 139 | ;-- Olivier 140 | ; 141 | ;PS: This definition is not unlike David Espinoza's implementation of monadic 142 | ;effects, ie, it has no interpretive or translation overhead. 143 | 144 | 145 | 146 | ; JAR's notes: 147 | ; 148 | ; ; CWCC defined in terms of SHIFT 149 | ; 150 | ; (define cwcc 151 | ; (lambda (p) 152 | ; (shift k (k (p (lambda (x) 153 | ; (shift k1 (k x)))))))) 154 | ; 155 | ; ; Monads from shift and reset (from Filinski, POPL '94) 156 | ; 157 | ; (define (reflect meaning) 158 | ; (shift k (extend k meaning))) 159 | ; 160 | ; (define (reify thunk) 161 | ; (reset (eta (thunk)))) 162 | ; 163 | ; Example: nondeterminism monad. 164 | ; 165 | ; > (define (eta x) (list x)) 166 | ; > (define (extend f l) (apply append (map f l))) 167 | ; > 168 | ; > (define-syntax amb 169 | ; (syntax-rules () ((amb ?x ?y) (*amb (lambda () ?x) (lambda () ?y))))) 170 | ; 171 | ; > (define (*amb t1 t2) 172 | ; (reflect (append (reify t1) (reify t2)))) 173 | ; > 174 | ; > (reify (lambda () (amb 1 2))) 175 | ; '(1 2) 176 | ; > (reify (lambda () (+ (amb 1 2) 3))) 177 | ; '(4 5) 178 | ; > 179 | ; > (define cwcc call-with-current-continuation) 180 | ; > (reify (lambda () 181 | ; (+ 1 (cwcc (lambda (k) 182 | ; (* 10 (amb 3 (k 4)))))))) 183 | ; '(31 51) 184 | ; > 185 | -------------------------------------------------------------------------------- /smurf-queue.scm: -------------------------------------------------------------------------------- 1 | ;; More essential stuff for queues 2 | 3 | (define (queue-assoc x q) 4 | (assoc x (queue-head q))) 5 | 6 | (define (queue-any p q) 7 | (any p (queue-head q))) 8 | 9 | (define (dequeue-first! p q) 10 | (let loop ((pair (queue-head q)) 11 | (last-pair '())) 12 | (cond 13 | ((null? pair) #f) 14 | ((p (car pair)) 15 | (let ((value (car pair)) 16 | (next (cdr pair))) 17 | (if (pair? last-pair) 18 | (set-cdr! last-pair next) 19 | (set-queue-head! q next)) 20 | (if (null? next) 21 | (set-queue-tail! q last-pair)) 22 | value)) 23 | (else 24 | (loop (cdr pair) pair))))) 25 | -------------------------------------------------------------------------------- /strong-updates/anf-convert.scm: -------------------------------------------------------------------------------- 1 | ;;; conversion to a normal form 2 | (define *anf-pp-count* 0) 3 | (define *anf-app-count* 0) 4 | (define *anf-let/unit-count* 0) 5 | (define *anf-lambdas* '()) 6 | (define *anf-ctors* '()) 7 | (define *anf-refs* '()) 8 | (define *anf-vectors* '()) 9 | (define *anf-apps* '()) 10 | (define *anf-let/units* '()) 11 | (define *anf-pp-map* '()) 12 | (define *anf-app-map* '()) 13 | (define anf-next-let! 14 | (lambda (anf) 15 | (let ((x *anf-let/unit-count*)) 16 | (set! *anf-let/unit-count* (+ 1 x)) 17 | (anf-let->nr! anf x) 18 | (set! *anf-let/units* (cons anf *anf-let/units*)) 19 | anf))) 20 | (define anf-next-unit! 21 | (lambda (anf) 22 | (let ((x *anf-let/unit-count*)) 23 | (set! *anf-let/unit-count* (+ 1 x)) 24 | (anf-unit->nr! anf x) 25 | (set! *anf-let/units* (cons anf *anf-let/units*)) 26 | anf))) 27 | (define anf-next-lambda! 28 | (lambda (anf) 29 | (let ((x *anf-pp-count*)) 30 | (set! *anf-pp-count* (+ 1 x)) 31 | (anf-lambda->nr! anf x) 32 | (set! *anf-lambdas* (cons anf *anf-lambdas*)) 33 | anf))) 34 | (define anf-next-vector! 35 | (lambda (anf) 36 | (let ((x *anf-pp-count*)) 37 | (set! *anf-pp-count* (+ 1 x)) 38 | (anf-vector->nr! anf x) 39 | (set! *anf-vectors* (cons anf *anf-vectors*)) 40 | anf))) 41 | (define anf-next-ref! 42 | (lambda (anf) 43 | (let ((x *anf-pp-count*)) 44 | (set! *anf-pp-count* (+ 1 x)) 45 | (anf-ref->nr! anf x) 46 | (set! *anf-refs* (cons anf *anf-refs*)) 47 | anf))) 48 | (define anf-next-ctor! 49 | (lambda (anf) 50 | (let ((x *anf-pp-count*)) 51 | (set! *anf-pp-count* (+ 1 x)) 52 | (anf-ctor->nr! anf x) 53 | (set! *anf-ctors* (cons anf *anf-ctors*)) 54 | anf))) 55 | (define anf-next-app! 56 | (lambda (anf) 57 | (let ((x *anf-app-count*)) 58 | (set! *anf-app-count* (+ 1 x)) 59 | (anf-app->nr! anf x) 60 | (set! *anf-apps* (cons anf *anf-apps*)) 61 | anf))) 62 | 63 | (define (anf-update-map! map get-index contents) 64 | (let loop ((contents contents)) 65 | (if (pair? contents) 66 | (let* ((entry (car contents)) 67 | (i (get-index entry))) 68 | (vector-set! map i entry) 69 | (loop (cdr contents)))))) 70 | (define (anf-extract-maps!) 71 | (set! *anf-pp-map* (make-vector *anf-pp-count*)) 72 | (anf-update-map! *anf-pp-map* anf-lambda->nr *anf-lambdas*) 73 | (anf-update-map! *anf-pp-map* anf-ref->nr *anf-refs*) 74 | (anf-update-map! *anf-pp-map* anf-vector->nr *anf-vectors*) 75 | (anf-update-map! *anf-pp-map* anf-ctor->nr *anf-ctors*) 76 | (set! *anf-app-map* (make-vector *anf-app-count*)) 77 | (anf-update-map! *anf-app-map* anf-app->nr *anf-apps*)) 78 | 79 | (define (anf-convert d*) 80 | (set! *anf-pp-count* 0) 81 | (set! *anf-app-count* 0) 82 | (set! *anf-let/unit-count* 0) 83 | (set! *anf-lambdas* '()) 84 | (set! *anf-ctors* '()) 85 | (set! *anf-refs* '()) 86 | (set! *anf-vectors* '()) 87 | (set! *anf-apps* '()) 88 | (set! *anf-let/units* '()) 89 | (set! *anf-pp-map* '()) 90 | (set! *anf-app-map* '()) 91 | (gensym-reset!) 92 | (let ((result (map anf-convert-d d*))) 93 | (anf-extract-maps!) 94 | result)) 95 | 96 | (define (anf-convert-d d) 97 | (let ((name (annDefFetchProcName d)) 98 | (formals (annDefFetchProcFormals d)) 99 | (body (annDefFetchProcBody d))) 100 | (if formals 101 | (make-anf-def name 102 | (anf-convert-top (annMakeLambda 0 formals body))) 103 | (make-anf-def name (anf-convert-top body))))) 104 | 105 | (define (anf-convert-e* e* v make-anf c) 106 | (let rec ((args e*) (conv-args '())) 107 | (if (null? args) 108 | (let ((newvar (or v (gensym 'anf)))) 109 | (anf-next-let! 110 | (make-anf-let newvar 111 | (make-anf (reverse conv-args)) 112 | (c (make-anf-var newvar))))) 113 | (let ((arg (car args)) 114 | (args (cdr args))) 115 | (anf-convert-e arg 116 | (lambda (conv-arg) 117 | (rec args (cons conv-arg conv-args)))))))) 118 | 119 | (define (anf-convert-top e) 120 | (anf-convert-e e (lambda (z) (anf-next-unit! (make-anf-unit z))))) 121 | 122 | (define (anf-convert-e e c) 123 | (let loop ((e e) (v #f) (c c)) 124 | (cond 125 | ((annIsVar? e) 126 | (c (make-anf-var (annFetchVar e)))) 127 | ((annIsConst? e) 128 | (let ((newvar (or v (gensym 'anf)))) 129 | (anf-next-let! 130 | (make-anf-let newvar 131 | (make-anf-const (annFetchConst e)) 132 | (c (make-anf-var newvar)))))) 133 | ((annIsCond? e) 134 | (loop (annFetchCondTest e) 135 | #f 136 | (lambda (t) 137 | (let ((newvar (or v (gensym 'anf)))) 138 | (anf-next-let! 139 | (make-anf-let newvar 140 | (make-anf-cond t (anf-convert-top (annFetchCondThen e)) 141 | (anf-convert-top (annFetchCondElse e))) 142 | (c (make-anf-var newvar)))))))) 143 | ;; an alternative 144 | ;;; ((annIsCond? e) 145 | ;;; (loop (annFetchCondTest e) 146 | ;;; #f 147 | ;;; (lambda (t) 148 | ;;; (make-anf-cond t 149 | ;;; (loop (annFetchCondThen e) v c) 150 | ;;; (loop (annFetchCondElse e) v c))))) 151 | ((annIsOp? e) 152 | (let ((args (annFetchOpArgs e))) 153 | (anf-convert-e* args v 154 | (lambda (conv-args) 155 | (case (annFetchOpName e) 156 | ((make-vector) 157 | (anf-next-vector! 158 | (make-anf-vector #t conv-args))) 159 | ((vector) 160 | (anf-next-vector! 161 | (make-anf-vector #f conv-args))) 162 | ((vector-ref) 163 | (make-anf-vector-ref (car conv-args) 164 | (cadr conv-args))) 165 | ((vector-set!) 166 | (make-anf-vector-set (car conv-args) 167 | (cadr conv-args) 168 | (caddr conv-args))) 169 | (else 170 | (make-anf-op (annFetchOpName e) conv-args)))) 171 | c))) 172 | ((annIsCall? e) 173 | (let ((args (annFetchCallArgs e))) 174 | (anf-convert-e* args v (lambda (conv-args) 175 | (anf-next-app! 176 | (make-anf-app (make-anf-var (annFetchCallName e)) conv-args))) 177 | c))) 178 | ((annIsLet? e) 179 | (let ((letvar (annFetchLetVar e)) 180 | (body (annFetchLetBody e))) 181 | (loop (annFetchLetHeader e) letvar 182 | (lambda (conv-header) 183 | (if (and (anf-var? conv-header) ;this will always be the case 184 | (eq? letvar (anf-var->name conv-header))) 185 | (loop body v c) 186 | (anf-next-let! 187 | (make-anf-let letvar conv-header 188 | (loop body v c)))))))) 189 | ((annIsVLambda? e) 190 | (error "VLambda ignored")) 191 | ((annIsLambda? e) 192 | (let ((newvar (or v (gensym 'anf)))) 193 | (anf-next-let! 194 | (make-anf-let newvar 195 | (anf-next-lambda! 196 | (make-anf-lambda (annFetchLambdaVars e) 197 | (anf-convert-top (annFetchLambdaBody e)))) 198 | (c (make-anf-var newvar)))))) 199 | ((annIsApp? e) 200 | (loop (annFetchAppRator e) #f 201 | (lambda (conv-rator) 202 | (anf-convert-e* (annFetchAppRands e) v 203 | (lambda (conv-rands) 204 | (anf-next-app! 205 | (make-anf-app conv-rator conv-rands))) 206 | c)))) 207 | ((annIsCtor? e) 208 | (anf-convert-e* (annFetchCtorArgs e) v 209 | (lambda (conv-rands) 210 | (anf-next-ctor! 211 | (make-anf-ctor (annFetchCtorName e) 212 | conv-rands))) 213 | c)) 214 | ((annIsSel? e) 215 | (anf-convert-e* (list (annFetchSelArg e)) v (lambda (conv-rands) 216 | (make-anf-sel (annFetchSelName e) 217 | (annFetchSelComp e) 218 | (car conv-rands))) 219 | c)) 220 | ((annIsTest? e) 221 | (anf-convert-e* (list (annFetchTestArg e)) v (lambda (conv-rands) 222 | (make-anf-test (annFetchTestName e) 223 | (car conv-rands))) 224 | c)) 225 | ((annIsRef? e) 226 | (anf-convert-e* (list (annFetchRefArg e)) v 227 | (lambda (conv-rands) 228 | (anf-next-ref! 229 | (make-anf-ref (car conv-rands)))) 230 | c)) 231 | ((annIsDeref? e) 232 | (anf-convert-e* (list (annFetchDerefArg e)) v (lambda (conv-rands) 233 | (make-anf-deref (car conv-rands))) 234 | c)) 235 | ((annIsAssign? e) 236 | (anf-convert-e* (list (annFetchAssignRef e) 237 | (annFetchAssignArg e)) v 238 | (lambda (conv-rands) 239 | (make-anf-assign (car conv-rands) (cadr conv-rands))) 240 | c)) 241 | ((annIsCellEq? e) 242 | (anf-convert-e* (annFetchCellEqArgs e) v 243 | (lambda (conv-rands) 244 | (make-anf-op 'cell-eq conv-rands)) 245 | c)) 246 | ((annIsEval? e) 247 | (let ((args (list (annFetchEvalBody e)))) 248 | (anf-convert-e* args v (lambda (conv-args) 249 | (make-anf-op 'eval conv-args)) 250 | c))) 251 | ((annIsLift? e) 252 | (error "Lift ignored")) 253 | ((annIsMemo? e) 254 | (error "Memo ignored")) 255 | (else 256 | (error 'annFreeVars "Unknown syntax construction"))))) 257 | -------------------------------------------------------------------------------- /strong-updates/config.scm: -------------------------------------------------------------------------------- 1 | (define-interface a-normal-form-interface 2 | (export anf-lambda? anf-lambda->free anf-lambda->formals anf-lambda->body 3 | anf-ref? 4 | anf-let? anf-let->info anf-let->formal anf-let->info! anf-let->header anf-let->body 5 | anf-unit->info! anf-unit? anf-unit->info anf-unit->body 6 | anf-cond? anf-cond->info anf-cond->info! anf-cond->then anf-cond->else 7 | anf-def->name anf-def->body 8 | anf-app->rpass! anf-app->rreturn! 9 | anf-def->last 10 | anf-var? anf-var->name 11 | anf-const? 12 | anf-op? 13 | anf-cond->last 14 | anf-call? 15 | anf-lambda->nr 16 | anf-app? anf-app->rator anf-app->rands 17 | anf-lambda->last 18 | anf-ref->nr anf-ref->actual 19 | anf-deref? anf-deref->actual 20 | anf-assign? anf-assign->ref anf-assign->actual 21 | anf-celleq? 22 | anf-cond->last-then anf-cond->last-else 23 | anf-app->rpass anf-app->rreturn 24 | anf-get-last 25 | anf-lambda->nr! 26 | anf-ref->nr! 27 | anf-app->nr! 28 | anf-lambda->nr 29 | anf-ref->nr 30 | anf-app->nr 31 | make-anf-def 32 | make-anf-var 33 | make-anf-let 34 | make-anf-unit 35 | make-anf-const 36 | make-anf-cond 37 | make-anf-op 38 | make-anf-app 39 | make-anf-lambda 40 | make-anf-ctor 41 | make-anf-sel 42 | make-anf-test 43 | make-anf-ref 44 | make-anf-deref 45 | make-anf-assign 46 | make-anf-celleq 47 | )) 48 | 49 | (define-interface anf-converter-interface 50 | (export anf-convert anf-convert-d anf-convert-e* anf-convert-e anf-convert-top 51 | *anf-pp-count* *anf-pp-map* *anf-app-map*)) 52 | 53 | (define-interface toplevel-interface 54 | (export main)) 55 | 56 | (define-interface finite-map-interface 57 | (export make-symbol-fm make-number-fm 58 | fm-lookup fm-update! fm-walk)) 59 | 60 | (define-interface analysis-interface 61 | (export allocate-avals-single-astore 62 | allocate-avals-multiple-astore 63 | allocate-avals-d* 64 | allocate-pass-return! 65 | environment-constraints-d* 66 | must-alias-constraints-d* 67 | store-constraints-d* 68 | collect! 69 | new-flowmap 70 | *anf-app-map* 71 | save-reachmap! 72 | equal-reachmap? 73 | flowmap-display latex-display-flowmap 74 | anf-display-d* latex-display-anf-d* 75 | anf-collect-freevars-d* 76 | anf-display-freevars-d* 77 | refcardmap-display latex-display-refcardmap 78 | varcardmap-display latex-display-varcardmap 79 | reachmap-display latex-display-reachmap 80 | all-astore-display latex-display-all-astore 81 | all-init-display latex-display-all-init 82 | display-analyze-varcardmap 83 | display-analyze-refcardmap 84 | display-free-variable-statistics 85 | )) 86 | 87 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 88 | (define-structure a-normal-form a-normal-form-interface 89 | (open scheme signals 90 | cogen-record cogen-labset-bylist)) 91 | 92 | (define-structure anf-converter anf-converter-interface 93 | (open scheme signals 94 | auxiliary 95 | cogen-abssyn 96 | a-normal-form) 97 | (files anf-convert)) 98 | 99 | (define-structure toplevel toplevel-interface 100 | (open scheme signals auxiliary 101 | cogen-abssyn cogen-scheme cogen-globals analysis) 102 | (files toplevel)) 103 | 104 | (define-structure finite-map finite-map-interface 105 | (open scheme features 106 | auxiliary cogen-record) 107 | (files finite-map)) 108 | 109 | (define-structure analysis (compound-interface analysis-interface 110 | anf-converter-interface) 111 | (open scheme signals 112 | cogen-record cogen-labset-bylist 113 | auxiliary cogen-abssyn ;for anf-convert 114 | ;; a-normal-form anf-converter ;for *anf-app-map* *anf-pp-map* *anf-pp-count* 115 | finite-map) 116 | (files a-normal-form anf-convert analysis)) 117 | -------------------------------------------------------------------------------- /strong-updates/cxxxxr.scm: -------------------------------------------------------------------------------- 1 | (define-syntax list 2 | (syntax-rules () 3 | ((list) '()) 4 | ((list x y ...) (cons x (list y ...))))) 5 | 6 | (define-syntax caar 7 | (syntax-rules () 8 | ((caar x) (car (car x))))) 9 | 10 | (define-syntax cadr 11 | (syntax-rules () 12 | ((caar x) (car (cdr x))))) 13 | 14 | (define-syntax cdar 15 | (syntax-rules () 16 | ((caar x) (cdr (car x))))) 17 | 18 | (define-syntax cddr 19 | (syntax-rules () 20 | ((caar x) (cdr (cdr x))))) 21 | 22 | (define-syntax caaar 23 | (syntax-rules () 24 | ((caar x) (car (car (car x)))))) 25 | 26 | (define-syntax caadr 27 | (syntax-rules () 28 | ((caar x) (car (car (cdr x)))))) 29 | 30 | (define-syntax cadar 31 | (syntax-rules () 32 | ((caar x) (car (cdr (car x)))))) 33 | 34 | (define-syntax caddr 35 | (syntax-rules () 36 | ((caar x) (car (cdr (cdr x)))))) 37 | 38 | (define-syntax cdaar 39 | (syntax-rules () 40 | ((caar x) (cdr (car (car x)))))) 41 | 42 | (define-syntax cdadr 43 | (syntax-rules () 44 | ((caar x) (cdr (car (cdr x)))))) 45 | 46 | (define-syntax cddar 47 | (syntax-rules () 48 | ((caar x) (cdr (cdr (car x)))))) 49 | 50 | (define-syntax cdddr 51 | (syntax-rules () 52 | ((caar x) (cdr (cdr (cdr x)))))) 53 | 54 | (define-syntax caaaar 55 | (syntax-rules () 56 | ((caar x) (car (car (car (car x))))))) 57 | 58 | (define-syntax caaadr 59 | (syntax-rules () 60 | ((caar x) (car (car (car (cdr x))))))) 61 | 62 | (define-syntax caadar 63 | (syntax-rules () 64 | ((caar x) (car (car (cdr (car x))))))) 65 | 66 | (define-syntax caaddr 67 | (syntax-rules () 68 | ((caar x) (car (car (cdr (cdr x))))))) 69 | 70 | (define-syntax cadaar 71 | (syntax-rules () 72 | ((caar x) (car (cdr (car (car x))))))) 73 | 74 | (define-syntax cadadr 75 | (syntax-rules () 76 | ((caar x) (car (cdr (car (cdr x))))))) 77 | 78 | (define-syntax caddar 79 | (syntax-rules () 80 | ((caar x) (car (cdr (cdr (car x))))))) 81 | 82 | (define-syntax cadddr 83 | (syntax-rules () 84 | ((caar x) (car (cdr (cdr (cdr x))))))) 85 | 86 | (define-syntax cdaaar 87 | (syntax-rules () 88 | ((caar x) (cdr (car (car (car x))))))) 89 | 90 | (define-syntax cdaadr 91 | (syntax-rules () 92 | ((caar x) (cdr (car (car (cdr x))))))) 93 | 94 | (define-syntax cdadar 95 | (syntax-rules () 96 | ((caar x) (cdr (car (cdr (car x))))))) 97 | 98 | (define-syntax cdaddr 99 | (syntax-rules () 100 | ((caar x) (cdr (car (cdr (cdr x))))))) 101 | 102 | (define-syntax cddaar 103 | (syntax-rules () 104 | ((caar x) (cdr (cdr (car (car x))))))) 105 | 106 | (define-syntax cddadr 107 | (syntax-rules () 108 | ((caar x) (cdr (cdr (car (cdr x))))))) 109 | 110 | (define-syntax cdddar 111 | (syntax-rules () 112 | ((caar x) (cdr (cdr (cdr (car x))))))) 113 | 114 | (define-syntax cddddr 115 | (syntax-rules () 116 | ((caar x) (cdr (cdr (cdr (cdr x))))))) 117 | 118 | -------------------------------------------------------------------------------- /strong-updates/finite-map.scm: -------------------------------------------------------------------------------- 1 | ;;; finite maps: symbol -> anything 2 | ;;; open features 3 | 4 | (define finite-map-size 3) 5 | (define (symbol-hash key size) 6 | (remainder (string-hash (symbol->string key)) size)) 7 | (define (symbolstring k1) (symbol->string k2))) 9 | 10 | (define make-symbol-fm 11 | (lambda (alist) 12 | (make-fm symbol-hash symbolhash fm)) 56 | (key< (finite-map->key< fm))) 57 | (fm-walk fm 58 | (lambda (key value) 59 | (let* ((i (hash key new-size)) 60 | (bucket (vector-ref vec i))) 61 | (vector-set! vec i (bucket-insert key< key value bucket 62 | (lambda () 63 | 'nothing-to-do)))))) 64 | (finite-map->vec! fm vec) 65 | (finite-map->size! fm new-size)))) 66 | 67 | (define fm->alist 68 | (lambda (fm) 69 | (let ((l (vector-length fm))) 70 | (let loop ((i 0) (result '())) 71 | (if (< i l) 72 | (loop (+ i 1) 73 | (append (vector-ref fm i) result)) 74 | result))))) 75 | 76 | (define fm-join ;broken 77 | (lambda (fm1 fm2 join) 78 | (let ((l finite-map-size) 79 | (vec (make-vector finite-map-size)) 80 | (vec1 (finite-map->vec fm1)) 81 | (vec2 (finite-map->vec fm2))) 82 | (let loop ((i 0)) 83 | (if (< i l) 84 | (begin 85 | (vector-set! vec i (fm-join-alist (finite-map->key< fm1) 86 | (vector-ref vec1 i) 87 | (vector-ref vec2 i) 88 | join)) 89 | (loop (+ i 1))) 90 | vec))))) 91 | 92 | (define fm-join-alist 93 | (lambda (key< al1 al2 join) 94 | (let loop ((al1 al1) (al2 al2)) 95 | (cond 96 | ((null? al1) 97 | al2) 98 | ((null? al2) 99 | al1) 100 | (else 101 | (let ((kv1 (car al1)) 102 | (kv2 (car al2))) 103 | (let ((k1 (car kv1)) 104 | (k2 (car kv2))) 105 | (cond 106 | ((key< k1 k2) 107 | (cons kv1 (loop (cdr al1) al2))) 108 | ((key< k2 k1) 109 | (cons kv2 (loop al1 (cdr al2)))) 110 | (else 111 | (cons (cons k1 (join (cdr kv1) (cdr kv2))) 112 | (loop (cdr al1) (cdr al2)))))))))))) 113 | 114 | (define fm-dom 115 | (lambda (fm) 116 | (let ((l (vector-length fm))) 117 | (let loop ((i 0) (result '())) 118 | (if (< i l) 119 | (loop (+ i 1) 120 | (append (map car (vector-ref fm i)) result))))))) 121 | 122 | (define fm-restrict ;broken 123 | (lambda (fm new-dom) 124 | (let ((vec (finite-map->vec fm)) 125 | (newvec (make-vector finite-map-size))) 126 | (let loop ((i 0)) 127 | (if (< i finite-map-size) 128 | (begin 129 | (vector-set! newvec i (filter (lambda (kv) (memq (car kv) new-dom)) 130 | (vector-ref vec i))) 131 | (loop (+ i 1))) 132 | (make-finite-map (finite-map->hash fm) 133 | (finite-map->key< fm) 134 | newvec)))))) 135 | 136 | (define fm-lookup 137 | (lambda (fm key) 138 | (let* ((i ((finite-map->hash fm) key (finite-map->size fm))) 139 | (bucket (vector-ref (finite-map->vec fm) i))) 140 | (assq key bucket)))) 141 | 142 | (define fm-update! 143 | (lambda (fm key value) 144 | (let* ((size (finite-map->size fm)) 145 | (i ((finite-map->hash fm) key size)) 146 | (vec (finite-map->vec fm)) 147 | (bucket (vector-ref vec i)) 148 | (overflow #f) 149 | (new (lambda () 150 | (let ((card (+ 1 (finite-map->card fm)))) 151 | (finite-map->card! fm card) 152 | (if (> card (* 2 size)) 153 | (set! overflow card)))))) 154 | (vector-set! vec i (bucket-insert (finite-map->key< fm) key value bucket new)) 155 | (if overflow (fm-reorganize fm overflow))))) 156 | 157 | (define fm-walk 158 | (lambda (fm proc) ;proc : key x value -> void 159 | (let* ((vec (finite-map->vec fm)) 160 | (l (vector-length vec))) 161 | (let loop ((i 0)) 162 | (if (< i l) 163 | (let ((bucket (vector-ref vec i))) 164 | (for-each (lambda (k-v) (proc (car k-v) (cdr k-v))) bucket) 165 | (loop (+ i 1)))))))) 166 | -------------------------------------------------------------------------------- /strong-updates/toplevel.scm: -------------------------------------------------------------------------------- 1 | ;;; toplevel driver 2 | 3 | (define (main job-file/files . commands) 4 | (let* ((source-files 5 | (if (string? job-file/files) 6 | (map (lambda (s) (if (symbol? s) (symbol->string s) s)) 7 | (file->list job-file/files)) 8 | job-file/files)) 9 | (full-source 10 | (apply append (map file->list source-files))) 11 | (def-function* 12 | (filter (lambda (defn) (equal? (car defn) 'define)) 13 | full-source)) 14 | (def-syntax* 15 | (filter (lambda (defn) (eq? (car defn) 'define-syntax)) 16 | full-source)) 17 | (abssyn-d* (begin 18 | (set-abssyn-maybe-coerce! #f) 19 | (scheme->abssyn-d def-function* 20 | def-syntax* 21 | symtab-pairs))) 22 | (d* (anf-convert abssyn-d*)) 23 | (freevars (anf-collect-freevars-d* d*)) 24 | (flowmap #f) 25 | (file-name-prefix "")) 26 | (let loop ((commands commands)) 27 | (if (null? commands) 28 | 'done 29 | (let ((command (car commands))) 30 | (case command 31 | ((alloc-flowmap) (set! flowmap (new-flowmap))) 32 | ((alloc-reachmap) (allocate-pass-return! *anf-app-map*)) 33 | ((alloc-single) (allocate-avals-single-astore d* flowmap)) 34 | ((alloc-multiple) (allocate-avals-multiple-astore d* flowmap)) 35 | ((environment) (environment-constraints-d* d* flowmap)) 36 | ((must-alias) (must-alias-constraints-d* d* flowmap)) 37 | ((store) (store-constraints-d* d* flowmap)) 38 | ((collect) (collect! *anf-app-map* flowmap)) 39 | ((disp-def) (anf-display-d* d*)) 40 | ((disp-freevars) (anf-display-freevars-d* d*)) 41 | ((disp-flowmap) (flowmap-display flowmap)) 42 | ((disp-varcardmap) (varcardmap-display)) 43 | ((disp-refcardmap) (refcardmap-display)) 44 | ((disp-reachmap) (reachmap-display *anf-app-map*)) 45 | ((disp-astore) (all-astore-display)) 46 | ((disp-init) (all-init-display)) 47 | ((disp-ana-var) (display-analyze-varcardmap freevars)) 48 | ((disp-ana-ref) (display-analyze-refcardmap)) 49 | ((disp-var-stat) (display-free-variable-statistics)) 50 | ((latex-def) (latex-display-anf-d* d*)) 51 | ((latex-flowmap) (latex-display-flowmap flowmap)) 52 | ((latex-varcardmap) (latex-display-varcardmap)) 53 | ((latex-refcardmap) (latex-display-refcardmap)) 54 | ((latex-reachmap) (latex-display-reachmap *anf-app-map*)) 55 | ((latex-astore) (latex-display-all-astore)) 56 | ((latex-init) (latex-display-all-init)) 57 | (else 58 | (if (pair? command) 59 | (case (car command) 60 | ((fix) (let fix-loop () 61 | (save-reachmap! *anf-app-map*) 62 | (loop (cdr command)) 63 | (if (equal-reachmap? *anf-app-map*) 64 | 'fixpoint-reached 65 | (fix-loop)))) 66 | ((file-name-prefix) (if (and (pair? (cdr command)) 67 | (string? (cadr command))) 68 | (set! file-name-prefix (cadr command)))) 69 | ((begin) (if (and (pair? (cdr command)) 70 | (string? (cadr command))) 71 | (with-output-to-file 72 | (string-append file-name-prefix (cadr command)) 73 | (lambda () 74 | (loop (cddr command)))) 75 | (loop (cdr command)))) 76 | ((display) (display (cdr command)) 77 | (newline)))))) 78 | (loop (cdr commands))))))) 79 | 80 | (define symtab-pairs 81 | `((cons , (lambda (ctor args) (annMakeCtor ctor 0 '*dummy* args)) 2) 82 | (car ,(annMakeSel1 'cons '*dummy* 1) 1) 83 | (cdr ,(annMakeSel1 'cons '*dummy* 2) 1))) 84 | --------------------------------------------------------------------------------