├── tests ├── 0.in ├── 0.ref ├── 1.in ├── 1.ref ├── 2.in ├── 2.ref ├── 3.in ├── 3.ref ├── 4.in ├── 5.in ├── pid.in ├── send.in ├── deadlock.in ├── deadlock.ref ├── pid.ref ├── send.ref ├── spawn.in ├── spawn.ref ├── spawnout.in ├── symtab.in ├── 4.ref ├── symtab.ref ├── 7.ref ├── spawnout.ref ├── 2.l ├── spawn.l ├── 0.l ├── 5.ref ├── 3.l ├── 1.l ├── complain ├── pid.l ├── send.l ├── testallmeta ├── spawnout.l ├── 7.in ├── syms.l ├── 6.ref ├── testselv ├── testmeta ├── 4.l ├── 6.in ├── deadlock.l ├── symtab.l ├── s5.l ├── 5.l ├── 6.l ├── bug.l ├── od.1 ├── od.2 ├── bug0.l └── 7.l ├── selvc.elv ├── bless-anyway ├── older ├── testall ├── testone ├── Makefile └── elvc.scm ├── .gitignore ├── bless ├── Makefile ├── README.md ├── TODO ├── notes.text ├── elvas.py ├── Ideas ├── selvc.scm ├── elv.c └── LICENSE /tests/0.in: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/0.ref: -------------------------------------------------------------------------------- 1 | ab -------------------------------------------------------------------------------- /tests/1.in: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/1.ref: -------------------------------------------------------------------------------- 1 | b -------------------------------------------------------------------------------- /tests/2.in: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/2.ref: -------------------------------------------------------------------------------- 1 | b -------------------------------------------------------------------------------- /tests/3.in: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/3.ref: -------------------------------------------------------------------------------- 1 | ab -------------------------------------------------------------------------------- /tests/4.in: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/5.in: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/pid.in: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/send.in: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/deadlock.in: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/deadlock.ref: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/pid.ref: -------------------------------------------------------------------------------- 1 | ab -------------------------------------------------------------------------------- /tests/send.ref: -------------------------------------------------------------------------------- 1 | a -------------------------------------------------------------------------------- /tests/spawn.in: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/spawn.ref: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/spawnout.in: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/symtab.in: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/4.ref: -------------------------------------------------------------------------------- 1 | t 2 | t 3 | f 4 | -------------------------------------------------------------------------------- /tests/symtab.ref: -------------------------------------------------------------------------------- 1 | hello world 2 | -------------------------------------------------------------------------------- /tests/7.ref: -------------------------------------------------------------------------------- 1 | Hello, world! 2 | #f 3 | -------------------------------------------------------------------------------- /tests/spawnout.ref: -------------------------------------------------------------------------------- 1 | ab 2 | AB 3 | 01 4 | -------------------------------------------------------------------------------- /tests/2.l: -------------------------------------------------------------------------------- 1 | (write-char (cond ((cond) \a) ('t \b))) 2 | -------------------------------------------------------------------------------- /tests/spawn.l: -------------------------------------------------------------------------------- 1 | (define (nop) 't) 2 | (spawn nop) 3 | -------------------------------------------------------------------------------- /tests/0.l: -------------------------------------------------------------------------------- 1 | (cond ('t (write-char \a) (write-char \b))) 2 | -------------------------------------------------------------------------------- /tests/5.ref: -------------------------------------------------------------------------------- 1 | () 2 | "abc" 3 | (\a "b") 4 | (hello f "world") 5 | -------------------------------------------------------------------------------- /selvc.elv: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/darius/elv/HEAD/selvc.elv -------------------------------------------------------------------------------- /tests/3.l: -------------------------------------------------------------------------------- 1 | (define (f) (write-char \a) (write-char \b)) 2 | (f) 3 | -------------------------------------------------------------------------------- /tests/1.l: -------------------------------------------------------------------------------- 1 | (cond (#f (write-char \a)) 2 | (#t (write-char \b))) 3 | -------------------------------------------------------------------------------- /tests/complain: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | echo "$@" >/dev/stderr 4 | echo 1 5 | -------------------------------------------------------------------------------- /bless-anyway: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | mv newselvc.elv selvc.elv 4 | mv newselvc.s selvc.s 5 | -------------------------------------------------------------------------------- /tests/pid.l: -------------------------------------------------------------------------------- 1 | (write-char (cond ((pid? (self)) \a) ('t \b))) 2 | (write-char (cond ((pid? 0) \a) ('t \b))) 3 | -------------------------------------------------------------------------------- /older/testall: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | for f in 0 1 2 3 4 5 6 7 4 | do 5 | ./testone $f || exit `./complain "$f failed"` 6 | done 7 | -------------------------------------------------------------------------------- /tests/send.l: -------------------------------------------------------------------------------- 1 | (start (spawn process)) 2 | 3 | (define (start pid) 4 | (! pid \a)) 5 | 6 | (define (process) 7 | (write-char (?))) 8 | -------------------------------------------------------------------------------- /tests/testallmeta: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | for f in 0 1 2 3 4 5 6 7 pid spawn spawnout send symtab 4 | do 5 | ./testselv $f || exit `./complain "$f failed"` 6 | done 7 | -------------------------------------------------------------------------------- /tests/spawnout.l: -------------------------------------------------------------------------------- 1 | (define (write c) 2 | (write-char c) 3 | (write-char (+ c 1)) 4 | (write-char \ 5 | )) 6 | 7 | (spawn write \a) 8 | (spawn write \A) 9 | (spawn write \0) 10 | -------------------------------------------------------------------------------- /tests/7.in: -------------------------------------------------------------------------------- 1 | (define (write-line cs) 2 | (cond ((null? cs) (write-char \ 3 | )) 4 | ('t (write-char (car cs)) 5 | (write-line (cdr cs))))) 6 | 7 | (write-line '"Hello, world!") 8 | -------------------------------------------------------------------------------- /tests/syms.l: -------------------------------------------------------------------------------- 1 | (string->symbol "xyz") 2 | (string->symbol "abc") 3 | (string->symbol "yo") 4 | (cond ((eq? (string->symbol "abc") (string->symbol "abc")) 5 | (write-char \y)) 6 | ('t (write-char \n))) 7 | (write-char \ 8 | ) 9 | -------------------------------------------------------------------------------- /tests/6.ref: -------------------------------------------------------------------------------- 1 | (define (string? x) (cond ((null? x) (quote t)) ((char? x) (quote f)) ((char? (car x)) (string? (cdr x))) ((quote t) (quote f)))) 2 | (define (string=? s t) (cond ((null? s) (null? t)) ((null? t) (quote f)) ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) ((quote t) (quote f)))) 3 | -------------------------------------------------------------------------------- /older/testone: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | compile=$1; shift 4 | f=$1; shift 5 | 6 | $compile <$f.l >$f.c || exit `./complain $f did not compile` 7 | gcc -g2 -Wall $f.c -o $f || exit `./complain $f.c did not compile` 8 | 9 | ./$f <$f.in >$f.out || exit `./complain Error in $f` 10 | diff $f.ref $f.out || exit `./complain Mismatch in $f` 11 | -------------------------------------------------------------------------------- /tests/testselv: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | f=$1; shift 4 | 5 | ../elv ../selvc.elv <$f.l >$f.a || exit `./complain $f did not compile` 6 | python ../elvas.py $f.a >$f.elv || exit `./complain $f.a did not assemble` 7 | 8 | ../elv ./$f.elv <$f.in >$f.out || exit `./complain Error in $f` 9 | diff $f.ref $f.out || exit `./complain Mismatch in $f` 10 | -------------------------------------------------------------------------------- /tests/testmeta: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | f=$1; shift 4 | 5 | ../elv ../newselvc.elv <$f.l >$f.a || exit `./complain $f did not compile` 6 | python ../elvas.py $f.a >$f.elv || exit `./complain $f.a did not assemble` 7 | 8 | ../elv ./$f.elv <$f.in >$f.out || exit `./complain Error in $f` 9 | diff $f.ref $f.out || exit `./complain Mismatch in $f` 10 | -------------------------------------------------------------------------------- /tests/4.l: -------------------------------------------------------------------------------- 1 | (define false (cond)) 2 | 3 | (define (string? x) 4 | (cond ((null? x) 't) 5 | ((char? x) false) 6 | ((char? (car x)) (string? (cdr x))) 7 | ('t false))) 8 | 9 | (define (try x) 10 | (write-char (cond ((string? x) \t) ('t \f))) 11 | (write-char \ 12 | )) 13 | 14 | (try '()) 15 | (try '"hell") 16 | (try '(\h \e "ll")) 17 | -------------------------------------------------------------------------------- /tests/6.in: -------------------------------------------------------------------------------- 1 | (define (string? x) 2 | (cond ((null? x) 't) 3 | ((char? x) 'f) 4 | ((char? (car x)) (string? (cdr x))) 5 | ('t 'f))) 6 | 7 | (define (string=? s t) 8 | (cond ((null? s) (null? t)) 9 | ((null? t) 'f) 10 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 11 | ('t 'f))) 12 | 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Object files 2 | *.o 3 | *.ko 4 | *.obj 5 | *.elf 6 | 7 | # Precompiled Headers 8 | *.gch 9 | *.pch 10 | 11 | # Libraries 12 | *.lib 13 | *.a 14 | *.la 15 | *.lo 16 | 17 | # Shared objects (inc. Windows DLLs) 18 | *.dll 19 | *.so 20 | *.so.* 21 | *.dylib 22 | 23 | # Executables 24 | *.exe 25 | *.out 26 | *.app 27 | *.i*86 28 | *.x86_64 29 | *.hex 30 | 31 | # Debug files 32 | *.dSYM/ 33 | *.su 34 | -------------------------------------------------------------------------------- /bless: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | make && 4 | 5 | (cd tests; ./testallmeta) && 6 | 7 | # Check that using the *new* compiler to compile itself 8 | # produces the same VM-assembly code. It's OK for this check 9 | # to fail, if you expect a nonessential or desired difference, 10 | # but you should stop and think whether you do. 11 | ./elv selvc.elv selvc2.s && 12 | diff -u newselvc.s selvc2.s && 13 | 14 | mv newselvc.elv selvc.elv 15 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | CFLAGS = -g2 -Wall -W 2 | 3 | all: elv newselvc.elv 4 | 5 | clean: 6 | rm -f elv *.o *.s newselvc.elv tests/*.elv tests/*.s tests/*.a tests/*.out syms tests/syms 7 | 8 | elvc: elvc.o 9 | elv: elv.o 10 | 11 | elvc.c: ichbins elvc.scm 12 | ./ichbins elvc.c 13 | 14 | newselvc.elv: elvas.py newselvc.s 15 | python elvas.py newselvc.s >newselvc.elv 16 | 17 | newselvc.s: elv selvc.elv selvc.scm 18 | ./elv selvc.elv newselvc.s 19 | -------------------------------------------------------------------------------- /tests/deadlock.l: -------------------------------------------------------------------------------- 1 | (main (spawn symtab)) 2 | 3 | (define (main st) 4 | (! st 'z) ;(cons 'z '())) 5 | ;(write-char (?)) 6 | ;(write-char \ 7 | ; ) 8 | ) 9 | 10 | (define (symtab) 11 | (symtabbing (?))) 12 | 13 | (define (symtabbing request) 14 | (cond ((symbol? request) 15 | (write (symbol->string request))) 16 | (#t (write-char \!)))) 17 | 18 | (define (write s) 19 | (cond ((null? s) 'ok) 20 | (#t (write-char (car s)) 21 | (write (cdr s))))) 22 | -------------------------------------------------------------------------------- /older/Makefile: -------------------------------------------------------------------------------- 1 | CFLAGS = -g2 -Wall -W 2 | 3 | all: ichbins ichbins2 elvc elv newselvc.elv 4 | 5 | clean: 6 | rm -f ichbins ichbins2* ichbins3* *.o tests/?.c tests/? tests/?.out 7 | 8 | ichbins: ichbins.o 9 | 10 | ichbins2: ichbins2.o 11 | 12 | ichbins2.c: ichbins ichbins.scm 13 | ./ichbins ichbins2.c 14 | 15 | elvc: elvc.o 16 | elv: elv.o 17 | 18 | elvc.c: ichbins elvc.scm 19 | ./ichbins elvc.c 20 | 21 | newselvc.elv: elvas.py newselvc.s 22 | python elvas.py newselvc.s >newselvc.elv 23 | 24 | newselvc.s: elv selvc.elv selvc.scm 25 | ./elv selvc.elv newselvc.s 26 | -------------------------------------------------------------------------------- /tests/symtab.l: -------------------------------------------------------------------------------- 1 | (main (spawn symtab '())) 2 | 3 | (define (main st) 4 | (! st (cons 'intern (cons 'world '()))) 5 | (! st (cons 'intern (cons 'hello '()))) 6 | (! st (cons 'get-symbols (cons (self) '()))) 7 | (write-each (?)) 8 | (write-char \ 9 | )) 10 | 11 | (define (write-each xs) 12 | (cond ((pair? xs) 13 | (write (symbol->string (car xs))) 14 | (write-each (cdr xs))))) 15 | 16 | (define (write cs) 17 | (cond ((null? cs) (write-char \ )) 18 | ('t (write-char (car cs)) 19 | (write (cdr cs))))) 20 | 21 | 22 | (define (symtab xs) 23 | (symtabbing xs (?))) 24 | 25 | (define (symtabbing xs request) 26 | (cond ((eq? (car request) 'intern) 27 | (symtab (adjoin (car (cdr request)) xs))) 28 | ((eq? (car request) 'get-symbols) 29 | (! (car (cdr request)) xs)) 30 | ('t (symtab xs)))) 31 | 32 | (define (memq? x xs) 33 | (cond ((null? xs) (cond)) 34 | ((eq? x (car xs)) 't) 35 | ('t (memq? x (cdr xs))))) 36 | 37 | (define (adjoin x xs) 38 | (cond ((memq? x xs) xs) 39 | ('t (cons x xs)))) 40 | -------------------------------------------------------------------------------- /tests/s5.l: -------------------------------------------------------------------------------- 1 | (define false (cond)) 2 | 3 | (define (string? x) 4 | (cond ((null? x) 't) 5 | ((char? x) false) 6 | ((char? (car x)) (string? (cdr x))) 7 | ('t false))) 8 | 9 | (define (print x) 10 | (write x) 11 | (write-char \ 12 | )) 13 | 14 | (define (write x) 15 | (cond ((null? x) (write-string '"()")) 16 | ((char? x) (write-char \\) (write-char x)) 17 | ((symbol? x) (write-string (symbol->string x))) 18 | ((string? x) (write-char \") (write-string x) (write-char \")) 19 | ((pair? x) 20 | (write-char \() 21 | (write (car x)) 22 | (write-each (cdr x)) 23 | (write-char \))))) 24 | 25 | (define (write-each xs) 26 | (cond ((null? xs) false) 27 | ('t (write-char \ ) 28 | (write (car xs)) 29 | (write-each (cdr xs))))) 30 | 31 | (define (write-string chars) 32 | (cond ((null? chars) false) 33 | ('t (write-char (car chars)) 34 | (write-string (cdr chars))))) 35 | 36 | (print '()) 37 | (print '"abc") 38 | (print '(\a (\b))) 39 | (print (cons (string->symbol '"hello") '(f "world"))) 40 | -------------------------------------------------------------------------------- /tests/5.l: -------------------------------------------------------------------------------- 1 | (define false (cond)) 2 | 3 | (define (string? x) 4 | (cond ((null? x) 't) 5 | ((pair? x) 6 | (cond ((char? (car x)) (string? (cdr x))) 7 | ('t false))) 8 | ('t false))) 9 | 10 | (define (print x) 11 | (write x) 12 | (write-char \ 13 | )) 14 | 15 | (define (write x) 16 | (cond ((null? x) (write-string '"()")) 17 | ((char? x) (write-char \\) (write-char x)) 18 | ((string? x) (write-char \") (write-string x) (write-char \")) 19 | ((symbol? x) (write-string (symbol->string x))) 20 | ((pair? x) (write-char \() 21 | (write (car x)) 22 | (write-each (cdr x)) 23 | (write-char \))))) 24 | 25 | (define (write-each xs) 26 | (cond ((null? xs) false) 27 | ('t (write-char \ ) 28 | (write (car xs)) 29 | (write-each (cdr xs))))) 30 | 31 | (define (write-string chars) 32 | (cond ((null? chars) false) 33 | ('t (write-char (car chars)) 34 | (write-string (cdr chars))))) 35 | 36 | (print '()) 37 | (print '"abc") 38 | (print '(\a (\b))) 39 | (print (cons (string->symbol '"hello") '(f "world"))) 40 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # elv 2 | A very basic Lisp with Erlang-style processes, on a virtual machine. 3 | 4 | I wrote this many years ago, descended from 5 | [https://github.com/darius/ichbins](Ichbins), but judged it a dead 6 | end. It's archived here for your entertainment: a tiny system 7 | showing a few aspects of Lisp and Erlang, depending only on C. (Well, 8 | plus the assembler in Python.) 9 | 10 | Undocumented, but these lines should build and run it: 11 | 12 | $ make 13 | $ (cd tests; ./testallmeta) 14 | 15 | The tests serve also as basic examples. 16 | 17 | Although now the compiler is compiled by itself, when developing this 18 | system I didn't depend on this ability to bootstrap; instead there was 19 | a version of the compiler that ichbins could compile 20 | (`older/elvc.scm`) along with a parallel version (`selvc.scm`) that 21 | could take advantage of the extra features of itself and the 22 | VM. `ichbins.scm` itself and its bootstrapping process were also 23 | included in this repo. So were the corresponding variants of the test 24 | scripts. I've cut all that out as clutter (except for keeping an 25 | archive copy of `elvc.scm` in `older/` so that the removed stuff can be 26 | reconstructed without undue effort). If you want to actively develop 27 | this system, as a weird challenge or learning experience or something, 28 | then it might be easiest to bring back the non-bootstrapped version of 29 | the compiler, just so then you can use gdb on its C-compiled output -- 30 | as the VM has no debugger. OTOH you might rather make debugging nicer 31 | on the VM! Whatevs. 32 | 33 | (`older/` retains a few other files useful when compiling via ichbins 34 | instead of bootstrapping. Move them back to their proper places then.) 35 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | processes: 2 | functionality: 3 | normal exits 4 | error exits 5 | flow control 6 | monitoring 7 | selective receive 8 | timeouts 9 | dynamic resizing of stack & heap 10 | structure: 11 | process-ID hashtable 12 | stack 13 | heap 14 | mailbox 15 | links, flags 16 | 17 | replace set-car! in compiler with a symbol-table process 18 | drop set-car! 19 | 20 | assembler in lisp 21 | 22 | systematize primitive error conditions 23 | 24 | abandon the ichbins crutch 25 | 26 | try-catch-finally or the like 27 | 28 | replace stdin/stdout with an I/O process 29 | 30 | basic debugger 31 | 32 | control-C handling 33 | 34 | quasiquote 35 | macros 36 | let-expressions 37 | 38 | add nested functions, drop (self) 39 | 40 | modules 41 | 42 | lazy code loading 43 | 44 | hot code loading 45 | (To do this Erlang-style we need to be able to find out which 46 | processes are executing in a module. What does that mean, exactly?) 47 | 48 | 'ref' type 49 | 50 | 'binary' type 51 | 52 | sockets 53 | 54 | distribution 55 | 56 | 57 | DONE: 58 | 59 | comments 60 | 61 | booleans 62 | type 63 | writing 64 | reading 65 | switch over from f and t 66 | 67 | symbols 68 | type 69 | string->symbol, symbol->string 70 | remove old symbol table stuff 71 | 72 | ditch the C stack 73 | object file with entry-point table 74 | stack traces 75 | 76 | fixnums 77 | type 78 | arithmetic functions 79 | comparison functions 80 | writing 81 | reading 82 | add fixnum? primitive, change char? 83 | instruction for full-size literal values 84 | check for arithmetic overflow, divide by 0, etc. 85 | 86 | round-robin scheduler 87 | process-ID type 88 | primitives: pid? 89 | (self) primitive, I guess, for now 90 | spawn 91 | instruction: spawn <#args> 92 | compiler & assembler support 93 | receive & send 94 | runtime code 95 | send primitive 96 | receive primitive 97 | -------------------------------------------------------------------------------- /tests/6.l: -------------------------------------------------------------------------------- 1 | (define false (cond)) 2 | 3 | (define (string? x) 4 | (cond ((pair? x) 5 | (cond ((char? (car x)) (string? (cdr x))) 6 | ('t false))) 7 | ('t (null? x)))) 8 | 9 | (define (string=? s t) 10 | (cond ((null? s) (null? t)) 11 | ((null? t) false) 12 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 13 | ('t false))) 14 | 15 | (define (memq? x xs) 16 | (cond ((null? xs) false) 17 | ((eq? x (car xs)) 't) 18 | ('t (memq? x (cdr xs))))) 19 | 20 | (define (print x) 21 | (write x) 22 | (newline)) 23 | 24 | (define (newline) 25 | (write-char \ 26 | )) 27 | 28 | (define (write x) 29 | (cond ((null? x) (write-string '"()")) 30 | ((char? x) (write-char \\) (write-char x)) 31 | ((symbol? x) (write-string (symbol->string x))) 32 | ((string? x) (write-char \") (write-string x) (write-char \")) 33 | ((boolean? x) (write-char \#) 34 | (write-char (cond (x \t) ('t \f)))) 35 | ('t (write-char \() 36 | (write (car x)) 37 | (write-each (cdr x)) 38 | (write-char \))))) 39 | 40 | (define (write-each xs) 41 | (cond ((null? xs) false) 42 | ('t (write-char \ ) 43 | (write (car xs)) 44 | (write-each (cdr xs))))) 45 | 46 | (define (write-string chars) 47 | (cond ((null? chars) false) 48 | ('t (write-char (car chars)) 49 | (write-string (cdr chars))))) 50 | 51 | 52 | (define (error plaint) 53 | (write-string plaint) 54 | (newline) 55 | (abort)) 56 | 57 | (define (read) 58 | (skip-blanks (peek-char)) 59 | (read-dispatch (read-char))) 60 | 61 | (define (skip-blanks c) 62 | (cond ((char-whitespace? c) 63 | (read-char) 64 | (skip-blanks (peek-char))) 65 | ('t 'ok))) 66 | 67 | (define (char-whitespace? c) 68 | (memq? c '" 69 | ")) 70 | 71 | (define non-symbol-chars (cons \" '"\(')")) 72 | 73 | (define eof-object '("eof")) 74 | 75 | (define (read-dispatch c) 76 | (cond ((eq? c false) eof-object) 77 | ((eq? c \\) (read-char-literal (read-char))) 78 | ((eq? c \") (read-string (read-char))) 79 | ((eq? c \() (read-list)) 80 | ((eq? c \') (cons 'quote (cons (read) '()))) 81 | ((eq? c \)) (error '"Unbalanced parentheses")) 82 | ('t (string->symbol (cons c (read-symbol (peek-char))))))) 83 | 84 | (define (read-char-literal c) 85 | (cond ((eq? c false) (error '"EOF in character literal")) 86 | ('t c))) 87 | 88 | (define (read-string c) 89 | (cond ((eq? c false) (error '"Unterminated string literal")) 90 | ((eq? c \") '()) 91 | ('t (cons c (read-string (read-char)))))) 92 | 93 | (define (read-symbol c) 94 | (cond ((char-whitespace? c) '()) 95 | ((memq? c non-symbol-chars) '()) 96 | ('t (read-char) (cons c (read-symbol (peek-char)))))) 97 | 98 | (define (read-list) 99 | (skip-blanks (peek-char)) 100 | (read-list-dispatch (read-char))) 101 | 102 | (define (read-list-dispatch c) 103 | (cond ((eq? c false) (error '"Unterminated list")) 104 | ((eq? c \)) '()) 105 | ('t (cons (read-dispatch c) (read-list))))) 106 | 107 | 108 | (print (read)) 109 | (print (read)) 110 | -------------------------------------------------------------------------------- /tests/bug.l: -------------------------------------------------------------------------------- 1 | (define false (cond)) 2 | 3 | (define (string? x) 4 | (;foo 5 | cond ((null? x) 't) 6 | ((char? x) false) 7 | ((char? (car x)) (string? (cdr x))) 8 | ; hurray this is a comment 9 | ('t false))) 10 | 11 | (define (memq? x xs) 12 | (cond ((null? xs) false) 13 | ((eq? x (car xs)) 't) 14 | ('t (memq? x (cdr xs))))) 15 | 16 | (define symbols 17 | '((t f eof-object define quote cond 18 | eq? null? pair? char? cons car cdr 19 | set-car! read-char peek-char write-char 20 | abort))) 21 | 22 | (define (symbol? x) 23 | (memq? x (car symbols))) 24 | 25 | (define (newline) 26 | (write-char \ 27 | )) 28 | 29 | (define (write-string chars) 30 | (cond ((null? chars) false) 31 | ('t (write-char (car chars)) 32 | (write-string (cdr chars))))) 33 | 34 | 35 | (define (error plaint) 36 | (write-string plaint) 37 | (newline) 38 | (abort)) 39 | 40 | 41 | (define definitions '(())) 42 | (define global-vars '(())) 43 | (define global-vals '(())) 44 | 45 | (define (eval-form form) 46 | (eval form '() '())) 47 | 48 | (define (eval e vars vals) 49 | (cond ((pair? e) 50 | (cond ((symbol? e) (lookup e vars vals)) 51 | ('t (eval-pair (car e) (cdr e) vars vals)))) 52 | ('t e))) 53 | 54 | (define (eval-pair rator rands vars vals) 55 | (cond ((eq? rator 'quote) (car rands)) 56 | ((eq? rator 'cond) (evcond rands vars vals)) 57 | ('t (apply rator (evlis rands vars vals))))) 58 | 59 | (define (evlis es vars vals) 60 | (cond ((null? es) '()) 61 | ('t (cons (eval (car es) vars vals) 62 | (evlis (cdr es) vars vals))))) 63 | 64 | (define (evcond clauses vars vals) 65 | (cond ((null? clauses) '"No matching cond clause yo") 66 | ((eval (car (car clauses)) vars vals) 67 | (evseq (cdr (car clauses)) vars vals)) 68 | ('t (evcond (cdr clauses) vars vals)))) 69 | 70 | (define (evseq es vars vals) 71 | (cond ((null? (cdr es)) (eval (car es) vars vals)) 72 | ('t (eval (car es) vars vals) 73 | (evseq (cdr es) vars vals)))) 74 | 75 | (define (lookup var vars vals) 76 | (cond ((null? vars) (lookup1 var (car global-vars) (car global-vals))) 77 | ((eq? var (car vars)) (car vals)) 78 | ('t (lookup var (cdr vars) (cdr vals))))) 79 | 80 | (define (lookup1 var vars vals) 81 | (cond ((null? vars) (error '"Unbound variable yo")) 82 | ((eq? var (car vars)) (car vals)) 83 | ('t (lookup1 var (cdr vars) (cdr vals))))) 84 | 85 | (define (apply rator args) 86 | (cond ((eq? rator 'eq?) (eq? (car args) (car (cdr args)))) 87 | ((eq? rator 'null?) (null? (car args))) 88 | ((eq? rator 'pair?) (pair? (car args))) 89 | ((eq? rator 'char?) (char? (car args))) 90 | ((eq? rator 'cons) (cons (car args) (car (cdr args)))) 91 | ((eq? rator 'car) (car (car args))) 92 | ((eq? rator 'cdr) (cdr (car args))) 93 | ((eq? rator 'set-car!) (set-car! (car args) (car (cdr args)))) 94 | ((eq? rator 'read-char) (read-char)) 95 | ((eq? rator 'peek-char) (peek-char)) 96 | ((eq? rator 'write-char) (write-char (car args))) 97 | ((eq? rator 'error) (error (car args))) 98 | ('t (call rator args (car definitions))))) 99 | 100 | (define (call rator args defs) 101 | (cond ((null? defs) (error '"Unknown rator")) 102 | ((eq? rator (car (car (car defs)))) 103 | (evseq (cdr (car defs)) (cdr (car (car defs))) args)) 104 | ('t (call rator args (cdr defs))))) 105 | 106 | 107 | (eval-form '(write-char \a)) 108 | -------------------------------------------------------------------------------- /tests/od.1: -------------------------------------------------------------------------------- 1 | 0000000 0a71 0a75 0a6f 0a74 0a65 0b11 1111 1111 2 | 0000020 0a6f 0a6b 0b11 110a 660b 110a 740b 1105 3 | 0000040 0002 0500 000b 1111 0b11 0a22 0a28 0a27 4 | 0000060 0a29 0b11 1111 110a 650a 6f0a 660b 1111 5 | 0000100 110b 1101 0000 4800 0300 0100 02e4 0201 6 | 0000120 02fc 0301 0600 0500 020d 0700 3e0a 550a 7 | 0000140 6e0a 740a 650a 720a 6d0a 690a 6e0a 610a 8 | 0000160 740a 650a 640a 200a 6c0a 690a 730a 740b 9 | 0000200 1111 1111 1111 1111 1111 1111 1111 1111 10 | 0000220 1102 0102 f108 0027 0600 0a29 0d07 0008 11 | 0000240 0b04 0800 1a05 0003 0700 1206 0001 0101 12 | 0000260 ee01 0000 bc11 0408 0005 0c04 0300 1601 13 | 0000300 0102 c009 1502 0100 5203 0106 0001 0102 14 | 0000320 ae07 0008 0b04 0800 2a06 0005 0005 0102 15 | 0000340 0385 0700 080b 0408 0019 0500 0307 0011 16 | 0000360 1509 0600 1601 0100 c911 0408 0005 0c04 17 | 0000400 0301 0600 0500 020d 0700 5c0a 550a 6e0a 18 | 0000420 740a 650a 720a 6d0a 690a 6e0a 610a 740a 19 | 0000440 650a 640a 200a 730a 740a 720a 690a 6e0a 20 | 0000460 670a 200a 6c0a 690a 740a 650a 720a 610a 21 | 0000500 6c0b 1111 1111 1111 1111 1111 1111 1111 22 | 0000520 1111 1111 1111 1111 1111 1111 1102 0102 23 | 0000540 f108 0024 0600 0a22 0d07 0008 0b04 0800 24 | 0000560 1705 0003 0700 0f06 0015 0101 0100 1104 25 | 0000600 0800 050c 0403 0106 0005 0002 0d07 0053 26 | 0000620 0a45 0a4f 0a46 0a20 0a69 0a6e 0a20 0a63 27 | 0000640 0a68 0a61 0a72 0a61 0a63 0a74 0a65 0a72 28 | 0000660 0a20 0a6c 0a69 0a74 0a65 0a72 0a61 0a6c 29 | 0000700 0b11 1111 1111 1111 1111 1111 1111 1111 30 | 0000720 1111 1111 1111 1111 1102 0102 f108 0011 31 | 0000740 0500 0307 0009 0600 0408 0005 0c04 0301 32 | 0000760 0600 0500 020d 0700 0a05 0006 0408 00b1 33 | 0001000 0600 0a5c 0d07 000b 1502 0101 8508 00a1 34 | 0001020 0600 0a22 0d07 000b 1502 0101 0008 0091 35 | 0001040 0600 0a28 0d07 000a 0200 00bc 0800 8206 36 | 0001060 000a 270d 0700 1105 0000 0100 02e4 0b11 37 | 0001100 1104 0800 6c06 000a 290d 0700 4d0a 550a 38 | 0001120 6e0a 620a 610a 6c0a 610a 6e0a 630a 650a 39 | 0001140 640a 200a 700a 610a 720a 650a 6e0a 740a 40 | 0001160 680a 650a 730a 650a 730b 1111 1111 1111 41 | 0001200 1111 1111 1111 1111 1111 1111 1111 1111 42 | 0001220 0201 02f1 0800 1a05 0003 0700 1206 0016 43 | 0001240 0101 00c9 1102 0103 6108 0005 0c04 0301 44 | 0001260 0600 0a20 0a0a 0a20 0b11 1111 0202 0385 45 | 0001300 0301 0600 0101 02ae 0700 0d15 0916 0201 46 | 0001320 02c0 0800 1205 0003 0700 0a05 0001 0408 47 | 0001340 0005 0c04 0300 1601 0102 c009 1502 0101 48 | 0001360 ee03 0106 0001 0102 fc09 1804 0301 0600 49 | 0001400 0e07 000a 0500 0204 0800 1a05 0003 0700 50 | 0001420 1206 0012 1709 0600 1302 0102 fc08 0005 51 | 0001440 0c04 0302 0601 0e07 0013 0600 0500 0401 52 | 0001460 0203 7909 0600 0408 002a 0600 0601 1201 53 | 0001500 0203 b807 000a 0601 1204 0800 1705 0003 54 | 0001520 0700 0f06 0006 0113 0202 0322 0800 050c 55 | 0001540 0403 0106 0005 0004 1202 0203 2203 0106 56 | 0001560 0005 0004 1202 0203 8503 0206 0106 0006 57 | 0001600 0112 1114 0403 0206 010e 0700 0a05 0002 58 | 0001620 0408 0027 0600 0601 120d 0700 0a05 0003 59 | 0001640 0408 0017 0500 0307 000f 0600 0601 1302 60 | 0001660 0203 8508 0005 0c04 0302 0600 0e07 000a 61 | 0001700 0601 0e04 0800 3606 010e 0700 0a05 0002 62 | 0001720 0408 0029 0600 1206 0112 0d07 0010 0600 63 | 0001740 1306 0113 0202 03b8 0800 1205 0003 0700 64 | 0001760 0a05 0002 0408 0005 0c04 65 | 0001772 66 | -------------------------------------------------------------------------------- /tests/od.2: -------------------------------------------------------------------------------- 1 | 0000000 0a71 0a75 0a6f 0a74 0a65 0b11 1111 1111 2 | 0000020 0a6f 0a6b 0b11 110a 660b 110a 740b 1105 3 | 0000040 0002 0500 000b 1111 0b11 0a22 0a28 0a27 4 | 0000060 0a29 0b11 1111 110a 650a 6f0a 660b 1111 5 | 0000100 110b 1101 0000 4800 0300 0100 02e4 0201 6 | 0000120 02fc 0301 0600 0500 020d 0700 3e0a 550a 7 | 0000140 6e0a 740a 650a 720a 6d0a 690a 6e0a 610a 8 | 0000160 740a 650a 640a 200a 6c0a 690a 730a 740b 9 | 0000200 1111 1111 1111 1111 1111 1111 1111 1111 10 | 0000220 1102 0102 f108 0027 0600 0a29 0d07 0008 11 | 0000240 0b04 0800 1a05 0003 0700 1206 0001 0101 12 | 0000260 ee01 0000 bc11 0408 0005 0c04 0300 1601 13 | 0000300 0102 c009 1502 0100 5203 0106 0001 0102 14 | 0000320 ae07 0008 0b04 0800 2a06 0005 0005 0102 15 | 0000340 0385 0700 080b 0408 0019 0500 0307 0011 16 | 0000360 1509 0600 1601 0100 c911 0408 0005 0c04 17 | 0000400 0301 0600 0500 020d 0700 5c0a 550a 6e0a 18 | 0000420 740a 650a 720a 6d0a 690a 6e0a 610a 740a 19 | 0000440 650a 640a 200a 730a 740a 720a 690a 6e0a 20 | 0000460 670a 200a 6c0a 690a 740a 650a 720a 610a 21 | 0000500 6c0b 1111 1111 1111 1111 1111 1111 1111 22 | 0000520 1111 1111 1111 1111 1111 1111 1102 0102 23 | 0000540 f108 0024 0600 0a22 0d07 0008 0b04 0800 24 | 0000560 1705 0003 0700 0f06 0015 0101 0100 1104 25 | 0000600 0800 050c 0403 0106 0005 0002 0d07 0053 26 | 0000620 0a45 0a4f 0a46 0a20 0a69 0a6e 0a20 0a63 27 | 0000640 0a68 0a61 0a72 0a61 0a63 0a74 0a65 0a72 28 | 0000660 0a20 0a6c 0a69 0a74 0a65 0a72 0a61 0a6c 29 | 0000700 0b11 1111 1111 1111 1111 1111 1111 1111 30 | 0000720 1111 1111 1111 1111 1102 0102 f108 0011 31 | 0000740 0500 0307 0009 0600 0408 0005 0c04 0301 32 | 0000760 0600 0500 020d 0700 0a05 0006 0408 00b1 33 | 0001000 0600 0a5c 0d07 000b 1502 0101 8508 00a1 34 | 0001020 0600 0a22 0d07 000b 1502 0101 0008 0091 35 | 0001040 0600 0a28 0d07 000a 0200 00bc 0800 8206 36 | 0001060 000a 270d 0700 1105 0000 0100 02e4 0b11 37 | 0001100 1104 0800 6c06 000a 290d 0700 4d0a 550a 38 | 0001120 6e0a 620a 610a 6c0a 610a 6e0a 630a 650a 39 | 0001140 640a 200a 700a 610a 720a 650a 6e0a 740a 40 | 0001160 680a 650a 730a 650a 730b 1111 1111 1111 41 | 0001200 1111 1111 1111 1111 1111 1111 1111 1111 42 | 0001220 0201 02f1 0800 1a05 0003 0700 1206 0016 43 | 0001240 0101 00c9 1102 0103 6108 0005 0c04 0301 44 | 0001260 0600 0a20 0a0a 0a09 0b11 1111 0202 0385 45 | 0001300 0301 0600 0101 02ae 0700 0d15 0916 0201 46 | 0001320 02c0 0800 1205 0003 0700 0a05 0001 0408 47 | 0001340 0005 0c04 0300 1601 0102 c009 1502 0101 48 | 0001360 ee03 0106 0001 0102 fc09 1804 0301 0600 49 | 0001400 0e07 000a 0500 0204 0800 1a05 0003 0700 50 | 0001420 1206 0012 1709 0600 1302 0102 fc08 0005 51 | 0001440 0c04 0302 0601 0e07 0013 0600 0500 0401 52 | 0001460 0203 7909 0600 0408 002a 0600 0601 1201 53 | 0001500 0203 b807 000a 0601 1204 0800 1705 0003 54 | 0001520 0700 0f06 0006 0113 0202 0322 0800 050c 55 | 0001540 0403 0106 0005 0004 1202 0203 2203 0106 56 | 0001560 0005 0004 1202 0203 8503 0206 0106 0006 57 | 0001600 0112 1114 0403 0206 010e 0700 0a05 0002 58 | 0001620 0408 0027 0600 0601 120d 0700 0a05 0003 59 | 0001640 0408 0017 0500 0307 000f 0600 0601 1302 60 | 0001660 0203 8508 0005 0c04 0302 0600 0e07 000a 61 | 0001700 0601 0e04 0800 3606 010e 0700 0a05 0002 62 | 0001720 0408 0029 0600 1206 0112 0d07 0010 0600 63 | 0001740 1306 0113 0202 03b8 0800 1205 0003 0700 64 | 0001760 0a05 0002 0408 0005 0c04 65 | 0001772 66 | -------------------------------------------------------------------------------- /tests/bug0.l: -------------------------------------------------------------------------------- 1 | (define false (cond)) 2 | 3 | (define (string? x) 4 | (;foo 5 | cond ((null? x) 't) 6 | ((char? x) false) 7 | ((char? (car x)) (string? (cdr x))) 8 | ; hurray this is a comment 9 | ('t false))) 10 | 11 | (define (string=? s t) 12 | (cond ((null? s) (null? t)) 13 | ((null? t) false) 14 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 15 | ('t false))) 16 | 17 | (define (memq? x xs) 18 | (cond ((null? xs) false) 19 | ((eq? x (car xs)) 't) 20 | ('t (memq? x (cdr xs))))) 21 | 22 | (define (cons! x xs-cell) 23 | (set-car! xs-cell (cons x (car xs-cell)))) 24 | 25 | (define symbols 26 | '((t f eof-object define quote cond 27 | eq? null? pair? char? cons car cdr 28 | set-car! read-char peek-char write-char 29 | abort))) 30 | 31 | (define (symbol? x) 32 | (memq? x (car symbols))) 33 | 34 | (define (intern s) 35 | (intern-lookup s (car symbols))) 36 | 37 | (define (intern-lookup s syms) 38 | (cond ((null? syms) (cons! s symbols) s) 39 | ((string=? s (car syms)) (car syms)) 40 | ('t (intern-lookup s (cdr syms))))) 41 | 42 | (define (print x) 43 | (write x) 44 | (newline)) 45 | 46 | (define (newline) 47 | (write-char \ 48 | )) 49 | 50 | (define (write x) 51 | (cond ((null? x) (write-string '"()")) 52 | ((char? x) (write-char \\) (write-char x)) 53 | ((string? x) 54 | (cond ((symbol? x) (write-string x)) 55 | ('t (write-char \") (write-string x) (write-char \")))) 56 | ('t (write-char \() 57 | (write (car x)) 58 | (write-each (cdr x)) 59 | (write-char \))))) 60 | 61 | (define (write-each xs) 62 | (cond ((null? xs) false) 63 | ('t (write-char \ ) 64 | (write (car xs)) 65 | (write-each (cdr xs))))) 66 | 67 | (define (write-string chars) 68 | (cond ((null? chars) false) 69 | ('t (write-char (car chars)) 70 | (write-string (cdr chars))))) 71 | 72 | 73 | (define (error plaint) 74 | (write-string plaint) 75 | (newline) 76 | (abort)) 77 | 78 | 79 | (define definitions '(())) 80 | (define global-vars '(())) 81 | (define global-vals '(())) 82 | 83 | (define (eval-form form) 84 | (cond ((cond ((pair? form) (eq? (car form) 'define)) 85 | ('t false)) 86 | (eval-define (cdr form))) 87 | ('t (print (eval form '() '()))))) 88 | 89 | (define (eval-define defn) 90 | (cond ((symbol? (car defn)) 91 | (define-global (car defn) 92 | (eval (car (cdr defn)) '() '()))) 93 | ('t (cons! defn definitions)))) 94 | 95 | (define (define-global var val) 96 | (cons! var global-vars) 97 | (cons! val global-vals)) 98 | 99 | (define (eval e vars vals) 100 | (cond ((pair? e) 101 | (cond ((symbol? e) (lookup e vars vals)) 102 | ('t (eval-pair (car e) (cdr e) vars vals)))) 103 | ('t e))) 104 | 105 | (define (eval-pair rator rands vars vals) 106 | (cond ((eq? rator 'quote) (car rands)) 107 | ((eq? rator 'cond) (evcond rands vars vals)) 108 | ('t (apply rator (evlis rands vars vals))))) 109 | 110 | (define (evlis es vars vals) 111 | (cond ((null? es) '()) 112 | ('t (cons (eval (car es) vars vals) 113 | (evlis (cdr es) vars vals))))) 114 | 115 | (define (evcond clauses vars vals) 116 | (cond ((null? clauses) '"No matching cond clause yo") 117 | ((eval (car (car clauses)) vars vals) 118 | (evseq (cdr (car clauses)) vars vals)) 119 | ('t (evcond (cdr clauses) vars vals)))) 120 | 121 | (define (evseq es vars vals) 122 | (cond ((null? (cdr es)) (eval (car es) vars vals)) 123 | ('t (eval (car es) vars vals) 124 | (evseq (cdr es) vars vals)))) 125 | 126 | (define (lookup var vars vals) 127 | (cond ((null? vars) (lookup1 var (car global-vars) (car global-vals))) 128 | ((eq? var (car vars)) (car vals)) 129 | ('t (lookup var (cdr vars) (cdr vals))))) 130 | 131 | (define (lookup1 var vars vals) 132 | (cond ((null? vars) (error '"Unbound variable yo")) 133 | ((eq? var (car vars)) (car vals)) 134 | ('t (lookup1 var (cdr vars) (cdr vals))))) 135 | 136 | (define (apply rator args) 137 | (cond ((eq? rator 'eq?) (eq? (car args) (car (cdr args)))) 138 | ((eq? rator 'null?) (null? (car args))) 139 | ((eq? rator 'pair?) (pair? (car args))) 140 | ((eq? rator 'char?) (char? (car args))) 141 | ((eq? rator 'cons) (cons (car args) (car (cdr args)))) 142 | ((eq? rator 'car) (car (car args))) 143 | ((eq? rator 'cdr) (cdr (car args))) 144 | ((eq? rator 'set-car!) (set-car! (car args) (car (cdr args)))) 145 | ((eq? rator 'read-char) (read-char)) 146 | ((eq? rator 'peek-char) (peek-char)) 147 | ((eq? rator 'write-char) (write-char (car args))) 148 | ((eq? rator 'error) (error (car args))) 149 | ('t (call rator args (car definitions))))) 150 | 151 | (define (call rator args defs) 152 | (cond ((null? defs) (error '"Unknown rator")) 153 | ((eq? rator (car (car (car defs)))) 154 | (evseq (cdr (car defs)) (cdr (car (car defs))) args)) 155 | ('t (call rator args (cdr defs))))) 156 | 157 | 158 | (eval-form '(write-char \a)) 159 | -------------------------------------------------------------------------------- /notes.text: -------------------------------------------------------------------------------- 1 | add an optional param to bless, naming the executable to bless. 2 | also, blessing doesn't update the C reference anymore... 3 | 4 | it looks like we don't use global vars enough to make them truly 5 | indispensable; try getting rid of them. generate the symbol table 6 | specially. this avoids any possible circular-initialization problems, 7 | too. 8 | 9 | make dotted pairs impossible 10 | 11 | how to do closures: 12 | * switch to stop-and-copy to handle variable-sized objects gracefully 13 | * make flat closures, leaving out globals? 14 | but linked environments are probably simpler. 15 | they seem to fit 'active literate programming' better, too. 16 | * only handle up to 10 (say) slots in a frame, to not need arithmetic 17 | * reserve a tag for procedures 18 | * (probably) use direct jumps for calls to known procedures, for speed 19 | 20 | how to do curses: 21 | * tty-write-char c (adds to the display buffer for the next refresh-screen) 22 | * tty-plant-cursor (on the next refresh, cursor will be placed at current pos) 23 | * tty-refresh cursor? (param says whether to show the cursor) 24 | * tty-get-key 25 | * tty-set-up, tty-tear-down (could be implicit if we use them always) 26 | * tty-key-waiting? (a bit of a frill) 27 | - expect a fixed terminal size? 28 | - we need some persistence mechanism for the editor 29 | - for games and such we also need timeouts 30 | 31 | can we deal with circular-initialization problems without too much 32 | extra complexity? 33 | 34 | get rid of the tail? param by inspecting the top of code-stack? 35 | 36 | bring back booleans and symbols as disjoint types? 37 | booleans because it's awkward to initialize and use sym_f/sym_t. 38 | [silly idea: use () and \t instead for false and true.] 39 | symbols because it's error-prone when they're not disjoint. 40 | 41 | maybe define a struct with car and cdr fields and delete the car() and 42 | cdr() functions. rename heap_index() to something more concise like at(). 43 | 44 | see how far you can squeeze the bootstrap interpreter, just for fun. 45 | also, why's it like hundreds of times slower than the compiled compiler? 46 | 47 | maybe we could cut down on source lines by adding some kind 48 | of mapping/iterating form. maybe. 49 | 50 | and of course we could save a few lines by using C-style 51 | identifiers only. bleah. 52 | 53 | 54 | 55 | DONE: 56 | types: nil, pair, character 57 | 58 | simpler syntax for chars: \c 59 | 60 | don't bother with dotted pairs, i guess 61 | 62 | similarly, a string is just a list of chars, read and printed 63 | specially 64 | 65 | a symbol is a string that happens to be in the symbol table, also read 66 | and printed specially 67 | 68 | use t and nil, or some such, for booleans. 69 | actually maybe we should include booleans as a disjoint type. 70 | but see how we do with this for now. 71 | 72 | (cond ((eq? proc 'eq?) (eq? (car args) (cadr args))) 73 | ((eq? proc 'null?) (null? (car args))) 74 | ((eq? proc 'pair?) (pair? (car args))) 75 | ((eq? proc 'char?) (char? (car args))) 76 | ((eq? proc 'cons) (cons (car args) (cadr args))) 77 | ((eq? proc 'car) (car (car args))) 78 | ((eq? proc 'cdr) (cdr (car args))) 79 | ((eq? proc 'set-car!) (set-car! (car args) (cadr args))) 80 | ((eq? proc 'read-char) (read-char)) 81 | ((eq? proc 'peek-char) (peek-char)) 82 | ((eq? proc 'write-char) (write-char (car args))) 83 | ((eq? proc 'abort) (abort)) ; actually (error x) 84 | 85 | use a unique-tag list for the EOF object (not a disjoint type) 86 | and a global variable naming it 87 | 88 | language: like icbins but with global vars, no get-global, and the 89 | above simplifications 90 | 91 | simplify it by outputting lines in reverse order 92 | (so the declarations at the top naturally are emitted last; 93 | and we avoid a couple gotos too.) 94 | 95 | make read-char/peek-char return () on eof 96 | 97 | change evseq to require a nonnull list 98 | 99 | switch from (error) back to (abort) as a primitive 100 | 101 | give the test driver more smarts about the output: 102 | - nicer multiline expectations 103 | - be able to get both non-error output and the terminating error 104 | also, some emacs support for the test driver 105 | 106 | require the cdr of a list to be a list -- simplifies code elsewhere 107 | 108 | interpreter & devel strategy: like 'Later.text' plans for icbins 109 | 110 | primitives left: 111 | ((eq? proc 'set-cdr!) (set-cdr! (car args) (cadr args))) 112 | and null? is dispensable 113 | 114 | look for other language simplifications since we're abandoning Scheme 115 | compatibility: 116 | 117 | (let var expr) 118 | (define (fn var ...) expr ...) 119 | 120 | use functional i/o? sort of need multiple-value support of some kind... 121 | and lists of chars are less primitive than read/write-char 122 | so no, i don't think so 123 | 124 | make cond default to 'f when running out of clauses. this can save a 125 | line when writing for-eaches (like (cond ((null? xs) 'ok) ). So, that 126 | saves 5 lines net. But I don't really like it. Most of those lines were 127 | for predicates rather than for-eaches, etc. But still, many conds-for-effect 128 | read more nicely without the default clause, so this goes in. 129 | 130 | get rid of (snarf) and make the compiler do its own reading as it goes 131 | along? this makes the compiler harder to reuse, though. 132 | 133 | simplify the compiler by accumulating def-names and def-exprs in 134 | separate lists? I don't think so... 135 | 136 | (express e syms) has different arg order from other functions with syms 137 | 138 | write code-emission in this style: (emit "foo;" (emit "bar;" 'ignored)) ? 139 | (to allow back-to-front emission with front-to-back-looking code) 140 | (has an efficiency cost though. kind of ugly in its own way.) 141 | 142 | capitalize Obj? 143 | -------------------------------------------------------------------------------- /tests/7.l: -------------------------------------------------------------------------------- 1 | (define false (cond)) 2 | 3 | (define (string? x) 4 | (;foo 5 | cond ((null? x) 't) 6 | ((pair? x) 7 | (cond ((char? (car x)) (string? (cdr x))) 8 | ('t false))) 9 | ; hurray this is a comment 10 | ('t false))) 11 | 12 | (define (string=? s t) 13 | (cond ((null? s) (null? t)) 14 | ((null? t) false) 15 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 16 | ('t false))) 17 | 18 | (define (memq? x xs) 19 | (cond ((null? xs) false) 20 | ((eq? x (car xs)) 't) 21 | ('t (memq? x (cdr xs))))) 22 | 23 | (define (cons! x xs-cell) 24 | (set-car! xs-cell (cons x (car xs-cell)))) 25 | 26 | (define (print x) 27 | (write x) 28 | (newline)) 29 | 30 | (define (newline) 31 | (write-char \ 32 | )) 33 | 34 | (define (write x) 35 | (cond ((null? x) (write-string '"()")) 36 | ((char? x) (write-char \\) (write-char x)) 37 | ((symbol? x) (write-string (symbol->string x))) 38 | ((string? x) (write-char \") (write-string x) (write-char \")) 39 | ((pair? x) (write-char \() 40 | (write (car x)) 41 | (write-each (cdr x)) 42 | (write-char \))) 43 | ((boolean? x) (write-char \#) 44 | (write-char (cond (x \t) ('t \f)))))) 45 | 46 | (define (write-each xs) 47 | (cond ((null? xs) false) 48 | ('t (write-char \ ) 49 | (write (car xs)) 50 | (write-each (cdr xs))))) 51 | 52 | (define (write-string chars) 53 | (cond ((null? chars) false) 54 | ('t (write-char (car chars)) 55 | (write-string (cdr chars))))) 56 | 57 | 58 | (define (error plaint) 59 | (write-string plaint) 60 | (newline) 61 | (abort)) 62 | 63 | (define (read) 64 | (skip-blanks (peek-char)) 65 | (read-dispatch (read-char))) 66 | 67 | (define (skip-blanks c) 68 | (cond ((char-whitespace? c) 69 | (read-char) 70 | (skip-blanks (peek-char))) 71 | ('t 'ok))) 72 | 73 | (define (char-whitespace? c) 74 | (memq? c '" 75 | ")) 76 | 77 | (define non-symbol-chars (cons \" '"\(')")) 78 | 79 | (define eof-object '("eof")) 80 | 81 | (define (read-dispatch c) 82 | (cond ((eq? c false) eof-object) 83 | ((eq? c \\) (read-char-literal (read-char))) 84 | ((eq? c \") (read-string (read-char))) 85 | ((eq? c \() (read-list)) 86 | ((eq? c \') (cons 'quote (cons (read) '()))) 87 | ((eq? c \)) (error '"Unbalanced parentheses")) 88 | ('t (string->symbol (cons c (read-symbol (peek-char))))))) 89 | 90 | (define (read-char-literal c) 91 | (cond ((eq? c false) (error '"EOF in character literal")) 92 | ('t c))) 93 | 94 | (define (read-string c) 95 | (cond ((eq? c false) (error '"Unterminated string literal")) 96 | ((eq? c \") '()) 97 | ('t (cons c (read-string (read-char)))))) 98 | 99 | (define (read-symbol c) 100 | (cond ((char-whitespace? c) '()) 101 | ((memq? c non-symbol-chars) '()) 102 | ('t (read-char) (cons c (read-symbol (peek-char)))))) 103 | 104 | (define (read-list) 105 | (skip-blanks (peek-char)) 106 | (read-list-dispatch (read-char))) 107 | 108 | (define (read-list-dispatch c) 109 | (cond ((eq? c false) (error '"Unterminated list")) 110 | ((eq? c \)) '()) 111 | ('t (cons (read-dispatch c) (read-list))))) 112 | 113 | 114 | (define definitions '(())) 115 | (define global-vars '(())) 116 | (define global-vals '(())) 117 | 118 | (define (repl form) 119 | (cond ((eq? eof-object form) false) 120 | ('t (eval-form form) 121 | (repl (read))))) 122 | 123 | (define (eval-form form) 124 | (cond ((cond ((pair? form) (eq? (car form) 'define)) 125 | ('t false)) 126 | (eval-define (cdr form))) 127 | ('t (print (eval form '() '()))))) 128 | 129 | (define (eval-define defn) 130 | (cond ((symbol? (car defn)) 131 | (define-global (car defn) 132 | (eval (car (cdr defn)) '() '()))) 133 | ('t (cons! defn definitions)))) 134 | 135 | (define (define-global var val) 136 | (cons! var global-vars) 137 | (cons! val global-vals)) 138 | 139 | (define (eval e vars vals) 140 | (cond ((symbol? e) (lookup e vars vals)) 141 | ((pair? e) (eval-pair (car e) (cdr e) vars vals)) 142 | ('t e))) 143 | 144 | (define (eval-pair rator rands vars vals) 145 | (cond ((eq? rator 'quote) (car rands)) 146 | ((eq? rator 'cond) (evcond rands vars vals)) 147 | ('t (apply rator (evlis rands vars vals))))) 148 | 149 | (define (evlis es vars vals) 150 | (cond ((null? es) '()) 151 | ('t (cons (eval (car es) vars vals) 152 | (evlis (cdr es) vars vals))))) 153 | 154 | (define (evcond clauses vars vals) 155 | (cond ((null? clauses) '"No matching cond clause yo") 156 | ((eval (car (car clauses)) vars vals) 157 | (evseq (cdr (car clauses)) vars vals)) 158 | ('t (evcond (cdr clauses) vars vals)))) 159 | 160 | (define (evseq es vars vals) 161 | (cond ((null? (cdr es)) (eval (car es) vars vals)) 162 | ('t (eval (car es) vars vals) 163 | (evseq (cdr es) vars vals)))) 164 | 165 | (define (lookup var vars vals) 166 | (cond ((null? vars) (lookup1 var (car global-vars) (car global-vals))) 167 | ((eq? var (car vars)) (car vals)) 168 | ('t (lookup var (cdr vars) (cdr vals))))) 169 | 170 | (define (lookup1 var vars vals) 171 | (cond ((null? vars) (error '"Unbound variable yo")) 172 | ((eq? var (car vars)) (car vals)) 173 | ('t (lookup1 var (cdr vars) (cdr vals))))) 174 | 175 | (define (apply rator args) 176 | (cond ((eq? rator 'eq?) (eq? (car args) (car (cdr args)))) 177 | ((eq? rator 'null?) (null? (car args))) 178 | ((eq? rator 'pair?) (pair? (car args))) 179 | ((eq? rator 'char?) (char? (car args))) 180 | ((eq? rator 'cons) (cons (car args) (car (cdr args)))) 181 | ((eq? rator 'car) (car (car args))) 182 | ((eq? rator 'cdr) (cdr (car args))) 183 | ((eq? rator 'set-car!) (set-car! (car args) (car (cdr args)))) 184 | ((eq? rator 'read-char) (read-char)) 185 | ((eq? rator 'peek-char) (peek-char)) 186 | ((eq? rator 'write-char) (write-char (car args))) 187 | ((eq? rator 'error) (error (car args))) 188 | ('t (call rator args (car definitions))))) 189 | 190 | (define (call rator args defs) 191 | (cond ((null? defs) (error '"Unknown rator")) 192 | ((eq? rator (car (car (car defs)))) 193 | (evseq (cdr (car defs)) (cdr (car (car defs))) args)) 194 | ('t (call rator args (cdr defs))))) 195 | 196 | 197 | (repl (read)) 198 | -------------------------------------------------------------------------------- /elvas.py: -------------------------------------------------------------------------------- 1 | import sys 2 | 3 | opcodes = {} 4 | 5 | primitives = ['read-char peek-char abort self ?'.split(), 6 | 'null? boolean? char? symbol? pair? ' \ 7 | 'string->symbol symbol->string ' \ 8 | 'car cdr write-char fixnum? pid?'.split(), 9 | 'eq? cons set-car! + - * quotient remainder < !'.split()] 10 | 11 | directives = 'halt checkdef char fixnum nil false true ' \ 12 | 'prim enframe call tailcall return ' \ 13 | 'global local if pop spawn defglobal'.split() 14 | 15 | def set_up(): 16 | ops = 'halt enframe call tailcall nparams return global local ' \ 17 | 'branch jump pop ' \ 18 | 'char nil false true eq? null? boolean? char? pair? ' \ 19 | 'cons car cdr set-car! read-char peek-char write-char abort ' \ 20 | 'symbol? string->symbol symbol->string ' \ 21 | '+ - * quotient remainder fixnum? fixnum < pid? self spawn ! ? ' \ 22 | 'defglobal' 23 | a = ops.split() 24 | for code, name in zip(range(len(a)), a): 25 | opcodes[name] = code 26 | 27 | for_real = None 28 | the_file = None 29 | line = None 30 | tokens = None 31 | here = None 32 | the_globals = None 33 | the_locals = None 34 | the_procs = None 35 | targets = None 36 | 37 | procs_list = [] 38 | syms_file = file('syms', 'wb') 39 | 40 | def main(filename): 41 | global the_procs, the_globals, the_locals, targets 42 | set_up() 43 | the_procs = {} 44 | the_globals = {} 45 | the_locals = {} 46 | targets = {} 47 | assemble(filename, False) 48 | write_symbols() 49 | assemble(filename, True) 50 | 51 | def write_symbols(): 52 | write16(sys.stdout, len(procs_list)) 53 | for name, address in procs_list: 54 | write16(sys.stdout, address) 55 | write8(sys.stdout, len(name)) 56 | sys.stdout.write(name) 57 | 58 | def write16(out, value): 59 | hi, lo = divmod(value, 256) 60 | write8(out, hi) 61 | write8(out, lo) 62 | 63 | def write8(out, value): 64 | assert 0 <= value and value < 256 65 | out.write(chr(value)) 66 | 67 | def assemble(filename, writing): 68 | global the_file, for_real, here 69 | for_real = writing 70 | the_file = file(filename, 'r') 71 | here = 0 72 | eat() 73 | program() 74 | expect('EOF') 75 | 76 | def eat(): 77 | global line, tokens 78 | while True: 79 | line = the_file.readline() 80 | if line == '': 81 | line = 'EOF' 82 | break 83 | if line.strip() != '': 84 | break 85 | tokens = line.split() 86 | 87 | def expect(keyword): 88 | if tokens[0] != keyword: 89 | panic('Expected %s instead of %s' % (keyword, tokens[0])) 90 | 91 | def program(): 92 | globals_() 93 | code() 94 | procs() 95 | 96 | def globals_(): 97 | expect('globals') 98 | namelist(the_globals) 99 | eat() 100 | 101 | def code(): 102 | while tokens[0] in directives: 103 | do_instruc() 104 | 105 | def do_instruc(): 106 | if tokens[0] == 'prim': 107 | arity = int(tokens[1]) 108 | if tokens[2] not in primitives[arity]: 109 | panic('Unknown primitive') 110 | output(opcodes[tokens[2]]) 111 | eat() 112 | elif tokens[0] == 'char': 113 | do_char() 114 | eat() 115 | elif tokens[0] == 'fixnum': 116 | output(opcodes['fixnum']) 117 | encode_int32(int(tokens[1])) 118 | eat() 119 | elif tokens[0] == 'global': 120 | output(opcodes['global']) 121 | encode16(the_globals[tokens[1]]) 122 | eat() 123 | elif tokens[0] == 'defglobal': 124 | output(opcodes['defglobal']) 125 | eat() 126 | elif tokens[0] == 'if': 127 | branch_from = here 128 | output(opcodes['branch']) 129 | encode_jump_offset(branch_from) 130 | eat() 131 | code() 132 | expect('else') 133 | eat() 134 | jump_from = here 135 | output(opcodes['jump']) 136 | encode_jump_offset(jump_from) 137 | resolve(branch_from) 138 | code() 139 | expect('then') 140 | eat() 141 | resolve(jump_from) 142 | elif tokens[0] == 'local': 143 | output(opcodes['local']) 144 | output(the_locals[tokens[1]]) 145 | eat() 146 | elif tokens[0] == 'call': 147 | output(opcodes['call']) 148 | output(int(tokens[1])) 149 | encode_address(tokens[2]) 150 | eat() 151 | elif tokens[0] == 'tailcall': 152 | output(opcodes['tailcall']) 153 | output(int(tokens[1])) 154 | encode_address(tokens[2]) 155 | eat() 156 | elif tokens[0] == 'spawn': 157 | output(opcodes['spawn']) 158 | output(int(tokens[1])) 159 | encode_address(tokens[2]) 160 | eat() 161 | elif tokens[0] == 'checkdef': 162 | eat() 163 | elif tokens[0] in opcodes: 164 | output(opcodes[tokens[0]]) 165 | eat() 166 | else: 167 | panic('wtf? ' + tokens[0]) 168 | 169 | def do_char(): 170 | q = line.index("'") 171 | assert 0 <= q 172 | r = line.rindex("'") 173 | assert q < r 174 | if q + 2 == r: 175 | c = line[q+1] 176 | assert c != '\\' 177 | elif q + 3 == r: 178 | assert line[q+1] == '\\' 179 | c = line[q+2] 180 | assert c in ['n', '\\', "'"] 181 | if c == 'n': c = '\n' 182 | else: 183 | panic('Bad char literal') 184 | output(opcodes['char']) 185 | output(ord(c)) 186 | 187 | def output(byte): 188 | if for_real: 189 | write8(sys.stdout, byte) 190 | global here 191 | here += 1 192 | 193 | def encode_address(name): 194 | if for_real: 195 | encode16(the_procs[name]) 196 | else: 197 | encode16(0) 198 | 199 | def encode_jump_offset(from_address): 200 | if for_real: 201 | encode16(targets[from_address] - from_address) 202 | else: 203 | encode16(0) 204 | 205 | def resolve(from_address): 206 | targets[from_address] = here 207 | 208 | def encode_int32(value): 209 | output((value >> 24) & 0xFF) 210 | output((value >> 16) & 0xFF) 211 | output((value >> 8) & 0xFF) 212 | output((value >> 0) & 0xFF) 213 | 214 | def encode16(value): 215 | hi, lo = divmod(value, 256) 216 | output(hi) 217 | output(lo) 218 | 219 | def procs(): 220 | while tokens[0] == 'proc': 221 | do_proc() 222 | 223 | def do_proc(): 224 | expect('proc') 225 | the_procs[tokens[1]] = here 226 | if not for_real: 227 | procs_list.append((tokens[1], here)) 228 | else: 229 | syms_file.write('%s\t%d\n' % (tokens[1], here)) 230 | eat() 231 | expect('locals') 232 | namelist(the_locals) 233 | output(opcodes['nparams']) 234 | output(len(tokens[1:])) 235 | eat() 236 | code() 237 | 238 | def namelist(table): 239 | table.clear() 240 | a = tokens[1:] 241 | for code, name in zip(range(len(a)), a): 242 | table[name] = code 243 | 244 | def panic(plaint): 245 | #sys.stderr.write(plaint + '\n') 246 | raise plaint 247 | 248 | main(sys.argv[1]) 249 | -------------------------------------------------------------------------------- /Ideas: -------------------------------------------------------------------------------- 1 | Use a unified heap, at least to start 2 | 3 | It's bad for realtime, for multi-CPU, and for memory accounting, but 4 | simpler for everything else if you put off those concerns. 5 | 6 | Once you have a unified heap, the resource-control motivation to send 7 | to PIDs instead of to channels goes away... OTOH I'm not sure I want 8 | to do channels even so: snapshots aren't naturally deterministic wrt 9 | how much of the channel has been filled in. (I'm assuming channels 10 | act like single-assignment lists, like in Oz.) 11 | 12 | 13 | One-pass mark-compact GC 14 | 15 | See the paper. This doesn't go very nicely with sharing the stack and 16 | heap in one block, growing towards each other, because the base address 17 | gets reset on every GC. However, it's possible to make them both wrap 18 | around as needed. Probably more trouble than it's worth compared to a 19 | separated stack. 20 | 21 | 22 | Process ID garbage collection: 23 | 24 | What if each GC cycle on each process guarantees there are no surviving 25 | process IDs older than a certain age? And processes over the whole 26 | system are cycled often enough that we can be sure of retiring process 27 | IDs system-wide before the ID space overflows? 28 | 29 | Of course, some IDs would legitimately survive, so we need a table of 30 | renamings. Can that be made to work? How does it compare to refcounting 31 | process-ID-table entries? Or of course to using a big enough space that 32 | you'll never run out? 33 | 34 | In summary, the approaches I've thought of to PID collection: 35 | * Don't do it. Use a big enough space that you never run out. 36 | * Collect PIDs as part of whole-system GC in a unified heap. 37 | * Reference-count entries in the PID table. Have each process 38 | conservatively track its PID reference set in between GCs. 39 | * Periodically recycle names into range with a rename table and 40 | process-at-a-time GC. 41 | 42 | 43 | KeyKOS-style snapshots: 44 | 45 | Sort of relatedly, we can use a system-wide GC cycle as a snapshot 46 | cycle. At the start of a snapshot, you go and make a copy of the process 47 | variables for every process (mailbox, stack, etc.), retaining them as 48 | roots on its heap. Then the next time we complete a GC on each process, 49 | we also append its state to the logfile and null out the snapshot root. 50 | (How bad would it be to write the current state vs. just the parts 51 | accessible from the snapshot root? Is there any point in combining this 52 | with the process GC? Actually that part seems like a bad idea -- the 53 | main advantage is to combine two traversals, but there are lots of 54 | disadvantages.) 55 | 56 | Stacks should be copied at snap time, or copy-on-write, or represented 57 | by immutable continuations on the heap. 58 | 59 | Simple snapshots interfere with memory accounting: in between snapping 60 | the snapshot and recording it, we don't know how much live data is 61 | 'really' still live vs. how much is retained only for the snapshot. 62 | Also, it affects the compression of the 'real' live data. 63 | 64 | Note that there are other applications besides persistence: e.g. 65 | omniscient debugging. This requires representing the snapshot in 66 | memory, not specializing the snapshotter to allow nothing but 67 | writing to disk. 68 | 69 | What about differential backups? Seems like that'd amount to garbage- 70 | collecting serialized data identifiers... or something. 71 | 72 | Can you handle multiple snapshots not yet written? Should you? 73 | 74 | 75 | Compressed data representations: 76 | 77 | First, obviously, when serializing data you can use relative addresses 78 | to get smaller pointers; and encode directly without any pointers at all 79 | where terms are just trees instead of DAGs. It might be worthwhile to 80 | (pretend to) hash-cons when serializing. 81 | 82 | But for live data inside a process it ought to make sense to use relative 83 | pointers and other compression tricks as well: 84 | 85 | * We can keep data in allocation order, and compact on every GC. 86 | (There may be complications or costs to representing the backpointer 87 | chain during GC, however -- we're no longer guaranteed a big-enough 88 | field for the backpointer, right?) 89 | * No mutation to worry about. 90 | 91 | I'll bet this would be worthwhile: lighter-weight processes, better cache 92 | behavior. And especially nice for embedded systems. Should be a paper in 93 | it. 94 | 95 | Maybe it'd be better to pick uncompressed representations on initial 96 | allocation, and only compress on GC -- don't waste time compressing 97 | soon-to-be garbage. OTOH that multiplies your allocation rate. 98 | 99 | Note you no longer need the tuple type for space efficiency! Though you 100 | may still want it for speed. 101 | 102 | 103 | Hash consing 104 | 105 | Would it be a good idea to hash-cons the live data in a process? I'm 106 | guessing not, on the whole, but we ought to at least measure the 107 | opportunity. Maybe make it an option like Erlang's 'hibernate'. 108 | 109 | (Unless you add a hashtable on the side, it destroys the 110 | unidirectional-heap property.) 111 | 112 | 113 | Super-tiny stackless processes 114 | 115 | Reactive processes, that are 'just objects', shouldn't have to pay the 116 | overhead of having their own stack and heap in between invocations. 117 | Something vaguely like Erlang's hibernate could be appropriate -- only 118 | we don't thaw a frozen heap, we allocate a fresh auxiliary one for the 119 | stack and intermediate allocations -- analogous to allocating a stack 120 | frame in a sequential method call. 121 | 122 | Maybe processes should start with that strategy by default until the 123 | runtime estimates it's a bad idea? I'll need to work out how this might 124 | possibly work... 125 | 126 | With a unified heap this pretty much reduces to giving up your stack 127 | when it's empty. 128 | 129 | 130 | More GC ideas 131 | 132 | It should be possible to GC without sweeping through garbage, using 133 | extra temporary storage instead. 134 | 135 | Maybe reorder objects sometimes, to improve locality. (I'm thinking 136 | particularly of the case where A uniquely references B, with C in 137 | between. Coalescing A and B raises an opportunity for data compression.) 138 | The tricky part is doing this cheaply -- doesn't fall out of the 139 | original algorithm because by the time you're scavenging B, you've 140 | already done C. 141 | 142 | Note that when we scavenge an object, we know how many references there 143 | are to it -- the length of the relocation chain. So one idea is to 144 | notice the above situation when it happens, and make a note to do the 145 | move on the *next* GC if the objects are still live. 146 | 147 | Maybe the GC is what the doctor ordered for rebalancing cords. (I think 148 | cords should be our primary data structure, not cons pairs.) 149 | 150 | 151 | Hot code loading 152 | 153 | Desired constraints: 154 | - capability discipline 155 | - persistent data structures to work well with snapshotting 156 | 157 | Basic idea: a hot code manager is a process you call with a function 158 | name and get back a function. Might want to have a dedicated channel for 159 | this... 160 | 161 | 162 | Memory accounting 163 | 164 | We want random people on the net to be able to test-drive the system. 165 | Their memory use must be limited. 166 | 167 | Say we base this on process memory quotas. Then: 168 | - messages it sends should stay under its account until they're accepted 169 | - new processes share the original space-bank 170 | - other processes doing work on its behalf should be able to get space 171 | from its account -- transferable and divisible space-banks 172 | 173 | GC renders enforcement rather nondeterministic. How big a problem is this? 174 | -------------------------------------------------------------------------------- /older/elvc.scm: -------------------------------------------------------------------------------- 1 | (define linefeed \ 2 | ) 3 | 4 | (define false (cond)) 5 | (define true (eq? \a \a)) 6 | 7 | (define (error complaint) 8 | (write-string complaint) 9 | (write-char linefeed) 10 | (abort)) 11 | 12 | (define (list1 z) (cons z '())) 13 | (define (list3 x y z) (cons x (cons y (cons z '())))) 14 | 15 | (define (append xs ys) 16 | (cond ((null? xs) ys) 17 | ('t (cons (car xs) (append (cdr xs) ys))))) 18 | 19 | (define (reverse xs) 20 | (revappend xs '())) 21 | 22 | (define (revappend xs ys) 23 | (cond ((null? xs) ys) 24 | ('t (revappend (cdr xs) (cons (car xs) ys))))) 25 | 26 | (define (memq? x xs) 27 | (cond ((null? xs) false) 28 | ((eq? x (car xs)) 't) 29 | ('t (memq? x (cdr xs))))) 30 | 31 | (define (length xs) 32 | (list1 (length-digit xs "0123456789"))) 33 | 34 | (define (length-digit xs digits) 35 | (cond ((null? xs) (car digits)) 36 | ('t (length-digit (cdr xs) (cdr digits))))) 37 | 38 | (define (string? x) 39 | (cond ((null? x) 't) 40 | ((char? x) false) 41 | ((char? (car x)) (string? (cdr x))) 42 | ('t false))) 43 | 44 | (define (string=? s t) 45 | (cond ((null? s) (null? t)) 46 | ((null? t) false) 47 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 48 | ('t false))) 49 | 50 | (define (write-string chars) 51 | (cond ((pair? chars) 52 | (write-char (car chars)) 53 | (write-string (cdr chars))))) 54 | 55 | (define (cons! x xs-box) 56 | (set-car! xs-box (cons x (car xs-box)))) 57 | 58 | (define (adjoin! x xs-box) 59 | (cond ((eq? false (memq? x (car xs-box))) 60 | (cons! x xs-box)))) 61 | 62 | 63 | (define primitives '(eq? null? boolean? char? pair? cons car cdr set-car! 64 | symbol? string->symbol symbol->string 65 | read-char peek-char write-char abort)) 66 | 67 | (define symbols-box (list1 (append '(define quote cond) primitives))) 68 | (define (intern? x) (memq? x (car symbols-box))) 69 | (define (intern s) (interning s (car symbols-box))) 70 | 71 | (define (interning s symbols) 72 | (cond ((null? symbols) (cons! s symbols-box) s) 73 | ((string=? s (car symbols)) (car symbols)) 74 | ('t (interning s (cdr symbols))))) 75 | 76 | 77 | (define (read) 78 | (read-dispatch (skip-blanks (read-char)))) 79 | 80 | (define (skip-blanks c) 81 | (cond ((memq? c whitespace-chars) (skip-blanks (read-char))) 82 | ((eq? c \;) (skip-blanks (skip-comment (read-char)))) 83 | ('t c))) 84 | 85 | (define (skip-comment c) 86 | (cond ((eq? c false) eof-object) 87 | ((eq? c linefeed) (read-char)) 88 | ('t (skip-comment (read-char))))) 89 | 90 | (define whitespace-chars (cons linefeed " ")) 91 | (define non-symbol-chars (cons false "\"\\(')")) 92 | 93 | (define eof-object '("eof")) 94 | 95 | (define (read-dispatch c) 96 | (cond ((eq? c false) eof-object) 97 | ((eq? c \\) (read-char-literal (read-char))) 98 | ((eq? c \") (read-string (read-char))) 99 | ((eq? c \() (read-list)) 100 | ((eq? c \') (cons 'quote (cons (read) '()))) 101 | ((eq? c \#) (parse-boolean (read-symbol (peek-char)))) 102 | ((eq? c \)) (write-string "Unbalanced parentheses") 103 | (write-char linefeed) 104 | (echo (read-char)) 105 | (abort)) 106 | ('t (intern (cons c (read-symbol (peek-char))))))) 107 | 108 | (define (echo c) 109 | (cond (c (write-char c) (echo (read-char))))) 110 | 111 | (define (read-char-literal c) 112 | (cond ((eq? c false) (error "EOF in character literal")) 113 | ('t c))) 114 | 115 | (define (read-string c) 116 | (cond ((eq? c false) (error "Unterminated string literal")) 117 | ((eq? c \") '()) 118 | ((eq? c \\) (cons (read-char) (read-string (read-char)))) 119 | ('t (cons c (read-string (read-char)))))) 120 | 121 | (define (read-symbol c) 122 | (cond ((memq? c whitespace-chars) '()) 123 | ((memq? c non-symbol-chars) '()) 124 | ('t (read-char) (cons c (read-symbol (peek-char)))))) 125 | 126 | (define (parse-boolean string) 127 | (cond ((string=? string "f") false) 128 | ((string=? string "t") true) 129 | ('t (error "Bad # syntax")))) 130 | 131 | (define (read-list) 132 | (read-list-dispatch (skip-blanks (read-char)))) 133 | 134 | (define (read-list-dispatch c) 135 | (cond ((eq? c false) (error "Unterminated list")) 136 | ((eq? c \)) '()) 137 | ('t (cons (read-dispatch c) (read-list))))) 138 | 139 | 140 | (define (push1 z k) (append z (cons linefeed k))) 141 | (define (push3 x y z k) (append x (append y (push1 z k)))) 142 | (define (push5 v w x y z k) (append v (append w (push3 x y z k)))) 143 | 144 | 145 | (define (compile) 146 | (write-string (compile-procs '(()) (read) '() '() ""))) 147 | 148 | (define (compile-procs syms form var-defs exprs k) 149 | (cond ((eq? eof-object form) 150 | (do-compile-defs syms (reverse var-defs) 151 | (compile-proc syms '__main '() (reverse exprs) k))) 152 | ((cond ((pair? form) (eq? 'define (car form))) 153 | ('t false)) 154 | (cond ((intern? (car (cdr form))) 155 | (compile-procs syms (read) (cons form var-defs) exprs k)) 156 | ('t (compile-procs syms (read) var-defs exprs 157 | (compile-proc syms 158 | (proc.name form) 159 | (proc.params form) 160 | (proc.body form) 161 | k))))) 162 | ('t (compile-procs syms (read) var-defs (cons form exprs) k)))) 163 | 164 | (define (do-compile-defs syms var-defs k) 165 | (compile-symbols syms var-defs 166 | (compile-defs syms var-defs 167 | (emit-start k)))) 168 | 169 | (define (compile-symbols syms var-defs k) 170 | (emit-globals (append (map-def.name (make-symbol-defs syms)) 171 | (map-def.name var-defs)) 172 | (emit-prelude 173 | (compile-defs syms (make-symbol-defs syms) k)))) 174 | 175 | (define (compile-defs syms defs k) 176 | (cond ((pair? defs) 177 | (compile-def syms (def.name (car defs)) (def.expr (car defs)) 178 | (compile-defs syms (cdr defs) k))) 179 | ('t k))) 180 | 181 | (define (express syms x) 182 | (cond ((intern? x) (adjoin! x syms) (symbol->var x)) 183 | ((pair? x) (express-pair syms x)) 184 | ('t x))) 185 | 186 | (define (express-pair syms x) 187 | (list3 'cons (express syms (car x)) (express syms (cdr x)))) 188 | 189 | (define (make-symbol-defs syms) 190 | (making-symbol-defs (car syms) '())) 191 | 192 | (define (making-symbol-defs symbols defs) 193 | (cond ((null? symbols) defs) 194 | ('t (making-symbol-defs 195 | (cdr symbols) 196 | (cons (list3 'define (symbol->var (car symbols)) 197 | (express-pair '() (car symbols))) 198 | defs))))) 199 | 200 | (define (symbol->var sym) 201 | (intern (cons \. sym))) 202 | 203 | (define (proc.name proc) (car (car (cdr proc)))) 204 | (define (proc.params proc) (cdr (car (cdr proc)))) 205 | (define (proc.body proc) (cdr (cdr proc))) 206 | 207 | (define (def.name def) (car (cdr def))) 208 | (define (def.expr def) (car (cdr (cdr def)))) 209 | 210 | (define (map-def.name defs) 211 | (cond ((null? defs) '()) 212 | ('t (cons (def.name (car defs)) 213 | (map-def.name (cdr defs)))))) 214 | 215 | (define (compile-proc syms name params body k) 216 | (emit-proc name params 217 | (compile-seq syms body params 't 218 | (emit-end-proc k)))) 219 | 220 | (define (compile-seq syms es vars tail? k) 221 | (cond ((null? (cdr es)) 222 | (compile-expr syms (car es) vars tail? k)) 223 | ('t (compile-expr syms (car es) vars false 224 | (emit-pop 225 | (compile-seq syms (cdr es) vars tail? k)))))) 226 | 227 | (define (compile-exprs syms es vars k) 228 | (cond ((null? es) k) 229 | ('t (compile-expr syms (car es) vars false 230 | (compile-exprs syms (cdr es) vars k))))) 231 | 232 | (define (compile-expr syms e vars tail? k) 233 | (cond ((char? e) (emit-char-lit e (maybe-return tail? k))) 234 | ((null? e) (emit-nil (maybe-return tail? k))) 235 | ((pair? e) 236 | (cond ((intern? e) 237 | (cond ((memq? e vars) (emit-local e (maybe-return tail? k))) 238 | ('t (emit-global e (maybe-return tail? k))))) 239 | ((string? e) (compile-expr syms (express syms e) vars tail? k)) 240 | ('t (compile-pair syms (car e) (cdr e) vars tail? k)))) 241 | ('t (emit-boolean e (maybe-return tail? k))))) 242 | 243 | (define (maybe-return tail? k) 244 | (cond (tail? (emit-return k)) 245 | ('t k))) 246 | 247 | (define (compile-pair syms rator rands vars tail? k) 248 | (cond ((eq? rator 'cond) (compile-cond syms rands vars tail? k)) 249 | ((eq? rator 'quote) 250 | (compile-expr syms (express syms (car rands)) vars tail? k)) 251 | ('t (compile-exprs syms rands vars 252 | (compile-call rator (length rands) tail? k))))) 253 | 254 | (define (compile-cond syms clauses vars tail? k) 255 | (cond ((null? clauses) (emit-boolean false (maybe-return tail? k))) 256 | ('t (compile-expr syms (car (car clauses)) vars false 257 | (emit-if 258 | (compile-seq syms (cdr (car clauses)) vars tail? 259 | (emit-else 260 | (compile-cond syms (cdr clauses) vars tail? 261 | (emit-end-if k))))))))) 262 | 263 | (define (compile-call rator n-args tail? k) 264 | (cond ((memq? rator primitives) 265 | (emit-prim rator n-args 266 | (maybe-return tail? k))) 267 | (tail? (emit-tail-call rator n-args k)) 268 | ('t (emit-call rator n-args k)))) 269 | 270 | (define c-char-map-domain (list3 linefeed \' \\)) 271 | (define c-char-map-range (list3 "\\n" "\\'" "\\\\")) 272 | (define (c-char-literal c) 273 | (translit c (list1 c) c-char-map-domain c-char-map-range)) 274 | 275 | (define (c-id str) str) 276 | 277 | (define (translit x default domain range) 278 | (cond ((null? domain) default) 279 | ((eq? x (car domain)) (car range)) 280 | ('t (translit x default (cdr domain) (cdr range))))) 281 | 282 | (define (comma names k) 283 | (cond ((null? names) (push1 "" k)) 284 | ('t (cons \ (append (c-id (car names)) (comma (cdr names) k)))))) 285 | 286 | (define (emit-start k) (push1 " call 0 __main" 287 | (push1 " halt" k))) 288 | (define (emit-globals names k) (append " globals" (comma names k))) 289 | (define (emit-locals names k) (append " locals" (comma names k))) 290 | (define (emit-prelude k) k) 291 | 292 | (define (emit-proc name params k) 293 | (push1 "" 294 | (push3 "proc " (c-id name) "" 295 | (emit-locals params k)))) 296 | 297 | (define (emit-end-proc k) k) 298 | 299 | (define (emit-check-def name k) 300 | (push3 " checkdef " (c-id name) "" k)) 301 | 302 | (define (emit-return k) 303 | (push1 " return" k)) 304 | 305 | (define (emit-tail-call name n-args k) 306 | (push5 " tailcall " n-args " " (c-id name) "" k)) 307 | 308 | (define (emit-call name n-args k) 309 | (push5 " call " n-args " " (c-id name) "" k)) 310 | 311 | (define (emit-prim name n-args k) 312 | (push5 " prim " n-args " " (c-id name) "" k)) 313 | 314 | (define (emit-pop k) 315 | (push1 " pop" k)) 316 | 317 | (define (emit-if k) (push1 " if" k)) 318 | (define (emit-else k) (push1 " else" k)) 319 | (define (emit-end-if k) (push1 " then" k)) 320 | 321 | (define (emit-char-lit c k) 322 | (push3 " char '" (c-char-literal c) "'" k)) 323 | 324 | (define (emit-nil k) 325 | (push1 " nil" k)) 326 | 327 | (define (emit-boolean b k) 328 | (push1 (cond (b " true") ('t " false")) k)) 329 | 330 | (define (emit-local name k) 331 | (push3 " local " (c-id name) "" k)) 332 | 333 | (define (emit-global name k) 334 | (push3 " global " (c-id name) "" k)) 335 | 336 | (define (compile-def syms name e k) 337 | (compile-expr syms e '() false 338 | (emit-check-def name k))) 339 | 340 | (compile) 341 | -------------------------------------------------------------------------------- /selvc.scm: -------------------------------------------------------------------------------- 1 | (define linefeed \ 2 | ) 3 | 4 | (define false (cond)) 5 | (define true (eq? \a \a)) 6 | 7 | (define (error complaint) 8 | (write-string complaint) 9 | (write-char linefeed) 10 | (abort)) 11 | 12 | (define (list1 z) (cons z '())) 13 | (define (list2 y z) (cons y (cons z '()))) 14 | (define (list3 x y z) (cons x (cons y (cons z '())))) 15 | 16 | (define (append xs ys) 17 | (cond ((null? xs) ys) 18 | ('t (cons (car xs) (append (cdr xs) ys))))) 19 | 20 | (define (reverse xs) 21 | (revappend xs '())) 22 | 23 | (define (revappend xs ys) 24 | (cond ((null? xs) ys) 25 | ('t (revappend (cdr xs) (cons (car xs) ys))))) 26 | 27 | (define (memq? x xs) 28 | (cond ((null? xs) false) 29 | ((eq? x (car xs)) 't) 30 | ('t (memq? x (cdr xs))))) 31 | 32 | (define the-digits "0123456789") 33 | 34 | (define (length xs) 35 | (list1 (length-digit xs the-digits))) 36 | 37 | (define (length-digit xs digits) 38 | (cond ((null? xs) (car digits)) 39 | ('t (length-digit (cdr xs) (cdr digits))))) 40 | 41 | (define (string? x) 42 | (cond ((null? x) 't) 43 | ((pair? x) 44 | (cond ((char? (car x)) (string? (cdr x))) 45 | ('t false))) 46 | ('t false))) 47 | 48 | (define (string=? s t) 49 | (cond ((null? s) (null? t)) 50 | ((null? t) false) 51 | ((eq? (car s) (car t)) (string=? (cdr s) (cdr t))) 52 | ('t false))) 53 | 54 | (define (write-string chars) 55 | (cond ((pair? chars) 56 | (write-char (car chars)) 57 | (write-string (cdr chars))))) 58 | 59 | (define (cons! x xs-box) 60 | (set-car! xs-box (cons x (car xs-box)))) 61 | 62 | (define (adjoin! x xs-box) 63 | (cond ((eq? false (memq? x (car xs-box))) 64 | (cons! x xs-box)))) 65 | 66 | 67 | (define (intern-each strings) 68 | (cond ((null? strings) '()) 69 | ('t (cons (string->symbol (car strings)) 70 | (intern-each (cdr strings)))))) 71 | 72 | (define primitives 73 | (intern-each 74 | '("eq?" "null?" "boolean?" "char?" "pair?" "cons" "car" "cdr" "set-car!" 75 | "symbol?" "string->symbol" "symbol->string" 76 | "read-char" "peek-char" "write-char" "abort" 77 | "+" "-" "*" "quotient" "remainder" "fixnum?" "<" 78 | "pid?" "self" "!" "?"))) 79 | 80 | (define %__main (string->symbol "__main")) 81 | (define %cond (string->symbol "cond")) 82 | (define %cons (string->symbol "cons")) 83 | (define %define (string->symbol "define")) 84 | (define %quote (string->symbol "quote")) 85 | (define %spawn (string->symbol "spawn")) 86 | (define %string->symbol (string->symbol "string->symbol")) 87 | (define %symbol->string (string->symbol "symbol->string")) 88 | 89 | 90 | (define (read) 91 | (read-dispatch (skip-blanks (read-char)))) 92 | 93 | (define (skip-blanks c) 94 | (cond ((memq? c whitespace-chars) (skip-blanks (read-char))) 95 | ((eq? c \;) (skip-blanks (skip-comment (read-char)))) 96 | ('t c))) 97 | 98 | (define (skip-comment c) 99 | (cond ((eq? c false) eof-object) 100 | ((eq? c linefeed) (read-char)) 101 | ('t (skip-comment (read-char))))) 102 | 103 | (define whitespace-chars (cons linefeed " ")) 104 | (define non-symbol-chars (cons false "\"\\(')")) 105 | 106 | (define eof-object '("eof")) 107 | 108 | (define (read-dispatch c) 109 | (cond ((eq? c false) eof-object) 110 | ((eq? c \\) (read-char-literal (read-char))) 111 | ((eq? c \") (read-string (read-char))) 112 | ((eq? c \() (read-list)) 113 | ((eq? c \') (cons %quote (cons (read) '()))) 114 | ((eq? c \#) (parse-boolean (read-atom (peek-char)))) 115 | ((eq? c \)) (error "Unbalanced parentheses")) 116 | ('t (parse-atom (cons c (read-atom (peek-char))))))) 117 | 118 | (define (read-char-literal c) 119 | (cond ((eq? c false) (error "EOF in character literal")) 120 | ('t c))) 121 | 122 | (define (read-string c) 123 | (cond ((eq? c false) (error "Unterminated string literal")) 124 | ((eq? c \") '()) 125 | ((eq? c \\) (cons (read-char) (read-string (read-char)))) 126 | ('t (cons c (read-string (read-char)))))) 127 | 128 | (define (read-atom c) 129 | (cond ((memq? c whitespace-chars) '()) 130 | ((memq? c non-symbol-chars) '()) 131 | ('t (read-char) (cons c (read-atom (peek-char)))))) 132 | 133 | (define (parse-atom string) 134 | (try-integer-parse (string->integer string) string)) 135 | 136 | (define (try-integer-parse opt-integer string) 137 | (cond (opt-integer opt-integer) 138 | ('t (string->symbol string)))) 139 | 140 | (define one (- \1 \0)) 141 | (define zero (- \0 \0)) 142 | (define minus-one (- \0 \1)) 143 | (define ten (+ (- \9 \0) one)) 144 | 145 | (define (string->integer string) 146 | (cond ((null? string) #f) 147 | ((eq? \- (car string)) 148 | (cond ((null? (cdr string)) #f) 149 | ('t (parse-unsigned zero (cdr string) minus-one)))) 150 | ('t (parse-unsigned zero string one)))) 151 | 152 | (define (parse-unsigned acc string sign) 153 | (cond ((null? string) (* sign acc)) 154 | ((memq? (car string) the-digits) 155 | (parse-unsigned (+ (* ten acc) (- (car string) \0)) 156 | (cdr string) 157 | sign)) 158 | ('t #f))) 159 | 160 | (define (parse-boolean string) 161 | (cond ((string=? string "f") false) 162 | ((string=? string "t") true) 163 | ('t (error "Bad # syntax")))) 164 | 165 | (define (read-list) 166 | (read-list-dispatch (skip-blanks (read-char)))) 167 | 168 | (define (read-list-dispatch c) 169 | (cond ((eq? c false) (error "Unterminated list")) 170 | ((eq? c \)) '()) 171 | ('t (cons (read-dispatch c) (read-list))))) 172 | 173 | 174 | (define (push1 z k) (append z (cons linefeed k))) 175 | (define (push3 x y z k) (append x (append y (push1 z k)))) 176 | (define (push5 v w x y z k) (append v (append w (push3 x y z k)))) 177 | 178 | 179 | (define (compile) 180 | (write-string (compile-procs '(()) (read) '() '() ""))) 181 | 182 | (define (compile-procs syms form var-defs exprs k) 183 | (cond ((eq? eof-object form) 184 | (do-compile-defs syms (reverse var-defs) 185 | (compile-proc syms %__main '() (reverse exprs) k))) 186 | ((cond ((pair? form) (eq? %define (car form))) 187 | ('t false)) 188 | (cond ((symbol? (car (cdr form))) 189 | (compile-procs syms (read) (cons form var-defs) exprs k)) 190 | ('t (compile-procs syms (read) var-defs exprs 191 | (compile-proc syms 192 | (proc.name form) 193 | (proc.params form) 194 | (proc.body form) 195 | k))))) 196 | ('t (compile-procs syms (read) var-defs (cons form exprs) k)))) 197 | 198 | (define (do-compile-defs syms var-defs k) 199 | (compile-symbols syms var-defs 200 | (compile-defs syms var-defs 201 | (emit-start k)))) 202 | 203 | (define (compile-symbols syms var-defs k) 204 | (emit-globals (append (map-def.name (make-symbol-defs syms)) 205 | (map-def.name var-defs)) 206 | (emit-prelude 207 | (compile-defs syms (make-symbol-defs syms) k)))) 208 | 209 | (define (compile-defs syms defs k) 210 | (cond ((pair? defs) 211 | (compile-def syms (def.expr (car defs)) 212 | (compile-defs syms (cdr defs) k))) 213 | ('t k))) 214 | 215 | (define (express syms x) 216 | (cond ((symbol? x) (adjoin! x syms) (symbol->var x)) 217 | ((pair? x) (express-pair syms x)) 218 | ('t x))) 219 | 220 | (define (express-pair syms x) 221 | (list3 %cons (express syms (car x)) (express syms (cdr x)))) 222 | 223 | (define (make-symbol-defs syms) 224 | (making-symbol-defs (car syms) '())) 225 | 226 | (define (making-symbol-defs symbols defs) 227 | (cond ((null? symbols) defs) 228 | ('t (making-symbol-defs 229 | (cdr symbols) 230 | (cons (list3 %define (symbol->var (car symbols)) 231 | (list2 %string->symbol 232 | (express '() (symbol->string (car symbols))))) 233 | defs))))) 234 | 235 | (define (symbol->var sym) 236 | (string->symbol (cons \. (symbol->string sym)))) 237 | 238 | (define (proc.name proc) (car (car (cdr proc)))) 239 | (define (proc.params proc) (cdr (car (cdr proc)))) 240 | (define (proc.body proc) (cdr (cdr proc))) 241 | 242 | (define (def.name def) (car (cdr def))) 243 | (define (def.expr def) (car (cdr (cdr def)))) 244 | 245 | (define (map-def.name defs) 246 | (cond ((null? defs) '()) 247 | ('t (cons (def.name (car defs)) 248 | (map-def.name (cdr defs)))))) 249 | 250 | (define (compile-proc syms name params body k) 251 | (emit-proc name params 252 | (compile-seq syms body params 't 253 | (emit-end-proc k)))) 254 | 255 | (define (compile-seq syms es vars tail? k) 256 | (cond ((null? (cdr es)) 257 | (compile-expr syms (car es) vars tail? k)) 258 | ('t (compile-expr syms (car es) vars false 259 | (emit-pop 260 | (compile-seq syms (cdr es) vars tail? k)))))) 261 | 262 | (define (compile-exprs syms es vars k) 263 | (cond ((null? es) k) 264 | ('t (compile-expr syms (car es) vars false 265 | (compile-exprs syms (cdr es) vars k))))) 266 | 267 | (define (compile-expr syms e vars tail? k) 268 | (cond ((pair? e) 269 | (cond ((string? e) (compile-expr syms (express syms e) vars tail? k)) 270 | ('t (compile-pair syms (car e) (cdr e) vars tail? k)))) 271 | ('t (compile-atom e vars (maybe-return tail? k))))) 272 | 273 | (define (compile-atom e vars k) 274 | (cond ((symbol? e) 275 | (cond ((memq? e vars) (emit-local e k)) 276 | ('t (emit-global e k)))) 277 | ((printable-char? e) (emit-char-lit e k)) 278 | ((fixnum? e) (emit-fixnum-lit e k)) 279 | ((boolean? e) (emit-boolean e k)) 280 | ((null? e) (emit-nil k)) 281 | ('t (error "Unknown atom type")))) 282 | 283 | (define (printable-char? x) 284 | (cond ((char? x) 285 | (cond ((< \ x) (< x (+ \~ one))) 286 | ('t #f))) 287 | ('t #f))) 288 | 289 | (define (maybe-return tail? k) 290 | (cond (tail? (emit-return k)) 291 | ('t k))) 292 | 293 | (define (compile-pair syms rator rands vars tail? k) 294 | (cond ((eq? rator %cond) (compile-cond syms rands vars tail? k)) 295 | ((eq? rator %spawn) 296 | (compile-spawn syms (car rands) (cdr rands) vars tail? k)) 297 | ((eq? rator %quote) 298 | (compile-expr syms (express syms (car rands)) vars tail? k)) 299 | ('t (compile-app syms rator rands (length rands) vars tail? k)))) 300 | 301 | (define (compile-cond syms clauses vars tail? k) 302 | (cond ((null? clauses) (emit-boolean false (maybe-return tail? k))) 303 | ('t (compile-expr syms (car (car clauses)) vars false 304 | (emit-if 305 | (compile-seq syms (cdr (car clauses)) vars tail? 306 | (emit-else 307 | (compile-cond syms (cdr clauses) vars tail? 308 | (emit-end-if k))))))))) 309 | 310 | (define (compile-spawn syms rator rands vars tail? k) 311 | (compile-exprs syms rands vars 312 | (emit-spawn rator (length rands) 313 | (maybe-return tail? k)))) 314 | 315 | (define (compile-app syms rator rands n-rands vars tail? k) 316 | (cond ((memq? rator primitives) 317 | (compile-exprs syms rands vars 318 | (emit-prim rator n-rands 319 | (maybe-return tail? k)))) 320 | (tail? (compile-exprs syms rands vars 321 | (emit-tail-call rator n-rands k))) 322 | ('t (emit-enframe 323 | (compile-exprs syms rands vars 324 | (emit-call rator n-rands k)))))) 325 | 326 | (define c-char-map-domain (list3 linefeed \' \\)) 327 | (define c-char-map-range (list3 "\\n" "\\'" "\\\\")) 328 | (define (c-char-literal c) 329 | (translit c (list1 c) c-char-map-domain c-char-map-range)) 330 | 331 | (define (c-id symbol) (symbol->string symbol)) 332 | 333 | (define (translit x default domain range) 334 | (cond ((null? domain) default) 335 | ((eq? x (car domain)) (car range)) 336 | ('t (translit x default (cdr domain) (cdr range))))) 337 | 338 | (define (comma names k) 339 | (cond ((null? names) (push1 "" k)) 340 | ('t (cons \ (append (c-id (car names)) (comma (cdr names) k)))))) 341 | 342 | (define (emit-start k) (emit-enframe 343 | (emit-call '__main "0" 344 | (push1 " halt" k)))) 345 | (define (emit-globals names k) (append " globals" (comma names k))) 346 | (define (emit-locals names k) (append " locals" (comma names k))) 347 | (define (emit-prelude k) k) 348 | 349 | (define (emit-proc name params k) 350 | (push1 "" 351 | (push3 "proc " (c-id name) "" 352 | (emit-locals params k)))) 353 | 354 | (define (emit-end-proc k) k) 355 | 356 | (define (emit-def-global k) (push1 " defglobal" k)) 357 | 358 | (define (emit-return k) (push1 " return" k)) 359 | (define (emit-enframe k) (push1 " enframe" k)) 360 | 361 | (define (emit-call name n-args k) 362 | (push5 " call " n-args " " (c-id name) "" k)) 363 | 364 | (define (emit-tail-call name n-args k) 365 | (push5 " tailcall " n-args " " (c-id name) "" k)) 366 | 367 | (define (emit-spawn name n-args k) 368 | (push5 " spawn " n-args " " (c-id name) "" k)) 369 | 370 | (define (emit-prim name n-args k) 371 | (push5 " prim " n-args " " (c-id name) "" k)) 372 | 373 | (define (emit-pop k) (push1 " pop" k)) 374 | 375 | (define (emit-if k) (push1 " if" k)) 376 | (define (emit-else k) (push1 " else" k)) 377 | (define (emit-end-if k) (push1 " then" k)) 378 | 379 | (define (emit-char-lit c k) 380 | (push3 " char '" (c-char-literal c) "'" k)) 381 | 382 | (define (emit-fixnum-lit value k) 383 | (push3 " fixnum " (integer->string value) " " k)) 384 | 385 | (define (emit-nil k) 386 | (push1 " nil" k)) 387 | 388 | (define (emit-boolean b k) 389 | (push1 (cond (b " true") ('t " false")) k)) 390 | 391 | (define (emit-local name k) 392 | (push3 " local " (c-id name) "" k)) 393 | 394 | (define (emit-global name k) 395 | (push3 " global " (c-id name) "" k)) 396 | 397 | (define (compile-def syms e k) 398 | (compile-expr syms e '() false 399 | (emit-def-global k))) 400 | 401 | (define (integer->string value) ; XXX breaks on most negative fixnum 402 | (cond ((< value zero) (cons \- (unsigned->string (- zero value) '()))) 403 | ('t (unsigned->string value '())))) 404 | 405 | (define (unsigned->string value acc) 406 | (cond ((< value ten) (cons (+ \0 value) acc)) 407 | ('t (unsigned->string (quotient value ten) 408 | (cons (+ \0 (remainder value ten)) acc))))) 409 | 410 | (compile) 411 | -------------------------------------------------------------------------------- /elv.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | enum { symbol_table_size = 64 * 1024 }; 8 | enum { entry_table_size = 1 * 1024 }; 9 | enum { process_table_size = 1 * 1024 }; 10 | enum { globals_size = 4 * 1024 }; 11 | enum { stack_size = 4 * 1024 }; // XXX that's still pretty big 12 | enum { heap_size = 512 * 1024 }; 13 | enum { code_size = 64 * 1024 }; 14 | 15 | enum { tracing = 0 }; 16 | #define TRACEOUT stderr 17 | 18 | #define TRACE1(f,x) do { if (tracing) fprintf (TRACEOUT,f,x); } while (0); 19 | #define TRACE2(f,x,y) do { if (tracing) fprintf (TRACEOUT,f,x,y); } while (0); 20 | 21 | static void panic (const char *plaint) { 22 | fprintf (stderr, "%s\n", plaint); 23 | exit (1); 24 | } 25 | 26 | static void *allot (size_t size) { 27 | void *result = malloc (size); 28 | if (NULL == result && 0 != size) 29 | panic ("Out of memory"); 30 | return result; 31 | } 32 | 33 | // syms_space holds a chain of strings from index 0 up below syms_ptr. 34 | // The first byte of each entry is its length. There are no duplicates. 35 | static unsigned char syms_space[symbol_table_size]; 36 | static unsigned syms_ptr = 0; 37 | 38 | // For each of the first n_entry_points symbols, there's a value in 39 | // entry_points giving the starting address of the function with that 40 | // name. These are in ascending order by address. 41 | static unsigned entry_points[entry_table_size]; 42 | static unsigned n_entry_points = 0; 43 | 44 | static unsigned nth_symbol (unsigned n) { 45 | unsigned s = 0; 46 | unsigned i; 47 | for (i = 0; i < n; ++i) { 48 | assert (s < syms_ptr); 49 | s += 1 + syms_space[s]; 50 | } 51 | assert (s < syms_ptr); 52 | return s; 53 | } 54 | 55 | static void print_symbol (unsigned s) { 56 | unsigned n = syms_space[s]; 57 | printf ("%*.*s\n", n, n, syms_space + s + 1); 58 | } 59 | 60 | // Print the name of the code block containing :address. 61 | static void print_proc_containing (unsigned address) { 62 | unsigned proc; 63 | if (0 < n_entry_points && address < entry_points[0]) { 64 | printf ("initialization\n"); 65 | return; 66 | } 67 | for (proc = 0; proc + 1 < n_entry_points; ++proc) 68 | if (entry_points[proc] <= address && address < entry_points[proc + 1]) { 69 | print_symbol (nth_symbol (proc)); 70 | return; 71 | } 72 | // TODO: simplify by searching from the end, above 73 | if (proc < n_entry_points && entry_points[proc] <= address) { 74 | print_symbol (nth_symbol (proc)); 75 | return; 76 | } 77 | printf ("wtf?\n"); 78 | } 79 | 80 | static unsigned read8 (FILE *f) { 81 | int result = getc (f); 82 | if (EOF == result) 83 | panic (ferror (f) ? strerror (errno) : "Premature EOF in read8"); 84 | return 0xFF & result; 85 | } 86 | 87 | static unsigned read16 (FILE *f) { 88 | unsigned hi = read8 (f); 89 | unsigned lo = read8 (f); 90 | return (hi << 8) | lo; 91 | } 92 | 93 | static void read_block (unsigned char *dest, unsigned size, FILE *f) { 94 | while (0 < size) { 95 | size_t n = fread (dest, 1, size, f); 96 | if (0 == n) 97 | panic (ferror (f) ? strerror (errno) : "Premature EOF in read_block"); 98 | dest += n, size -= n; 99 | } 100 | } 101 | 102 | static void load_syms (FILE *f) { 103 | unsigned n_entries = read16 (f); 104 | unsigned i; 105 | for (i = 0; i < n_entries; ++i) { 106 | unsigned address = read16 (f); 107 | assert (n_entry_points < entry_table_size); 108 | entry_points[n_entry_points++] = address; 109 | unsigned name_length = read8 (f); 110 | assert (syms_ptr + 1 + name_length <= symbol_table_size); 111 | syms_space[syms_ptr] = name_length; 112 | read_block (syms_space + syms_ptr + 1, name_length, f); 113 | syms_ptr += 1 + name_length; 114 | } 115 | } 116 | 117 | enum { tag_bits = 3 }; 118 | typedef enum { a_pair, nil, a_fixnum, a_bool, a_symbol, a_pid } Tag; 119 | static const char *tag_names[] = { 120 | "pair", "nil", "fixnum", "boolean", "symbol", "pid", 121 | }; 122 | typedef unsigned Obj; 123 | static Tag get_tag (Obj x) { return ~(~0 << tag_bits) & x; } 124 | #define ENTAG(tag, value) ( (tag) | ((value) << tag_bits) ) 125 | static Obj entag (Tag tag, unsigned value) 126 | { return ENTAG (tag, value); } 127 | static unsigned untag_fixnum (Obj x) { assert (a_fixnum == get_tag (x)); 128 | return x >> tag_bits; } 129 | 130 | 131 | typedef struct VM VM; 132 | struct VM { // A process 133 | const unsigned char *pc; // Program counter 134 | unsigned sp; // Stack pointer 135 | unsigned bp; // Base pointer 136 | Obj stack[stack_size]; 137 | Obj mailbox_head; // A queue of messages, represented by ... 138 | Obj mailbox_tail_reversed; // ... a pair of lists. 139 | unsigned pid; // Process ID 140 | VM *next; // The next process in the run queue 141 | }; 142 | 143 | static Obj globals[globals_size]; 144 | static unsigned n_globals = 0; 145 | 146 | static unsigned char code[code_size]; 147 | 148 | static VM *the_processes[process_table_size] = { }; 149 | 150 | static unsigned next_pid = 1; 151 | 152 | static unsigned vm_index (const VM *vm) { 153 | unsigned i; 154 | for (i = 0; i < process_table_size; ++i) 155 | if (the_processes[i] == vm) 156 | return i; 157 | if (NULL == vm) 158 | panic ("Process table full"); 159 | panic ("Can't happen: missing process"); assert (0); 160 | } 161 | 162 | static VM *pid_to_vm (unsigned pid) { 163 | unsigned i; 164 | for (i = 0; i < process_table_size; ++i) 165 | if (NULL != the_processes[i] && the_processes[i]->pid == pid) 166 | return the_processes[i]; 167 | return NULL; 168 | } 169 | 170 | // Pre: vm is in the process table but not on the run queue 171 | static void unmake_vm (VM *vm) { 172 | the_processes[vm_index (vm)] = NULL; 173 | free (vm); 174 | } 175 | 176 | static VM *make_vm (void) { 177 | VM *vm = allot (sizeof *vm); // XXX raise an exception on error 178 | vm->pc = code; 179 | vm->sp = -1; 180 | vm->bp = 0; 181 | vm->mailbox_head = nil; 182 | vm->mailbox_tail_reversed = nil; 183 | if (next_pid != ((next_pid << tag_bits) >> tag_bits)) 184 | panic ("Out of new PIDs"); 185 | vm->pid = next_pid++; 186 | vm->next = NULL; 187 | the_processes[vm_index (NULL)] = vm; 188 | return vm; 189 | } 190 | 191 | static VM *run_queue_predecessor; 192 | 193 | static void run_queue_advance (void) { 194 | run_queue_predecessor = run_queue_predecessor->next; 195 | } 196 | 197 | static VM *run_queue_front (void) { 198 | return run_queue_predecessor->next; 199 | } 200 | 201 | static void run_queue_pop_front (void) { 202 | if (run_queue_predecessor->next == run_queue_predecessor) 203 | exit (0); // No more processes to run. 204 | run_queue_predecessor->next = run_queue_predecessor->next->next; 205 | } 206 | 207 | static void run_queue_push_back (VM *vm) { 208 | VM *head = run_queue_predecessor->next; 209 | run_queue_predecessor->next = vm; 210 | vm->next = head; 211 | run_queue_predecessor = vm; 212 | } 213 | 214 | static void make_startup_vm (void) { 215 | VM *vm = make_vm (); 216 | run_queue_predecessor = vm->next = vm; 217 | } 218 | 219 | #define TOP(vm) ( vm->stack[vm->sp] ) 220 | static Obj pop (VM *vm) { return vm->stack[vm->sp--]; } 221 | static void push (VM *vm, Obj x) { assert (vm->sp + 1 < stack_size); 222 | vm->stack[++vm->sp] = x; } 223 | 224 | static void print_traceback (VM *vm) { 225 | unsigned p = vm->bp; 226 | for (; 0 < p; p = untag_fixnum (vm->stack[p-2])) 227 | print_proc_containing (untag_fixnum (vm->stack[p-1])); 228 | } 229 | 230 | static void panic_traceback (VM *vm, const char *plaint) { 231 | fprintf (stderr, "%s\n", plaint); 232 | print_traceback (vm); 233 | exit (1); 234 | } 235 | 236 | static unsigned untag (VM *vm, Tag tag, Obj x) { 237 | if (tag != get_tag (x)) { 238 | fprintf (stderr, "Bad type: %s (expected %s)\n", 239 | tag_names[get_tag(x)], tag_names[tag]); 240 | print_traceback (vm); 241 | exit (1); 242 | } 243 | return x >> tag_bits; 244 | } 245 | 246 | static int is_fixnum (Obj x) { 247 | return a_fixnum == get_tag (x); 248 | } 249 | static int fixnum_value (VM *vm, Obj x) { 250 | unsigned v = untag (vm, a_fixnum, x); 251 | return (((int)v) << tag_bits) >> tag_bits; // XXX unportable 252 | } 253 | static Obj make_fixnum (VM *vm, int value) { 254 | Obj result = entag (a_fixnum, (unsigned) value); 255 | if (value != fixnum_value (vm, result)) 256 | panic_traceback (vm, "Overflow"); 257 | return result; 258 | } 259 | static Obj make_long (VM *vm, long long value) { 260 | Obj result = entag (a_fixnum, (unsigned) value); 261 | if (value != fixnum_value (vm, result)) 262 | panic_traceback (vm, "Overflow"); 263 | return result; 264 | } 265 | 266 | static int is_char (Obj x) { 267 | return (a_fixnum == get_tag (x) 268 | && (x >> tag_bits) < 256); 269 | } 270 | static unsigned char char_value (VM *vm, Obj c) { 271 | return untag (vm, a_fixnum, c); // XXX range check 272 | } 273 | 274 | 275 | static Obj heap[heap_size][2]; 276 | static char marks[heap_size]; 277 | static unsigned hp = 0; 278 | 279 | static unsigned heap_index (VM *vm, Obj x) { 280 | unsigned p = untag (vm, a_pair, x); 281 | assert (p < heap_size); 282 | return p; 283 | } 284 | static Obj car (VM *vm, Obj x) { return heap[heap_index (vm, x)][0]; } 285 | static Obj cdr (VM *vm, Obj x) { return heap[heap_index (vm, x)][1]; } 286 | static void set_car (VM *vm, Obj x, Obj y) { heap[heap_index (vm, x)][0] = y; } 287 | 288 | static void mark (VM *vm, Obj x) { 289 | while (get_tag (x) == a_pair && !marks[heap_index (vm, x)]) { 290 | marks[heap_index (vm, x)] = 1; 291 | mark (vm, car (vm, x)); 292 | x = cdr (vm, x); 293 | } 294 | } 295 | static void sweep (void) { 296 | while (hp < heap_size && marks[hp]) 297 | marks[hp++] = 0; 298 | } 299 | static void gc (VM *vm, Obj car, Obj cdr) { 300 | unsigned i, j; 301 | mark (vm, car); mark (vm, cdr); 302 | for (i = 0; i <= n_globals; ++i) 303 | mark (vm, globals[i]); 304 | for (i = 0; i < process_table_size; ++i) { 305 | VM *vi = the_processes[i]; 306 | if (NULL != vi) { 307 | mark (vi, vi->mailbox_head); 308 | mark (vi, vi->mailbox_tail_reversed); 309 | for (j = 0; j <= vi->sp; ++j) 310 | mark (vi, vi->stack[j]); 311 | } 312 | } 313 | hp = 0; 314 | } 315 | 316 | static Obj cons (VM *vm, Obj car, Obj cdr) { 317 | sweep (); 318 | if (heap_size <= hp) { 319 | gc (vm, car, cdr); 320 | sweep (); 321 | if (heap_size <= hp) 322 | panic ("Heap full"); } 323 | heap[hp][0] = car; 324 | heap[hp][1] = cdr; 325 | return entag (a_pair, hp++); 326 | } 327 | 328 | static Obj reverse (VM *vm, Obj xs) { 329 | Obj acc = nil; 330 | for (; nil != xs; xs = cdr (vm, xs)) 331 | acc = cons (vm, car (vm, xs), acc); 332 | return acc; 333 | } 334 | 335 | static void send (VM *vm, Obj message) { 336 | vm->mailbox_tail_reversed = cons (vm, message, vm->mailbox_tail_reversed); 337 | } 338 | 339 | // Remove the first message from vm's mailbox and push it on its stack, 340 | // if there is one; return true iff so. 341 | static int receive (VM *vm) { 342 | if (nil == vm->mailbox_head) { 343 | vm->mailbox_head = reverse (vm, vm->mailbox_tail_reversed); 344 | vm->mailbox_tail_reversed = nil; 345 | } 346 | if (nil == vm->mailbox_head) 347 | return 0; 348 | push (vm, car (vm, vm->mailbox_head)); 349 | vm->mailbox_head = cdr (vm, vm->mailbox_head); 350 | return 1; 351 | } 352 | 353 | static void add_symbol (VM *vm, Obj chars) { 354 | unsigned i; 355 | for (i = 1; nil != chars; ++i, chars = cdr (vm, chars)) { 356 | if (symbol_table_size <= syms_ptr + i) 357 | panic ("Symbol table full"); 358 | syms_space[syms_ptr + i] = char_value (vm, car (vm, chars)); 359 | } 360 | assert (i - 1 < 256); 361 | syms_space[syms_ptr] = i - 1; 362 | syms_ptr += i; 363 | } 364 | 365 | static int is_interned_at (VM *vm, Obj chars, unsigned s) { 366 | unsigned i, length = syms_space[s]; 367 | for (i = 1; i <= length; ++i, chars = cdr (vm, chars)) 368 | if (a_pair != get_tag (chars) 369 | || !is_char (car (vm, chars)) 370 | || syms_space[s + i] != char_value (vm, car (vm, chars))) 371 | return 0; 372 | return nil == chars; 373 | } 374 | 375 | static unsigned intern (VM *vm, Obj chars) { 376 | unsigned i; 377 | for (i = 0; i < syms_ptr; i += 1 + syms_space[i]) 378 | if (is_interned_at (vm, chars, i)) 379 | return i; 380 | add_symbol (vm, chars); 381 | return i; 382 | } 383 | 384 | #define sym_f ( ENTAG (a_bool, 0) ) 385 | #define sym_t ( ENTAG (a_bool, 1) ) 386 | static Obj make_flag (int flag) { return flag ? sym_t : sym_f; } 387 | 388 | static int read_char (VM *vm) { int c = getchar (); 389 | push (vm, 390 | EOF == c 391 | ? sym_f 392 | : make_fixnum (vm, c)); 393 | return c; } 394 | 395 | #define DEF(prim) static void prim (VM *vm) 396 | DEF(prim2_eqP) { Obj z = pop (vm); 397 | TOP (vm) = make_flag (TOP (vm) == z); } 398 | DEF(prim1_nullP) { TOP (vm) = make_flag (nil == TOP (vm)); } 399 | DEF(prim1_booleanP) { TOP (vm) = make_flag (a_bool == get_tag (TOP (vm))); } 400 | DEF(prim1_charP) { TOP (vm) = make_flag (is_char (TOP (vm))); } 401 | DEF(prim1_symbolP) { TOP (vm) = make_flag (a_symbol == get_tag (TOP (vm))); } 402 | DEF(prim1_pairP) { TOP (vm) = make_flag (a_pair == get_tag (TOP (vm))); } 403 | DEF(prim2_cons) { Obj z = pop (vm); TOP (vm) = cons (vm, TOP (vm), z); } 404 | DEF(prim1_car) { TOP (vm) = car (vm, TOP (vm)); } 405 | DEF(prim1_cdr) { TOP (vm) = cdr (vm, TOP (vm)); } 406 | DEF(prim2_set_carB) { Obj z = pop (vm); set_car (vm, TOP (vm), z); 407 | TOP (vm) = sym_f; } 408 | DEF(prim0_read_char) { (void) read_char (vm); } 409 | DEF(prim0_peek_char) { ungetc (read_char (vm), stdin); } 410 | DEF(prim1_write_char) { putchar (char_value (vm, TOP (vm))); TOP (vm) = sym_f; } 411 | DEF(prim0_abort) { (void) vm; exit (1); } 412 | DEF(prim1_string_Gsymbol) 413 | { TOP (vm) = entag (a_symbol, intern (vm, TOP (vm))); } 414 | DEF(prim1_symbol_Gstring) { 415 | unsigned s = untag (vm, a_symbol, TOP (vm)); 416 | unsigned i, length = syms_space[s]; 417 | TOP (vm) = nil; 418 | for (i = length; 0 < i; --i) 419 | TOP (vm) = cons (vm, make_fixnum (vm, syms_space[s + i]), TOP (vm)); 420 | } 421 | 422 | static Obj add (VM *vm, Obj a, Obj b) { 423 | return make_fixnum (vm, fixnum_value (vm, a) + fixnum_value (vm, b)); 424 | } 425 | static Obj sub (VM *vm, Obj a, Obj b) { 426 | return make_fixnum (vm, fixnum_value (vm, a) - fixnum_value (vm, b)); 427 | } 428 | static Obj mul (VM *vm, Obj a, Obj b) { 429 | return make_long (vm, (long long)fixnum_value (vm, a) * fixnum_value (vm, b)); 430 | } 431 | static Obj divide (VM *vm, Obj a, Obj b) { 432 | int bv = fixnum_value (vm, b); 433 | if (bv == 0) 434 | panic_traceback (vm, "Division by 0"); 435 | return make_fixnum (vm, fixnum_value (vm, a) / bv); 436 | } 437 | static Obj rem (VM *vm, Obj a, Obj b) { 438 | int bv = fixnum_value (vm, b); 439 | if (bv == 0) 440 | panic_traceback (vm, "Division by 0"); 441 | return make_fixnum (vm, fixnum_value (vm, a) % bv); 442 | } 443 | 444 | DEF(prim2_add) { Obj z = pop (vm); TOP (vm) = add (vm, TOP (vm), z); } 445 | DEF(prim2_sub) { Obj z = pop (vm); TOP (vm) = sub (vm, TOP (vm), z); } 446 | DEF(prim2_mul) { Obj z = pop (vm); TOP (vm) = mul (vm, TOP (vm), z); } 447 | DEF(prim2_div) { Obj z = pop (vm); TOP (vm) = divide (vm, TOP (vm), z); } 448 | DEF(prim2_rem) { Obj z = pop (vm); TOP (vm) = rem (vm, TOP (vm), z); } 449 | 450 | DEF(prim1_fixnumP) { TOP (vm) = make_flag (is_fixnum (TOP (vm))); } 451 | 452 | DEF(prim2_lt) { Obj z = pop (vm); 453 | TOP (vm) = make_flag (fixnum_value (vm, TOP (vm)) 454 | < fixnum_value (vm, z)); } 455 | 456 | DEF(prim1_pidP) { TOP (vm) = make_flag (a_pid == get_tag (TOP (vm))); } 457 | 458 | DEF(prim2_send) { Obj z = pop (vm); 459 | VM *receiver = pid_to_vm (untag (vm, a_pid, TOP (vm))); 460 | if (NULL != receiver) 461 | send (receiver, z); 462 | TOP (vm) = sym_f; } 463 | 464 | enum { 465 | op_halt, 466 | op_enframe, 467 | op_call, 468 | op_tailcall, 469 | op_nparams, 470 | op_return, 471 | op_global, 472 | op_local, 473 | op_branch, 474 | op_jump, 475 | op_pop, 476 | op_char, 477 | op_nil, 478 | op_false, 479 | op_true, 480 | op_eqP, 481 | op_nullP, 482 | op_booleanP, 483 | op_charP, 484 | op_pairP, 485 | op_cons, 486 | op_car, 487 | op_cdr, 488 | op_set_carB, 489 | op_read_char, 490 | op_peek_char, 491 | op_write_char, 492 | op_abort, 493 | op_symbolP, 494 | op_string_Gsymbol, 495 | op_symbol_Gstring, 496 | op_add, 497 | op_sub, 498 | op_mul, 499 | op_div, 500 | op_rem, 501 | op_fixnumP, 502 | op_fixnum, 503 | op_lt, 504 | op_pidP, 505 | op_self, 506 | op_spawn, 507 | op_send, 508 | op_receive, 509 | op_defglobal, 510 | }; 511 | 512 | static int find_halt (void) { 513 | unsigned i; 514 | for (i = 0; i < code_size; ++i) 515 | if (op_halt == code[i]) 516 | return i; 517 | panic ("HALT instruction missing"); assert (0); 518 | } 519 | 520 | static unsigned decode16 (const unsigned char *address) { 521 | return (address[0]<<8) + address[1]; 522 | } 523 | 524 | static int decode_int32 (const unsigned char *address) { 525 | unsigned u = (((((address[0]<<8)+address[1])<<8)+address[2])<<8)+address[3]; 526 | return (int) u; // XXX sign-extend portably 527 | } 528 | 529 | #define CASE(value) \ 530 | break; case value: \ 531 | TRACE2 ("\n%zd %s\t", vm->pc - code, #value); 532 | 533 | #define NEXT(incr) ( vm->pc += (incr) ) 534 | 535 | // Run from the front of the run queue for up to the given number of steps. 536 | static void run (unsigned steps) { 537 | VM *vm = run_queue_front (); 538 | 539 | // A stack frame looks like this, growing upwards: 540 | // sp[0]: topmost temporary 541 | // ...temporaries... 542 | // bp[n-1]: rightmost argument (where n is the number of arguments) 543 | // ... 544 | // bp[0]: leftmost argument 545 | // bp[-1]: return address (encoded as a_fixnum) 546 | // bp[-2]: old bp (encoded as a_fixnum) 547 | // (this is also where the return value will go) 548 | // (Except that when starting up there's nothing below the temporaries.) 549 | // When we first enter the function, there are no temporaries; when we're 550 | // ready to execute op_return, there's only one temporary left, the return 551 | // value. 552 | 553 | for (; 0 < steps; --steps) { 554 | // An instruction may take up to 5 bytes: 555 | assert ((unsigned) (vm->pc - code) < code_size - 4u); 556 | switch (vm->pc[0]) { 557 | default: panic ("Unknown opcode"); 558 | 559 | CASE(op_halt) run_queue_pop_front (); unmake_vm (vm); return; 560 | CASE(op_enframe) push (vm, make_fixnum (vm, vm->bp)); 561 | push (vm, make_fixnum (vm, 0)); // slot for return 562 | NEXT (1); 563 | CASE(op_call) TRACE1 ("%u", vm->pc[1]); 564 | vm->bp = vm->sp - vm->pc[1] + 1; 565 | vm->stack[vm->bp-1] = 566 | make_fixnum (vm, vm->pc - code + 4); 567 | vm->pc = code + decode16 (vm->pc + 2); 568 | CASE(op_tailcall) { unsigned nargs = vm->pc[1]; 569 | memmove (vm->stack + vm->bp, 570 | vm->stack + vm->sp - nargs + 1, 571 | nargs * sizeof vm->stack[0]); 572 | vm->sp = vm->bp + nargs - 1; 573 | vm->pc = code + decode16 (vm->pc + 2); } 574 | CASE(op_nparams) TRACE1 ("%u", vm->pc[1]); 575 | if (vm->pc[1] != vm->sp - vm->bp + 1) 576 | panic_traceback (vm, "Bad arity"); 577 | NEXT (2); 578 | CASE(op_return) { unsigned old_bp = untag (vm, a_fixnum, 579 | vm->stack[vm->bp - 2]); 580 | vm->pc = code + untag (vm, a_fixnum, 581 | vm->stack[vm->bp - 1]); 582 | vm->stack[vm->bp - 2] = vm->stack[vm->sp]; 583 | vm->sp = vm->bp - 2; 584 | vm->bp = old_bp; } 585 | CASE(op_global) { unsigned g = decode16 (vm->pc + 1); 586 | TRACE1 ("%u", g); 587 | if (n_globals <= g) 588 | panic_traceback (vm, "Uninitialized global"); 589 | push (vm, globals[g]); 590 | NEXT (3); } 591 | CASE(op_local) TRACE1 ("%u", vm->pc[1]); 592 | push (vm, vm->stack[vm->bp + vm->pc[1]]); NEXT (2); 593 | CASE(op_branch) NEXT (sym_f == pop (vm) ? decode16 (vm->pc + 1) : 3); 594 | CASE(op_jump) NEXT (decode16 (vm->pc + 1)); 595 | CASE(op_pop) pop (vm); NEXT (1); 596 | CASE(op_char) TRACE1 ("%c", vm->pc[1]); 597 | push (vm, make_fixnum (vm, vm->pc[1])); NEXT (2); 598 | CASE(op_nil) push (vm, nil); NEXT (1); 599 | CASE(op_false) push (vm, sym_f); NEXT (1); 600 | CASE(op_true) push (vm, sym_t); NEXT (1); 601 | 602 | CASE(op_eqP) prim2_eqP (vm); NEXT (1); 603 | CASE(op_nullP) prim1_nullP (vm); NEXT (1); 604 | CASE(op_booleanP) prim1_booleanP (vm); NEXT (1); 605 | CASE(op_charP) prim1_charP (vm); NEXT (1); 606 | CASE(op_pairP) prim1_pairP (vm); NEXT (1); 607 | CASE(op_cons) prim2_cons (vm); NEXT (1); 608 | CASE(op_car) prim1_car (vm); NEXT (1); 609 | CASE(op_cdr) prim1_cdr (vm); NEXT (1); 610 | CASE(op_set_carB) prim2_set_carB (vm); NEXT (1); 611 | CASE(op_read_char) prim0_read_char (vm); NEXT (1); 612 | CASE(op_peek_char) prim0_peek_char (vm); NEXT (1); 613 | CASE(op_write_char) prim1_write_char (vm); NEXT (1); 614 | CASE(op_abort) prim0_abort (vm); NEXT (1); 615 | 616 | CASE(op_symbolP) prim1_symbolP (vm); NEXT (1); 617 | CASE(op_string_Gsymbol) prim1_string_Gsymbol (vm); NEXT (1); 618 | CASE(op_symbol_Gstring) prim1_symbol_Gstring (vm); NEXT (1); 619 | 620 | CASE(op_add) prim2_add (vm); NEXT (1); 621 | CASE(op_sub) prim2_sub (vm); NEXT (1); 622 | CASE(op_mul) prim2_mul (vm); NEXT (1); 623 | CASE(op_div) prim2_div (vm); NEXT (1); 624 | CASE(op_rem) prim2_rem (vm); NEXT (1); 625 | 626 | CASE(op_fixnumP) prim1_fixnumP (vm); NEXT (1); 627 | 628 | CASE(op_fixnum) TRACE1 ("%d", decode_int32 (vm->pc + 1)); 629 | push (vm, 630 | make_fixnum (vm, decode_int32 (vm->pc + 1))); 631 | NEXT (5); 632 | 633 | CASE(op_lt) prim2_lt (vm); NEXT (1); 634 | 635 | CASE(op_pidP) prim1_pidP (vm); NEXT (1); 636 | CASE(op_self) push (vm, entag (a_pid, vm->pid)); NEXT (1); 637 | 638 | CASE(op_spawn) TRACE1 ("%u", vm->pc[1]); 639 | { VM *nvm = make_vm (); 640 | unsigned n = vm->pc[1]; 641 | nvm->pc = code + decode16 (vm->pc + 2); 642 | 643 | // Push a halt continuation on, first: 644 | nvm->stack[0] = make_fixnum (vm, 0); 645 | nvm->stack[1] = make_fixnum (vm, find_halt ()); 646 | 647 | memcpy (nvm->stack + 2, 648 | vm->stack + vm->sp - n + 1, 649 | n * sizeof nvm->stack[0]); 650 | nvm->bp = 2; 651 | nvm->sp = 2 + n - 1; 652 | run_queue_push_back (nvm); 653 | 654 | vm->sp -= n; 655 | push (vm, entag (a_pid, nvm->pid)); 656 | NEXT (4); } 657 | 658 | CASE(op_send) prim2_send (vm); NEXT (1); 659 | CASE(op_receive) if (receive (vm)) 660 | NEXT (1); 661 | else 662 | goto yield; 663 | 664 | // XXX use of this opcode had better be serialized! 665 | CASE(op_defglobal) if (globals_size <= n_globals) 666 | panic ("Too many globals"); 667 | globals[n_globals++] = pop (vm); 668 | NEXT (1); 669 | } 670 | } 671 | yield: 672 | run_queue_advance (); 673 | } 674 | 675 | static void running (void) { 676 | for (;;) 677 | run (100); 678 | } 679 | 680 | static FILE *open_file (const char *filename, const char *mode) { 681 | if (0 == strcmp (filename, "-")) 682 | return 'r' == mode[0] ? stdin : stdout; 683 | { 684 | FILE *f = fopen (filename, mode); 685 | if (!f) 686 | panic (strerror (errno)); 687 | return f; 688 | } 689 | } 690 | 691 | static void load_stream (FILE *f) { 692 | unsigned char *p = code; 693 | while (p < code + code_size) { 694 | size_t n = fread (p, 1, code + code_size - p, f); 695 | if (0 == n) 696 | break; 697 | p += n; 698 | } 699 | if (ferror (f)) 700 | panic (strerror (errno)); 701 | if (!feof (f)) 702 | panic ("Code too big"); 703 | } 704 | 705 | static void load_file (const char *filename) { 706 | FILE *f = open_file (filename, "rb"); 707 | load_syms (f); 708 | load_stream (f); 709 | fclose (f); 710 | } 711 | 712 | int main (int argc, char **argv) { 713 | if (2 != argc) 714 | panic ("Usage: elv filename"); 715 | load_file (argv[1]); 716 | make_startup_vm (); 717 | running (); 718 | return 0; 719 | } 720 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | {one line to give the program's name and a brief idea of what it does.} 635 | Copyright (C) {year} {name of author} 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | {project} Copyright (C) {year} {fullname} 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | --------------------------------------------------------------------------------