Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-05-18 21:29:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Initial file

Browse source
This commit is contained in:
Justin Ethier 2015-02-21 22:15:18 -05:00
commit cdec643680
25 changed files with 6332 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

38
FEATURES.md Normal file
View file

@ -0,0 +1,38 @@
TODO: list of features, table of RxRS features (??), etc
R<sup>7</sup>RS Compliance
Section | Status | Comments
------- | ------ | ---------
2.2 Whitespace and comments | |
2.3 Other notations | |
2.4 Datum labels | |
3.1 Variables, syntactic keywords, and regions | |
3.2 Disjointness of types | |
3.3 External representations | |
3.4 Storage model | |
3.5 Proper tail recursion | |
4.1 Primitive expression types | |
4.2 Derived expression types | |
4.3 Macros | |
5.1 Programs | |
5.2 Import declarations | |
5.3 Variable definitions | |
5.4 Syntax definitions | |
5.5 Record-type definitions | |
5.6 Libraries | |
5.7 The REPL | |
6.1 Equivalence predicates | |
6.2 Numbers | |
6.3 Booleans | |
6.4 Pairs and lists | |
6.5 Symbols | |
6.6 Characters | |
6.7 Strings | |
6.8 Vectors | |
6.9 Bytevectors | |
6.10 Control features | |
6.11 Exceptions | |
6.12 Environments and evaluation | |
6.13 Input and output | |
6.14 System interface | |

32
Makefile Normal file
View file

@ -0,0 +1,32 @@
TESTSCM = unit-tests
TESTFILES = $(addprefix tests/, $(addsuffix .scm, $(TESTSCM)))
all: cyclone
trans.so: trans.scm
csc -s trans.scm
cgen.so: cgen.scm
csc -s cgen.scm
parser.so: parser.scm
csc -s parser.scm
cyclone: cyclone.scm trans.so cgen.so parser.so
csc cyclone.scm
.PHONY: test
test: $(TESTFILES) cyclone
$(foreach f,$(TESTSCM), echo tests/$(f) ; ./cyclone tests/$(f).scm && tests/$(f) && rm -rf tests/$(f);)
repl: cyclone repl.scm eval.scm parser.scm
./cyclone repl.scm
.PHONY: tags
tags:
ctags -R *
.PHONY: clean
clean:
rm -rf a.out *.o *.so *.c *.out tags cyclone repl
$(foreach f,$(TESTSCM), rm -rf $(f) $(f).c tests/$(f).c;)

57
README.md Normal file
View file

@ -0,0 +1,57 @@
[<img src="web/cyclone-logo-03-header.png" alt="cyclone-scheme">](http://justinethier.github.com/nugget/cyclone)
Cyclone is an experimental Scheme-to-C compiler that uses the [Cheney on the MTA](http://www.pipeline.com/~hbaker1/CheneyMTA.html) technique to implement full tail recursion, continuations, and generational garbage collection.
Building
------------
Prerequisites:
- make
- gcc
- CHICKEN Scheme
CHICKEN is required to bootstrap the Scheme parts of Cyclone. A long-term goal is for the compiler to be self-hosting.
From the source directory, to build and run the compiler:
$ make
...
$ ./cyclone
To build the interpreter:
$ make repl
...
$ ./repl
Installation
------------
At the moment there is no support for a separate installation. Just run `cyclone` from the build directory.
Documentation
-------------
Run the `cyclone` command to compile a single Scheme file, and the `repl` command to start the interactive interpreter.
List of [features](FEATURES.md).
TODO: "how it works section", or a link to a document that provides a brief overview. Much of this would also involve tying together references
References
----------
- [CONS Should Not CONS Its Arguments, Part II: Cheney on the M.T.A.](http://www.pipeline.com/~hbaker1/CheneyMTA.html), by Henry Baker
- [CHICKEN Scheme](http://www.call-cc.org/)
- [Chibi Scheme](http://code.google.com/p/chibi-scheme/)
- [Compiling Scheme to C with closure conversion](http://matt.might.net/articles/compiling-scheme-to-c/)
- [Lisp in Small Pieces](http://pagesperso-systeme.lip6.fr/Christian.Queinnec/WWW/LiSP.html), by Christian Queinnec
- [R<sup>5</sup>RS Scheme Specification](http://www.schemers.org/Documents/Standards/R5RS/HTML/)
- [R<sup>7</sup>RS Scheme Specification](http://trac.sacrideo.us/wg/wiki)
- [Structure and Interpretation of Computer Programs](https://mitpress.mit.edu/sicp/full-text/book/book.html), by Harold Abelson and Gerald Jay Sussman with Julie Sussman
- [The 90 minute Scheme to C compiler](http://churchturing.org/y/90-min-scc.pdf), by Marc Feeley
License
-------
Copyright (C) 2014 [Justin Ethier](http://github.com/justinethier)
License terms TBD

129
TODO Normal file
View file

@ -0,0 +1,129 @@
Working TODO list:
- Issues with detecting cycles:
- (equal?) loops forever when comparing two different circular lists
- printing *global-environment* in the repl still loops forever
- compiled/interpreted code integration
* call a compiled function from eval
* call an interpreted function from compiled code (or is eval good enough? maybe that is the answer?)
- Use a lib.scm for libs, similar to eval/parser modules?
- cyclone should return an error code (IE: 1) when compilation fails and a 0 when it is successful. that way it can be scripted via bash (for example)
or, does it already do this?
- along the same lines, output should be controlled in a better way. or at minimum should print errors using stderr (possible with standard scheme, though??)
- Globals - issue list
- call/cc may be broken for global define's, or at least is not optimal
in that the code for call/cc will be added separately to each define.
maybe this is OK, at least functionally
- String support
issue is how to support strings themselves in memory. can add them directly to the string_type, but then apply won't work
because it could return an unknown number of bytes. on the other hand could use a separate data heap that is mirrored during GC.
may need some extra buffer for that because technically it could overflow any time a new string is allocated, not just during
function calls. but this would work for apply as well as everything else, I believe. obviously it makes GC a bit harder because
there is another pair of heaps to deal with. but all that would be done is that strings from heap A would be copied to B during GC.
GC would need to keep track of a pointer to each one. Sounds straightforward, but have to be careful of complications.
Initial plan:
- Add two "data" heap sections, and vars for each (head ptr, pos ptr [active only?], size)
- Allocate string on active data heap via make_string
- Initiate GC when stack exceeded or data heap under certain threshold
- Need adequate extra space in data heap (100K? make config), since we only check it upon function call
- Need to update GC to copy strings to other heap
- Wait, this is broken if anything is pointing to one of these strings, since memory location changes upon GC!
Is that a fatal issue? How to handle? could write string operations such that any operate on copies of
strings rather than pointing to another string. not nearly as efficient but avoids this problem. could revisit
other solutions down the road.
- Anything else? Probably want to branch for this development, just in case there are complications
COMPLICATION - only need to memcpy strings on data heap during a major collection. during a minor collection the strings are already where they need to be
need to fully-implement this in the runtime by passing minor/major flag to transport
TODO: trigger GC if data heap too low
TODO: once this works but before moving all, consolidate all this in docs/strings.txt or such. would be useful to keep these notes
- Error handling
need to perform much more error handling of input code. one of the biggest is to report if a function is passed the wrong number of arguments, as this will result in segfauls, bad transport errors, etc downstream if it is allowed.
- Unit test improvements
- concatenate all into one file when compiling / running
- add assert functions, and actually test for equality
otherwise it is too easy to miss failing test cases, unless they
blow up the runtime
- This has already been done, just need to incorporate other existing tests.
- Parser
;'a'c ;; TODO: this is still an issue, try it
- in regard to native apply support for primitives
- do we need to create a table of primitives, like husk?
might allow for more efficient comparisons than the stupid string cmp's
that are required if we use symbols to denote primitives (which also
breaks lexical scoping)
- Improved symbol storage
as part of above, probably will need a more dynamic and accurate way to store symbols.
for example, how to store the + symbol, how to differentiate #t and 't etc.
perhaps could use a malloc'd table for this? do want the lookups to be fast - IE, integer (pointer) comparisons and NOT string comparisons (those are unacceptable for symbols)
- Improvements to symbol handling, including printing of symbols with invalid C chars, like 'hello-world
- Consoldate list of primitives in (prim?) and (c-compile-prim?). should also include other information such as number of args (or variable args), for error handling
- Notes on implementing variables
* could maintain env's in the interpreted code, and perform operations there to lookup vars. If a lookup fails though, would have to then fall back to looking in the compiled code. The compiler would have to (only if eval is used) set aside data to allow a reference back to vars in this case. Also, this becomes tricky because a var may not even be used, so it might not be added to any closures. There may have to be special analysis done if eval is used.
* chicken does this, obviously. could map var ==> rename (how to know?) and then look it up in a C-based symbol table
* lexical addressing (see chapter 5 of SICP) can be used to find a variable in recursive env's, so you can access it directly instead of having to recursively traverse environments.
- Add eval support.
- moving forward with meta-circular evaluator from SICP. Let's try to add more cases and code, and see how far it can be pushed.
- also want to try integrating it with trans somehow. IE, if eval is a free var, then add eval code to the compiled program.
Original notes: Will probably also require apply, read, etc. will probably be necessary to write interpreter in CPS style - see notes. One idea - parse and compile input to scheme expressions, then call apply. could that work? should also see chapter 6 of lisp in small pieces.
- Integrate debug script into cyclone, so that by passing a specific command line arg, the compiler will output results of closure-conversion, prepended with the debug contents. That way the SCM code can be debugged independently of the compiled executable.
- What happens when a continuation is captured? assigned to a variable? applied?
Should look into this a bit using cyclone and call/cc
- Implement ER-macros using eval, in scheme. with this in place, could implement basic macros using ER and replace "desugar". presumably syntax rules could be implemented this way as well, but that can wait for a later time
- Pass port along with emit procedures, to allow the scheme code to write to an output file (IE, c file)?? Or is with-output-file good enough? unfortunately that is not in husk yet so it makes boostrapping harder
- Add more numeric support, and doubles
- WRT set! support, and mutable variables:
- set aggressive GC, and see if there are any problems with data being lost
need to do this with a more complicated example, though
- Could add other scheme library functions to the compiled prog just
like call/cc. alternatively could compile them into a library somewhere
for inclusion.
- define - can this with with mutable variable elimination, or does it require C globals (per cboyer)? Are there special cases for top-level? If cells can be used for vars, do we need to keep track of the roots to prevent invalid GC? lots of questions here
- Question about closures and continuations:
Presumably every function will recieve a closure. Do we have to differentiate between continuation (which every
function must have) and closure (which can be empty if no fv)? right now the MTA runtime combines the two by
having an fn argument to each closure. Is that OK?
FWIW, chicken passes the following to generated C funcs:
- number of args
- env (the closure from caller)
- continuation (function to call into)
- actual args
- may be necessary to specify arity of functions in call to apply
- GC - notes from: http://www.more-magic.net/posts/internals-gc.html
JAE - Good notes here about mutations (use write barrier to keep track of changes, EG: vector-set!). remember changes so they can be handled properly during next GC:
Another major oversight is the assumption that objects can only point from the stack into the heap. If Scheme was a purely functional language, this would be entirely accurate: new objects can refer to old objects, but there is no way that a preexisting object can be made to refer to a newly created object. For that, you need to support mutation.
But Scheme does support mutation! So what happens when you use vector-set! to store a newly created, stack-allocated value in an old, heap-allocated vector? If we used the above algorithm, the newly created element would either be part of the live set and get copied, but the vector's pointer would not be updated, or it wouldn't be part of the live set and the object would be lost in the stack reset.
The answer to this problem is also pretty simple: we add a so-called write barrier. Whenever a value is written to an object, it is remembered. Then, when performing a GC, these remembered values are considered to be part of the live set, just like the addresses in the saved call. This is also the reason CHICKEN always shows the number of mutations when you're asking for GC statistics: mutation may slow down a program because GCs might take longer.
JAE - Important point, that the heap must be reallocated during a major GC if there is too much data in the stack / old heap. Considered this but not sure if cyclone's GC does that right now:
The smart reader might have noticed a small problem here: what if the amount of garbage cleaned up is less than the data on the stack? Then, the stack data can't be copied to the new heap because it simply is too small. Well, this is when a third GC mode is triggered: a reallocating GC. This causes a new heap to be allocated, twice as big as the current heap. This is also split in from- and tospace. Then, Cheney's algorithm is performed on the old heap's fromspace, using one half of the new heap as tospace. When it's finished, the new tospace is called fromspace, and the other half of the new heap is called tospace. Then, the old heap is de-allocated.
- farther off but along the same lines, how to support compilation of
multiple scheme files into multiple C modules?
- Just a thought: if this ever became self-hosting, could distribute compiled C files

1079
cgen.scm Normal file
View file

File diff suppressed because it is too large Load diff

165
cyclone.scm Normal file
View file

@ -0,0 +1,165 @@
;; Cyclone Scheme
;; Copyright (c) 2014, Justin Ethier
;; All rights reserved.
;;
;; This module contains a front-end for the compiler itself.
;;
(cond-expand
(chicken
(require-extension extras) ;; pretty-print
(require-extension chicken-syntax) ;; when
(load "parser.so")
(load "trans.so")
(load "cgen.so"))
; (husk
; (import (husk pretty-print))
; ;; TODO: load files
; )
(else
(load "parser.scm")
(load "trans.scm")
(load "cgen.scm")))
;; Code emission.
; c-compile-and-emit : (string -> A) exp -> void
(define (c-compile-and-emit input-program)
(call/cc
(lambda (return)
(define globals '())
(emit *c-file-header-comment*) ; Guarantee placement at top of C file
(trace:info "---------------- input program:")
(trace:info input-program) ;pretty-print
(set! input-program (add-libs input-program))
(set! input-program (expand input-program))
(trace:info "---------------- after macro expansion:")
(trace:info input-program) ;pretty-print
(set! input-program
(filter-unused-variables
(isolate-globals input-program)))
(trace:info "---------------- after processing globals")
(trace:info input-program) ;pretty-print
; Note alpha-conversion is overloaded to convert internal defines to
; set!'s below, since all remaining phases operate on set!, not define.
;
; TODO: consider moving some of this alpha-conv logic below back into trans?
(set! globals (global-vars input-program))
(set! input-program
(map
(lambda (expr)
(alpha-convert expr globals return))
input-program))
(trace:info "---------------- after alpha conversion:")
(trace:info input-program) ;pretty-print
(set! input-program
(map
(lambda (expr)
(cps-convert expr))
input-program))
(trace:info "---------------- after CPS:")
(trace:info input-program) ;pretty-print
(set! input-program
(map
(lambda (expr)
(clear-mutables)
(analyze-mutable-variables expr)
(wrap-mutables expr globals))
input-program))
(trace:info "---------------- after wrap-mutables:")
(trace:info input-program) ;pretty-print
(set! input-program
(map
(lambda (expr)
(if (define? expr)
;; Global
`(define ,(define->var expr)
,@(caddr (closure-convert (define->exp expr) globals)))
(caddr ;; Strip off superfluous lambda
(closure-convert expr globals))))
input-program))
; (caddr ;; Strip off superfluous lambda
; (closure-convert input-program)))
(trace:info "---------------- after closure-convert:")
(trace:info input-program) ;pretty-print
(if (not *do-code-gen*)
(begin
(trace:error "DEBUG, existing program")
(exit)))
(trace:info "---------------- C code:")
(mta:code-gen input-program globals)
(return '())))) ;; No codes to return
;; TODO: longer-term, will be used to find where cyclone's data is installed
(define (get-data-path)
".")
(define (get-lib filename)
(string-append (get-data-path) "/" filename))
(define (read-file filename)
(call-with-input-file filename
(lambda (port)
(read-all port))))
;; Compile and emit:
(define (run-compiler args cc?)
(let* ((in-file (car args))
(in-prog (read-file in-file))
(exec-file (basename in-file))
(src-file (string-append exec-file ".c"))
(create-c-file
(lambda (program)
(with-output-to-file
src-file
(lambda ()
(c-compile-and-emit program)))))
(result (create-c-file in-prog)))
;; Load other modules if necessary
(cond
((not (null? result))
(let ((program
(append
(if (member 'eval result)
(read-file (get-lib "eval.scm"))
'())
(if (member 'read result)
(append
(read-file (get-lib "parser.scm"))
'((define read cyc-read)))
'())
in-prog)))
(create-c-file program))))
;; Compile the generated C file
(if cc?
(system
;; -I is a hack, real answer is to use 'make install' to place .h file
(string-append "gcc " src-file " -I. -g -o " exec-file)))))
;; Handle command line arguments
(let ((args (command-line-arguments))) ;; TODO: port (command-line-arguments) to husk??
(cond
((< (length args) 1)
(display "cyclone: no input file")
(newline))
((member "-h" args)
(display "TODO: display help text")
(newline))
((member "-v" args)
(display *version-banner*))
((member "-d" args)
(run-compiler args #f)) ;; Debug, do not run GCC
(else
(run-compiler args #t))))

628
debug/unit-test-trans.scm Normal file
View file

@ -0,0 +1,628 @@
;;
;; A test framework to attempt to make it easier to debug generated programs.
;; The idea is to allow execution of Scheme code that has been transformed
;; using cyclone's source-to-source transformations. If the code executes
;; OK here, then it should execute fine after being transformed into C code.
;; Unless of course there is a bug here (hopefully not) or in the Scheme->C
;; compiler.
;;
;; Return a function that can be called directly to
;; invoke the closure, or indirectly to access closure
;; elements.
;;
;; When called directly, the first arg is the closure
;; itself (self), followed by args passed when the
;; closure was defined.
(define (%closure . clo-args)
(define clo-data (list->vector clo-args))
(define clo
(lambda args
(cond
((and (> (length args) 1)
(equal? 'ref (car args)))
(vector-ref clo-data (cadr args)))
(else
(apply
(car clo-args)
(cons clo args))))))
clo)
(define (%closure-ref clo idx)
(clo 'ref idx))
(define (%halt x)
(exit))
;; Test code from matt might, may need to tweak per corresponding
;; functionality in the MTA C runtime
;; Suitable definitions for the cell functions:
(define (cell value) (lambda (get? new-value)
(if get? value (set! value new-value))))
(define (set-cell! c v) (c #f v))
(define (cell-get c) (c #t #t))
;; END matt might
(define (test-fac)
((lambda (fac)
((lambda (fac)
((%closure
(lambda (self$698 r$689)
((%closure
(lambda (self$699 r$687)
((%closure
(lambda (self$700 $_$684)
((%closure-ref (cell-get (%closure-ref self$700 1)) 0)
(cell-get (%closure-ref self$700 1))
(%closure
(lambda (self$701 r$688)
((lambda (r$686) (%halt r$686)) (display r$688))))
10))
(%closure-ref self$699 1))
r$687))
(%closure-ref self$698 1))
(set-cell! (%closure-ref self$698 1) r$689)))
fac)
(%closure
(lambda (self$694 k$690 n$685)
((%closure
(lambda (self$695 r$691)
(if r$691
((%closure-ref (%closure-ref self$695 2) 0)
(%closure-ref self$695 2)
1)
((%closure
(lambda (self$696 r$693)
((%closure-ref (cell-get (%closure-ref self$696 1)) 0)
(cell-get (%closure-ref self$696 1))
(%closure
(lambda (self$697 r$692)
((%closure-ref (%closure-ref self$697 1) 0)
(%closure-ref self$697 1)
(* (%closure-ref self$697 2) r$692)))
(%closure-ref self$696 2)
(%closure-ref self$696 3))
r$693))
(%closure-ref self$695 1)
(%closure-ref self$695 2)
(%closure-ref self$695 3))
(- (%closure-ref self$695 3) 1))))
(%closure-ref self$694 1)
k$690
n$685)
(= 0 n$685)))
fac)))
(cell fac)))
#f))
;(test-fac)
(define (test-set)
((lambda (x$684)
((lambda (x$684)
((%closure
(lambda (self$687 r$686)
((lambda (r$685) (%halt r$685))
(display (cell-get (%closure-ref self$687 1)))))
x$684)
(set-cell! x$684 #t)))
(cell x$684)))
#f))
;(test-set)
(define (test-adder)
((lambda (increment make-adder)
((%closure
(lambda (self$696 increment)
((%closure
(lambda (self$697 make-adder)
((%closure
(lambda (self$700 r$693)
((%closure
(lambda (self$701 r$689)
((%closure
(lambda (self$702 $_$684)
((%closure-ref
(cell-get (%closure-ref self$702 2))
0)
(cell-get (%closure-ref self$702 2))
(%closure
(lambda (self$703 r$692)
((%closure
(lambda (self$704 r$690)
((%closure
(lambda (self$705 $_$685)
((%closure-ref
(cell-get (%closure-ref self$705 1))
0)
(cell-get (%closure-ref self$705 1))
(%closure
(lambda (self$706 r$691)
((lambda (r$688) (%halt r$688)) (display r$691))))
41))
(%closure-ref self$704 1))
r$690))
(%closure-ref self$703 1))
(set-cell! (%closure-ref self$703 1) r$692)))
(%closure-ref self$702 1))
1))
(%closure-ref self$701 1)
(%closure-ref self$701 2))
r$689))
(%closure-ref self$700 1)
(%closure-ref self$700 2))
(set-cell! (%closure-ref self$700 2) r$693)))
(%closure-ref self$697 1)
make-adder)
(%closure
(lambda (self$698 k$694 x$686)
((%closure-ref k$694 0)
k$694
(%closure
(lambda (self$699 k$695 y$687)
((%closure-ref k$695 0)
k$695
(+ (%closure-ref self$699 1) y$687)))
x$686))))))
increment)
(cell (%closure-ref self$696 1))))
make-adder)
(cell increment)))
#f
#f))
;(test-adder)
;; Transformed scheme code from if.scm
(define (test-if)
((lambda (k$699) (if #t (k$699 1) (k$699 2)))
(lambda (r$698)
((lambda (r$689)
((lambda ($_$684)
((lambda (k$697) (if #f (k$697 1) (k$697 2)))
(lambda (r$696)
((lambda (r$690)
((lambda ($_$685)
((lambda (k$694)
((lambda (r$695)
(if r$695 (k$694 (+ 3 4)) (k$694 (* 3 4))))
(+ 1 2)))
(lambda (r$691)
((lambda ($_$686)
((lambda (k$692)
((lambda (x$687)
((lambda (r$693)
(if r$693 (k$692 (+ 1 1)) (k$692 (* 0 0))))
(+ x$687 1)))
0))
(lambda (r$688) (%halt r$688))))
r$691))))
r$690))
(display r$696)))))
r$689))
(display r$698)))))
(define (test-eval)
((lambda (analyze$737
analyze-quoted$738
analyze-self-evaluating$739
env$740
eval$741
exp$742
quoted?$743
self-evaluating?$744
tag$745
tagged-list?$746)
((%closure
(lambda (self$803 analyze$737)
((%closure
(lambda (self$804 analyze-quoted$738)
((%closure
(lambda (self$805 analyze-self-evaluating$739)
((%closure
(lambda (self$806 eval$741)
((%closure
(lambda (self$807 quoted?$743)
((%closure
(lambda (self$808 self-evaluating?$744)
((%closure
(lambda (self$809 tagged-list?$746)
((%closure
(lambda (self$812 r$800)
((%closure
(lambda (self$813 r$768)
((%closure
(lambda (self$814 $_$747)
((%closure
(lambda (self$818 r$796)
((%closure
(lambda (self$819 r$769)
((%closure
(lambda (self$820 $_$748)
((%closure
(lambda (self$823 r$793)
((%closure
(lambda (self$824 r$770)
((%closure
(lambda (self$825 $_$749)
((%closure
(lambda (self$828 r$790)
((%closure
(lambda (self$829 r$771)
((%closure
(lambda (self$830 $_$750)
((%closure
(lambda (self$834 r$786)
((%closure
(lambda (self$835 r$772)
((%closure
(lambda (self$836 $_$751)
((%closure
(lambda (self$839 r$783)
((%closure
(lambda (self$840 r$773)
((%closure
(lambda (self$841 $_$752)
((%closure
(lambda (self$846 r$779)
((%closure
(lambda (self$847 r$774)
((%closure
(lambda (self$848 $_$753)
((%closure-ref
(cell-get (%closure-ref self$848 1))
0)
(cell-get (%closure-ref self$848 1))
(%closure
(lambda (self$849 r$778)
((%closure
(lambda (self$850 r$775)
((%closure
(lambda (self$851 $_$754)
((%closure
(lambda (self$852 r$777)
((%closure-ref
(cell-get (%closure-ref self$852 1))
0)
(cell-get (%closure-ref self$852 1))
(%closure
(lambda (self$853 r$776)
((lambda (r$767) (%halt r$767)) (write r$776))))
r$777
#f))
(%closure-ref self$851 1))
'(1 . 2)))
(%closure-ref self$850 1))
r$775))
(%closure-ref self$849 1))
(write r$778)))
(%closure-ref self$848 1))
2
#f))
(%closure-ref self$847 1))
r$774))
(%closure-ref self$846 2))
(set-cell! (%closure-ref self$846 1) r$779)))
(%closure-ref self$841 1)
(%closure-ref self$841 2))
(%closure
(lambda (self$842 k$780 exp$755)
((%closure
(lambda (self$843 r$781)
((%closure
(lambda (self$844 qval$756)
((%closure-ref (%closure-ref self$844 1) 0)
(%closure-ref self$844 1)
(%closure
(lambda (self$845 k$782 env$757)
((%closure-ref k$782 0)
k$782
(%closure-ref self$845 1)))
qval$756)))
(%closure-ref self$843 1))
r$781))
k$780)
(cadr exp$755))))))
(%closure-ref self$840 1)
(%closure-ref self$840 2))
r$773))
(%closure-ref self$839 1)
(%closure-ref self$839 3))
(set-cell! (%closure-ref self$839 2) r$783)))
(%closure-ref self$836 1)
(%closure-ref self$836 2)
(%closure-ref self$836 3))
(%closure
(lambda (self$837 k$784 exp$758)
((%closure-ref k$784 0)
k$784
(%closure
(lambda (self$838 k$785 env$759)
((%closure-ref k$785 0)
k$785
(%closure-ref self$838 1)))
exp$758))))))
(%closure-ref self$835 1)
(%closure-ref self$835 2)
(%closure-ref self$835 3))
r$772))
(%closure-ref self$834 2)
(%closure-ref self$834 3)
(%closure-ref self$834 4))
(set-cell! (%closure-ref self$834 1) r$786)))
(%closure-ref self$830 1)
(%closure-ref self$830 2)
(%closure-ref self$830 3)
(%closure-ref self$830 4))
(%closure
(lambda (self$831 k$787 exp$760)
((%closure-ref
(cell-get (%closure-ref self$831 4))
0)
(cell-get (%closure-ref self$831 4))
(%closure
(lambda (self$832 r$788)
(if r$788
((%closure-ref
(cell-get (%closure-ref self$832 2))
0)
(cell-get (%closure-ref self$832 2))
(%closure-ref self$832 4)
(%closure-ref self$832 3))
((%closure-ref
(cell-get (%closure-ref self$832 5))
0)
(cell-get (%closure-ref self$832 5))
(%closure
(lambda (self$833 r$789)
(if r$789
((%closure-ref
(cell-get (%closure-ref self$833 1))
0)
(cell-get (%closure-ref self$833 1))
(%closure-ref self$833 3)
(%closure-ref self$833 2))
((%closure-ref (%closure-ref self$833 3) 0)
(%closure-ref self$833 3)
#f)))
(%closure-ref self$832 1)
(%closure-ref self$832 3)
(%closure-ref self$832 4))
(%closure-ref self$832 3))))
(%closure-ref self$831 1)
(%closure-ref self$831 2)
exp$760
k$787
(%closure-ref self$831 3))
exp$760))
(%closure-ref self$830 2)
(%closure-ref self$830 3)
(%closure-ref self$830 5)
(%closure-ref self$830 6))))
(%closure-ref self$829 1)
(%closure-ref self$829 2)
(%closure-ref self$829 3)
(%closure-ref self$829 4)
(%closure-ref self$829 5)
(%closure-ref self$829 6))
r$771))
(%closure-ref self$828 1)
(%closure-ref self$828 2)
(%closure-ref self$828 3)
(%closure-ref self$828 4)
(%closure-ref self$828 5)
(%closure-ref self$828 6))
(set-cell! (%closure-ref self$828 5) r$790)))
(%closure-ref self$825 1)
(%closure-ref self$825 2)
(%closure-ref self$825 3)
(%closure-ref self$825 4)
(%closure-ref self$825 5)
(%closure-ref self$825 6))
(%closure
(lambda (self$826 k$791 exp$761)
((%closure
(lambda (self$827 r$792)
((%closure-ref
(cell-get (%closure-ref self$827 3))
0)
(cell-get (%closure-ref self$827 3))
(%closure-ref self$827 2)
(%closure-ref self$827 1)
r$792))
exp$761
k$791
(%closure-ref self$826 1))
'quote))
(%closure-ref self$825 7))))
(%closure-ref self$824 1)
(%closure-ref self$824 2)
(%closure-ref self$824 3)
(%closure-ref self$824 4)
(%closure-ref self$824 5)
(%closure-ref self$824 6)
(%closure-ref self$824 7))
r$770))
(%closure-ref self$823 1)
(%closure-ref self$823 2)
(%closure-ref self$823 3)
(%closure-ref self$823 4)
(%closure-ref self$823 5)
(%closure-ref self$823 6)
(%closure-ref self$823 7))
(set-cell! (%closure-ref self$823 6) r$793)))
(%closure-ref self$820 1)
(%closure-ref self$820 2)
(%closure-ref self$820 3)
(%closure-ref self$820 4)
(%closure-ref self$820 5)
(%closure-ref self$820 6)
(%closure-ref self$820 7))
(%closure
(lambda (self$821 k$794 exp$762)
((%closure
(lambda (self$822 r$795)
(if r$795
((%closure-ref (%closure-ref self$822 1) 0)
(%closure-ref self$822 1)
#t)
((%closure-ref (%closure-ref self$822 1) 0)
(%closure-ref self$822 1)
#f)))
k$794)
(number? exp$762))))))
(%closure-ref self$819 1)
(%closure-ref self$819 2)
(%closure-ref self$819 3)
(%closure-ref self$819 4)
(%closure-ref self$819 5)
(%closure-ref self$819 6)
(%closure-ref self$819 7))
r$769))
(%closure-ref self$818 1)
(%closure-ref self$818 2)
(%closure-ref self$818 3)
(%closure-ref self$818 4)
(%closure-ref self$818 5)
(%closure-ref self$818 6)
(%closure-ref self$818 7))
(set-cell! (%closure-ref self$818 7) r$796)))
(%closure-ref self$814 1)
(%closure-ref self$814 2)
(%closure-ref self$814 3)
(%closure-ref self$814 4)
(%closure-ref self$814 5)
(%closure-ref self$814 6)
(%closure-ref self$814 7))
(%closure
(lambda (self$815 k$797 exp$763 tag$764)
((%closure
(lambda (self$816 r$798)
(if r$798
((%closure
(lambda (self$817 r$799)
((%closure-ref (%closure-ref self$817 1) 0)
(%closure-ref self$817 1)
(equal? r$799 (%closure-ref self$817 2))))
(%closure-ref self$816 2)
(%closure-ref self$816 3))
(car (%closure-ref self$816 1)))
((%closure-ref (%closure-ref self$816 2) 0)
(%closure-ref self$816 2)
#f)))
exp$763
k$797
tag$764)
(pair? exp$763))))))
(%closure-ref self$813 1)
(%closure-ref self$813 2)
(%closure-ref self$813 3)
(%closure-ref self$813 4)
(%closure-ref self$813 5)
(%closure-ref self$813 6)
(%closure-ref self$813 7))
r$768))
(%closure-ref self$812 1)
(%closure-ref self$812 2)
(%closure-ref self$812 3)
(%closure-ref self$812 4)
(%closure-ref self$812 5)
(%closure-ref self$812 6)
(%closure-ref self$812 7))
(set-cell! (%closure-ref self$812 4) r$800)))
(%closure-ref self$809 1)
(%closure-ref self$809 2)
(%closure-ref self$809 3)
(%closure-ref self$809 4)
(%closure-ref self$809 5)
(%closure-ref self$809 6)
tagged-list?$746)
(%closure
(lambda (self$810 k$801 exp$765 env$766)
((%closure-ref
(cell-get (%closure-ref self$810 1))
0)
(cell-get (%closure-ref self$810 1))
(%closure
(lambda (self$811 r$802)
((%closure-ref r$802 0)
r$802
(%closure-ref self$811 2)
(%closure-ref self$811 1)))
env$766
k$801)
exp$765))
(%closure-ref self$809 1))))
(%closure-ref self$808 1)
(%closure-ref self$808 2)
(%closure-ref self$808 3)
(%closure-ref self$808 4)
(%closure-ref self$808 5)
self-evaluating?$744)
(cell (%closure-ref self$808 6))))
(%closure-ref self$807 1)
(%closure-ref self$807 2)
(%closure-ref self$807 3)
(%closure-ref self$807 4)
quoted?$743
(%closure-ref self$807 6))
(cell (%closure-ref self$807 5))))
(%closure-ref self$806 1)
(%closure-ref self$806 2)
(%closure-ref self$806 3)
eval$741
(%closure-ref self$806 5)
(%closure-ref self$806 6))
(cell (%closure-ref self$806 4))))
(%closure-ref self$805 1)
(%closure-ref self$805 2)
analyze-self-evaluating$739
(%closure-ref self$805 4)
(%closure-ref self$805 5)
(%closure-ref self$805 6))
(cell (%closure-ref self$805 3))))
(%closure-ref self$804 1)
analyze-quoted$738
(%closure-ref self$804 3)
(%closure-ref self$804 4)
(%closure-ref self$804 5)
(%closure-ref self$804 6))
(cell (%closure-ref self$804 2))))
analyze$737
(%closure-ref self$803 2)
(%closure-ref self$803 3)
(%closure-ref self$803 4)
(%closure-ref self$803 5)
(%closure-ref self$803 6))
(cell (%closure-ref self$803 1))))
analyze-quoted$738
analyze-self-evaluating$739
eval$741
quoted?$743
self-evaluating?$744
tagged-list?$746)
(cell analyze$737)))
#f
#f
#f
#f
#f
#f
#f
#f
#f
#f))
(test-eval)
; l21 line 1565 - passes #f to l43, which then tries to execute it:
; according to scaffolding though, this is a problem in the transformed Scheme code
;
;static void __lambda_21(object self_73833, object r_73789) {
; if( !eq(quote_f, r_73789) ){
; return_funcall2( cell_get(((closureN)self_73833)->elts[0]), ((closureN)self_73833)->elts[2], ((closureN)self_73833)->elts[1]);
;} else {
; return_funcall1( ((closureN)self_73833)->elts[2], quote_f);}
;;
;}
;static void __lambda_43(object self_73811, object r_73802) {
; return_funcall2( r_73802, ((closureN)self_73811)->elts[1], ((closureN)self_73811)->elts[0]);;
;}

95
docs/compiler-int-dev.scm Normal file
View file

@ -0,0 +1,95 @@
;; This is a temporary test file, move everything to a test suite and/or docs once it works!
;
;test code:
;(let ((x (apply length '((#t #f))))
; (y (apply length '((#t #f)))))
;(if (apply length '((#t #f)))
; 2
; #f))
(write (cons (apply cons '(1 2)) (apply cons '(3 4))))
;; The purpose of this file is to test interactions between the interpreter
;; and compiled code.
;;
;; Some requirements and notes:
;; - The interpreter can create new variables, but those new vars are only
;; accessible by the interpreter (otherwise code would not compile)
;; - The interpreter should be able to access compiled variables, including
;; functions
;; - The interpreter should be able to call compiled functions
;; - The interpreter should be able to change variables that originate
;; in compiled code
;; - If eval is never called, compiled code can be more efficient by omitting
;; information that is only required by the interpreter.
;;
;; How to represent environments?
;; Presumably the interpreter's global environment needs to include compiled globals as well. It should also be extended to include local vars, presumably prior to each call to eval??
;;
;; global env can be extended to include C globals and locals. their representations will be:
;;
;; - globals are just C variables. problem is, we may need to include the locations of those vars. otherwise how can the interpreter mutate them? IE, if global 'x' is a list, need the memory location of 'x' not the list, if we want to mutate the list
;; simple - add a new type for globals that includes the memory address,
;; but whenever we look one up, return the obj at that address.
;; we want to avoid 'leaking' global objs outside of the env and associated
;; code. then when a set comes in, change the var at the memory address.
;;
;; obviously we want to just load the globals once when *global-env* is
;; built, and do not want to load them ever again.
;;
;; does any of this apply to locals?
;;
;; - locals are ... ? cells?
;; presumably we need to extend global-env to include locals, then pass that
;; extended env as the parameter to eval, each time it is called.
;; this obviously would happen in the compiled code generated by cyclone.
;;
;; local can be a local C variable:
;; ((lambda (x) (display x)) 1)
;; ...
;; static void __lambda_11(int argc, closure _,object x_737) {
;; return_check1(__lambda_10,Cyc_display(x_737));;
;; }
;; but it can also be a closure:
;; ((lambda (x)
;; ((lambda () (display x))))
;; 1)
;; ...
;; static void __lambda_12(int argc, closure _,object x_737) {
;;
;; closureN_type c_7380;
;; c_7380.tag = closureN_tag;
;; c_7380.fn = __lambda_11;
;; c_7380.num_elt = 1;
;; c_7380.elts = (object *)alloca(sizeof(object) * 1);
;; c_7380.elts[0] = x_737;
;;
;; return_funcall0((closure)&c_7380);;
;; }
;;
;; static void __lambda_11(int argc, object self_7331) {
;; return_check1(__lambda_10,Cyc_display(((closureN)self_7331)->elts[0]));;
;; }
;;
;; case #1 - pass a global variable to the interpreter
(define x 1)
(define y 2)
(define *z* 3)
;(write (eval '(Cyc-global-vars)))
(write (eval 'x))
(write (eval '(set! x 'mutated-x)))
;(write (eval '*global-environment*))
(write (eval '*z*))
; TODO: need a valid example of passing a local to eval (assume that is allowed)
;((lambda (tmp)
; (write (eval 'tmp))) #f)
(write (list 'after-eval 'x x 'y y '*z* *z*))
x ;; oh shit, need to reference x/y otherwise they get optimized out!
;; case #2 - pass a local (IE, lambda var)
;; No, this is not allowed, see: http://stackoverflow.com/questions/3844196/how-can-i-use-external-variables-in-eval-in-scheme/3851284#3851284
;; case #3 - mutate global/local. or is this the same as previous?
;; case #4 - introduce new vars in interpreter, then use them later on??

59
docs/global-opts-notes.txt Normal file
View file

@ -0,0 +1,59 @@
These are my old notes for using globals as a performance improvement over creating dozens of nested closures. The old problem is still there if the code is restructured, so these notes may still be valuable. (1) is the only improvement that was implemented.
- Optimizations - there are massive performance problems in compiling eval.scm!!!
1) it might be better for (define) statements to create GC roots, rather than attempting to pass
all defines around in closures. that should minimize closure size and the amount of data each function
needs to pass around (IE: funcall80)
Here are pure lines-of-code metrics:
Phase Last line First line LOC % LOC
input 206 13 193 0.31%
expand 601 212 389 0.63%
alpha 1253 607 646 1.05%
CPS 2586 1259 1327 2.15%
wrap-mut 4151 2676 1475 2.39%
CC 29738 4157 25581 41.49%
C 61652 29743 31909 51.76%
should compare times in each phase. but this still avoids WHY the last two phases are taking so long.
is it just the sheer amount of code that is being generated?
notes about globals:
would have to occur after expand, since that could introduce more defines
want to take each top-level define and create a global for it
could filter top level into two categories - (define) expressions and other expressions, to be enclosed within a (begin)
could create a single list of these, eg: (define, define, ..., begin) and then map over it for the other phases
TBD: how to store defined functions? Do they become closures? how does that work?
a global function can reference other globals, but I do not believe it needs to be a closure, because a global function can only reference other globals.
Issue list
- alpha conversion broken for internal define shadowing global (see below)
- call/cc probably broken for global define's
2) it looked like there were cases where a closure had a copy created of it, and the copy was passed along. it would be nice if the closure conversion phase could detect this and just pass the original closure along instead of building a new one. that saves a lot of work downstream, and seems like it might save work in cc as well (depending upon how complex the check is, of course!)
of course, fn is changed upon new closure, so it is not exactly the same object...
Could make this happen by separating the continuation (which contains next fn) from the environment (closure vars). Even just doing this conceptually (in CC phase) may allow CC to detect unchanged environments. Also, can the existing code just reassign fn? I think that would work since closures are newly-allocated upon function invocation, though maybe it would break loops?
just brainstorming this at the moment.
3) important to see if optimizations can be made independent of adding globals, since even with globals there could be performance problems if there were to be large closures for whatever reason.
4) does sequencing (IE, begin) have to create a new lambda for each expr?
might not make a difference, but seems like it should just create a lambda
body, and let CPS worry about extracting the lambdas. may end up with the
same result, though
by the same token, are there ever cases where it would make sense to pass a sequence all the way to the compiler? probably not, but just a thought
- lexical scoping issue - local does not shadow a global in this case:
(define a 2) ; global
(define (test2)
; TODO: need to be able to shadow globals, too
; using an internal define
(define a 1)
a)

BIN
docs/images/cyclone-logo-01.pdn Normal file
View file

Binary file not shown.

BIN
docs/images/cyclone-logo-01.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 19 KiB

BIN
docs/images/cyclone-logo-03-header.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 11 KiB

BIN
docs/images/cyclone-logo-03-thumb.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 1.1 KiB

BIN
docs/images/cyclone-logo-03.pdn Normal file
View file

Binary file not shown.

BIN
docs/images/cyclone-logo-03.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 30 KiB

BIN
docs/images/cyclone-logo-small.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 1.5 KiB

397
eval.scm Normal file
View file

@ -0,0 +1,397 @@
;; The meta-circular evaluator from SICP 4.1
;; http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-26.html#%_sec_4.1
;;
(define (eval exp . env)
(if (null? env)
((analyze exp) *global-environment*)
((analyze exp) (car env))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Expression handling helper functions
(define (tagged-list? exp tag)
(if (pair? exp)
(equal? (car exp) tag)
#f))
(define (self-evaluating? exp)
(cond ((number? exp) #t)
((boolean? exp) #t)
((string? exp) #t)
((char? exp) #t)
((eof-object? exp) #t)
(else #f)))
(define (variable? exp) (symbol? exp))
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (assignment? exp)
(tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (definition? exp)
(tagged-list? exp 'define))
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp) ; formal parameters
(cddr exp)))) ; body
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp))) ;; TODO: add (not) support
(cadddr exp)
#f))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
;(define (no-operands? ops) (null? ops))
;(define (first-operand ops) (car ops))
;(define (rest-operands ops) (cdr ops))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Evaluator data structures
(define procedure-tag 'Cyc_procedure)
(define (make-procedure parameters body env)
(list procedure-tag parameters body env))
(define (compound-procedure? p)
(tagged-list? p procedure-tag))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
;; Environments
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())
(define (make-frame variables values)
(cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
(define (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
(if (< (length vars) (length vals))
(error "Too many arguments supplied" vars vals)
(error "Too few arguments supplied" vars vals))))
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(cond-expand
(cyclone
(Cyc-get-cvar (car vals)))
(else
(car vals))))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(cond-expand
(cyclone
(if (Cyc-cvar? (car vals))
(Cyc-set-cvar! (car vals) val)
(set-car! vals val)))
(else
(set-car! vals val))))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable -- SET!" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (define-variable! var val env)
(let ((frame (first-frame env)))
(define (scan vars vals)
(cond ((null? vars)
(add-binding-to-frame! var val frame))
((eq? var (car vars))
;; TODO: update compiled var
;; cond-expand
;; if cvar
;; set-cvar
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame))))
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'eq? eq?)
(list 'equal? equal?)
(list 'set-car! set-car!)
(list 'set-cdr! set-cdr!)
(list 'null? null?)
(list 'has-cycle? has-cycle?)
(list 'Cyc-global-vars Cyc-global-vars)
(list '+ +)
; TODO: <more primitives>
))
(define (primitive-procedure-names)
(map car
primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
(define (apply-primitive-procedure proc args)
(apply ;apply-in-underlying-scheme
(primitive-implementation proc) args))
;; TODO: temporary testing
;; also, it would be nice to pass around something other than
;; symbols for primitives. could the runtime inject something into the env?
;; of course that is a problem for stuff like make_cons, that is just a
;; C macro...
;; (define (primitive-procedure? proc)
;; (equal? proc 'cons))
(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(cond-expand
(cyclone
;; Also include compiled variables
(extend-environment
(map (lambda (v) (car v)) (Cyc-global-vars))
(map (lambda (v) (cdr v)) (Cyc-global-vars))
initial-env))
(else initial-env))))
(define *global-environment* (setup-environment))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Derived expressions
;; TODO: longer-term, this would be replaced by a macro system
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
#f ; no else clause
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last -- COND->IF"
clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Improvement from section 4.1.7 - Separate syntactic analysis from execution
;;
;; TODO: need to finish this section
;; TODO: see 4.1.6 Internal Definitions
;;
(define (analyze exp)
(cond ((self-evaluating? exp)
(analyze-self-evaluating exp))
((quoted? exp) (analyze-quoted exp))
((variable? exp) (analyze-variable exp))
((assignment? exp) (analyze-assignment exp))
((definition? exp) (analyze-definition exp))
((if? exp) (analyze-if exp))
((lambda? exp) (analyze-lambda exp))
;; TODO: ideally, macro system would handle these next three
((tagged-list? exp 'let)
(let ((vars (map car (cadr exp))) ;(let->bindings exp)))
(args (map cadr (cadr exp))) ;(let->bindings exp))))
(body (cddr exp)))
(analyze
(cons
(cons 'lambda (cons vars body))
args))))
((begin? exp) (analyze-sequence (begin-actions exp)))
((cond? exp) (analyze (cond->if exp)))
;; END derived expression processing
((application? exp) (analyze-application exp))
(else
(error "Unknown expression type -- ANALYZE" exp))))
;(lambda () 'TODO-unknown-exp-type)))) ; JAE - this is a debug line
(define (analyze-self-evaluating exp)
(lambda (env) exp))
(define (analyze-quoted exp)
(let ((qval (cadr exp)))
(lambda (env) qval)))
(define (analyze-variable exp)
(lambda (env) (lookup-variable-value exp env)))
(define (analyze-assignment exp)
(let ((var (assignment-variable exp))
(vproc (analyze (assignment-value exp))))
(lambda (env)
(set-variable-value! var (vproc env) env)
'ok)))
(define (analyze-definition exp)
(let ((var (definition-variable exp))
(vproc (analyze (definition-value exp))))
(lambda (env)
(define-variable! var (vproc env) env)
'ok)))
(define (analyze-if exp)
(let ((pproc (analyze (if-predicate exp)))
(cproc (analyze (if-consequent exp)))
(aproc (analyze (if-alternative exp))))
(lambda (env)
(if (pproc env)
(cproc env)
(aproc env)))))
(define (analyze-lambda exp)
(let ((vars (lambda-parameters exp))
(bproc (analyze-sequence (lambda-body exp))))
(lambda (env) (make-procedure vars bproc env))))
(define (analyze-sequence exps)
(define (sequentially proc1 proc2)
(lambda (env) (proc1 env) (proc2 env)))
(define (loop first-proc rest-procs)
(if (null? rest-procs)
first-proc
(loop (sequentially first-proc (car rest-procs))
(cdr rest-procs))))
(let ((procs (map analyze exps)))
(if (null? procs)
(error "Empty sequence -- ANALYZE"))
(loop (car procs) (cdr procs))))
(define (analyze-application exp)
(let ((fproc (analyze (operator exp)))
(aprocs (map analyze (operands exp))))
(lambda (env)
(execute-application (fproc env)
(map (lambda (aproc) (aproc env))
aprocs)))))
(define (execute-application proc args)
(cond ((primitive-procedure? proc)
(apply-primitive-procedure proc args))
((compound-procedure? proc)
((procedure-body proc)
(extend-environment (procedure-parameters proc)
args
(procedure-environment proc))))
(else
(error
"Unknown procedure type -- EXECUTE-APPLICATION"
proc))))
;(define (analyze-application exp)
; (let ((fproc (analyze (operator exp)))
; (aprocs (operands exp))) ; TODO: (map analyze (operands exp))))
; (lambda (env)
; (execute-application (fproc env)
;; TODO: (map (lambda (aproc) (aproc env))
; aprocs)))) ;; TODO: temporary testing w/constants
;; TODO: aprocs)))))
;(define (execute-application proc args)
; (cond ((primitive-procedure? proc)
; (apply proc args))
; ;(apply-primitive-procedure proc args))
;;; TODO:
;; ;((compound-procedure? proc)
;; ; ((procedure-body proc)
;; ; (extend-environment (procedure-parameters proc)
;; ; args
;; ; (procedure-environment proc))))
; (else
;#f))) ;; TODO: this is a temporary debug line
;; (error
;; "Unknown procedure type -- EXECUTE-APPLICATION"
;; proc))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; JAE - Testing, should work both with cyclone and other compilers (husk, chicken, etc)
;; although, that may not be possible with (app) and possibly other forms.
;(write (eval 2 *global-environment*))
;(write (eval ''(1 2) *global-environment*))
;(write (eval ''(1 . 2) *global-environment*))
;(write (eval '(if #t 'test-ok 'test-fail) *global-environment*))
;(write (eval '(if 1 'test-ok) *global-environment*))
;(write (eval '(if #f 'test-fail 'test-ok) *global-environment*))
;(write (eval '((lambda (x) (cons x 2) (cons #t x)) 1) *global-environment*))
;;(write (eval '((lambda () (cons 1 2) (cons #t #f))) *global-environment*))
;;(write (eval '(cons 1 2) *global-environment*)) ; TODO
;;(write (eval '(+ 1 2) *global-environment*)) ; TODO
;(define (loop)
; (display (eval (read) *global-environment*))
; (display (newline))
; (loop))
;(loop)

1
examples/fac.scm Normal file
View file

@ -0,0 +1 @@
(define (fac n) (if (= n 0) 1 (* n (fac (- n 1)))))

11
examples/tail-call-optimization.scm Normal file
View file

@ -0,0 +1,11 @@
;; This should run forever using a constant amount of memory
;; and max CPU:
;; Original program:
;; (define (foo) (bar))
;; (define (bar) (foo))
;; (foo)
(letrec ((foo (lambda () (bar)))
(bar (lambda () (foo))))
(foo))

14
examples/tail-call-testing.scm Normal file
View file

@ -0,0 +1,14 @@
;; A program to use all available memory, and eventually crash
(letrec ((foo (lambda (x)
(write (length x))
(bar (cons 1 x))))
(bar (lambda (x) (foo (cons 1 x)))))
(foo '()))
;; TODO: try rewriting it so memory is reclaimed. Does it run
;; forever now?
;(letrec ((foo (lambda (x)
; (write (length x))
; (bar (cons 1 x))))
; (bar (lambda (x) (foo (cons 1 x)))))
; (foo '()))

376
parser.scm Normal file
View file

@ -0,0 +1,376 @@
;; Cyclone Scheme
;; Copyright (c) 2014, Justin Ethier
;; All rights reserved.
;;
;; This module contains the s-expression parser and supporting functions.
;;
;; FUTURE: if this was a module/library, would probably only want to export
;; read and read-all
;;
;; Extended information for each input port
(define *in-port-table* '())
(define (reg-port fp)
(let ((r (assoc fp *in-port-table*)))
(cond
((not r)
;(write `(ADDED NEW ENTRY TO in port table!!))
(set! r
(list fp
#f ; Buffered char, if any
1 ; Line number
0)) ; Char number
(set! *in-port-table* (cons r *in-port-table*))
r)
(else r))))
;; TODO: unreg-port - delete fp entry from *in-port-table*
;; would want to do this when port is closed
(define (in-port:read-buf! ptbl)
(let ((result (cadr ptbl)))
(in-port:set-buf! ptbl #f)
result))
(define (in-port:get-buf ptbl) (cadr ptbl))
(define (in-port:set-buf! ptbl buf) (set-car! (cdr ptbl) buf))
(define (in-port:get-lnum ptbl) (caddr ptbl))
(define (in-port:set-lnum! ptbl lnum) (set-car! (cddr ptbl) lnum))
(define (in-port:get-cnum ptbl) (cadddr ptbl))
(define (in-port:set-cnum! ptbl cnum) (set-car! (cdddr ptbl) cnum))
;; END input port table
;; Helper functions
(define (add-tok tok toks quotes)
(define (loop i)
(if (= quotes i)
tok
(cons 'quote (cons (loop (+ i 1)) '()))))
(if quotes
(cons
(loop 0)
toks)
(cons tok toks)))
;; Get completed list of tokens
(define (get-toks tok toks quotes)
(if (null? tok)
toks
(add-tok (->tok tok) toks quotes)))
;; Add a token to the list, quoting it if necessary
(define (->tok lst)
(parse-atom (reverse lst)))
;; Did we read a dotted list
(define (dotted? lst)
(and (> (length lst) 2)
(equal? (cadr (reverse lst)) (string->symbol "."))))
;; Convert a list read by the reader into an improper list
(define (->dotted-list lst)
(cond
((null? lst) '())
((equal? (car lst) (string->symbol "."))
(cadr lst))
(else
(cons (car lst) (->dotted-list (cdr lst))))))
(define (parse-error msg lnum cnum)
(error
(string-append
"Error (line "
(number->string lnum)
", char "
(number->string cnum)
"): "
msg)))
;; Add finished token, if there is one, and continue parsing
(define (parse/tok fp tok toks all? comment? quotes parens ptbl curr-char)
(cond
((null? tok)
(parse fp '() toks all? comment? quotes parens ptbl))
(all?
(parse fp '()
(add-tok (->tok tok) toks quotes)
all?
comment?
#f ; read tok, no more quote
parens
ptbl))
(else
;; Reached a terminating char, return current token and
;; save term char for the next (read).
;; Note: never call set-buf! if in "all?" mode, since
;; that mode builds a list of tokens
(in-port:set-buf! ptbl curr-char)
;(write `(DEBUG ,tok ,ptbl))
;(write "\n")
(car (add-tok (->tok tok) toks quotes)))))
;; Parse input from stream
;;
;; Input:
;; - Port object
;; - Current token
;; - List of tokens read (if applicable)
;; - Bool - Read-all mode, or just read the next object?
;; - Bool - Are we inside a comment?
;; - Quote level
;; - Level of nested parentheses
;; - Entry in the in-port table for this port
;;
;; Output: next object, or list of objects (if read-all mode)
;;
(define (parse fp tok toks all? comment? quotes parens ptbl)
(in-port:set-cnum! ptbl
(+ 1 (in-port:get-cnum ptbl)))
(let ((c (if (in-port:get-buf ptbl)
(in-port:read-buf! ptbl) ;; Already buffered
(read-char fp))))
;; DEBUGGING
;(write `(DEBUG read ,tok ,c))
;(write (newline))
;; END DEBUG
(cond
((eof-object? c)
(if (> parens 0)
(parse-error "missing closing parenthesis"
(in-port:get-lnum ptbl)
(in-port:get-cnum ptbl)))
(if all?
(reverse (get-toks tok toks quotes))
(let ((last (get-toks tok toks quotes)))
(if (> (length last) 0)
(car last)
c)))) ;; EOF
(comment?
(if (eq? c #\newline)
(begin
(in-port:set-lnum! ptbl
(+ 1 (in-port:get-lnum ptbl)))
(in-port:set-cnum! ptbl 0)
(parse fp '() toks all? #f quotes parens ptbl))
(parse fp '() toks all? #t quotes parens ptbl)))
((char-whitespace? c)
(if (equal? c #\newline)
(in-port:set-lnum! ptbl
(+ 1 (in-port:get-lnum ptbl))))
(if (equal? c #\newline)
(in-port:set-cnum! ptbl 0))
(parse/tok fp tok toks all? #f quotes parens ptbl c))
((eq? c #\;)
(parse/tok fp tok toks all? #t quotes parens ptbl c))
((eq? c #\')
(cond
((and (not all?) (not quotes) (not (null? tok)))
;; Reached a terminal char, read out previous token
;; TODO: would also need to do this if previous char was
;; not a quote!
;; EG: 'a'b ==> (quote a) (quote b), NOT (quote (quote b))
(in-port:set-buf! ptbl c)
(car (add-tok (->tok tok) toks quotes)))
(else
(let ((quote-level (if quotes
(+ quotes 1)
1)))
(cond
((null? tok)
(parse fp '() toks all? comment? quote-level parens ptbl))
(else
(parse fp '() (add-tok (->tok tok) toks quotes)
all? comment? quote-level parens ptbl)))))))
((eq? c #\()
;(write `(DEBUG read open paren ,tok))
(cond
((and (not all?) (not (null? tok)))
;; Reached a terminal char, read out previous token
(in-port:set-buf! ptbl c)
(car (add-tok (->tok tok) toks quotes)))
(else
(let ((sub ;(_cyc-read-all fp (+ parens 1)))
(parse fp '() '() #t #f #f (+ parens 1) ptbl))
(toks* (get-toks tok toks quotes)))
(define new-toks (add-tok
(if (and (pair? sub) (dotted? sub))
(->dotted-list sub)
sub)
toks*
quotes))
;(write `(DEBUG incrementing paren level ,parens ,sub))
(if all?
(parse fp '() new-toks all? #f #f parens ptbl)
(car new-toks))))))
((eq? c #\))
;(write `(DEBUG decrementing paren level ,parens))
(if (= parens 0)
(parse-error "unexpected closing parenthesis"
(in-port:get-lnum ptbl)
(in-port:get-cnum ptbl)))
(reverse (get-toks tok toks quotes)))
((eq? c #\")
(cond
((and (not all?) (not (null? tok)))
;; Reached a terminal char, read out previous token
(in-port:set-buf! ptbl c)
(car (add-tok (->tok tok) toks quotes)))
(else
(let ((str (read-str fp '() ptbl))
(toks* (get-toks tok toks quotes)))
(define new-toks (add-tok str toks* quotes))
(if all?
(parse fp '() new-toks all? #f #f parens ptbl)
(car new-toks))))))
((eq? c #\#)
(if (null? tok)
;; # reader
(let ((next-c (read-char fp)))
(in-port:set-cnum! ptbl
(+ 1 (in-port:get-cnum ptbl)))
(cond
;; Do not use add-tok below, no need to quote a bool
((eq? #\t next-c) (parse fp '() (cons #t toks) all? #f #f parens ptbl))
((eq? #\f next-c) (parse fp '() (cons #f toks) all? #f #f parens ptbl))
((eq? #\\ next-c)
(let ((new-toks (cons (read-pound fp ptbl) toks)))
(if all?
(parse fp '() new-toks all? #f #f parens ptbl)
(car new-toks))))
(else
(parse-error "Unhandled input sequence"
(in-port:get-lnum ptbl)
(in-port:get-cnum ptbl)))))
;; just another char...
(parse fp (cons c tok) toks all? #f quotes parens ptbl)))
(else
(parse fp (cons c tok) toks all? #f quotes parens ptbl)))))
;; Read chars past a leading #\
(define (read-pound fp ptbl)
(define (done raw-buf)
(let ((buf (reverse raw-buf)))
(cond
((= 0 (length buf))
(parse-error "missing character"
(in-port:get-lnum ptbl)
(in-port:get-cnum ptbl)))
((= 1 (length buf))
(car buf))
((equal? buf '(#\a #\l #\a #\r #\m))
(integer->char 7))
((equal? buf '(#\b #\a #\c #\k #\s #\p #\a #\c #\e))
(integer->char 8))
((equal? buf '(#\d #\e #\l #\e #\t #\e))
(integer->char 127))
((equal? buf '(#\e #\s #\c #\a #\p #\e))
(integer->char 27))
((equal? buf '(#\n #\e #\w #\l #\i #\n #\e))
(integer->char 10))
((equal? buf '(#\n #\u #\l #\l))
(integer->char 0))
((equal? buf '(#\r #\e #\t #\u #\r #\n))
(integer->char 13))
((equal? buf '(#\s #\p #\a #\c #\e))
(integer->char 32))
((equal? buf '(#\t #\a #\b))
(integer->char 9))
(else
(parse-error (string-append
"unable to parse character: "
(list->string buf))
(in-port:get-lnum ptbl)
(in-port:get-cnum ptbl))))))
(define (loop buf)
(let ((c (peek-char fp)))
(if (or (eof-object? c)
(char-whitespace? c)
(and (> (length buf) 0)
(equal? c #\))))
(done buf)
(loop (cons (read-char fp) buf)))))
(loop '()))
(define (read-str fp buf ptbl)
(let ((c (read-char fp)))
(cond
((eof-object? c)
(parse-error "missing closing double-quote"
(in-port:get-lnum ptbl)
(in-port:get-cnum ptbl)))
((equal? #\\ c)
(read-str fp (read-str-esc fp buf ptbl) ptbl))
((equal? #\" c)
(list->string (reverse buf)))
(else
(read-str fp (cons c buf) ptbl)))))
;; Read an escaped character within a string
;; The escape '\' has already been read at this point
(define (read-str-esc fp buf ptbl)
(let ((c (read-char fp)))
(cond
((eof-object? c)
(parse-error "missing escaped character within string"
(in-port:get-lnum ptbl)
(in-port:get-cnum ptbl)))
((or (equal? #\" c)
(equal? #\\ c))
(cons c buf))
(else
(parse-error "invalid escape character in string"
(in-port:get-lnum ptbl)
(in-port:get-cnum ptbl))))))
(define (sign? c)
(or
(equal? c #\+)
(equal? c #\-)))
;; parse-atom -> [chars] -> literal
(define (parse-atom a)
(cond
((or (char-numeric? (car a))
(and (> (length a) 1)
(char-numeric? (cadr a))
(sign? (car a))))
(string->number (list->string a)))
(else
(string->symbol (list->string a)))))
;; Main lexer/parser
(define cyc-read ;; TODO: should be (read), but that is breaking on csi 4.8.0.5
(lambda args
(let ((fp (if (null? args)
(current-input-port)
(car args))))
(parse fp '() '() #f #f #f 0 (reg-port fp)))))
;; read-all -> port -> [objects]
(define (read-all . args)
(let ((fp (if (null? args)
(current-input-port)
(car args))))
(define (loop fp result)
(let ((obj (cyc-read fp)))
(if (eof-object? obj)
(reverse result)
(loop fp (cons obj result)))))
(loop fp '())))
;; TODO: for some reason this causes trouble in chicken 4.8. WTF??
;; read -> port -> object
;(define read cyc-read)
;(define (repl)
; ;; Test code
; ;(let ((fp (open-input-file "tests/begin.scm")))
; ;(let ((fp (open-input-file "tests/strings.scm")))
; ;(let ((fp (open-input-file "eval.scm")))
; ;(let ((fp (open-input-file "dev.scm")))
; ; (write (read-all fp)))
; (let ((fp (current-input-port)))
; (write (cyc-read fp)))
; (repl))
;;(repl)

16
repl.scm Normal file
View file

@ -0,0 +1,16 @@
;; Cyclone Scheme
;; Copyright (c) 2014, Justin Ethier
;; All rights reserved.
;;
;; This module contains a simple Read-Eval-Print Loop
;;
(display *Cyc-version-banner*)
(define (repl)
(display "cyclone> ")
(let ((c (eval (read))))
(cond
((not (eof-object? c))
(write c)
(repl))
(else #f))))
(repl)

1464
runtime.h Normal file
View file

File diff suppressed because it is too large Load diff

228
tests/unit-tests.scm Normal file
View file

@ -0,0 +1,228 @@
(define *num-passed* 0)
(define (assert:equal msg actual expected)
(if (not (equal? actual expected))
(error "Unit test failed [" msg "] actual [" actual "] expected [" expected "]")
(set! *num-passed* (+ *num-passed* 1))))
(define (assert:not-equal msg x y)
(assert:equal msg (not (equal? x y)) #t))
(define (assert msg val)
(assert:equal msg (not val) #f))
(assert "Testing assert function" #t)
(assert "Testing assert function" 1)
;; Adder example
(define (make-adder x)
(lambda (y) (+ x y)))
(define increment (make-adder +1))
(assert:equal "Adder #1" (increment 41) 42)
(define decrement (make-adder -1))
(assert:equal "Adder #2" (decrement 42) 41)
(assert:equal "Application example"
((lambda (x) x) (+ 41 1))
42)
;; Apply section
(assert:equal "" (apply length '((#t #f))) 2)
(assert:equal "" (apply cons '(#t #f)) '(#t . #f))
(assert:equal "" (apply cadr (list (list 1 2 3 4))) 2)
(assert:equal "" (apply null? (list '())) #t)
;; Varargs
(define (list2 a b . objs) objs)
(assert:equal "apply varargs" (list 42 1) '(42 1))
(assert:equal "apply varargs" (list 42 1 2) '(42 1 2))
(assert:equal "apply varargs" (list2 42 1) '())
(assert:equal "apply varargs" (list2 42 1 2) '(2))
(assert:equal "begin" (begin 1 2 (+ 1 2) (+ 3 4)) 7)
;; Continuation section
(assert:equal
"simple call/cc"
(call/cc
(lambda (k)
(k 2)))
2)
(assert:equal "escape continuation"
(call/cc
(lambda (return)
(begin
(return 'return))))
'return)
;; Closure section
(assert:equal "simple closure"
(((lambda (x.1)
(lambda (y.2)
(cons x.1 y.2))) #t) #f)
'(#t . #f))
(assert:equal "closure #2"
((lambda (x y)
((lambda () (- x y)))) 5 4)
1)
;; Factorial
(define (fac n) (if (= n 0) 1 (* n (fac (- n 1)))))
(assert:equal "Factorial example" (fac 10) 3628800)
;; If section
(assert:equal "if example" (if #t 1 2) 1)
(assert:equal "if example" (if #f 1 2) 2)
(assert:equal "if example" (if (+ 1 2) (+ 3 4) (* 3 4)) 7)
(assert:equal "if" (if ((lambda (x) (+ x 1)) 0) (+ 1 1) (* 0 0)) 2)
(assert:equal "no else clause" (if #t 'no-else-clause) 'no-else-clause)
(assert:equal "" (+ (+ 1 1) (* 3 4)) 14)
;; Set section
((lambda (x)
(set! x #t) ; (+ 2 (* 3 4)))
(assert:equal "set local x" x #t))
#f)
(define a '(#f #f))
(define b '(#f . #f))
(set-car! a 1)
(set-cdr! a '(2))
(assert:equal "set car/cdr a" a '(1 2))
(set-cdr! a 2)
(set-car! b '(#t))
(set-cdr! b '#t)
(assert:equal "set a" a '(1 . 2))
(assert:equal "set b" b '((#t) . #t))
;; Scoping example
(define scope #f)
(assert:equal "outer scope" scope #f)
((lambda (scope)
(assert:equal "inner scope" scope #t)
) #t)
;; Square example
(let ((x 10)
(y 20)
(square (lambda (x) (* x x))))
(begin
(assert:equal "square x" (square x) 100)
(assert:equal "square y" (square y) 400)))
;; String section
(define a "a0123456789")
(assert:equal "string eq" a "a0123456789")
(assert:not-equal "string eq" a 'a0123456789)
(define b "abcdefghijklmnopqrstuvwxyz")
(define c "hello, world!")
(define d (list->string '(#\( #\" #\a #\b #\c #\" #\))))
(assert:equal "strings" d "(\"abc\")")
(assert:equal "strings" d "(\"abc\")") ;; Test GC
(assert:equal "strings" d "(\"abc\")") ;; Test GC
(set! a "hello 2")
(assert:equal "strings" a "hello 2")
;; Recursion example:
(letrec ((fnc (lambda (i)
(begin
;(display i)
(if (> i 0) (fnc (- i 1)) 0)))))
(fnc 10))
(assert:equal "numeric small reverse" (reverse '(1 2)) '(2 1))
(assert:equal "small reverse" (reverse '(a b c)) '(c b a))
(assert:equal "larger reverse" (reverse '(1 2 3 4 5 6 7 8 9 10)) '(10 9 8 7 6 5 4 3 2 1))
;; ;TODO: improper list, this is an error: (reverse '(1 . 2))
(assert:equal "char whitespace" (char-whitespace? #\space) #t)
(assert:equal "char whitespace" (char-whitespace? #\a) #f)
(assert:equal "char numeric" (char-numeric? #\1) #t)
(assert:equal "char numeric" (char-numeric? #\newline) #f)
(assert:equal "" (and 1 2 3) 3)
(assert:equal "" (and #t #f 'a 'b 'c) #f)
(assert:equal "" (or 1 2 3) 1)
(assert:equal "" (or #f 'a 'b 'c) 'a)
(assert:equal "" (string-append "") "")
;error - (string-append 1)
(assert:equal "" (string-append "test") "test")
(assert:equal "" (string-append "ab" "cdefgh ij" "klmno" "p" "q" "rs " "tuv" "w" " x " "yz")
"abcdefgh ijklmnopqrs tuvw x yz")
(assert:equal "" (string->number "0") 0)
(assert:equal "" (string->number "42") 42)
;(assert:equal "" (string->number "343243243232") ;; Note no bignum support
(assert:equal "" (string->number "3.14159") 3) ;; Currently no float support
(assert:equal "" (list->string (list #\A #\B #\C)) "ABC")
(assert:equal "" (list->string (list #\A)) "A")
(assert:equal "" (list->string (list)) "")
(assert:equal "" (integer->char 65) #\A)
(assert:equal "" (char->integer #\a) 97)
(assert:equal "" (number->string (+ 1 2)) "3")
(assert:equal "" (string->list "test") '(#\t #\e #\s #\t))
(assert:equal "" (string->symbol "a-b-c-d") 'a-b-c-d)
(assert:equal "" (symbol->string 'a/test-01) "a/test-01")
(assert:equal "" (eq? 'a-1 'a-1) #t)
(assert:equal "" (eq? (string->symbol "aa") 'aa) #t)
(assert:equal "" (equal? (string->symbol "aa") 'aa) #t)
;; Map
(assert:equal "map 1" (map (lambda (x) (car x)) '((a . b) (1 . 2) (#\h #\w))) '(a 1 #\h))
(assert:equal "map 2" (map car '((a . b) (1 . 2) (#\h #\w))) '(a 1 #\h))
(assert:equal "map 3" (map cdr '((a . b) (1 . 2) (#\h #\w))) '(b 2 (#\w)))
(assert:equal "map length"
(map length '(() (1) (1 2) (1 2 3) (1 2 3 4)))
'(0 1 2 3 4))
;; Prove internal defines are compiled properly
;;
;; Illustrates an old problem with compiling parser.
;; how to handle the internal define p?
;; trans was trying to wrap p with a lambda, which is not going to
;; work because callers want to pass a,b,c directly.
(define (glob a b c)
(define (p d)
(list a b c d))
(p 4))
(assert:equal "internal defs for global funcs"
(glob 1 2 3)
'(1 2 3 4))
;; Global shadowing issue
;; Do not allow global define to shadow local ones
(define x 'global)
((lambda ()
(define x 1)
((lambda ()
(define x 2)
(assert:equal "local define of x" x 2)))
(assert:equal "another local define of x" x 1)))
(assert:equal "global define of x" x 'global)
; TODO: could add parser tests for these
;(
;123(list)
;1'b
;(write
; (list
; 1;2
; ))
;1;2
;3"four five"
;#\space
;)
;; EVAL section
(define x 1)
(define y 2)
(define *z* 3)
;(write (eval '(Cyc-global-vars)))
(assert:equal "eval compiled - x" (eval 'x) x)
(eval '(set! x 'mutated-x))
(assert:equal "Access var with a mangled name" (eval '*z*) *z*)
(assert:equal "Access compile var mutated by eval" x 'mutated-x)
;; END eval
; TODO: use display, output without surrounding quotes
(write (list *num-passed* " tests passed with no errors"))
;;

1543
trans.scm Normal file
View file

File diff suppressed because it is too large Load diff