├── .gitignore ├── ISSUES.md ├── Makefile ├── README.md ├── docs ├── SECD.md └── Scheme.md ├── include └── secd │ ├── conf.h │ ├── secd.h │ └── secd_io.h ├── repl.scm ├── scm2secd.scm ├── scm2secd.secd ├── secd.c ├── secdscheme ├── std ├── andor.scm ├── hashtable.scm ├── lazy.scm ├── lists.scm └── ports.scm ├── tests ├── append.scm ├── append.secd ├── cyrillic.txt ├── define.scm ├── dynwind.scm ├── eval.scm ├── hello.secd ├── load.scm ├── loop.secd ├── parser.scm ├── qsort.scm ├── r7rs-compliance.scm ├── rbtree.scm ├── regex.scm ├── secd.scm ├── secdtool.scm ├── test1.secd ├── test2.secd ├── test_fact.secd ├── test_io.secd ├── test_tco.secd └── ukrainian.scm └── vm ├── env.c ├── env.h ├── interp.c ├── machine.c ├── memory.c ├── memory.h ├── native.c ├── ports.c ├── readparse.c └── secdops.h /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.a 3 | *~ 4 | libsecd.c 5 | .*.swp 6 | .depend 7 | repl.secd 8 | secd 9 | tags 10 | -------------------------------------------------------------------------------- /ISSUES.md: -------------------------------------------------------------------------------- 1 | Tasks Pending: 2 | ============= 3 | | Task | Description 4 | |-------|------------------------------------------------ 5 | | T6 | move to indexes instead of `cell_t *` - ? 6 | | T7 | audit for refcounting correctness 7 | | T8 | Scheme parser in Scheme 8 | | T9 | Scheme language testing framework + tests 9 | | T11 | static check for TCO during function compilation, APTR? 10 | | T12 | fast environment lookup: self-bal. tree? Static analysis for free variables? -> LDV index 11 | | T13 | inline `let` lambdas: ST opcode 12 | | T14 | static analysis: rewrite simple tail-call iterations into loops 13 | | T16 | change #.OP syntax to be compatible with other interpreters; eliminate compile_control_path() ? Scheme enum type? 14 | | T19 | `letrec*`, `let*`; analyses for dependencies in large `letrec*`s 15 | | T20 | numbers: floating point, libgmp? 16 | | T22 | unquote-splicing 17 | | T24 | `dynamic-wind`, fix exceptions 18 | | T25 | `eq?`, `eqv?`, `equal?` according to R7RS 19 | | T26 | abstract away ad-hoc `assert`-typing for native functions 20 | | T27 | CELL_CLOS for closures, <= T16, T13, T14, T11 21 | | F3 | FEATURE: non-blocking I/O, green threads + mailboxes + messaging 22 | | F5 | FEATURE: small FFI, native modules as .so 23 | | F6 | FEATURE: LLVM-backend 24 | 25 | Tasks Done: 26 | =========== 27 | | Task | Description 28 | |-------|-------------------- 29 | | T1 | move symbols to the heap; 30 | | T2 | `ATOM_CHAR`: read/print, support, `char->int` 31 | | T3 | bytevectors, `utf8->string` 32 | | T4 | reader: dot-lists 33 | | T5 | refactor out `atom_type` 34 | | T7 | polymorhic CAR/CDR; use arrays for `ATOM_OP` 35 | | T8 | `open-input-port`, `port?`, `read`, `read-u8`, `read-string` 36 | | T10 | static check for stack correctness: tests/secdtool.scm:valid-stack 37 | | T15 | exception handling; dynamic environment? 38 | | T17 | arity checks for function calls 39 | | T18 | or/and macros 40 | | T23 | native hashtables 41 | | F1 | FEATURE: fast symbol lookup 42 | | F2 | FEATURE: alternative garbade collection - (secd 'gc), mark & sweep 43 | 44 | Defects Pending: 45 | =============== 46 | | Defect| Description 47 | |-------|-------------------- 48 | | D5 | Crash on `(list->vector (read-file (open-input-file "repl.scm")))` (large lists?) 49 | | D6 | the Yin-Yang call/cc puzzle does not work as expected 50 | | D9 | `eval` does not use the supplied environment 51 | 52 | Defects Fixed: 53 | ============= 54 | | Defect| Description 55 | |-------|-------------------- 56 | | D3 | Crash on `(make-vector 1 '())` 57 | | D1 | `(eq? "str" "str")` not handled 58 | | D2 | Crash on reading `#()` 59 | | D4 | Crash on freeing result of `(make-vector 2 'any)` -- part of T1 60 | | D9 | `(test-ap)`/`secd_execute()` does not work 61 | | D7 | secdtool:free-variables does not handle #.DUM - #.RAP correctly 62 | | D8 | crash on (secd 'gc) 63 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | VM := ./secd 2 | REPL := repl.secd 3 | SECDCC := scm2secd.secd 4 | CFLAGS += -Wall -I./include 5 | 6 | SRC_DIR := vm 7 | 8 | .PHONY: clean libsecd 9 | .PHONY: install uninstall 10 | 11 | secdscheme: $(VM) $(REPL) 12 | 13 | $(REPL): repl.scm 14 | 15 | $(VM): secd.o libsecd.a 16 | $(CC) $(CFLAGS) $^ -o $@ 17 | 18 | .depend: 19 | @echo " MKDEPEND" 20 | @$(CC) -MM *.h *.c > $@ 21 | 22 | 23 | %.secd: %.scm $(VM) 24 | @echo " SECDCC $@" 25 | @$(VM) scm2secd.secd < $< > tmp.secd && mv tmp.secd $@ 26 | 27 | libsecd: libsecd.a 28 | 29 | libsecd.a: libsecd.o 30 | $(AR) -r $@ $^ 31 | 32 | # the world simplest build system: cat! 33 | libsecd.c: 34 | cat include/secd/conf.h include/secd/secd.h include/secd/secd_io.h >> $@ 35 | cat vm/secdops.h vm/env.h vm/memory.h >> $@ 36 | cat vm/*.c >> $@ 37 | sed -i 's/^#include ".*"//' $@ 38 | 39 | 40 | install: $(VM) $(REPL) 41 | mkdir -p $(INSTALL_DIR)/bin $(INSTALL_DIR)/share/secdscheme/secd $(INSTALL_DIR)/share/secdscheme/std 42 | cp $(VM) $(REPL) $(SECDCC) secdscheme $(INSTALL_DIR)/share/secdscheme/secd/ 43 | cp repl.scm scm2secd.scm std/* $(INSTALL_DIR)/share/secdscheme/std/ 44 | echo "#!/bin/sh" > $(INSTALL_DIR)/bin/secdscheme 45 | echo 'exec $(INSTALL_DIR)/share/secdscheme/secd/secdscheme $$@' >> $(INSTALL_DIR)/bin/secdscheme 46 | chmod +x $(INSTALL_DIR)/bin/secdscheme 47 | 48 | uninstall: 49 | test -d "$(INSTALL_DIR)" 50 | rm -r "$(INSTALL_DIR)/" 51 | 52 | clean: 53 | @echo " rm *.o" 54 | @rm secd *.o 2>/dev/null || true 55 | @echo " rm libsecd*" 56 | @rm libsecd* 2>/dev/null || true 57 | 58 | 59 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | SECDScheme 2 | ========== 3 | 4 | [![Join the chat at https://gitter.im/EarlGray/SECD](https://badges.gitter.im/EarlGray/SECD.svg)](https://gitter.im/EarlGray/SECD?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) 5 | 6 | This is a loose implementation of [SECD machine](http://en.wikipedia.org/wiki/SECD) and a simple self-hosted Scheme-to-SECD compiler/interpreter. 7 | 8 | Running Scheme: 9 | ``` 10 | $ ./secdscheme 11 | ;>> (+ 2 2) 12 | 4 13 | 14 | ;>> (define n 10) 15 | n 16 | 17 | ;>> (define (sqr x) (* x x)) 18 | sqr 19 | 20 | ;>> (define apply-to-42 (lambda (g) (g 42))) 21 | apply-to-42 22 | 23 | ;>> (apply-to-42 sqr) 24 | 1764 25 | 26 | ;>> (define (fact n) (if (eq? n 0) 1 (* n (fact (- n 1))))) 27 | fact 28 | 29 | ;>> (fact 10) 30 | 3628800 31 | 32 | ;>> (load "std/lists.scm") 33 | ok 34 | 35 | ;>> (filter odd (range 12)) 36 | (1 3 5 7 9 11) 37 | 38 | ;>> (begin (display 'bye) (quit)) 39 | bye 40 | $ 41 | ``` 42 | 43 | Running bare [SECD opcodes](docs/SECD.md): 44 | ``` 45 | $ echo "(STOP)" | ./secd 46 | $ echo "(LDC 2 LDC 2 ADD PRINT STOP)" | ./secd 47 | $ ./secd < tests/append.secd 48 | (1 2 3 4 5 6) 49 | ``` 50 | 51 | The design is mostly inspired by detailed description in _Functional programming: Application and Implementation_ by Peter Henderson and his LispKit, but is not limited by the specific details of traditional SECD implementations (like 64 Kb size of heap, etc) and R7RS. 52 | 53 | Here is [a series of my blog posts about SECD machine](http://dmytrish.wordpress.com/2013/08/09/secd-about) 54 | 55 | Join a [Gitter chat](https://gitter.im/EarlGray/SECD) if you want to discuss the project or need help with it. 56 | -------------------------------------------------------------------------------- /docs/SECD.md: -------------------------------------------------------------------------------- 1 | SECD implementation internals 2 | ============================= 3 | 4 | Opcodes and operational semantics 5 | --------------------------------- 6 | 7 | The machine's state is represented as tuple of 4 lists: 8 | * S for (computational) stack 9 | * E for environment: 10 | Environment is a list of frames. 11 | Each frame is a pair (cons) of two lists: 12 | the first for symbol names, 13 | the second for bound values. 14 | The first frame represents the global environment and built-in routines. 15 | * C for control path (list of opcodes to execute) 16 | * D for dump (stack): it's for storing S/E/C that must be restored later 17 | 18 | This state is written as `(s, e, c, d)`. 19 | 20 | Notation: `(x.s)` means cons of value `x` and list `s`. Recursively, `(x.y.s)` means `(x.(y.s))`. An empty list may be written as `nil`, so `(v.nil)` is equal to `(v)`, `(x.y.nil)` to `(x y)`, etc. 21 | 22 | **The current opcode set and the operational semantics**: 23 | 24 | ADD, SUB, MUL, DIV, REM 25 | : (x.y.s, e, OP.c, d) -> ((x OP y).s, e, c, d) 26 | LEQ : (x.y.s, e, LEQ.c, d) -> ((x < y? #t : nil).s, e, c, d) 27 | 28 | CAR : ((x._).s, e, CAR.c, d) -> (x.s, e, c, d) 29 | CDR : ((_.x).s, e, CDR.c, d) -> (x.s, e, c, d) 30 | CONS : (x.y.s, e, CONS.c, d) -> ((x.y).s, e, c, d) 31 | 32 | LDC v : (s, e, LDC.v.c, d) -> (v.s, e, c, d) 33 | LD sym : (s, e, LD.sym.c, d) -> ((lookup e sym).s, e, c, d) 34 | 35 | TYPE : (v.s, e, TYPE.c, d) -> ((typeof v).s, e, c, d) 36 | where typeof returns a symbol describing variable type 37 | EQ : (v1.v2.s, e, EQ.c, d) -> ((eq? v1 v2).s, e, c, d) 38 | 39 | SEL : (v.s, e, SEL.thenb.elseb.c, d) 40 | -> (s, e, (if v then thenb else elseb), c.d) 41 | JOIN : (s, e, JOIN.nil, c.d) -> (s, e, c, d) 42 | 43 | LDF : (s, e, LDF.(args body).c, d) -> (clos.s, e, c, d) 44 | where closure `clos` is ((args body).e); 45 | `args` is a list of argument name symbols; 46 | `body` is control path of the function. 47 | 48 | AP : (((args c') . e').argv.s, e, AP.c, d) 49 | -> (nil, (frame args argv).e', c', kont(s,e,c).d) 50 | -- a closure ((args c1) . e') must be on the stack, 51 | -- followed by list of argument values `argv`. 52 | 53 | ((kont(s',e',c').d').(v).s, e, AP.c, d) 54 | -> (v.s', e', c', d') 55 | -- run continuation with value v 56 | 57 | RTN : (v.nil, e', RTN.nil, kont(s,e,c).d) -> (v.s, e, c, d) 58 | 59 | APCC : ((((arg) c') . e').s, e, APCC.c, d) 60 | -> (nil, (frame (arg=(kont(s, e, c) . d))).e', c', kont(s,e,c).d) 61 | -- captures the continuation that can be called with AP 62 | 63 | DUM : (s, e, DUM.c, d) -> (s, Ω.e, c, d) 64 | RAP : (clos.argv.s, Ω.e, RAP.c, d) 65 | -> (nil, set-car!(frame(args, argv), Ω.e'), c', s.e.c.d) 66 | where `clos` is ((args c').(Ω.e')) 67 | 68 | PRINT : side-effect of printing the head of S: 69 | (v.s, e, PRINT.c, d) -> (v.s, e, c, d) -- printing v 70 | 71 | READ : puts the input s-expression on top of S: 72 | (s, e, READ.c, d) -> ((read).s, e, c, d) 73 | 74 | There are functions implemented in C (`native.c`): 75 | - `append`, `list`: heavily used by the compiler, native for efficiency; 76 | - `eof-object?`, `secd-hash`, `defined?`; 77 | - `secd-bind!` used for binding global variables like `(secd-bind! 'sym val)`. Top-level `define` macros desugar to `secd-bind!`; 78 | - i/o related: `display`, `open-input-file`, `open-input-string`, `read-char`, `read-u8`, `read-string`, `port-close`; 79 | - `secd`: takes a symbol as the first argument, outputs the following: current tick number with `(secd 'tick)`, prints current environment for `(secd 'env)`, shows how many cells are available with `(secd 'free)`; memory info with `(secd 'mem)`, the array heap layout with `(secd 'heap)`. 80 | - `interaction-environment` - this native form returns the current environment, the last frame is the global environment; 81 | - vector-related: `make-vector`, `vector-length`, `vector-ref`, `vector-set!`, `vector->list`, `list->vector`; 82 | - bytevectors: `make-bytevector`, `bytevector-length`, `bytevector-u8-ref`, `bytevector-u8-set!`, `utf8->string`, `string->utf8`; 83 | - string-related: `string-length`, `string-ref`, `string->list`, `list->string`, `symbol->string`, `string->symbol`; 84 | - `char->integer`, `integer->char`; 85 | 86 | **About types:** 87 | Supported types are (see `secd.h`, `enum cell_type`): 88 | - CONSes that make persistent lists; 89 | - ARRAYs, that implement Scheme vectors; 90 | - STR, implementing UTF-8 encoded Unicode strings. Strings are immutable, contrary to R7RS; 91 | - BYTES, implementing bytevectors as described in R7RS; 92 | - SYMs, implementing symbols; 93 | - INTs, a platform-specific `long int` C type; not an arbitrary-precision integer; 94 | - CHARs, a unicode point below 0x10fff; 95 | - FUNCs, built-in native functions; 96 | - OPs, SECD operations; 97 | - PORTs, Scheme I/O ports, file/string based, with other backends possible in the future; 98 | 99 | Internal types: 100 | - CELL_UNDEF, non-initialized value that is default for cells in non-initialized vectors; 101 | - CELL_FRAME, a frame of the environment; 102 | - CELL_ARRMETA: cells for arrays metainformation; 103 | - CELL_REF: just a pointer to another cell; used to include NILs into arrays; 104 | - CELL_FREE: this cell may be allocated; 105 | - CELL_ERROR: contains an exception thrown by failed opcode execution; 106 | 107 | Boolean values are Scheme symbols `#t` and `#f`. Any values except `#f` are evaluated to `#t`. 108 | 109 | **Mutability and sharing** 110 | Values are persistent, immutable and shared. Arrays are really handles for access to "mutable" memory. Array cells are owned by its array and are copied on every access from Scheme. Setting a cell in array means destructing the previous value and initialization of the cell with copy of the new value. If you want to emulate mutable variables, use array boxing: 111 | ``` Scheme 112 | ;; emulating a counter object: 113 | (define (make-counter) 114 | (let ((count (box 0))) ;; desugars to (make-vector 1 0) 115 | (let ((get (lambda () (box-ref count))) ;; desugars to (vector-ref count 0) 116 | ;; desugars to (vector-set! count 0 ...): 117 | (inc (lambda () (box-set! count (+ 1 (box-ref count)))))) 118 | (lambda (msg) 119 | (cond 120 | ((eq? msg 'inc) (inc)) 121 | ((eq? msg 'get) (get)) 122 | (else 'do-not-understand)))))) 123 | 124 | (define counter (make-counter)) 125 | (counter 'get) ;; => 0 126 | (counter 'inc) 127 | (counter 'get) ;; => 1 128 | ``` 129 | 130 | **Memory management**: 131 | Memory is managed using reference counting by default, a simple optional Mark&Sweep garbage collection is available via `(secd 'gc)` 132 | 133 | *Reference counting*. Every cell after allocation must be shared with `share_cell()` - this increments the refcount of the cell. When a cell is not used anymore, it must be `drop_cell()`d - it decrements the refcount and if it's 0 `free_cell()` is called. To initialize a cell of an array, use `copy_value()` of other cell. If a cell in an array must be set, previous value must be destructed with `drop_value()` to drop all its owned cells. 134 | 135 | SECD occupes a contiguous region of memory divided into cells of type `cell_t` (starting at `secd->begin` and ending just before `secd->end`). The SECD heap is divided into 3 regions: _persistent heap_ from `secd->begin` to `secd->fixedptr`, _the free space_ from `secd->fixedptr` to `secd->arrayptr`, _array heap_ from `secd->arrayptr` to `secd->arrlist` (`secd->arrlist` is the last cell before `secd->end`). 136 | _Persistent heap_ is for quick (_O(1)_) allocation of one cell (of any type except CELL_ARRMETA and CELL_UNDEF). All cells in the persistent heap belong to one of five lists: `secd->stack`, `secd->env`, `secd->control`, `secd->dump`, `secd->free`. Some information about the persistent heap is available in REPL via `(secd 'mem)`. To view information about a specific cell by its number, use `(secd 'cell cell-num)` in REPL (like `(secd 'cell 1)`. 137 | 138 | _Array heap_ is a sparse double-linked list of CELL_ARRMETA that reflects memory order: `meta->as.mcons.next` always points to the left adjacent CELL_ARRMETA and `meta->as.mcons.prev` to the right one; the list starts at `secd->arrlist` and grows to lesser addresses. Gaps between CELL_ARRMETA are arrays managed by the left adjacent CELL_ARRMETA. Arrays have their own refcount, so there may be any non-zero number of CELL_ARRAY/CELL_STRING/CELL_BYTES in the persistent heap or in cells of other arrays pointing to that CELL_ARRMETA space, so CELL_ARRAY are persistent as well and may be copied harmlessly using `copy_value()`. Arrays are: used/free, their space may be treated as bytes (for strings and bytevectors) or cells (for vectors) - this information is stored in CELL_ARRMETA. All cells in a vector have refcount 1 and must be copied into the persistent heap on every access. Information about heap layout is available in REPL via `(secd 'heap)`. 139 | 140 | _Memory allocation/release_. Allocation of one cell is very quick: it uses head of `cell->free` double-linked list. If `secd->free` is empty, `secd->fixedptr` is incremented for persistent heap to grow into the free space. Allocation of arrays is more complicated: it's basically a first-fit allocator starting at `secd->arrlist` and looking for a free gap of sufficient size in the array heap, that gap is divided into the new array and possibly a smaller free gap. If there is no such gap, `secd->arrayptr` is moved into the free space to allocate an array of the given size just after `secd->arrayptr`. 141 | 142 | If `secd->fixedptr` or `secd->arrayptr` can't be moved (there is no free space between them), SECD machine fails with `'error:_out_of_memory`. 143 | 144 | Deallocation: if a cell from the persistent heap is released and it's adjacent to `secd->fixedptr`, `secd->fixedptr` is decremented to release all free cells adjacent to the free space. Otherwise the cell is prepended to `secd->free` list. If an array is released and its CELL_ARRMETA is at `secd->arrayptr`, `secd->arrayptr` is moved to reclaim its memory to the free space, otherwise this array is marked as free and all dependencies of its cells are `drop_cell`d; if there are free adjacent gaps, they are merged with the new one. 145 | 146 | If you want to see the full machine state as a text file, do `(secd 'dump)` - the machine state will be serialized into file `secdstate.dump`. 147 | 148 | **Garbage collection** 149 | `(secd 'gc)` implements Mark&Sweep GC. See `secd_mark_and_sweep_gc()` in `memory.c` for details. 150 | 151 | **Symbol storage**. 152 | Symbol strings are stored in the _symstore_: it's a list of bytevector buffers in the array heap. Symbols are only created and can't be deleted (like in EVM, this allows to avoid reallocation of symbol on each repeated function call). Symbol string pointers are unique: if such symbol string already exists, a pointer to the existing string is shared, otherwise full (32-bit) hash of the string and this string with ending '\0' is appended into the last buffer in the symstore; if there is no space in that buffer, a new buffer is allocated. String lookup is implemented by a chained rebalancing hashtable that points to a symbol string by symbol hash. 153 | 154 | **Input/output**: `READ`/`PRINT` are implemented as built-in opcodes in C code. Scheme ports are half-implemented at the moment (see the list of native I/O functions). `(load "path/to/file.scm")` is implemented by the interpreter. 155 | To use a port for READ/PRINT, override variables `*stdin*` and `*stdout*` respectively: 156 | ```scheme 157 | (let ((*stdin* (open-input-string "(+ 2 2)"))) (read)) ;=> '(+ 2 2) 158 | ``` 159 | 160 | **Tail-recursion**: added tail-recursive calls optimization. 161 | The criterion for tail-recursion optimization: given a function A which calls a function B, which calles a function C, if B does not mess the stack after C call (that is, returns the value produced by C to A), we can drop saving B state (its S,E,C) on the dump when calling C. "Not messing the stack" means that there are no commands other than `JOIN`, `RTN` and combo `CONS CAR` (used by the Scheme compiler to implement `(begin)` forms) between `AP` in B and B's `RTN`. Also all `SEL` return points saved on the dump must be dropped. 162 | The check for validity of TR optimization is done by function `new_dump_if_tailrec()` in `interp.c` for every AP. 163 | 164 | Tail-recursion modifies AP operation to not save S,E,C of the current function on the dump, also dropping all conditional branches return points saved on the dump: 165 | 166 | AP (with TR) : ( ((args c').e').argv.s, e, AP.c, j1.j2...jN.d) 167 | -> (nil, frame(args, argv).e', c', d) 168 | where j1, j2, ..., jN are jump return points saved by SELs in the current function. 169 | 170 | RTN : not changed, it just loads A's state from the dump in C's `RTN`. 171 | 172 | 173 | **Continuations** 174 | SECDScheme supports compiling `call/cc` using a special opcode, APCC. Captured continuations may be called just like a function that takes a single argument: 175 | ```scheme 176 | ;;;; Example #1 177 | >> 178 | (define (any pred lst) 179 | (call/cc (lambda (return) 180 | (for-each 181 | (lambda (x) (if (pred x) 182 | (return #t) ;; jump out, returning #t instead of call/cc body 183 | #f)) lst) 184 | #f))) 185 | 186 | ;; Example #2 187 | >> (define cc (box #f)) 188 | >> (define (val!) (call/cc (lambda (k) (box-set! cc k) 1))) 189 | >> (+ 1 (* 10 (val!))) 190 | 11 191 | >> ((box-ref cc) 2) 192 | 21 193 | >> ((box-ref cc) 3) 194 | 31 195 | ``` 196 | 197 | -------------------------------------------------------------------------------- /docs/Scheme.md: -------------------------------------------------------------------------------- 1 | Scheme compiler: scm2secd.scm and repl.scm 2 | ------------------------------------------ 3 | 4 | `scm2secd.scm` file a simple compiler from Scheme to SECD code. It is written in a quite limited subset of Scheme (using `let`/`letrec` instead of `define`, though now it supports `define` definitions). It does not have all the goodies of `repl.scm`, so keep in mind that `repl.scm` is compiled with `scm2secd.scm`, so the former must use (simpler) language compilable with `scm2secd.scm`. 5 | `repl.scm` has much more featureful Scheme compiler. 6 | There is a `define` macro. In top-level definitions it desugars to a native function `(secd-bind! 'symbol value)`. A macro can be defined with macro `define-macro` which works just like in Guile. 7 | 8 | The compiler is self-hosted and can be bootstrapped using its pre-compiled SECD code in `scm2secd.secd`: 9 | 10 | ```bash 11 | # self-bootstrapping: 12 | $ ./secd scm2secd.secd scm2secd.1.secd 13 | $ mv scm2secd.1.secd scm2secd.secd 14 | 15 | # or, using a bootstrapping interpreter (tested with guile and mzscheme): 16 | $ guile -s scm2secd.scm scm2secd.secd 17 | $ mzscheme -f scm2secd.scm scm2secd.secd 18 | ``` 19 | 20 | Scheme expression and files may be evaluated this way: 21 | ```bash 22 | $ cat tests/append.scm | ./secd scm2secd.secd | ./secd 23 | ``` 24 | 25 | Bootstrapping REPL: 26 | ```bash 27 | $ ./secd scm2secd.secd repl.secd 28 | $ ./secd repl.secd 29 | >> (append '(1 2 3) '(4 5 6)) 30 | (1 2 3 4 5 6) 31 | 32 | >> (begin (display 'bye) (quit)) 33 | bye 34 | 35 | $ 36 | ``` 37 | 38 | Use `secd-compile` function to examine results of Scheme-to-SECD conversion in the REPL: 39 | ```scheme 40 | >> (secd-compile '(+ 2 2)) 41 | (LDC 2 LDC 2 ADD) 42 | 43 | >> (let ((*stdin* (open-input-file "repl.scm"))) (secd-compile (read))) 44 | ... ;; full compiled code of repl.scm 45 | 46 | >> (eval '(+ 2 2) (interaction-environment)) 47 | 4 48 | 49 | ``` 50 | -------------------------------------------------------------------------------- /include/secd/conf.h: -------------------------------------------------------------------------------- 1 | #ifndef __SECD_CONF_H___ 2 | #define __SECD_CONF_H___ 3 | 4 | #define TAILRECURSION 1 5 | #define CASESENSITIVE 1 6 | 7 | #define TYPE_BITS 8 8 | #define NREF_BITS (8 * sizeof(size_t) - TYPE_BITS) 9 | 10 | #define DONT_FREE_THIS (1ul << (8 * sizeof(size_t) - TYPE_BITS - 2)) 11 | 12 | #if CASESENSITIVE 13 | # define str_eq(s1, s2) !strcmp(s1, s2) 14 | # define str_cmp(s1, s2) strcmp(s1, s2) 15 | #else 16 | # define str_eq(s1, s2) !strcasecmp(s1, s2) 17 | # define str_cmp(s1, s2) strcasecmp(s1, s2) 18 | #endif 19 | 20 | #define MEMDEBUG 0 21 | #define MEMTRACE 0 22 | #define CTRLDEBUG 0 23 | #define ENVDEBUG 0 24 | #define TIMING 0 25 | 26 | #endif //__SECD_CONF_H___ 27 | 28 | -------------------------------------------------------------------------------- /include/secd/secd.h: -------------------------------------------------------------------------------- 1 | #ifndef __SECD_H__ 2 | #define __SECD_H__ 3 | 4 | #include "conf.h" 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | #ifndef __unused 13 | # define __unused __attribute__((unused)) 14 | #endif 15 | 16 | #define errorf(...) secd_errorf(secd, __VA_ARGS__) 17 | 18 | /* 19 | * Macros that check input not to be SECD_NIL or CELL_ERROR: 20 | */ 21 | #define assert_or_continue(cond, ...) \ 22 | if (!(cond)) \ 23 | { errorf(__VA_ARGS__); errorf("\n"); continue; } 24 | 25 | #define assert(cond, ...) \ 26 | if (!(cond)) { \ 27 | errorf(__VA_ARGS__); errorf("\n"); \ 28 | return new_error(secd, SECD_NIL, __VA_ARGS__); } 29 | 30 | #define assert_cell(cond, msg) assert_cellf((cond), "%s", msg) 31 | 32 | #define assert_cellf(cond, fmt, ...) \ 33 | if (is_error(cond)) { \ 34 | errorf(fmt, __VA_ARGS__); errorf("\n"); \ 35 | return new_error_with(secd, (cond), fmt, __VA_ARGS__); } 36 | 37 | 38 | #define asserti(cond, ...) \ 39 | if (!(cond)) { errorf(__VA_ARGS__); errorf("\n"); return 0; } 40 | 41 | #define assertv(cond, ...) \ 42 | if (!(cond)) { errorf(__VA_ARGS__); errorf("\n"); return; } 43 | 44 | #define SECD_NIL NULL 45 | 46 | #define SECD_FALSE "#f" 47 | #define SECD_TRUE "#t" 48 | 49 | typedef uint32_t hash_t; 50 | 51 | typedef struct secd secd_t; 52 | typedef struct cell cell_t; 53 | 54 | typedef struct cons cons_t; 55 | typedef struct symbol symbol_t; 56 | typedef struct error error_t; 57 | typedef struct frame frame_t; 58 | typedef struct port port_t; 59 | typedef struct array array_t; 60 | typedef struct string string_t; 61 | 62 | /* machine operation set */ 63 | typedef enum { 64 | /* (a&int . b&int . s, e, ADD . c, d) -> (a+b . s, e, c, d) */ 65 | SECD_ADD, 66 | 67 | /* (clos(args, c', e').argv.s, e, AP.c, d) 68 | * -> (nil, frame(args, argv).e', c', kont(s.e.c).d) 69 | * ((kont(s', e', c').d').v.s, e, c, d) -> (v.s', e', c', d') 70 | */ 71 | SECD_AP, 72 | 73 | /* (clos((arg), c', e').s, e, APCC.c, d) 74 | * -> (nil, frame(arg=(kont(s,e,c).d)).e', c', d) 75 | */ 76 | SECD_APCC, 77 | 78 | /* (v&cons . s, e, CAR.c, d) -> ((car v).s, e, c, d) */ 79 | SECD_CAR, 80 | /* (v&cons . s, e, CDR.c, d) -> ((cdr v).s, e, c, d) */ 81 | SECD_CDR, 82 | /* (hd . tl . s, e, CONS.c, d) -> ((hd . tl).s, e, c, d) */ 83 | SECD_CONS, 84 | /* (x&int . y&int . s, e, DIV.c, d) -> ((x/y).s, e, c, d) */ 85 | SECD_DIV, 86 | /* (s, e, DUM.c, d) -> (s, dummyframe.e, c, d) */ 87 | SECD_DUM, 88 | /* (x . y . s, e, EQ.c, d) -> ((eq? x y) . s, e, c, d) */ 89 | SECD_EQ, 90 | /* (s, e, JOIN.nil, c'.d) -> (s, e, c', d) */ 91 | SECD_JOIN, 92 | /* (s, e, LD.v.c, d) -> (lookup(v, e).s, e, c, d) */ 93 | SECD_LD, 94 | /* (s, e, LDC.v.c, d) -> (v.s, e, c, d) */ 95 | SECD_LDC, 96 | /* (s, e, LDF.(args c').c, d) -> (clos(args, c', e).s, e, c, d) */ 97 | SECD_LDF, 98 | /* (x&int . y&int . s, e, LEQ.c, d) -> ((x <= y).s, e, c, d) */ 99 | SECD_LEQ, 100 | /* (x&int . y&int . s, e, MUL.c, d) -> ((x * y).s, e, c, d) */ 101 | SECD_MUL, 102 | /* (v.s, e, PRINT.c, d) -> (v.s, e, c, d) with priting v to *stdout* */ 103 | SECD_PRN, 104 | /* (clos(args, c', e').argv.s, e', RAP.c, d) 105 | * -> (nil, set-car!(frame(args, argv), e'), c', kont(s, cdr(e'), c).d) 106 | */ 107 | SECD_RAP, 108 | /* (s, e, READ.c, d) -> (v.s, e, c, d) where v is read from *stdin* */ 109 | SECD_READ, 110 | /* (x&int . y&int . s, e, REM.c, d) -> ((x mod y).s, e, c, d) */ 111 | SECD_REM, 112 | /* (v.nil, e, RTN.nil, kont(s',e',c').d) -> (v.s', e', c', d) */ 113 | SECD_RTN, 114 | /* (v&bool . s, e, SEL.thenc.elsec.c, d) -> (s, e, (v ? thenc : elsec), c.d) */ 115 | SECD_SEL, 116 | /* (v.s, e, c, d) -> stop. */ 117 | SECD_STOP, 118 | /* (x&int . y&int . s, e, SUB.c, d) -> ((x - y).s, e, c, d) */ 119 | SECD_SUB, 120 | /* (v . s, e, TYPE.c, d) -> (type(v).s, e, c, d) */ 121 | SECD_TYPE, 122 | 123 | SECD_LAST, // not an operation 124 | } opindex_t; 125 | 126 | enum cell_type { 127 | CELL_UNDEF, // also marks secd->free 128 | 129 | /* compound types */ 130 | CELL_CONS, // shares two other cells, car and cdr 131 | CELL_ARRAY, // shares a pointer to cell_t[] in array heap. 132 | CELL_STR, // shares a pointer to a UTF8 byte sequence 133 | CELL_BYTES, // shares a pointer to a raw byte sequence 134 | CELL_FRAME, // a environment frame, private; the same as CELL_CONS 135 | CELL_KONT, // continuation: (stack, env, ctrl) 136 | CELL_ARRMETA, // array metadata, private; a double linked node like CELL_CONS 137 | CELL_FREE, // free list node; a double linked node like CELL_CONS 138 | 139 | CELL_REF, // a pivot point between compound and atomic types 140 | 141 | /* atomic types */ 142 | CELL_SYM, 143 | CELL_INT, 144 | CELL_CHAR, 145 | CELL_OP, 146 | CELL_FUNC, 147 | CELL_PORT, // I/O handle 148 | 149 | CELL_ERROR, 150 | }; 151 | 152 | typedef cell_t* (*secd_opfunc_t)(secd_t *); 153 | typedef cell_t* (*secd_nativefunc_t)(secd_t *, cell_t *); 154 | 155 | struct cons { 156 | cell_t *car; // shares 157 | cell_t *cdr; // shares 158 | }; 159 | 160 | struct symbol { 161 | size_t size; 162 | const char *data; 163 | cell_t *bvect; 164 | }; 165 | 166 | struct frame { 167 | struct cons cons; // must be first to cast to cons 168 | cell_t *io; // cons of *stdin* and *stdout* for the frame 169 | }; 170 | 171 | struct kont { 172 | cell_t *stack; 173 | cell_t *env; 174 | cell_t *ctrl; 175 | }; 176 | 177 | struct metacons { 178 | cell_t *prev; // prev from arrlist, arrlist-ward 179 | cell_t *next; // next from arrlist, arrptr-ward 180 | bool free:1; // is area free 181 | bool cells:1; // does area contain cells 182 | }; 183 | 184 | struct port { 185 | unsigned char type:3; 186 | bool input:1; 187 | bool output:1; 188 | long data[2]; 189 | }; 190 | 191 | struct error { 192 | cell_t *info; // owned object 193 | cell_t *msg; // owned string 194 | cell_t *kont; // owned cont. or NIL 195 | }; 196 | 197 | struct string { 198 | char *data; 199 | ptrdiff_t offset; // bytes 200 | size_t size; // bytes 201 | }; 202 | 203 | struct array { 204 | cell_t *data; // array 205 | ptrdiff_t offset; // cells 206 | }; 207 | 208 | 209 | cell_t *new_error(secd_t *, cell_t *info, const char *fmt, ...); 210 | cell_t *new_errorv(secd_t *secd, cell_t *info, const char *fmt, va_list va); 211 | cell_t *new_error_with(secd_t *secd, cell_t *preverr, const char *fmt, ...); 212 | 213 | struct cell { 214 | enum cell_type type:TYPE_BITS; 215 | size_t nref:NREF_BITS; 216 | 217 | union { // if cell_type is: 218 | cons_t cons; // CELL_CONS, CELL_FREE 219 | symbol_t sym; // CELL_SYM 220 | frame_t frame; // CELL_FRAME 221 | port_t port; // CELL_PORT 222 | error_t err; // CELL_ERR 223 | string_t str; // CELL_STR 224 | array_t arr; // CELL_ARRAY, CELL_BYTES 225 | int num; // CELL_INT, CELL_CHAR 226 | void *ptr; // CELL_FUNC 227 | cell_t *ref; // CELL_REF 228 | opindex_t op; // CELL_OP 229 | struct metacons mcons; // CELL_ARRMETA 230 | struct kont kont; // CELL_KONT 231 | } as; 232 | }; 233 | 234 | #define SECD_PORTTYPES_MAX 8 235 | 236 | typedef struct portops portops_t; 237 | 238 | typedef enum { 239 | SECD_NOPOST = 0, 240 | SECDPOST_GC, 241 | SECDPOST_MACHINE_DUMP 242 | } secdpostop_t; 243 | 244 | typedef struct secd_stat { 245 | size_t used_stack; 246 | size_t used_control; 247 | size_t used_dump; 248 | size_t free_cells; 249 | size_t n_alloc; 250 | } secd_stat_t; 251 | 252 | struct secd { 253 | /**** memory layout ****/ 254 | /* pointers: begin, fixedptr, arrayptr, end 255 | * - should keep the same position ordering at run-time */ 256 | cell_t *begin; // the first cell of the heap 257 | 258 | /* these lists reside between secd->begin and secd->fixedptr */ 259 | cell_t *stack; // list 260 | cell_t *env; // list of CELL_FRAME 261 | cell_t *control; // list of CELL_OP 262 | cell_t *dump; // list of CELL_KONT 263 | 264 | cell_t *free; // double-linked list 265 | cell_t *global_env; // frame 266 | cell_t *symstore; // symbol storage info array 267 | 268 | // all cells before this one are fixed-size cells 269 | cell_t *fixedptr; // pointer 270 | 271 | /* some free space between these two pointers for both to grow in */ 272 | 273 | cell_t *arrayptr; // pointer 274 | // this one and all cells after are managed memory for arrays 275 | 276 | cell_t *arrlist; // cdr points to the double-linked list of array metaconses 277 | 278 | cell_t *end; // the last cell of the heap 279 | 280 | /**** I/O ****/ 281 | cell_t *input_port; 282 | cell_t *output_port; 283 | cell_t *error_port; 284 | cell_t *debug_port; 285 | portops_t* portops[SECD_PORTTYPES_MAX]; 286 | 287 | /* booleans */ 288 | cell_t *truth_value; 289 | cell_t *false_value; 290 | 291 | /* how many opcodes executed */ 292 | unsigned long tick; 293 | 294 | /* some operation to be done after the current opcode */ 295 | secdpostop_t postop; 296 | 297 | /* some statistics */ 298 | secd_stat_t stat; 299 | }; 300 | 301 | 302 | /* 303 | * Cell accessors 304 | */ 305 | extern int secd_errorf(secd_t *, const char *, ...); 306 | 307 | inline static enum cell_type cell_type(const cell_t *c) { 308 | if (!c) return CELL_CONS; 309 | return c->type; 310 | } 311 | 312 | inline static bool is_nil(const cell_t *cell) { 313 | return cell == SECD_NIL; 314 | } 315 | 316 | inline static bool not_nil(const cell_t *cell) { 317 | return cell != SECD_NIL; 318 | } 319 | 320 | inline static long cell_index(secd_t *secd, const cell_t *cons) { 321 | if (is_nil(cons)) return -1; 322 | return cons - secd->begin; 323 | } 324 | 325 | inline static const char * symname(const cell_t *c) { 326 | if (cell_type(c) != CELL_SYM) { 327 | return NULL; 328 | } 329 | return c->as.sym.data; 330 | } 331 | inline static hash_t symhash(const cell_t *c) { 332 | if (cell_type(c) != CELL_SYM) { 333 | return 0; 334 | } 335 | return ((hash_t *)c->as.sym.data)[-1]; 336 | } 337 | 338 | inline static int numval(const cell_t *c) { 339 | return c->as.num; 340 | } 341 | inline static const char *strval(const cell_t *c) { 342 | switch (cell_type(c)) { 343 | case CELL_STR: case CELL_BYTES: break; 344 | default: return NULL; 345 | } 346 | return c->as.str.data; 347 | } 348 | inline static char *strmem(cell_t *c) { 349 | switch (cell_type(c)) { 350 | case CELL_STR: case CELL_BYTES: break; 351 | default: return NULL; 352 | } 353 | return c->as.str.data; 354 | } 355 | 356 | inline static const char * errmsg(const cell_t *err) { 357 | return strval(err->as.err.msg); 358 | } 359 | 360 | void dbg_print_cell(secd_t *secd, const cell_t *c); 361 | 362 | inline static cell_t *list_next(secd_t *secd, const cell_t *cons) { 363 | if (cell_type(cons) != CELL_CONS) { 364 | errorf("list_next: not a cons at [%ld]\n", cell_index(secd, cons)); 365 | dbg_print_cell(secd, cons); 366 | return NULL; 367 | } 368 | return cons->as.cons.cdr; 369 | } 370 | 371 | inline static cell_t *list_head(const cell_t *cons) { 372 | return cons->as.cons.car; 373 | } 374 | 375 | inline static cell_t *get_car(const cell_t *cons) { 376 | return cons->as.cons.car; 377 | } 378 | inline static cell_t *get_cdr(const cell_t *cons) { 379 | return cons->as.cons.cdr; 380 | } 381 | inline static bool is_cons(const cell_t *cell) { 382 | if (is_nil(cell)) return true; 383 | return cell_type(cell) == CELL_CONS; 384 | } 385 | inline static bool is_symbol(const cell_t *cell) { 386 | return cell_type(cell) == CELL_SYM; 387 | } 388 | inline static bool is_number(const cell_t *cell) { 389 | return cell->type == CELL_INT; 390 | } 391 | 392 | inline static bool is_error(const cell_t *cell) { 393 | if (is_nil(cell)) return false; 394 | return cell_type(cell) == CELL_ERROR; 395 | } 396 | 397 | inline static bool is_input(const cell_t *port) { 398 | return port->as.port.input; 399 | } 400 | inline static bool is_output(const cell_t *port) { 401 | return port->as.port.output; 402 | } 403 | 404 | inline static cell_t *mcons_prev(cell_t *mcons) { 405 | return mcons->as.mcons.prev; 406 | } 407 | inline static cell_t *mcons_next(cell_t *mcons) { 408 | return mcons->as.mcons.next; 409 | } 410 | 411 | #define INIT_FUNC(func) { \ 412 | .type = CELL_FUNC, \ 413 | .nref = DONT_FREE_THIS, \ 414 | .as.ptr = (func) } 415 | 416 | /* 417 | * reader/parser 418 | */ 419 | 420 | void dbg_print_cell(secd_t *secd, const cell_t *c); 421 | void dbg_printc(secd_t *secd, cell_t *c); 422 | 423 | void sexp_print(secd_t *secd, const cell_t *c); 424 | void sexp_pprint(secd_t *secd, cell_t *port, const cell_t *c); 425 | void sexp_display(secd_t *secd, cell_t *port, cell_t *cell); 426 | 427 | /* Reads S-expressions from port. 428 | * If port is SECD_NIL, defaults to secd->input_port */ 429 | cell_t *sexp_parse(secd_t *secd, cell_t *port); 430 | cell_t *sexp_lexeme(secd_t *secd, int line, int pos, int prevchar); 431 | 432 | cell_t *read_secd(secd_t *secd); 433 | 434 | /* 435 | * machine 436 | */ 437 | 438 | secd_t * init_secd(secd_t *secd, cell_t *heap, size_t ncells); 439 | cell_t * run_secd(secd_t *secd, cell_t *ctrl); 440 | 441 | /* serialization */ 442 | cell_t *serialize_cell(secd_t *secd, cell_t *cell); 443 | cell_t *secd_mem_info(secd_t *secd); 444 | 445 | /* control path */ 446 | bool is_control_compiled(cell_t *control); 447 | cell_t *compile_control_path(secd_t *secd, cell_t *control); 448 | 449 | cell_t *secd_execute(secd_t *secd, cell_t *clos, cell_t *argv); 450 | cell_t *secd_raise(secd_t *secd, cell_t *exc); 451 | 452 | /* 453 | * utilities 454 | */ 455 | hash_t secd_strhash(const char *strz); 456 | 457 | const cell_t *secd_default_equal_fun(void); 458 | const cell_t *secd_default_hash_fun(void); 459 | 460 | cell_t *secd_first(secd_t *secd, cell_t *stream); 461 | cell_t *secd_rest(secd_t *secd, cell_t *stream); 462 | 463 | /* return a symbol describing the cell */ 464 | cell_t *secd_type_sym(secd_t *secd, const cell_t *cell); 465 | 466 | /* in the sense of 'equal?' */ 467 | bool is_equal(secd_t *secd, const cell_t *a, const cell_t *b); 468 | 469 | inline static cell_t *to_bool(secd_t *secd, bool cond) { 470 | return ((cond)? secd->truth_value : secd->false_value); 471 | } 472 | inline static bool secd_bool(secd_t *secd, cell_t *cell) { 473 | if (is_symbol(cell) && (is_equal(secd, cell, secd->false_value))) 474 | return false; 475 | return true; 476 | } 477 | 478 | #endif //__SECD_H__ 479 | -------------------------------------------------------------------------------- /include/secd/secd_io.h: -------------------------------------------------------------------------------- 1 | #ifndef __SECD_IO_H_ 2 | #define __SECD_IO_H_ 3 | 4 | #include 5 | #include "secd.h" 6 | 7 | #define SECD_EOF (-1) 8 | #define EOF_OBJ "#" 9 | 10 | enum secd_portstd { 11 | SECD_STDIN, 12 | SECD_STDOUT, 13 | SECD_STDERR, 14 | SECD_STDDBG, 15 | }; 16 | 17 | typedef const char * (*portinfo_func_t)(secd_t *, cell_t *, cell_t **); 18 | typedef int (*portopen_func_t)(secd_t *, cell_t *, const char *mode, cell_t *params); 19 | typedef int (*portgetc_func_t)(secd_t *, cell_t *); 20 | typedef long (*portsize_func_t)(secd_t *, cell_t *); 21 | typedef int (*portvprintf_func_t)(secd_t *, cell_t *, const char *, va_list); 22 | typedef size_t (*portread_func_t)(secd_t *, cell_t *, size_t, char *); 23 | typedef int (*portclose_func_t)(secd_t *, cell_t *); 24 | typedef cell_t *(*portowns_func_t)(secd_t*, cell_t *,cell_t **, cell_t **, cell_t **); 25 | typedef cell_t *(*portstd_func_t)(secd_t*, enum secd_portstd); 26 | 27 | struct portops { 28 | portinfo_func_t pinfo; 29 | portopen_func_t popen; 30 | portgetc_func_t pgetc; 31 | portread_func_t pread; 32 | portvprintf_func_t pvprintf; 33 | portsize_func_t psize; 34 | portclose_func_t pclose; 35 | portowns_func_t powns; 36 | portstd_func_t pstd; 37 | }; 38 | 39 | 40 | cell_t *secd_stdin(secd_t *secd); 41 | cell_t *secd_stdout(secd_t *secd); 42 | cell_t *secd_stderr(secd_t *secd); 43 | cell_t *secd_stddbg(secd_t *secd); 44 | cell_t *secd_setport(secd_t *secd, enum secd_portstd std, cell_t *dbgport); 45 | 46 | int secd_popen(secd_t *secd, cell_t *p, const char *mode, cell_t *info); 47 | long secd_portsize(secd_t *secd, cell_t *port); 48 | int secd_pclose(secd_t *secd, cell_t *port); 49 | 50 | int secd_pgetc(secd_t *secd, cell_t *port); 51 | size_t secd_pread(secd_t *secd, cell_t *port, char *s, int size); 52 | 53 | int secd_printf(secd_t *secd, const char *format, ...); 54 | int secd_errorf(secd_t *secd, const char *format, ...); 55 | int secd_pprintf(secd_t *secd, cell_t *port, const char *format, ...); 56 | int secd_vpprintf(secd_t *secd, cell_t *port, const char *format, va_list ap); 57 | 58 | void sexp_print_port(secd_t *secd, const cell_t *port); 59 | void sexp_pprint_port(secd_t *secd, cell_t *p, const cell_t *port); 60 | 61 | cell_t *secd_pserialize(secd_t *secd, cell_t *p); 62 | cell_t *secd_newport(secd_t *secd, const char *mode, const char *ty, cell_t *params); 63 | cell_t *secd_newport_by_name(secd_t *secd, const char *mode, const char *ty, const char * name); 64 | cell_t *secd_port_owns(secd_t *secd, cell_t *p, cell_t **, cell_t **, cell_t **); 65 | 66 | const char * secd_porttyname(secd_t *secd, int ty); 67 | int secd_pdump_array(secd_t *secd, cell_t *p, cell_t *mcons); 68 | 69 | static inline bool is_closed(cell_t *port) { 70 | return !port->as.port.input && !port->as.port.output; 71 | } 72 | 73 | void secd_init_ports(secd_t *secd); 74 | 75 | #include "conf.h" 76 | 77 | #if (MEMDEBUG) 78 | # define memdebugf(...) if (not_nil(secd->debug_port)) { \ 79 | secd_printf(secd, secd->debug_port, "%ld | ", secd->tick); \ 80 | secd_printf(secd, secd->debug_port, __VA_ARGS__); \ 81 | } 82 | # if (MEMTRACE) 83 | # define memtracef(...) printf(__VA_ARGS__) 84 | # else 85 | # define memtracef(...) 86 | # endif 87 | #else 88 | # define memdebugf(...) 89 | # define memtracef(...) 90 | #endif 91 | 92 | #if (CTRLDEBUG) 93 | # define ctrldebugf(...) if (not_nil(secd->debug_port)) { \ 94 | secd_printf(secd, secd->debug_port, "%ld | ", secd->tick); \ 95 | secd_printf(secd, secd->debug_port, __VA_ARGS__); \ 96 | } 97 | #else 98 | # define ctrldebugf(...) 99 | #endif 100 | 101 | #if (ENVDEBUG) 102 | # define envdebugf(...) secd_printf(secd, secd->debug_port, __VA_ARGS__) 103 | #else 104 | # define envdebugf(...) 105 | #endif 106 | 107 | #ifndef __unused 108 | # define __unused __attribute__((unused)) 109 | #endif 110 | 111 | inline static cell_t *secd_fopen(secd_t *secd, const char *fname, const char *mode) { 112 | return secd_newport_by_name(secd, mode, "file", fname); 113 | } 114 | 115 | #endif //__SECD_IO_H_; 116 | -------------------------------------------------------------------------------- /repl.scm: -------------------------------------------------------------------------------- 1 | (letrec 2 | ;; what: 3 | ( 4 | ;; 5 | ;; List routines 6 | ;; 7 | 8 | (list-ref (lambda (xs nth) 9 | (cond 10 | ((null? xs) (raise 'err_out_of_bounds)) 11 | ((eq? nth 0) (car xs)) 12 | (else (list-ref (cdr xs) (- nth 1)))))) 13 | 14 | (list-tail (lambda (lst nth) 15 | (cond 16 | ((eq? nth 0) lst) 17 | ((null? lst) (raise 'err_out_of_bounds)) 18 | (else (list-tail (cdr lst) (- nth 1)))))) 19 | 20 | ;; (unzip '((one 1) (two 2) (three 3))) => ((one two three) (1 2 3)) 21 | (unzip (lambda (ps) 22 | (letrec 23 | ((unzipt 24 | (lambda (pairs z1 z2) 25 | (if (null? pairs) 26 | (list (reverse z1) (reverse z2)) 27 | (let ((pair (car pairs)) 28 | (rest (cdr pairs))) 29 | (let ((p1 (car pair)) 30 | (p2 (cadr pair))) 31 | (unzipt rest (cons p1 z1) (cons p2 z2)))))))) 32 | (unzipt ps '() '())))) 33 | 34 | (memq (lambda (obj lst) 35 | (cond 36 | ((null? lst) #f) 37 | ((eq? obj (car lst)) lst) 38 | (else (memq obj (cdr lst)))))) 39 | 40 | (assq (lambda (obj alist) 41 | (cond 42 | ((null? alist) #f) 43 | ((eq? (caar alist) obj) (car alist)) 44 | (else (assq obj (cdr alist)))))) 45 | 46 | (list-index (lambda (lst obj) 47 | (letrec ((loop 48 | (lambda (l i) 49 | (cond 50 | ((null? l) #f) 51 | ((eq? (car l) obj) i) 52 | (else (loop (cdr l) (+ i 1))))))) 53 | (loop lst 0)))) 54 | 55 | (list-fold (lambda (func val lst) 56 | (cond 57 | ((null? lst) val) 58 | (else (list-fold func (func (car lst) val) (cdr lst)))))) 59 | 60 | (length (lambda (lst) (list-fold (lambda (x v) (+ 1 v)) 0 lst))) 61 | (reverse (lambda (lst) (list-fold cons '() lst))) 62 | (for-each (lambda (func lst) (list-fold (lambda (x _) (func x)) #f lst))) 63 | (map (lambda (func lst) (reverse (list-fold (lambda (x v) (cons (func x) v)) '() lst)))) 64 | 65 | (vector-map (lambda (func vect) 66 | (let ((vectlen (vector-length vect))) 67 | (letrec 68 | ((result (make-vector vectlen)) 69 | (iter (lambda (index) 70 | (if (<= vectlen index) 71 | result 72 | (begin 73 | (vector-set! result index (func (vector-ref vect index))) 74 | (iter (+ 1 index))))))) 75 | (iter 0))))) 76 | 77 | 78 | ;; 79 | ;; Scheme to SECD compiler 80 | ;; 81 | 82 | (compile-bindings 83 | (lambda (bs) 84 | (if (null? bs) '(LDC ()) 85 | (append (compile-bindings (cdr bs)) 86 | (secd-compile (car bs)) 87 | '(CONS))))) 88 | 89 | (compile-n-bindings 90 | (lambda (bs) 91 | (if (null? bs) '() 92 | (append (compile-n-bindings (cdr bs)) 93 | (secd-compile (car bs)))))) 94 | 95 | (compile-begin-acc 96 | (lambda (stmts acc) ; acc must be '(LDC ()) at the beginning 97 | (if (null? stmts) 98 | (append acc '(CAR)) 99 | (compile-begin-acc (cdr stmts) 100 | (append acc (secd-compile (car stmts)) '(CONS)))))) 101 | 102 | (compile-cond 103 | (lambda (conds) 104 | (if (null? conds) 105 | '(LDC ()) 106 | (let ((clause-cond (car (car conds))) 107 | (clause-body (cdr (car conds)))) 108 | (let ((compiled-body 109 | (if (eq? (car clause-body) '=>) 110 | (secd-compile (cadr clause-body)) 111 | (secd-compile (cons 'begin clause-body))))) 112 | (if (eq? clause-cond 'else) 113 | compiled-body 114 | (append (secd-compile clause-cond) '(SEL) 115 | (list (append compiled-body '(JOIN))) 116 | (list (append (compile-cond (cdr conds)) '(JOIN)))))))))) 117 | 118 | (compile-quasiquote 119 | (lambda (lst) 120 | (cond 121 | ((null? lst) (list 'LDC '())) 122 | ((pair? lst) 123 | (let ((hd (car lst)) (tl (cdr lst))) 124 | (cond 125 | ((not (pair? hd)) 126 | (append (compile-quasiquote tl) (list 'LDC hd 'CONS))) 127 | ((eq? (car hd) 'unquote) 128 | (append (compile-quasiquote tl) (secd-compile (cadr hd)) '(CONS))) 129 | ;; TODO: (unquote a1 a2 ...) 130 | ((eq? (car hd) 'unquote-splicing) 131 | (display 'Error:_unquote-splicing_TODO)) ;; TODO 132 | (else (append (compile-quasiquote tl) 133 | (compile-quasiquote hd) '(CONS)))))) 134 | (else (list 'LDC lst))))) 135 | 136 | (compile-form (lambda (f) 137 | (let ((hd (car f)) 138 | (tl (cdr f))) 139 | (cond 140 | ((eq? hd 'quote) 141 | (list 'LDC (car tl))) 142 | ((eq? hd 'quasiquote) 143 | (compile-quasiquote (car tl))) 144 | ((eq? hd '+) 145 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(ADD))) 146 | ((eq? hd '-) 147 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(SUB))) 148 | ((eq? hd '*) 149 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(MUL))) 150 | ((eq? hd '/) 151 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(DIV))) 152 | ((eq? hd 'remainder) 153 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(REM))) 154 | ((eq? hd '<=) 155 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(LEQ))) 156 | ((eq? hd 'secd-type) 157 | (append (secd-compile (car tl)) '(TYPE))) 158 | ((eq? hd 'car) 159 | (append (secd-compile (car tl)) '(CAR))) 160 | ((eq? hd 'cdr) 161 | (append (secd-compile (car tl)) '(CDR))) 162 | ((eq? hd 'cons) 163 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(CONS))) 164 | ((eq? hd 'eq? ) 165 | (append (secd-compile (car tl)) (secd-compile (cadr tl)) '(EQ))) 166 | ((eq? hd 'if ) 167 | (let ((condc (secd-compile (car tl))) 168 | (thenb (append (secd-compile (cadr tl)) '(JOIN))) 169 | (elseb (append (secd-compile (caddr tl)) '(JOIN)))) 170 | (append condc '(SEL) (list thenb) (list elseb)))) 171 | ((eq? hd 'lambda) 172 | (let ((args (car tl)) 173 | (body (append (secd-compile (cons 'begin (cdr tl))) '(RTN)))) 174 | (list 'LDF (list args body)))) 175 | ((eq? hd 'let) 176 | (cond 177 | ((symbol? (car tl)) ;; let-loop 178 | (let ((loopname (car tl)) 179 | (bindings (unzip (cadr tl))) 180 | (body (cddr tl))) 181 | (let ((args (car bindings)) 182 | (exprs (cadr bindings))) 183 | (let ((loopfun 184 | (list 'letrec 185 | (list (list loopname (list 'lambda args (cons 'begin body)))) 186 | (cons loopname exprs)))) 187 | (begin 188 | ;(display loopfun) 189 | (secd-compile loopfun)))))) 190 | (else ;; just let 191 | (let ((bindings (unzip (car tl))) 192 | (body (cdr tl))) 193 | (let ((args (car bindings)) 194 | (exprs (cadr bindings))) 195 | (append (compile-bindings exprs) 196 | (list 'LDF 197 | (list args 198 | (append (secd-compile (cons 'begin body)) '(RTN)))) 199 | '(AP))))))) 200 | ((eq? hd 'letrec) 201 | (let ((bindings (unzip (car tl))) 202 | (body (cdr tl))) 203 | (let ((args (car bindings)) 204 | (exprs (cadr bindings))) 205 | (append '(DUM) 206 | (compile-bindings exprs) 207 | (list 'LDF 208 | (list args 209 | (append (secd-compile (cons 'begin body)) '(RTN)))) 210 | '(RAP))))) 211 | 212 | ;; (begin (e1) (e2) ... (eN)) => LDC () CONS CONS ... CONS CAR 213 | ((eq? hd 'begin) 214 | (cond 215 | ((null? tl) '(LDC ())) ;; (begin) 216 | ((null? (cdr tl)) (secd-compile (car tl))) ;; (begin (expr)) => (expr) 217 | ;; TODO: actually, few (define ...) in a row must be rewritten to (letrec* ..) 218 | ((eq? 'define (caar tl)) 219 | (let ((defform (car tl)) 220 | (body (cdr tl))) 221 | (let ((what (cadr defform)) 222 | (expr (caddr defform))) 223 | (cond 224 | ((symbol? 'what) 225 | (let ((letexpr 226 | (list 'let (list `(,what ,expr)) (cons 'begin body)))) 227 | (secd-compile letexpr))) 228 | ;;((pair? 'what) ; TODO: check for let/letrec 229 | (else 'Error:_define_what?))))) 230 | (else (compile-begin-acc tl '(LDC ()))))) 231 | ((eq? hd 'cond) 232 | (compile-cond tl)) 233 | ((eq? hd 'write) 234 | (append (secd-compile (car tl)) '(PRINT))) 235 | ((eq? hd 'read) 236 | '(READ)) 237 | ((eq? hd 'eval) 238 | (append '(LDC () LDC ()) (secd-compile (car tl)) 239 | '(CONS LD secd-from-scheme AP AP))) 240 | ;(secd-compile `((secd-from-scheme ,(car tl))))) 241 | ((eq? hd 'secd-apply) 242 | (cond 243 | ((null? tl) (display 'Error:_secd-apply_requires_args)) 244 | ((null? (cdr tl)) (display 'Error:_secd-apply_requires_second_arg)) 245 | (else (append (secd-compile (car (cdr tl))) (secd-compile (car tl)) '(AP))))) 246 | ((eq? hd 'call/cc) 247 | (append (secd-compile (car tl)) '(APCC))) 248 | ((eq? hd 'quit) 249 | '(STOP)) 250 | (else 251 | (let ((macro (lookup-macro hd))) 252 | (if (null? macro) 253 | ;; it is a form 254 | (let ((compiled-head 255 | (if (symbol? hd) (list 'LD hd) (secd-compile hd))) 256 | (nbinds (length tl))) 257 | (append (compile-n-bindings tl) compiled-head (list 'AP nbinds))) 258 | ;; it is a macro application 259 | (let ((evalclos (secd-apply macro tl))) 260 | (begin 261 | ;(display evalclos) ;; expanded macro 262 | (secd-compile evalclos)))))) 263 | )))) 264 | 265 | (secd-compile (lambda (s) 266 | (cond 267 | ((pair? s) (compile-form s)) 268 | ((symbol? s) (list 'LD s)) 269 | (else (list 'LDC s))))) 270 | 271 | (secd-compile-top (lambda (s) 272 | (cond 273 | ((not (pair? s)) 274 | (secd-compile s)) 275 | ((eq? 'define (car s)) 276 | (let ((what (cadr s)) 277 | (expr (cddr s))) 278 | (cond 279 | ((symbol? what) 280 | (secd-compile (list 'secd-bind! `(quote ,what) (cons 'begin expr)))) 281 | ((pair? what) 282 | (let ((name (car what)) 283 | (args (cdr what))) 284 | (secd-compile 285 | (list 'secd-bind! 286 | `(quote ,name) 287 | (list 'lambda args (cons 'begin expr)))))) 288 | (else 'Error:_define_what?)))) 289 | (else (secd-compile s))))) 290 | 291 | (secd-from-scheme (lambda (s) 292 | (secd-closure (secd-compile-top s) '() '()))) 293 | 294 | (secd-closure (lambda (ctrlpath args maybe-env) 295 | (let ((func (list args (append ctrlpath '(RTN)))) 296 | (env (if (null? maybe-env) (interaction-environment) maybe-env))) 297 | (cons func env)))) 298 | 299 | ;; Macros 300 | (lookup-macro (lambda (name) 301 | (letrec 302 | ((lookup 303 | (lambda (macro-list) 304 | (if (null? macro-list) '() 305 | (let ((hd (car macro-list))) 306 | (let ((macro-name (car hd))) 307 | (if (eq? macro-name name) (cdr hd) 308 | (lookup (cdr macro-list))))))))) 309 | (if (symbol? name) 310 | (lookup *macros*) 311 | '())))) 312 | 313 | (secd-define-macro! (lambda (macrodef macrobody) 314 | (let ((macroname (car macrodef)) 315 | (macroargs (cdr macrodef))) 316 | (let ((macroclos ;; TODO: macrobody may be more longer than 1 form 317 | (secd-closure (secd-compile macrobody) macroargs '()))) 318 | (begin 319 | ;(display macrobody) ;;; what macro is compiled to. 320 | (secd-bind! '*macros* (cons (cons macroname macroclos) *macros*)) 321 | ''ok))))) 322 | 323 | ;; to be run on SECD only: 324 | (#t (eq? 1 1)) 325 | (#f (eq? 1 2)) 326 | (not (lambda (b) (if b #f #t))) 327 | 328 | (apply (lambda (command arglist) (secd-apply command arglist))) 329 | 330 | (eq? (lambda (x y) (eq? x y))) 331 | (+ (lambda (x y) (+ x y))) ; compiled to (LD x LD y ADD) 332 | (- (lambda (x y) (- x y))) 333 | (* (lambda (x y) (* x y))) 334 | (/ (lambda (x y) (/ x y))) 335 | (remainder (lambda (x y) (remainder x y))) 336 | (<= (lambda (x y) (<= x y))) 337 | (car (lambda (pair) (car pair))) 338 | (cdr (lambda (pair) (cdr pair))) 339 | (cons (lambda (hd tl) (cons hd tl))) 340 | 341 | (> (lambda (x y) (cond ((eq? x y) #f) (else (<= y x))))) 342 | (< (lambda (x y) (cond ((eq? x y) #f) (else (<= x y))))) 343 | 344 | (caar (lambda (x) (car (car x)))) 345 | (cadr (lambda (x) (car (cdr x)))) 346 | (cddr (lambda (x) (cdr (cdr x)))) 347 | 348 | (cadar (lambda (x) (car (cdr (car x))))) 349 | (caddr (lambda (x) (car (cdr (cdr x))))) 350 | (cdddr (lambda (x) (cdr (cdr (cdr x))))) 351 | (caddar (lambda (x) (car (cdr (cdr (car x)))))) 352 | 353 | (vector (lambda args (list->vector args))) 354 | 355 | (null? (lambda (obj) (eq? obj '()))) 356 | (number? (lambda (obj) (eq? (secd-type obj) 'int))) 357 | (string? (lambda (obj) (eq? (secd-type obj) 'str))) 358 | (vector? (lambda (obj) (eq? (secd-type obj) 'vect))) 359 | (port? (lambda (obj) (eq? (secd-type obj) 'port))) 360 | (char? (lambda (obj) (eq? (secd-type obj) 'char))) 361 | (bytevector? (lambda (obj) (eq? (secd-type obj) 'bvect))) 362 | (boolean? (lambda (obj) (if obj (eq? obj #t) #t))) 363 | (pair? (lambda (obj) 364 | (cond 365 | ((not (eq? (secd-type obj) 'cons)) #f) 366 | ((null? obj) #f) 367 | ((procedure? obj) #f) 368 | (else #t)))) 369 | (symbol? (lambda (obj) 370 | (cond 371 | ((not (eq? (secd-type obj) 'sym)) #f) 372 | ((boolean? obj) #f) 373 | ((eof-object? obj) #f) 374 | (else #t)))) 375 | (procedure? (lambda (obj) 376 | (cond 377 | ((eq? (secd-type obj) 'func) 378 | #t) 379 | ((eq? (secd-type obj) 'cons) 380 | (cond 381 | ((null? obj) #f) 382 | ((eq? (secd-type (car obj)) 'kont) #t) 383 | ((null? (cdr obj)) #f) 384 | ((null? (car obj)) #f) 385 | ((null? (cdr (car obj))) #f) 386 | ; TODO: (procedure? (cons (1) 2)) crashes 387 | ((not (eq? (secd-type (car (cdr obj))) 'frame)) #f) 388 | ((not (eq? (secd-type (car(car(cdr(car obj))))) 'op)) #f) 389 | (else 390 | (let ((args (car (car obj)))) 391 | (cond 392 | ((null? args) #t) 393 | (else (eq? (secd-type (car args)) 'sym))))))) 394 | (else #f)))) 395 | 396 | (load (lambda (filename) 397 | (letrec 398 | ((loadsexp (lambda () 399 | (let ((sexpr (read))) 400 | (if (eof-object? sexpr) 'ok 401 | (begin 402 | (eval sexpr (interaction-environment)) 403 | (loadsexp)))))) 404 | (*stdin* (open-input-file filename))) 405 | (loadsexp)))) 406 | 407 | (newline (lambda () (display "\n"))) 408 | 409 | (repl-exc-handler 410 | (lambda (e) 411 | (begin 412 | (display "** EXCEPTION **\n") 413 | (display e) 414 | (display "\n*************\n"); 415 | (repl)))) 416 | 417 | (repl (lambda () 418 | (begin 419 | (display *prompt*) 420 | (let 421 | ((inp (read))) 422 | (if (eof-object? inp) 423 | (quit) 424 | (let ((result (eval inp (interaction-environment)))) 425 | (begin 426 | (display " ") 427 | (write result) 428 | (repl)))))))) 429 | 430 | ) 431 | 432 | ;; in 433 | (begin 434 | (cond ((not (defined? 'secd)) 435 | (begin 436 | (display "This file must be run in SECDScheme\n") 437 | (quit)))) 438 | (secd-bind! '*secd-exception-handlers* (list repl-exc-handler)) 439 | (secd-bind! '*prompt* "\n;>> ") 440 | (secd-bind! '*macros* 441 | (list 442 | (cons 'define-macro secd-define-macro!) 443 | (cons 'box 444 | (lambda (val) (list 'make-vector 1 val))) 445 | (cons 'define! 446 | (lambda (sym val) (list 'secd-bind! `(quote ,sym) `(box ,val)))) 447 | (cons 'box-set! 448 | (lambda (sym val) (list 'vector-set! sym 0 val))) 449 | (cons 'box-ref 450 | (lambda (sym) (list 'vector-ref sym 0))))) 451 | (display ";;; Welcome to SECDScheme\n") 452 | (display ";;; sizeof(cell_t) = ")(display (secd 'cell 'size))(newline) 453 | (if (defined? 'secd-ffi) 454 | (let ((tty (secd-ffi 'call '(cstr ttyname 0)))) 455 | (begin (display ";;; tty = ")(display tty)(newline))) 456 | 'else-pass) 457 | (display ";;; Type (secd) to get some help.\n") 458 | (repl))) 459 | -------------------------------------------------------------------------------- /scm2secd.scm: -------------------------------------------------------------------------------- 1 | (letrec 2 | ;; what: 3 | ( 4 | (secd-not (lambda (b) (if b (eq? 1 2) (eq? 1 1)))) 5 | 6 | (unzip (lambda (ps) 7 | (letrec 8 | ((unzipt 9 | (lambda (pairs z1 z2) 10 | (if (null? pairs) 11 | (list z1 z2) 12 | (let ((pair (car pairs)) 13 | (rest (cdr pairs))) 14 | (let ((p1 (car pair)) 15 | (p2 (cadr pair))) 16 | (unzipt rest (append z1 (list p1)) (append z2 (list p2))))))))) 17 | (unzipt ps '() '())))) 18 | 19 | (compile-bindings 20 | (lambda (bs) 21 | (if (null? bs) '(LDC ()) 22 | (append (compile-bindings (cdr bs)) 23 | (secd-compile (car bs)) 24 | '(CONS))))) 25 | 26 | (compile-n-bindings 27 | (lambda (bs) 28 | (if (null? bs) '() 29 | (append (compile-n-bindings (cdr bs)) 30 | (secd-compile (car bs)))))) 31 | 32 | (length (lambda (xs) 33 | (letrec 34 | ((len (lambda (xs acc) 35 | (if (null? xs) acc 36 | (len (cdr xs) (+ 1 acc)))))) 37 | (len xs 0)))) 38 | 39 | (compile-begin-acc 40 | (lambda (stmts acc) ; acc must be '(LDC ()) at the beginning 41 | (if (null? stmts) 42 | (append acc '(CAR)) 43 | (compile-begin-acc (cdr stmts) 44 | (append acc (secd-compile (car stmts)) '(CONS)))))) 45 | 46 | (compile-cond 47 | (lambda (conds) 48 | (if (null? conds) 49 | '(LDC ()) 50 | (let ((this-cond (car (car conds))) 51 | (this-expr (cadr (car conds)))) 52 | (if (eq? this-cond 'else) 53 | (secd-compile this-expr) 54 | (append (secd-compile this-cond) '(SEL) 55 | (list (append (secd-compile this-expr) '(JOIN))) 56 | (list (append (compile-cond (cdr conds)) '(JOIN))))))))) 57 | 58 | (compile-quasiquote 59 | (lambda (lst) 60 | (cond 61 | ((null? lst) '()) 62 | ((pair? lst) 63 | (let ((hd (car lst)) (tl (cdr lst))) 64 | (cond 65 | ((secd-not (pair? hd)) 66 | (append (compile-quasiquote tl) (list 'LDC hd 'CONS))) 67 | ((eq? (car hd) 'unquote) 68 | (append (compile-quasiquote tl) (secd-compile (cadr hd)) '(CONS))) 69 | ;; TODO: (unquote a1 a2 ...) 70 | ((eq? (car hd) 'unquote-splicing) 71 | (display 'Error:_unquote-splicing_TODO)) ;; TODO 72 | (else (append (compile-quasiquote tl) 73 | (compile-quasiquote hd) '(CONS)))))) 74 | (else (list 'LDC lst))))) 75 | 76 | (compile-form (lambda (f) 77 | (let ((hd (car f)) 78 | (tl (cdr f))) 79 | (cond 80 | ((eq? hd 'quote) 81 | (list 'LDC (car tl))) 82 | ((eq? hd 'quasiquote) 83 | (append '(LDC ()) (compile-quasiquote (car tl)))) 84 | ((eq? hd '+) 85 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(ADD))) 86 | ((eq? hd '-) 87 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(SUB))) 88 | ((eq? hd '*) 89 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(MUL))) 90 | ((eq? hd '/) 91 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(DIV))) 92 | ((eq? hd 'remainder) 93 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(REM))) 94 | ((eq? hd '<=) 95 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(LEQ))) 96 | ((eq? hd 'eq? ) 97 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(EQ))) 98 | ((eq? hd 'cons) 99 | (append (secd-compile (cadr tl)) (secd-compile (car tl)) '(CONS))) 100 | ((eq? hd 'secd-type) 101 | (append (secd-compile (car tl)) '(TYPE))) 102 | ((eq? hd 'pair?) 103 | (append (secd-compile (car tl)) '(TYPE LDC cons EQ))) 104 | ((eq? hd 'car) 105 | (append (secd-compile (car tl)) '(CAR))) 106 | ((eq? hd 'cdr) 107 | (append (secd-compile (car tl)) '(CDR))) 108 | ((eq? hd 'cadr) 109 | (append (secd-compile (car tl)) '(CDR CAR))) 110 | ((eq? hd 'caddr) 111 | (append (secd-compile (car tl)) '(CDR CDR CAR))) 112 | ((eq? hd 'if ) 113 | (let ((condc (secd-compile (car tl))) 114 | (thenb (append (secd-compile (cadr tl)) '(JOIN))) 115 | (elseb (append (secd-compile (caddr tl)) '(JOIN)))) 116 | (append condc '(SEL) (list thenb) (list elseb)))) 117 | ((eq? hd 'lambda) 118 | (let ((args (car tl)) 119 | (body (append (secd-compile (cadr tl)) '(RTN)))) 120 | (list 'LDF (list args body)))) 121 | ((eq? hd 'let) 122 | (let ((bindings (unzip (car tl))) 123 | (body (cadr tl))) 124 | (let ((args (car bindings)) 125 | (exprs (cadr bindings))) 126 | (append (compile-bindings exprs) 127 | (list 'LDF (list args (append (secd-compile body) '(RTN)))) 128 | '(AP))))) 129 | ((eq? hd 'letrec) 130 | (let ((bindings (unzip (car tl))) 131 | (body (cadr tl))) 132 | (let ((args (car bindings)) 133 | (exprs (cadr bindings))) 134 | (append '(DUM) 135 | (compile-bindings exprs) 136 | (list 'LDF (list args (append (secd-compile body) '(RTN)))) 137 | '(RAP))))) 138 | 139 | ;; (begin (e1) (e2) ... (eN)) => LDC () CONS CONS ... CONS CAR 140 | ((eq? hd 'begin) 141 | (compile-begin-acc tl '(LDC ()))) 142 | ((eq? hd 'cond) 143 | (compile-cond tl)) 144 | ((eq? hd 'write) 145 | (append (secd-compile (car tl)) '(PRINT))) 146 | ((eq? hd 'read) 147 | '(READ)) 148 | ((eq? hd 'eval) 149 | (append '(LDC () LDC () LDC () CONS) (secd-compile (car tl)) '(CONS LD secd-from-scheme AP AP))) 150 | ((eq? hd 'secd-apply) 151 | (append (secd-compile (car (cdr tl))) (secd-compile (car tl)) '(AP))) 152 | ((eq? hd 'quit) 153 | '(STOP)) 154 | (else 155 | (let ((compiled-head 156 | (if (symbol? hd) (list 'LD hd) (secd-compile hd))) 157 | (nbinds (length tl))) 158 | (append (compile-n-bindings tl) compiled-head (list 'AP nbinds)))) 159 | )))) 160 | 161 | (secd-compile (lambda (s) 162 | (cond 163 | ((pair? s) (compile-form s)) 164 | ((symbol? s) (list 'LD s)) 165 | (else (list 'LDC s))))) 166 | 167 | (repl (lambda () 168 | (let ((inp (read))) 169 | (if (eof-object? inp) (quit) 170 | (begin 171 | (write (append (secd-compile inp) '(STOP))) 172 | (repl)))))) 173 | 174 | 175 | ;; to be run on SECD only 176 | (set-secd-env 177 | (lambda (lst) 178 | (if (eq? lst '()) 179 | 'ok 180 | (let ((hd (car lst)) (tl (cdr lst))) 181 | (let ((sym (car hd)) (val (cdr hd))) 182 | (begin 183 | (secd-bind! sym val) 184 | (set-secd-env tl))))))) 185 | ) 186 | 187 | ;; in 188 | (begin 189 | (cond 190 | ((defined? 'secd) 191 | (set-secd-env 192 | (list 193 | (cons 'null? (lambda (obj) (eq? obj '()))) 194 | (cons 'number? (lambda (obj) (eq? (secd-type obj) 'int))) 195 | (cons 'symbol? (lambda (obj) (eq? (secd-type obj) 'sym))))))) 196 | (repl))) 197 | -------------------------------------------------------------------------------- /scm2secd.secd: -------------------------------------------------------------------------------- 1 | (DUM LDC () LDF ((lst) (LDC () LD lst EQ SEL (LDC ok JOIN) (LDC () LD lst CDR CONS LD lst CAR CONS LDF ((hd tl) (LDC () LD hd CDR CONS LD hd CAR CONS LDF ((sym val) (LDC () LD val LD sym LD secd-bind! AP 2 CONS LD tl LD set-secd-env AP 1 CONS CAR RTN)) AP RTN)) AP JOIN) RTN)) CONS LDF (() (LDC () READ CONS LDF ((inp) (LD inp LD eof-object? AP 1 SEL (STOP JOIN) (LDC () LDC (STOP) LD inp LD secd-compile AP 1 LD append AP 2 PRINT CONS LD repl AP 0 CONS CAR JOIN) RTN)) AP RTN)) CONS LDF ((s) (LD s TYPE LDC cons EQ SEL (LD s LD compile-form AP 1 JOIN) (LD s LD symbol? AP 1 SEL (LD s LDC LD LD list AP 2 JOIN) (LD s LDC LDC LD list AP 2 JOIN) JOIN) RTN)) CONS LDF ((f) (LDC () LD f CDR CONS LD f CAR CONS LDF ((hd tl) (LDC quote LD hd EQ SEL (LD tl CAR LDC LDC LD list AP 2 JOIN) (LDC quasiquote LD hd EQ SEL (LD tl CAR LD compile-quasiquote AP 1 LDC (LDC ()) LD append AP 2 JOIN) (LDC + LD hd EQ SEL (LDC (ADD) LD tl CAR LD secd-compile AP 1 LD tl CDR CAR LD secd-compile AP 1 LD append AP 3 JOIN) (LDC - LD hd EQ SEL (LDC (SUB) LD tl CAR LD secd-compile AP 1 LD tl CDR CAR LD secd-compile AP 1 LD append AP 3 JOIN) (LDC * LD hd EQ SEL (LDC (MUL) LD tl CAR LD secd-compile AP 1 LD tl CDR CAR LD secd-compile AP 1 LD append AP 3 JOIN) (LDC / LD hd EQ SEL (LDC (DIV) LD tl CAR LD secd-compile AP 1 LD tl CDR CAR LD secd-compile AP 1 LD append AP 3 JOIN) (LDC remainder LD hd EQ SEL (LDC (REM) LD tl CAR LD secd-compile AP 1 LD tl CDR CAR LD secd-compile AP 1 LD append AP 3 JOIN) (LDC <= LD hd EQ SEL (LDC (LEQ) LD tl CAR LD secd-compile AP 1 LD tl CDR CAR LD secd-compile AP 1 LD append AP 3 JOIN) (LDC eq? LD hd EQ SEL (LDC (EQ) LD tl CAR LD secd-compile AP 1 LD tl CDR CAR LD secd-compile AP 1 LD append AP 3 JOIN) (LDC cons LD hd EQ SEL (LDC (CONS) LD tl CAR LD secd-compile AP 1 LD tl CDR CAR LD secd-compile AP 1 LD append AP 3 JOIN) (LDC secd-type LD hd EQ SEL (LDC (TYPE) LD tl CAR LD secd-compile AP 1 LD append AP 2 JOIN) (LDC pair? LD hd EQ SEL (LDC (TYPE LDC cons EQ) LD tl CAR LD secd-compile AP 1 LD append AP 2 JOIN) (LDC car LD hd EQ SEL (LDC (CAR) LD tl CAR LD secd-compile AP 1 LD append AP 2 JOIN) (LDC cdr LD hd EQ SEL (LDC (CDR) LD tl CAR LD secd-compile AP 1 LD append AP 2 JOIN) (LDC cadr LD hd EQ SEL (LDC (CDR CAR) LD tl CAR LD secd-compile AP 1 LD append AP 2 JOIN) (LDC caddr LD hd EQ SEL (LDC (CDR CDR CAR) LD tl CAR LD secd-compile AP 1 LD append AP 2 JOIN) (LDC if LD hd EQ SEL (LDC () LDC (JOIN) LD tl CDR CDR CAR LD secd-compile AP 1 LD append AP 2 CONS LDC (JOIN) LD tl CDR CAR LD secd-compile AP 1 LD append AP 2 CONS LD tl CAR LD secd-compile AP 1 CONS LDF ((condc thenb elseb) (LD elseb LD list AP 1 LD thenb LD list AP 1 LDC (SEL) LD condc LD append AP 4 RTN)) AP JOIN) (LDC lambda LD hd EQ SEL (LDC () LDC (RTN) LD tl CDR CAR LD secd-compile AP 1 LD append AP 2 CONS LD tl CAR CONS LDF ((args body) (LD body LD args LD list AP 2 LDC LDF LD list AP 2 RTN)) AP JOIN) (LDC let LD hd EQ SEL (LDC () LD tl CDR CAR CONS LD tl CAR LD unzip AP 1 CONS LDF ((bindings body) (LDC () LD bindings CDR CAR CONS LD bindings CAR CONS LDF ((args exprs) (LDC (AP) LDC (RTN) LD body LD secd-compile AP 1 LD append AP 2 LD args LD list AP 2 LDC LDF LD list AP 2 LD exprs LD compile-bindings AP 1 LD append AP 3 RTN)) AP RTN)) AP JOIN) (LDC letrec LD hd EQ SEL (LDC () LD tl CDR CAR CONS LD tl CAR LD unzip AP 1 CONS LDF ((bindings body) (LDC () LD bindings CDR CAR CONS LD bindings CAR CONS LDF ((args exprs) (LDC (RAP) LDC (RTN) LD body LD secd-compile AP 1 LD append AP 2 LD args LD list AP 2 LDC LDF LD list AP 2 LD exprs LD compile-bindings AP 1 LDC (DUM) LD append AP 4 RTN)) AP RTN)) AP JOIN) (LDC begin LD hd EQ SEL (LDC (LDC ()) LD tl LD compile-begin-acc AP 2 JOIN) (LDC cond LD hd EQ SEL (LD tl LD compile-cond AP 1 JOIN) (LDC write LD hd EQ SEL (LDC (PRINT) LD tl CAR LD secd-compile AP 1 LD append AP 2 JOIN) (LDC read LD hd EQ SEL (LDC (READ) JOIN) (LDC eval LD hd EQ SEL (LDC (CONS LD secd-from-scheme AP AP) LD tl CAR LD secd-compile AP 1 LDC (LDC () LDC () LDC () CONS) LD append AP 3 JOIN) (LDC secd-apply LD hd EQ SEL (LDC (AP) LD tl CAR LD secd-compile AP 1 LD tl CDR CAR LD secd-compile AP 1 LD append AP 3 JOIN) (LDC quit LD hd EQ SEL (LDC (STOP) JOIN) (LDC () LD tl LD length AP 1 CONS LD hd LD symbol? AP 1 SEL (LD hd LDC LD LD list AP 2 JOIN) (LD hd LD secd-compile AP 1 JOIN) CONS LDF ((compiled-head nbinds) (LD nbinds LDC AP LD list AP 2 LD compiled-head LD tl LD compile-n-bindings AP 1 LD append AP 3 RTN)) AP JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) JOIN) RTN)) AP RTN)) CONS LDF ((lst) (LD lst LD null? AP 1 SEL (LDC () JOIN) (LD lst TYPE LDC cons EQ SEL (LDC () LD lst CDR CONS LD lst CAR CONS LDF ((hd tl) (LD hd TYPE LDC cons EQ LD secd-not AP 1 SEL (LDC CONS LD hd LDC LDC LD list AP 3 LD tl LD compile-quasiquote AP 1 LD append AP 2 JOIN) (LDC unquote LD hd CAR EQ SEL (LDC (CONS) LD hd CDR CAR LD secd-compile AP 1 LD tl LD compile-quasiquote AP 1 LD append AP 3 JOIN) (LDC unquote-splicing LD hd CAR EQ SEL (LDC Error:_unquote-splicing_TODO LD display AP 1 JOIN) (LDC (CONS) LD hd LD compile-quasiquote AP 1 LD tl LD compile-quasiquote AP 1 LD append AP 3 JOIN) JOIN) JOIN) RTN)) AP JOIN) (LD lst LDC LDC LD list AP 2 JOIN) JOIN) RTN)) CONS LDF ((conds) (LD conds LD null? AP 1 SEL (LDC (LDC ()) JOIN) (LDC () LD conds CAR CDR CAR CONS LD conds CAR CAR CONS LDF ((this-cond this-expr) (LDC else LD this-cond EQ SEL (LD this-expr LD secd-compile AP 1 JOIN) (LDC (JOIN) LD conds CDR LD compile-cond AP 1 LD append AP 2 LD list AP 1 LDC (JOIN) LD this-expr LD secd-compile AP 1 LD append AP 2 LD list AP 1 LDC (SEL) LD this-cond LD secd-compile AP 1 LD append AP 4 JOIN) RTN)) AP JOIN) RTN)) CONS LDF ((stmts acc) (LD stmts LD null? AP 1 SEL (LDC (CAR) LD acc LD append AP 2 JOIN) (LDC (CONS) LD stmts CAR LD secd-compile AP 1 LD acc LD append AP 3 LD stmts CDR LD compile-begin-acc AP 2 JOIN) RTN)) CONS LDF ((xs) (DUM LDC () LDF ((xs acc) (LD xs LD null? AP 1 SEL (LD acc JOIN) (LD acc LDC 1 ADD LD xs CDR LD len AP 2 JOIN) RTN)) CONS LDF ((len) (LDC 0 LD xs LD len AP 2 RTN)) RAP RTN)) CONS LDF ((bs) (LD bs LD null? AP 1 SEL (LDC () JOIN) (LD bs CAR LD secd-compile AP 1 LD bs CDR LD compile-n-bindings AP 1 LD append AP 2 JOIN) RTN)) CONS LDF ((bs) (LD bs LD null? AP 1 SEL (LDC (LDC ()) JOIN) (LDC (CONS) LD bs CAR LD secd-compile AP 1 LD bs CDR LD compile-bindings AP 1 LD append AP 3 JOIN) RTN)) CONS LDF ((ps) (DUM LDC () LDF ((pairs z1 z2) (LD pairs LD null? AP 1 SEL (LD z2 LD z1 LD list AP 2 JOIN) (LDC () LD pairs CDR CONS LD pairs CAR CONS LDF ((pair rest) (LDC () LD pair CDR CAR CONS LD pair CAR CONS LDF ((p1 p2) (LD p2 LD list AP 1 LD z2 LD append AP 2 LD p1 LD list AP 1 LD z1 LD append AP 2 LD rest LD unzipt AP 3 RTN)) AP RTN)) AP JOIN) RTN)) CONS LDF ((unzipt) (LDC () LDC () LD ps LD unzipt AP 3 RTN)) RAP RTN)) CONS LDF ((b) (LD b SEL (LDC 2 LDC 1 EQ JOIN) (LDC 1 LDC 1 EQ JOIN) RTN)) CONS LDF ((secd-not unzip compile-bindings compile-n-bindings length compile-begin-acc compile-cond compile-quasiquote compile-form secd-compile repl set-secd-env) (LDC () LDC secd LD defined? AP 1 SEL (LDF ((obj) (LDC sym LD obj TYPE EQ RTN)) LDC symbol? CONS LDF ((obj) (LDC int LD obj TYPE EQ RTN)) LDC number? CONS LDF ((obj) (LDC () LD obj EQ RTN)) LDC null? CONS LD list AP 3 LD set-secd-env AP 1 JOIN) (LDC () JOIN) CONS LD repl AP 0 CONS CAR RTN)) RAP STOP) -------------------------------------------------------------------------------- /secd.c: -------------------------------------------------------------------------------- 1 | #include "secd/secd.h" 2 | #include "secd/secd_io.h" 3 | 4 | #include 5 | #include 6 | 7 | #define N_CELLS 64 * 1024 8 | 9 | int main(int argc, char *argv[]) { 10 | secd_t secd; 11 | cell_t *heap = (cell_t *)malloc(sizeof(cell_t) * N_CELLS); 12 | 13 | init_secd(&secd, heap, N_CELLS); 14 | #if ((CTRLDEBUG) || (MEMDEBUG)) 15 | secd_setport(&secd, SECD_STDDBG, secd_fopen(&secd, "secd.log", "w")); 16 | #endif 17 | 18 | cell_t *cmdport = SECD_NIL; 19 | if (argc == 2) 20 | cmdport = secd_fopen(&secd, argv[1], "r"); 21 | 22 | cell_t *inp = sexp_parse(&secd, cmdport); // cmdport is dropped after 23 | if (is_nil(inp) || !is_cons(inp)) { 24 | secd_errorf(&secd, "list of commands expected\n"); 25 | dbg_printc(&secd, inp); 26 | return 1; 27 | } 28 | 29 | cell_t *ret; 30 | ret = run_secd(&secd, inp); 31 | 32 | return (is_error(ret) ? EXIT_FAILURE : EXIT_SUCCESS); 33 | } 34 | -------------------------------------------------------------------------------- /secdscheme: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | DIR=`dirname $0` 4 | SECDVM=$DIR/secd 5 | COMPILER=$DIR/scm2secd.secd 6 | REPLSRC=$DIR/repl.scm 7 | REPL=$DIR/repl.secd 8 | 9 | die () { 10 | echo $@ >&2 11 | exit 1 12 | } 13 | 14 | interp () { 15 | RLWRAP="`which rlwrap`" 16 | [ "$RLWRAP" ] && RLWRAP="$RLWRAP -r -q \"\\\"\" " 17 | exec $RLWRAP $SECDVM $REPL 18 | } 19 | 20 | compile () { 21 | case "$1" in 22 | *.scm) ;; 23 | *) die "Error: file $1 must have .scm extension" ;; 24 | esac 25 | 26 | SRC="$1" 27 | DST="${1/scm/secd}" 28 | 29 | # backup destination if needed 30 | [ -e "$DST" ] && mv "$DST" "$DST~" 31 | $SECDVM $COMPILER <$SRC >"${DST}.1" || die "Error: compilation failed" 32 | mv "${DST}.1" $DST 33 | exit 0 34 | } 35 | 36 | test -f "$REPL" || { 37 | export REPL="$DIR/../share/secdscheme/secd/repl.secd" 38 | test -f "$REPL" || die "repl.secd not found" 39 | } 40 | 41 | # is there the secd interpreter? 42 | [ -x $SECDVM ] || die "$SECDVM not found" 43 | 44 | if [ "$1" = '-c' ] ; then 45 | shift 46 | echo ";; compiling $@..." >&2 47 | compile "$@" 48 | else 49 | interp 50 | fi 51 | 52 | -------------------------------------------------------------------------------- /std/andor.scm: -------------------------------------------------------------------------------- 1 | (define (andfunc . thunks) 2 | (if (null? thunks) #t 3 | (if ((car thunks)) (apply andfunc (cdr thunks)) #f))) 4 | 5 | (define (orfunc . thunks) 6 | (if (null? thunks) #f 7 | (let ((res ((car thunks))) 8 | (if res res (apply orfunc (cdr thunks))))))) 9 | 10 | (define-macro (and . exprs) 11 | (let ((thunks (map (lambda (expr) `(lambda () ,expr)) exprs))) 12 | `(apply andfunc (list ,@thunks)))) 13 | 14 | (define-macro (or . exprs) 15 | (let ((thunks (map (lambda (expr) `(lambda () ,expr)) exprs))) 16 | `(apply orfunc (list ,@thunks)))) 17 | -------------------------------------------------------------------------------- /std/hashtable.scm: -------------------------------------------------------------------------------- 1 | ;; creates a new empty hashtable 2 | (define (make-hashtable) 3 | (let ((initial-capacity 2)) 4 | (let ((lookup-table (make-vector initial-capacity 0))) 5 | (list->vector (list initial-capacity lookup-table 0))))) 6 | 7 | ;; return count of mappings 8 | (define (hashtable-size ht) (vector-ref ht 2)) 9 | 10 | (define (hashtable-capacity ht) (vector-ref ht 0)) 11 | (define (hashtable-loadratio ht) 12 | (/ (* 100 (vector-ref ht 2)) (vector-ref ht 0))) 13 | 14 | ;; for internal use 15 | (define (hashtable-index key cap) 16 | (let ((ind (remainder (secd-hash key) cap))) 17 | (cond 18 | ((eq? ind 0) ind) 19 | ((<= ind 0) (+ ind cap)) 20 | (else ind)))) 21 | 22 | (define (alist-lookup alist key) 23 | (if (null? alist) 24 | '() 25 | (let ((kv (car alist))) 26 | (if (eq? (car kv) key) 27 | (list (cdr kv)) 28 | (alist-lookup (cdr alist) key))))) 29 | 30 | ;; accepts symbol keys only at the moment 31 | (define (hashtable-set! hashtable key val) 32 | (let ((capacity (vector-ref hashtable 0)) 33 | (table (vector-ref hashtable 1)) 34 | (count (vector-ref hashtable 2))) 35 | (let ((index (hashtable-index key capacity)) 36 | (inc-count (lambda (h) (vector-set! h 2 (+ (hashtable-size h) 1))))) 37 | (let ((prev-alist (vector-ref table index))) 38 | (begin 39 | (if (pair? prev-alist) 40 | (letrec 41 | ((alist-replace 42 | (lambda (alist) 43 | (if (null? alist) 44 | (begin (inc-count hashtable) (list (cons key val))) 45 | (let ((kv (car alist)) (rst (cdr alist))) 46 | (if (eq? (car kv) key) 47 | (cons (cons key val) rst) 48 | (cons kv (alist-replace rst)))))))) 49 | (vector-set! table index (alist-replace prev-alist key val))) 50 | (begin 51 | (inc-count hashtable) 52 | (vector-set! table index (list (cons key val))))) 53 | (if (<= (hashtable-loadratio hashtable) 75) 54 | hashtable 55 | (let ((reb-ht (rebalanced-hashtable hashtable))) 56 | (begin 57 | (vector-set! hashtable 0 (vector-ref reb-ht 0)) 58 | (vector-set! hashtable 1 (vector-ref reb-ht 1)) 59 | (vector-set! hashtable 2 (vector-ref reb-ht 2)) 60 | hashtable)))))))) 61 | 62 | ;; returns '() if no value 63 | ;; returns (value) if key has value 64 | (define (hashtable-mb-ref hashtable key) 65 | (let ((capacity (vector-ref hashtable 0)) 66 | (table (vector-ref hashtable 1)) 67 | (count (vector-ref hashtable 2))) 68 | (let ((index (hashtable-index key capacity))) 69 | (let ((alist (vector-ref table index))) 70 | (if (pair? alist) 71 | (alist-lookup alist key) 72 | '()))))) 73 | 74 | (define (hashtable-ref/default hashtable key default) 75 | (let ((mb-val (hashtable-mb-ref hashtable key))) 76 | (if (null? mb-val) 77 | default 78 | (car mb-val)))) 79 | 80 | (define (hashtable-ref hashtable key) 81 | (car (hashtable-mb-ref hashtable key))) 82 | 83 | (define (hashtable-exists? hashtable key) 84 | (not (null? (hashtable-mb-ref hashtable key)))) 85 | 86 | (define (alist->hashtable alist) 87 | (let ((ht (make-hashtable))) 88 | (begin 89 | (for-each 90 | (lambda (pair) 91 | (let ((key (car pair)) (val (cdr pair))) 92 | (hashtable-set! ht key val))) 93 | alist) 94 | ht))) 95 | 96 | (define (hashtable-merge! this that) 97 | (begin 98 | (for-each 99 | (lambda (key) 100 | (cond ((not (hashtable-exists? this key)) 101 | (hashtable-set! this key (hashtable-ref that key))))) 102 | (hashtable-keys that)) 103 | this)) 104 | 105 | (define (hashtable-fold func state hashtable) 106 | (let ((htlen (hashtable-capacity hashtable))) 107 | (letrec 108 | ((folditer (lambda (htpair state) 109 | (let ((key (car htpair)) (val (cdr htpair))) 110 | (func key val state)))) 111 | (fold-htentry (lambda (index state) 112 | (if (<= htlen index) 113 | state 114 | (let ((htalist (vector-ref (vector-ref hashtable 1) index))) 115 | (fold-htentry (+ 1 index) 116 | (if (pair? htalist) (list-fold folditer state htalist) state))))))) 117 | (fold-htentry 0 state)))) 118 | 119 | 120 | (define (hashtable-keys hashtable) 121 | (hashtable-fold 122 | (lambda (key val state) (cons key state)) 123 | '() 124 | hashtable)) 125 | 126 | (define (hashtable-copy that) 127 | (hashtable-merge! (make-hashtable) that)) 128 | 129 | (define (rebalanced-hashtable ht) 130 | (let ((old-cap (vector-ref ht 0)) 131 | (old-table (vector-ref ht 1)) 132 | (count (vector-ref ht 2))) 133 | (let ((new-cap (* 2 old-cap))) 134 | (let ((new-table (make-vector new-cap 0)) 135 | (inc-count (lambda (h) (vector-set! h 2 (+ 1 (hashtable-size h)))))) 136 | (letrec 137 | ((new-ht (list->vector (list new-cap new-table 0))) 138 | (while-not-zero ;; rewrite with (vector-map) 139 | (lambda (i f) 140 | (if (eq? i 0) 141 | (f 0) 142 | (begin (f i) (while-not-zero (- i 1) f))))) 143 | (map-alist 144 | (lambda (f alist) 145 | (if (null? alist) '() 146 | (cons (f (car alist)) (map-alist f (cdr alist))))))) 147 | (begin 148 | (while-not-zero (- old-cap 1) 149 | (lambda (i) 150 | (let ((alist (vector-ref old-table i))) 151 | (if (pair? alist) 152 | (map-alist (lambda (kv) (hashtable-set! new-ht (car kv) (cdr kv))) alist) 153 | '())))) 154 | new-ht)))))) 155 | -------------------------------------------------------------------------------- /std/lazy.scm: -------------------------------------------------------------------------------- 1 | (define (promise? obj) 2 | (if (procedure? obj) 3 | (eq? (car (car obj)) '()) 4 | #f)) 5 | 6 | (define-macro (delay expr) (list 'lambda '() expr)) 7 | 8 | (define (force promise) (promise)) 9 | 10 | (define (delay-force promise) (delay (force promise))) 11 | 12 | (define (make-promise obj) (lambda () obj)) 13 | 14 | -------------------------------------------------------------------------------- /std/lists.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; Basic functional things 3 | ;; 4 | 5 | (define (filter p xs) 6 | (reverse (list-fold (lambda (x lst) (if (p x) (cons x lst) lst)) '() xs))) 7 | 8 | (define (foldr f s xs) 9 | (if (null? xs) 10 | s 11 | (f (car xs) (foldr f s (cdr xs))))) 12 | (define (foldl f s xs) 13 | (if (null? xs) 14 | s 15 | (foldl f (f s (car xs)) (cdr xs)))) 16 | 17 | (define (fold f s . lsts) 18 | (if (any null? lsts) 19 | s 20 | (apply fold (cons f (cons (apply f (cons s (map car lsts))) (map cdr lsts)))))) 21 | 22 | (define (range n) 23 | (letrec ((range-tco 24 | (lambda (acc n) 25 | (if (eq? n 0) 26 | acc 27 | (range-tco (cons n acc) (- n 1)))))) 28 | (range-tco '() n))) 29 | 30 | (define (last xs) 31 | (if (null? xs) 32 | '() 33 | (if (null? (cdr xs)) (car xs) (last (cdr xs))))) 34 | 35 | (define (take n xs) 36 | (cond 37 | ((null? xs) '()) 38 | ((eq? n 0) '()) 39 | (else (cons (car xs) (take (- n 1) (cdr xs)))))) 40 | 41 | (define (partition pred xs) 42 | (let ((res (list-fold 43 | (lambda (x lst) 44 | (let ((rights (car lst)) (wrongs (cdr lst))) 45 | (if (pred x) (cons (cons x rights) wrongs) (cons rights (cons x wrongs))))) 46 | '(() . ()) xs))) 47 | (list (reverse (car res)) (reverse (cdr res))))) 48 | 49 | (define (remove pred lst) 50 | (reverse (list-fold (lambda (x res) (if (pred x) res (cons x res))) '() lst))) 51 | 52 | (define (any pred lst) 53 | (call/cc (lambda (return) 54 | (for-each (lambda (x) (if (pred x) (return #t) #f)) lst)))) 55 | 56 | (define (every pred lst) 57 | (call/cc (lambda (return) 58 | (for-each (lambda (x) (if (pred x) #t (return #f))) lst)))) 59 | 60 | (define (take-while pred lst) 61 | (call/cc (lambda (return) 62 | (reverse (list-fold 63 | (lambda (x xs) (if (pred x) (cons x xs) (return (reverse xs)))) 64 | '() lst))))) 65 | 66 | (define (drop-while pred lst) 67 | (call/cc (lambda (return) 68 | (list-fold (lambda (x xs) (if (pred x) (cdr xs) (return xs))) lst lst)))) 69 | 70 | (define (zip . lsts) 71 | (if (any null? lsts) '() 72 | (cons (map car lsts) (apply zip (map cdr lsts))))) 73 | 74 | (define (even x) (eq? (remainder x 2) 0)) 75 | (define (odd x) (eq? (remainder x 2) 1)) 76 | 77 | (define (product xs) (foldr (lambda (x y) (* x y)) 1 xs)) 78 | (define (sum xs) (foldr (lambda (x y) (+ x y)) 0 xs)) 79 | -------------------------------------------------------------------------------- /std/ports.scm: -------------------------------------------------------------------------------- 1 | (define (current-input-port) *stdin*) 2 | (define (current-output-port) *stdout*) 3 | (define (current-error-port) *stdout*) ;; TODO 4 | 5 | (define (input-port? obj) 6 | (cdr (assq 'in (secd-port-info obj)))) 7 | (define (output-port? obj) 8 | (cdr (assq 'out (secd-port-info obj)))) 9 | 10 | (define (textual-port? obj) 11 | (cdr (assq 'txt (secd-port-info obj)))) 12 | (define (binary-port? obj) 13 | (not (textual-port? obj))) 14 | 15 | (define (input-port-open? port) 16 | (input-port? port)) 17 | (define (output-port-open? port) 18 | (output-port? port)) 19 | 20 | (define (with-input-from-file filename thunk) 21 | (let ((*stdin* (open-input-file filename))) 22 | (thunk))) 23 | 24 | (define (with-input-from-string str thunk) 25 | (let ((*stdin* (open-input-string str))) 26 | (thunk))) 27 | 28 | (define (eof-object) (string->symbol "#")) 29 | -------------------------------------------------------------------------------- /tests/append.scm: -------------------------------------------------------------------------------- 1 | (letrec 2 | ((append 3 | (lambda (xs ys) 4 | (if (eq? xs '()) 5 | ys 6 | (cons (car xs) (append (cdr xs) ys)))))) 7 | (display (append '(1 2 3) '(4 5 6)))) 8 | -------------------------------------------------------------------------------- /tests/append.secd: -------------------------------------------------------------------------------- 1 | (DUM 2 | LDC () 3 | LDF ((xs ys) ( 4 | LD xs LDC () EQ 5 | SEL (LD ys JOIN) 6 | (LDC () 7 | LD ys CONS 8 | LD xs CDR CONS 9 | LD append AP 10 | LD xs CAR CONS 11 | JOIN) 12 | RTN)) 13 | CONS 14 | LDF ((append) ( 15 | LDC () 16 | LDC (4 5 6) CONS 17 | LDC (1 2 3) CONS 18 | LD append AP 19 | PRINT 20 | RTN)) 21 | RAP 22 | STOP) 23 | -------------------------------------------------------------------------------- /tests/cyrillic.txt: -------------------------------------------------------------------------------- 1 | Осліпле листя відчувало яр 2 | і палене збігало до потоку, 3 | брело стежками, навпрошки і покотом 4 | донизу, в воду - загасить пожар. 5 | У лісі рівний голубий вогонь 6 | гудів і струнчив жертвенні дерева. 7 | Зібравши літніх райдуг оберемок, 8 | просторив вітер білу хоругов. 9 | Осамотілі липи в вітрі хрипли, 10 | сухе проміння пахло сірником, 11 | і плакала за втраченим вінком 12 | юначка, заробивши на горіхи. 13 | І верби в шумі втоплені. Аж ось 14 | паде як мед настояно-загуслий 15 | останній лист. Зажолобіє з гусінню - 16 | і жди-пожди прийдешніх медоносів. 17 | Так по стерні збирають пізній даток, 18 | так вибілене полотно - в сувій, 19 | так юна породілля стане матір'ю 20 | в своєму щасті і в ганьбі своїй. 21 | Схилились осокори до води, 22 | на шум єдиний в лісі. Яр вирує, 23 | а осінь день, як повечір'я, чує. 24 | 25 | Кружляє лист в передчутті біди. 26 | -------------------------------------------------------------------------------- /tests/define.scm: -------------------------------------------------------------------------------- 1 | ;;(define (mul-n x) (* x n)) 2 | 3 | (define (sqr x) (* x x)) 4 | 5 | (define n (sqr 2)) 6 | 7 | (sqr n) 8 | 9 | ;;(define (cube x) (* x x x)) 10 | -------------------------------------------------------------------------------- /tests/dynwind.scm: -------------------------------------------------------------------------------- 1 | (define (test-dynwind) 2 | (let ((msgs '()) (c #f)) 3 | (let ((log (lambda (msg) (set! msgs (cons msg msgs))))) 4 | (dynamic-wind 5 | (lambda () (log 'connect)) 6 | (lambda () 7 | (log (call/cc (lambda (k) 8 | (set! c k) 9 | 'first-time-here)))) 10 | (lambda () (log 'disconnect))) 11 | (if (< (length msgs) 4) 12 | (c 'second-time) 13 | (reverse msgs))))) 14 | 15 | (define-macro (box val) `(make-vector 1 ,val)) 16 | (define-macro (box-set! b val) `(vector-set! ,b 0 ,val)) 17 | (define-macro (box-ref b) `(vector-ref ,b 0)) 18 | 19 | (define kont (box #f)) 20 | (define (test-dynwind2) 21 | (dynamic-wind 22 | (lambda () (display "entered test2 dynextent\n")) 23 | (lambda () 24 | (dynamic-wind 25 | (lambda () (display "entered test2inner dynextent\n")) 26 | (lambda () (call/cc (lambda (k) 27 | (if (box-ref kont) ((box-ref kont) 12) (box-set! kont k))))) 28 | (lambda () (display "exited test2inner dynextent\n")))) 29 | (lambda () (display "exited test2 dynextent\n")))) 30 | 31 | (define (test-dynwind3) 32 | (dynamic-wind 33 | (lambda () (display "test3 outer entered")) 34 | (lambda () 35 | (let ((save-context (lambda (x) 36 | (dynamic-wind 37 | (lambda () (display "test3 save-context entered\n")) 38 | (lambda () 39 | (call/cc (lambda (k) 40 | (if (box-ref kont) ((box-ref kont) 12) (box-set! kont k)) x))) 41 | (lambda () (display "test3 save-context exited\n")))))) 42 | (save-context 21)) 43 | (dynamic-wind 44 | (lambda () (display "test3 inner entered\n")) 45 | (lambda () ((box-ref kont) 15)) 46 | (lambda () (display "test3 inner entered\n")))) 47 | (lambda () (display "test3 outer exited\n")))) 48 | -------------------------------------------------------------------------------- /tests/eval.scm: -------------------------------------------------------------------------------- 1 | (letrec ( 2 | (repl 3 | (lambda () ( 4 | (let ((input (read))) 5 | (if (eof-object? input) 6 | (display 'bye) 7 | (begin 8 | ((secd-closure (secd-compile input) '() '())) 9 | (display 'done) 10 | (repl))))))) 11 | ) (repl)) 12 | -------------------------------------------------------------------------------- /tests/hello.secd: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env secd 2 | (LDC ("Hello world!\n") LD display AP STOP) 3 | -------------------------------------------------------------------------------- /tests/load.scm: -------------------------------------------------------------------------------- 1 | (load "tests/hashtable.scm") 2 | (load "tests/secdtool.scm") 3 | (display (hashtable-keys (free-variables (closure-func free-variables)))) 4 | -------------------------------------------------------------------------------- /tests/loop.secd: -------------------------------------------------------------------------------- 1 | (DUM 2 | LDC () 3 | ;; inc 4 | LDF ((x) (LD x LDC 1 ADD RTN)) 5 | CONS 6 | ;; iter 7 | LDF (() (LDC () READ CONS LD inc AP PRINT RTN)) 8 | CONS 9 | ;; loop 10 | LDF ((iterf) (LDC () LDC () LD iterf AP CONS LD loop AP RTN)) 11 | CONS 12 | ;; 13 | LDF ((loop iter inc) 14 | (LDC () 15 | LD iter 16 | CONS 17 | LD loop 18 | AP 19 | RTN)) 20 | RAP) 21 | 22 | 1 23 | 2 24 | 3 25 | -------------------------------------------------------------------------------- /tests/parser.scm: -------------------------------------------------------------------------------- 1 | (define (string->number s) 2 | (let ((*stdin* (open-input-string s))) 3 | (let ((num (read-lexeme))) 4 | (if (eq? 'int (car (cdddr num))) 5 | (if (eof-object? (read-lexeme)) 6 | (car (list-tail num 4)) 7 | #f) 8 | #f)))) 9 | 10 | (define (lexdebug s) 11 | (let ((*stdin* (open-input-string s))) 12 | (let loop ((endchr #\space) (line 1) (pos 0)) 13 | (let ((inp (read-lexeme endchr line pos))) 14 | (if (eof-object? inp) 'ok 15 | (begin 16 | (display line) (display ":") (display pos) (display ": ") 17 | (display inp) (newline) 18 | (loop (car (list-tail inp 2)) (car inp) (cadr inp)))))))) 19 | -------------------------------------------------------------------------------- /tests/qsort.scm: -------------------------------------------------------------------------------- 1 | (define (quicksort xs) 2 | (cond 3 | ((null? xs) xs) 4 | ((null? (cdr xs)) xs) 5 | (else 6 | (let ((pivot (car xs))) 7 | (let ((r (partition (lambda (x) (<= x pivot)) (cdr xs)))) 8 | (append (quicksort (car r)) 9 | (cons pivot 10 | (quicksort (cadr r))))))))) 11 | -------------------------------------------------------------------------------- /tests/r7rs-compliance.scm: -------------------------------------------------------------------------------- 1 | ;;; Short resume of R7RS 2 | ; must provide the base library and all exported identifiers 3 | 4 | ; every other library must be provided in its entirety 5 | 6 | ;; Identifiers 7 | ; support for required characters: !$%&*+-./:<=>?@^_~ 8 | ; cases: +soup+, +, <=?, a43kTMNs, ->string, lambda, list->vector 9 | ; ->string, q, V17a, the-word-recursion 10 | ; support for zero or more characters inside || 11 | ; cases: ||, |two words|, |two\x20;words| 12 | ; (symbol=? |two words| |two\x20;words|) => #t 13 | ; whitespaces: ' ', '\t', '\n' + maybe more 14 | ; comments: 15 | ; ;, 16 | ; #; 17 | ; #||# 18 | ; datum label: #=, ## 19 | ; disjointness of types: 20 | ; boolean? bytevector? char? eof-object? null? number? 21 | ; pair? port? procedure? string? symbol? vector? 22 | ; + all created by define-record-type 23 | ; external representation: 24 | ; "28", "#e28.000", "#x1c" are ER of the same object; (+ 8 20) is not. 25 | ; not all types have ER 26 | ; (read), (write) 27 | ; storage model: 28 | ; '() is unique 29 | ; "", #(), #u8() may be or may be not newly allocated 30 | ; immutable: literal constants, results of symbol->string, scheme-report-environment 31 | ; proper tail recursion 32 | ; (lambda * * ) 33 | ; (if ) 34 | ; (cond ( )* (else )?) 35 | ; (case ((+) )* (else )?) 36 | ; (and * ) (or * ) 37 | ; (when ) (unless ) 38 | ; let, let*, letrec, letrec*, let-values, let-values* 39 | ; let-syntax, letrec-syntax 40 | ; (begin ) 41 | ; expressions 42 | ; 43 | ; literal expressions: (quote ), 44 | ; numerical, boolean, string, char, bytevector: self-evaluating 45 | ; '# => #, # => #, ''a => (quote a), '"abc" => "abc" 46 | ; function calls 47 | ; all operands are evaluated (in unspecified order) 48 | ; ((if #f + -) 4 2) => 2 49 | ; multiple return values with (values ...) 50 | ; (apply fun args) 51 | 52 | ; procedures 53 | ; (lambda ) => obj, s.t. (procedure? obj), closure 54 | ; ((lambda (x) (+ x x)) 4) => 8 55 | ; formals: (arg*), arglist, (arg* . argrest) 56 | ; arg must be unique 57 | ; conditions: 58 | ; (if ) 59 | ; (if ) 60 | ; (if #t ) => 61 | ; assignments 62 | ; (set! ) => 63 | ; must be bound 64 | ; inclusions 65 | ; (include ""+), 66 | ; => (let ((content (read)+)) (begin content)) 67 | ; (include-ci ""+) - as if with #!fold-case 68 | ; conditionals 69 | ; (cond + (else =>? +)?) 70 | ; where ::= ( *) | ( => ) 71 | ; (cond () ...) if => 72 | ; cond with no => 73 | ; (cond), (cond (else #f) (#t)) are errors 74 | ; (case + ?) 75 | ; where ::= ((+) =>? *), ::= (else =>? ) 76 | ; (eqv? ...) equality 77 | ; if no matches and there's no => 78 | ; (and *) => #f if any is #f; left-to-right short-circuited evaluation 79 | ; => value of the last otherwise, (and) => #t 80 | ; (or *) => value of the first expr that is #t 81 | ; => #f otherwise, (or) => #f 82 | ; (when|unless +) => 83 | ; (cond-expand *) - first that is #t, is evaluated 84 | ; where ::= ( +) 85 | ; ::= | (library ) 86 | ; | (and +) | (or +) 87 | ; | (not 88 | ; bindings 89 | -------------------------------------------------------------------------------- /tests/rbtree.scm: -------------------------------------------------------------------------------- 1 | (define BLACK 0) 2 | (define RED 1) 3 | 4 | (define-macro (childs node) (list 'car node)) 5 | (define-macro (rbdata node) (list 'cdr node)) 6 | 7 | (define-macro (lchild node) (list 'car (list 'childs node))) 8 | (define-macro (rchild node) (list 'cdr (list 'childs node))) 9 | (define-macro (rbval node) (list 'car (list 'rbdata node))) 10 | (define-macro (rbcolor node) (list 'cdr (list 'rbdata node))) 11 | 12 | (define-macro (make-childs left right) (list 'cons left right)) 13 | (define-macro (make-rbinfo data color) (list 'cons data color)) 14 | (define-macro (make-node left right data color) 15 | (list 'cons (list 'make-childs left right) (list 'make-rbinfo data color))) 16 | 17 | (define-macro (make-node-with-rbinf l r i) 18 | (list 'cons (list 'cons l r) i)) 19 | 20 | (define (has-rchild t) 21 | (not (eq? (rchild t) '()))) 22 | (define (has-lchild t) 23 | (not (eq? (lchild t) '()))) 24 | 25 | (define (make-leaf val) (make-node '() '() val RED)) 26 | 27 | (define (tree-set-left node left) 28 | (make-node-with-rbinf left (rchild node) (rbdata node))) 29 | (define (tree-set-right node right) 30 | (make-node-with-rbinf (lchild node) right (rbdata node))) 31 | 32 | (define (bintree-search tree val cmp) 33 | (if (null? tree) '() 34 | (let ((compared (cmp val (rbval tree)))) 35 | (cond 36 | ((eq? compared 0) (list (rbval tree))) 37 | ((<= compared 0) (bintree-search (lchild tree) val cmp)) 38 | ((<= 0 compared) (bintree-search (rchild tree) val cmp)))))) 39 | 40 | (define (tree-insert t val cmp rebalance) 41 | (if (null? t) (make-leaf val) 42 | (let ((compared (cmp val (rbval t)))) 43 | (cond 44 | ((eq? compared 0) t) 45 | ((<= compared 0) 46 | (let ((l (lchild t))) 47 | (if (null? l) 48 | (rebalance (tree-set-left t (make-leaf val))) 49 | (rebalance (tree-set-left t (tree-insert l val cmp rebalance)))))) 50 | ((<= 0 compared) 51 | (let ((r (rchild t))) 52 | (if (null? r) 53 | (rebalance (tree-set-right t (make-leaf val))) 54 | (rebalance (tree-set-right t (tree-insert r val cmp rebalance)))))))))) 55 | 56 | (define (bintree-insert tree val cmp) 57 | (tree-insert tree val cmp (lambda (x) x))) 58 | 59 | (define (rbtree-insert t val cmp) 60 | (let ((t1 (tree-insert t val cmp rb-rebalance))) 61 | (make-node (lchild t1) (rchild t1) (rbval t1) BLACK))) 62 | 63 | (define (andf . thunks) 64 | (cond 65 | ((null? thunks) #t) 66 | (((car thunks)) (apply andf (cdr thunks))) 67 | (else #f))) 68 | 69 | (define (rb-rebalance t) 70 | (cond 71 | ((not (eq? BLACK (rbcolor t))) t) 72 | ((andf (lambda () (has-rchild t)) 73 | (lambda () (eq? RED (rbcolor (rchild t)))) 74 | (lambda () (has-rchild (rchild t))) 75 | (lambda () (eq? RED (rbcolor (rchild (rchild t)))))) 76 | (let ((r (rchild t)) (rr (rchild (rchild t)))) 77 | (make-node 78 | (make-node (lchild t) (lchild r) (rbval t) BLACK) 79 | (make-node (lchild rr) (rchild rr) (rbval rr) BLACK) 80 | (rbval r) RED))) 81 | ((andf (lambda () (has-rchild t)) 82 | (lambda () (eq? RED (rbcolor (rchild t)))) 83 | (lambda () (has-lchild (rchild t))) 84 | (lambda () (eq? RED (rbcolor (lchild (rchild t)))))) 85 | (let ((r (rchild t)) (lr (lchild (rchild t)))) 86 | (make-node 87 | (make-node (lchild t) (lchild lr) (rbval t) BLACK) 88 | (make-node (rchild lr) (rchild r) (rbval r) BLACK) 89 | (rbval lr) RED))) 90 | ((andf (lambda () (has-lchild t)) 91 | (lambda () (eq? RED (rbcolor (lchild t)))) 92 | (lambda () (has-rchild (lchild t))) 93 | (lambda () (eq? RED (rbcolor (rchild (lchild t)))))) 94 | (let ((l (lchild t)) (rl (rchild (lchild t)))) 95 | (make-node 96 | (make-node (lchild l) (lchild rl) (rbval l) BLACK) 97 | (make-node (rchild rl) (rchild t) (rbval t) BLACK) 98 | (rbval rl) RED))) 99 | ((andf (lambda () (has-lchild t)) 100 | (lambda () (eq? RED (rbcolor (lchild t)))) 101 | (lambda () (has-lchild (lchild t))) 102 | (lambda () (eq? RED (rbcolor (lchild (lchild t)))))) 103 | (let ((l (lchild t)) (ll (lchild (lchild t)))) 104 | (make-node 105 | (make-node (lchild ll) (rchild ll) (rbval ll) BLACK) 106 | (make-node (rchild l) (rchild t) (rbval l) BLACK) 107 | (rbval l) RED))) 108 | (else t))) 109 | -------------------------------------------------------------------------------- /tests/regex.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; regular expressions 3 | ;; 4 | 5 | (define EPSILON #xFF) 6 | 7 | (define (make-dynamic-vector) 8 | (let ((FREE_INDEX 0) 9 | (VAL_INDEX 1) 10 | (obj (vector 0 #(#f)))) 11 | (let ((dv-endptr (lambda () (vector-ref obj FREE_INDEX))) 12 | (dv-vect (lambda () (vector-ref obj VAL_INDEX)))) 13 | (letrec 14 | ((least-2power-more-than (lambda (x acc) 15 | (if (< x acc) acc (least-2power-more-than x (+ acc acc))))) 16 | (vector-copy! (lambda (v1 v2 . args) 17 | (if (null? args) 18 | (vector-copy! v1 v2 0 0) 19 | (let ((i1 (car args)) (i2 (cadr args))) 20 | (cond 21 | ((<= (vector-length v1) i1) v1) 22 | ((<= (vector-length v2) i2) v1) 23 | (else 24 | (begin 25 | (vector-set! v1 i1 (vector-ref v2 i2)) 26 | (vector-copy! v1 v2 (+ 1 i1) (+ 1 i2))))))))) 27 | 28 | (dv-append (lambda (val) 29 | (let ((capacity (vector-length (dv-vect))) 30 | (index (dv-endptr))) 31 | (cond 32 | ((<= capacity index) 33 | (let ((new-vect (make-vector (least-2power-more-than capacity 1)))) 34 | (vector-copy! new-vect (dv-vect)) 35 | (vector-set! obj VAL_INDEX new-vect)))) 36 | (vector-set! (dv-vect) index val) 37 | (vector-set! obj FREE_INDEX (+ 1 index)) 38 | index))) 39 | (dv-shrink (lambda () 40 | (let ((newvect (make-vector (dv-endptr)))) 41 | (vector-copy! newvect (dv-vect)) 42 | (vector-set! obj VAL_INDEX newvect))))) 43 | (lambda (msg . args) 44 | (cond 45 | ((eq? msg 'append) (dv-append (car args))) 46 | ((eq? msg 'get) (dv-vect)) 47 | ((eq? msg 'size) (dv-endptr)) 48 | ((eq? msg 'at) (vector-ref (dv-vect) (car args))) 49 | ((eq? msg 'set) (vector-set! (dv-vect) (car args) (cadr args))) 50 | ((eq? msg 'shrink) (dv-shrink)) 51 | (else 'do-not-understand))))))) 52 | 53 | (define (make-nfa) 54 | (let ((dv (make-dynamic-vector))) 55 | (lambda (msg . args) 56 | (cond 57 | ((eq? msg 'get) (dv 'get)) 58 | ((eq? msg 'size) (dv 'size)) 59 | ((eq? msg 'new-node) (dv 'append '() )) 60 | ((eq? msg 'new-edge) 61 | (let ((from (car args)) (to (cadr args)) (val (caddr args))) 62 | (dv 'set from (cons (cons to val) (dv 'at from))))) 63 | (else 'do-not-understand))))) 64 | 65 | ;; regex parsing 66 | ;; Grammar: 67 | ;; ;; atomic expression: 68 | ;; = 69 | ;; | . 70 | ;; | ( ) 71 | ;; | [ ] 72 | ;; ;; pipable expression 73 | ;; = * 74 | ;; | ? 75 | ;; | + 76 | ;; | 77 | ;; = 78 | ;; | 79 | ;; ;; top-level expression 80 | ;; = | 81 | ;; | 82 | ;; 83 | ;; = ... ; TODO 84 | 85 | (define (re-parse-aexpr nfa str) 86 | (cond 87 | ((null? str) '()) ;; eof, failed 88 | ((eq? #\( (car str)) 89 | (let ((e1 (re-parse-expr nfa (cdr str)))) 90 | (if (null? e1) '() 91 | (let ((str1 (car e1)) (startend1 (cdr e1))) 92 | (cond 93 | ((null? str1) '()) 94 | ((eq? (car str1) #\) ) 95 | (cons (cdr str1) startend1)) 96 | (else '())))))) 97 | ;((eq? #\. (car str)) ; TODO 98 | ;((eq? #\[ (car str)) ; TODO 99 | ((memq (car str) '(#\) #\[ #\* #\? #\+ #\|)) 100 | '()) 101 | (else 102 | (let ((start (nfa 'new-node)) 103 | (end (nfa 'new-node)) 104 | (chr (if (eq? (car str) #\\) (cadr str) (car str)))) 105 | (let ((node-val (char->integer chr))) 106 | (nfa 'new-edge start end (if (<= #x80 node-val) #x80 node-val)) 107 | (cons (cdr str) (cons start end))))))) 108 | 109 | (define (re-parse-rexpr nfa str) 110 | (let ((a1 (re-parse-aexpr nfa str))) 111 | (if (null? a1) '() 112 | (let ((str1 (car a1)) (start1 (cadr a1)) (end1 (cddr a1))) 113 | (cond 114 | ((null? str1) a1) ;; eof 115 | ((eq? (car str1) #\*) 116 | (begin 117 | (nfa 'new-edge end1 start1 EPSILON) 118 | (nfa 'new-edge start1 end1 EPSILON) 119 | (cons (cdr str1) (cons start1 end1)))) 120 | ((eq? (car str1) #\?) 121 | (let ((end (nfa 'new-node))) 122 | (nfa 'new-edge start1 end EPSILON) 123 | (nfa 'new-edge end1 end EPSILON) 124 | (cons (cdr str1) (cons start1 end)))) 125 | ; TODO: ((eq? (car str1) #\+ 126 | (else a1)))))) 127 | 128 | (define (re-parse-pexpr nfa str) 129 | ;; returns (str . (start . end)) 130 | (let ((r1 (re-parse-rexpr nfa str))) 131 | (if (null? r1) '() ;; parsing failed 132 | (let ((str1 (car r1)) (start1 (cadr r1)) (end1 (cddr r1))) 133 | (if (null? str1) r1 ;; eof 134 | (let ((p2 (re-parse-pexpr nfa str1))) 135 | (if (null? p2) 136 | r1 ;; back track 137 | (let ((str2 (car p2)) (start2 (cadr p2)) (end2 (cddr p2))) 138 | (nfa 'new-edge end1 start2 EPSILON) 139 | (cons str2 (cons start1 end2)))))))))) 140 | 141 | (define (re-parse-expr nfa str) 142 | ;; returns (str . (start . end)) 143 | (let ((p1 (re-parse-pexpr nfa str))) 144 | (if (null? p1) '() ;; parsing failed? 145 | ;; ok 146 | (let ((str1 (car p1)) (start1 (cadr p1)) (end1 (cddr p1))) 147 | (cond 148 | ((null? str1) p1) ;; eof, return pexpr 149 | ((eq? (car str1) #\|) ;; pipe 150 | (let ((e2 (re-parse-expr nfa (cdr str1)))) 151 | (if (null? e2) '() 152 | (let ((str2 (car e2)) (start2 (cadr e2)) (end2 (cddr e2))) 153 | (let ((start (nfa 'new-node)) (end (nfa 'new-node))) 154 | (begin 155 | (nfa 'new-edge start start1 EPSILON) 156 | (nfa 'new-edge start start2 EPSILON) 157 | (nfa 'new-edge end1 end EPSILON) 158 | (nfa 'new-edge end2 end EPSILON) 159 | (cons str2 (cons start end)))))))) 160 | (else p1)))))) 161 | 162 | ;; regex string => NFA 163 | (define (re-parse str) 164 | (let ((nfa (make-nfa))) 165 | (let ((result (re-parse-expr nfa (string->list str)))) 166 | (cons (nfa 'get) result)))) 167 | 168 | 169 | (define (reverse-vect-fold/index vect state fun) 170 | ;; folds vector in reverse order calling `fun` as 171 | ;; (fun 172 | (letrec 173 | ((fold (lambda (index state) 174 | (cond 175 | ((<= 0 index) 176 | (fold 177 | (- index 1) 178 | (fun index (vector-ref vect index) state))) 179 | (else state))))) 180 | (fold (- (vector-length vect) 1) state))) 181 | 182 | (define (epsilon-closure nfa vertset) 183 | ;; takes nfa array, index of a vertex 184 | ;; returns epsilon-closure of the vertex as a list of vertices 185 | (let ((marks (make-vector (vector-length nfa) #f))) 186 | (letrec 187 | ((mark-epsilon-neighbours (lambda (i) 188 | (cond 189 | ((vector-ref marks i) #f) 190 | (else 191 | (vector-set! marks i #t) 192 | (for-each 193 | (lambda (neighb) 194 | (let ((j (car neighb)) (val (cdr neighb))) 195 | (if (eq? val EPSILON) 196 | (mark-epsilon-neighbours j) 197 | #f))) 198 | (vector-ref nfa i))))))) 199 | (begin 200 | (for-each 201 | (lambda (index) (mark-epsilon-neighbours index)) 202 | vertset) 203 | (reverse-vect-fold/index 204 | marks '() 205 | (lambda (ind val acc) 206 | (if val (cons ind acc) acc))))))) 207 | 208 | (define (moveset nfa fromset val) 209 | ;; takes nfa array, list of vertices `fromset', character code `val' 210 | ;; returns list of verices accesible from `fromset' with `val' 211 | (let ((marks (make-vector (vector-length nfa) #f))) 212 | (letrec 213 | ((mark-neighbours (lambda (i) 214 | (for-each 215 | (lambda (neighb) 216 | (let ((j (car neighb)) (v (cdr neighb))) 217 | (if (eq? v val) 218 | (vector-set! marks j #t) 219 | #f))) 220 | (vector-ref nfa i))))) 221 | (begin 222 | (for-each 223 | (lambda (i) (mark-neighbours i)) 224 | fromset) 225 | (reverse-vect-fold/index 226 | marks '() 227 | (lambda (ind val acc) 228 | (if val (cons ind acc) acc))))))) 229 | 230 | (define (nfa-alphabet nfa) 231 | ;; takes nfa array, returns list of character codes 232 | (let ((charset (make-vector #x81 #f))) 233 | ;(display ";") (display nfa) (newline) 234 | (reverse-vect-fold/index nfa #f 235 | (lambda (ind val _) 236 | (cond 237 | ((pair? val) 238 | (for-each 239 | (lambda (edge) 240 | (let ((v (cdr edge))) 241 | (cond 242 | ((<= v 0) #f) 243 | ((<= #x81 v) #f) 244 | (else (vector-set! charset v #t))))) 245 | val)) 246 | (else #f)))) 247 | (reverse-vect-fold/index charset '() 248 | (lambda (ind val acc) 249 | (if val (cons ind acc) acc))))) 250 | 251 | (define (re-nfa-to-dfa nfa start end) 252 | (let ((CURRENT-IND 0) 253 | (state (vector 0)) 254 | (table (make-dynamic-vector))) 255 | (let ((curr-index (lambda () (vector-ref state CURRENT-IND)))) 256 | (let ((inc-curr-index (lambda () 257 | (vector-set! state CURRENT-IND (+ 1 (curr-index)))))) 258 | (let ((search-set (lambda (set) 259 | ;; returns index of the set if found or #f 260 | (letrec 261 | ((vector-index-for (lambda (vct ind pred) 262 | (cond 263 | ((< ind 0) #f) 264 | ((pred (vector-ref vct ind)) ind) 265 | (else (vector-index-for vct (- ind 1) pred)))))) 266 | (vector-index-for (table 'get) (- (table 'size) 1) 267 | (lambda (row) (equal? (car row) set))))))) 268 | (let ((abc (nfa-alphabet nfa))) 269 | (let ((make-mvsets (lambda (set) 270 | (map (lambda (chr) (epsilon-closure nfa (moveset nfa set chr))) abc))) 271 | (set-to-index (lambda (set) 272 | (if (null? set) -1 273 | (let ((i (search-set set))) 274 | (if i i (table 'append (list set)))))))) 275 | (let ((fill-row (lambda () 276 | (let ((set (car (vector-ref (table 'get) (curr-index))))) 277 | (let ((mvsets (map set-to-index (make-mvsets set)))) 278 | (table 'set (curr-index) (cons set mvsets)) 279 | (inc-curr-index)))))) 280 | (begin 281 | (table 'append (list (epsilon-closure nfa (list start)))) 282 | (let loop () 283 | (if (<= (table 'size) (curr-index)) 284 | (begin 285 | (table 'shrink) 286 | (table 'get)) 287 | (begin 288 | ;(newline) (display (curr-index)) (newline) 289 | ;(display (table 'get)) (newline) 290 | (fill-row) (loop))))))))))))) 291 | 292 | (define (is-final-dfa-row dfa end r) 293 | (if (memq end (car r)) #t #f)) 294 | 295 | (define (re-compile regexp) 296 | (let ((vector-map (if (defined? 'vector-map) 297 | vector-map 298 | (lambda (f v) (list->vector (map f (vector->list v))))))) 299 | (let ((r (re-parse regexp))) ; parse result 300 | (let ((nfa (car r)) (tmp (cdr r))) 301 | (let ((re-rest (car tmp)) (start (cadr tmp)) (end (cddr tmp))) 302 | (if (null? re-rest) 303 | (let ((dfa (re-nfa-to-dfa nfa start end))) 304 | (list (nfa-alphabet nfa) 305 | (vector-map (lambda (r) (is-final-dfa-row dfa end r)) dfa) 306 | (vector-map cdr dfa))) 307 | (raise 'error:_re-compile_failed_to_parse))))))) 308 | 309 | (define (re-match re str) 310 | (let ((abc (car re)) 311 | (final-states (cadr re)) 312 | (dfa (caddr re))) 313 | (let loop ((state 0) 314 | (s (string->list str))) 315 | (cond 316 | ((null? s) 317 | (list (vector-ref final-states state) s)) 318 | (else 319 | (let ((i (list-index abc (char->integer (car s))))) 320 | ;(newline) (display (car s)) (newline) (display state) (newline) 321 | (if i 322 | (let ((n (list-ref (vector-ref dfa state) i))) 323 | (if (<= 0 n) (loop n (cdr s)) (list #f s))) 324 | (list #f s)))))))) 325 | 326 | ;; 327 | ;; Tests 328 | ;; 329 | 330 | (define re-example1 331 | '((string . "\"(\\.|[^\"])*\"") 332 | (decnumber . "[-+]?[0-9]+"))) 333 | 334 | (define re-test1 "ab*c") 335 | (define re-test2 "(ba*c)*") 336 | (define re-test3 "lol(what|whut)") 337 | (define re-test4 "[01234567]+") 338 | 339 | -------------------------------------------------------------------------------- /tests/secd.scm: -------------------------------------------------------------------------------- 1 | (define (cdddr lst) (cdr (cddr lst))) 2 | 3 | (define (self-print-env env) 4 | (letrec ((print-frame 5 | (lambda (syms vals) 6 | (if (null? syms) 7 | (if (null? vals) '() 8 | (begin (display "\n;; Error: trailing vals\n") (display vals) (newline))) 9 | (if (null? vals) 10 | (begin 11 | (display "\n;; Error: no vals\n") (display syms) '()) 12 | (begin 13 | (display "\n;; ") (display (car syms)) (display " -> ") (display (car vals)) 14 | (print-frame (cdr syms) (cdr vals)))))))) 15 | (if (null? env) '() 16 | (let ((frame (car env))) 17 | (if (null? frame) 18 | (begin 19 | (display "\n;; Error: null frame\n") '()) 20 | (begin 21 | (display "\n;; Frame\n") 22 | (if (vector? frame) 23 | (begin 24 | (display "\n;; ###") 25 | (let ((f (vector-ref frame 0))) 26 | (print-frame (car f) (cdr f)))) 27 | (print-frame (car frame) (cdr frame))) 28 | (self-print-env (cdr env)))))))) 29 | 30 | (define (self-lookup-env env sym) 31 | (if (null? env) 32 | ;; access to the Scheme env: 33 | (if (defined? sym) (eval sym (interaction-environment)) '()) 34 | (let ((frame (let ((f (car env))) 35 | (if (vector? f) (vector-ref f 0) f))) 36 | (envrest (cdr env))) 37 | (if (pair? frame) 38 | (letrec ((lookup-frame 39 | (lambda (syms vals) 40 | (if (null? syms) '() 41 | (if (eq? (car syms) sym) 42 | (list (car vals)) 43 | (lookup-frame (cdr syms) (cdr vals))))))) 44 | (if (eq? (length (car frame)) (length (cdr frame))) 45 | (let ((res (lookup-frame (car frame) (cdr frame)))) 46 | (if (null? res) 47 | (self-lookup-env envrest sym) 48 | res)) 49 | (begin 50 | (display "\nError:_args") (newline) 51 | (self-print-env env) 52 | '()))) 53 | ;; it's an omega-frame, skipping: 54 | (self-lookup-env envrest sym))))) 55 | 56 | (define (self-eval-step s e c d) 57 | (let ((cmd (car c)) (c1 (cdr c))) 58 | (begin 59 | ;(display "\n\n s = ") (display s) 60 | ;(display "\n e = ") (display e) 61 | ;(display "\n c = ") (display c) 62 | ;(display "\n d = ") (display d) 63 | (cond 64 | ((eq? cmd 'LDC) 65 | (let ((cn (car c1)) (c2 (cdr c1))) 66 | (self-eval-step (cons cn s) e c2 d))) 67 | ((eq? cmd 'ADD) 68 | (let ((v1 (car s)) (v2 (cadr s)) (s2 (cddr s))) 69 | (self-eval-step (cons (+ v1 v2) s2) e c1 d))) 70 | ((eq? cmd 'SUB) 71 | (let ((v1 (car s)) (v2 (cadr s)) (s2 (cddr s))) 72 | (self-eval-step (cons (- v1 v2) s2) e c1 d))) 73 | ((eq? cmd 'MUL) 74 | (let ((v1 (car s)) (v2 (cadr s)) (s2 (cddr s))) 75 | (self-eval-step (cons (* v1 v2) s2) e c1 d))) 76 | 77 | ((eq? cmd 'CONS) 78 | (let ((v1 (car s)) (v2 (cadr s)) (s2 (cddr s))) 79 | (self-eval-step (cons (cons v1 v2) s2) e c1 d))) 80 | ((eq? cmd 'CAR) 81 | (let ((v (car s)) (s1 (cdr s))) 82 | (self-eval-step (cons (car v) s1) e c1 d))) 83 | ((eq? cmd 'CDR) 84 | (let ((v (car s)) (s1 (cdr s))) 85 | (if (null? v) 86 | 'Error:_cdr_nil 87 | (self-eval-step (cons (cdr v) s1) e c1 d)))) 88 | 89 | ((eq? cmd 'LEQ) 90 | (let ((v1 (car s)) (v2 (cadr s)) (s2 (cddr s))) 91 | (self-eval-step (cons (<= v1 v2) s2) e c1 d))) 92 | ((eq? cmd 'TYPE) 93 | (let ((v (car s)) (s1 (cdr s))) 94 | (self-eval-step (cons (secd-type v) s1) e c1 d))) 95 | ((eq? cmd 'EQ) 96 | (let ((v1 (car s)) (v2 (cadr s)) (s2 (cddr s))) 97 | (self-eval-step (cons (eq? v1 v2) s2) e c1 d))) 98 | 99 | ((eq? cmd 'SEL) 100 | (let ((v (car s)) (s1 (cdr s)) 101 | (thenb (car c1)) (elseb (cadr c1)) (c2 (cddr c1))) 102 | (self-eval-step s1 e (if v thenb elseb) (cons c2 d)))) 103 | ((eq? cmd 'JOIN) 104 | (let ((c1 (car d)) (d1 (cdr d))) 105 | (self-eval-step s e c1 d1))) 106 | 107 | ((eq? cmd 'LD) 108 | (let ((cn (car c1)) (c2 (cdr c1))) 109 | (let ((v (self-lookup-env e cn))) 110 | (if (null? v) 111 | (list 'Error:_lookup_failed_for cn) 112 | (self-eval-step (cons (car v) s) e c2 d))))) 113 | ((eq? cmd 'LDF) 114 | (let ((func (car c1)) (c2 (cdr c1))) 115 | (let ((clos (cons func e))) 116 | (self-eval-step (cons clos s) e c2 d)))) 117 | ((eq? cmd 'AP) 118 | (let ((clos (car s)) (argvals (cadr s)) (s2 (cddr s))) 119 | (let ((func (car clos)) (e1 (cdr clos))) 120 | (let ((args (car func)) (body (cadr func))) 121 | (let ((d1 (append (list s2 e c1) d))) 122 | (begin 123 | ;(display "\n; argnames: ") (display args) 124 | ;(display "\n; argvals : ") (display argvals) (newline) 125 | ;(self-print-env e1) 126 | (self-eval-step '() (cons (cons args argvals) e1) body d1))))))) 127 | ((eq? cmd 'RTN) 128 | (let ((v (car s)) 129 | (s1 (car d)) (e1 (cadr d)) (c1 (caddr d)) (d1 (cdddr d))) 130 | (self-eval-step (cons v s1) e1 c1 d1))) 131 | 132 | ((eq? cmd 'READ) 133 | (let ((inp (read))) 134 | (self-eval-step (cons inp s) e c1 d))) 135 | ((eq? cmd 'PRINT) 136 | (begin 137 | (display (car s)) 138 | (self-eval-step s e c d))) 139 | 140 | ((eq? cmd 'DUM) 141 | (self-eval-step s (cons (make-vector 1 0) e) c1 d)) 142 | ((eq? cmd 'RAP) 143 | (let ((clos (car s)) (argvals (cadr s)) (s2 (cddr s))) 144 | (let ((func (car clos)) (e1 (cdr clos))) 145 | (let ((args (car func)) (body (cadr func))) 146 | (let ((frame (cons args argvals)) 147 | (d1 (append (list s2 (cdr e1) c1) d))) 148 | (begin 149 | ;(display "\n; RAP argnames: ") (display args) 150 | ;(display "\n; RAP argvals: ") (display argvals) 151 | (vector-set! (car e1) 0 frame) 152 | (self-eval-step '() e1 body d1))))))) 153 | 154 | ((eq? cmd 'STOP) 155 | (car s)) 156 | (else 157 | (list 'Error:_unknown_command cmd)) 158 | )))) 159 | 160 | (define (self-eval-secd ctrl) 161 | (self-eval-step '() '() ctrl '())) 162 | 163 | (define (self-eval expr) 164 | (self-eval-secd (append (secd-compile expr) '(STOP)))) 165 | -------------------------------------------------------------------------------- /tests/secdtool.scm: -------------------------------------------------------------------------------- 1 | (define secdop-info 2 | '(( #.ADD 0 2 1 ADD) 3 | ( #.AP 0 2 1 AP) 4 | ( #.CAR 0 1 1 CAR) 5 | ( #.CDR 0 1 1 CDR) 6 | ( #.CONS 0 2 1 CONS) 7 | ( #.DIV 0 2 1 DIV) 8 | ( #.DUM 0 0 0 DUM) 9 | ( #.EQ 0 2 1 EQ) 10 | ( #.JOIN 0 0 0 JOIN) 11 | ( #.LD 1 0 1 LD) 12 | ( #.LDC 1 0 1 LDC) 13 | ( #.LDF 1 0 1 LDF) 14 | ( #.LEQ 0 2 1 LEQ) 15 | ( #.MUL 0 2 1 MUL) 16 | ( #.PRINT 0 0 0 PRINT) 17 | ( #.RAP 0 2 1 RAP) 18 | ( #.READ 0 0 1 READ) 19 | ( #.REM 0 2 1 REM) 20 | ( #.RTN 0 0 0 RTN) 21 | ( #.SEL 2 1 0 SEL) 22 | ( #.STOP 0 0 0 STOP) 23 | ( #.SUB 0 2 1 SUB) 24 | ( #.TYPE 0 1 1 TYPE))) 25 | 26 | (define (takes-from-stack info) (cadr info)) 27 | (define (puts-to-stack info) (caddr info)) 28 | 29 | (define (closure-func clos) (car clos)) 30 | (define (secd-func-ctrl func) (cadr func)) 31 | (define (secd-func-args func) (car func)) 32 | (define (closure-ctrl clos) (secd-func-ctrl (closure-func clos))) 33 | 34 | (define (info-for op) 35 | (letrec ((search 36 | (lambda (info) 37 | (if (null? info) 38 | 'err:_no_info_for 39 | (if (eq? op (car (car info))) 40 | (cdr (car info)) 41 | (search (cdr info))))))) 42 | (search secdop-info))) 43 | 44 | (define (take n lst) 45 | (if (eq? n 0) '() 46 | (if (null? lst) '() 47 | (cons (car lst) (take (- n 1) (cdr lst)))))) 48 | (define (drop n lst) 49 | (if (eq? n 0) lst 50 | (if (null? lst) '() 51 | (drop (- n 1) (cdr lst))))) 52 | 53 | ;(define (secd-ctrl-compile ctrl compiled) 54 | ; (cond 55 | ; ((null? ctrl) (reverse compiled)) 56 | ; ((or (eq? (car ctrl) 'SEL) (eq? (car ctrl) #.SEL)) 57 | ; (let ((thenb (secd-ctrl-compile (cadr ctrl) '())) 58 | ; (elseb (secd-ctrl-compile (caddr ctrl) '())) 59 | ; (joinb (cadr (cddr ctrl)))) 60 | ; (secd-ctrl-compile joinb (cons elseb (cons thenb (cons #.SEL compiled)))))) 61 | ; ((or (eq? (car ctrl) 'LDF) (eq? (car ctrl) #.LDF)) 62 | ; (let ((subfunc (cadr ctrl))) 63 | ; (let ((subargs (car subfunc)) 64 | ; (subctrl (secd-ctrl-compile (cadr subfunc) '())) 65 | ; (subother (cddr subfunc)))) 66 | ; (secd-ctrl-compile (caddr ctrl) 67 | ; (cons (cons subargs (cons subctrl subother)) (cons #.LDF compiled))))) 68 | ; (else 69 | ; (cond 70 | ; ((eq? (secd-type (car ctrl)) 'op) 71 | ; (let ((info (info-for (car ctrl)))) 72 | ; (secd-ctrl-compile (list-tail ctrl (car info)) 73 | 74 | ;; this function does not descend into SEL branches 75 | ;; `func` is invoked as: (func val oplst opinfo) 76 | (define (secd-ctrl-fold func val ctrl) 77 | (if (null? ctrl) 78 | val 79 | (begin 80 | (define info (info-for (car ctrl))) 81 | (define to-take (+ 1 (car info))) 82 | (define oplst (take to-take ctrl)) 83 | (define brest (drop to-take ctrl)) 84 | (cond 85 | ((eq? (car oplst) #.AP) 86 | (if (number? (cadr ctrl)) 87 | (secd-ctrl-fold func (func val (take 2 ctrl) info) (cddr ctrl)) 88 | (secd-ctrl-fold func (func val oplst info) brest))) 89 | (else (secd-ctrl-fold func (func val oplst info) brest)))))) 90 | 91 | (define (secd-stack-depth ctrl) 92 | (letrec 93 | ((iteration 94 | (lambda (depth oplst info) 95 | (if (number? depth) 96 | (begin 97 | (define from-stack (if (eq? (car oplst) #.AP) 98 | (if (null? (cdr oplst)) 2 (+ 1 (cadr oplst))) 99 | (takes-from-stack info))) 100 | (define to-stack (puts-to-stack info)) 101 | (define depth1 (- depth from-stack)) 102 | (define depth2 (+ depth1 to-stack)) 103 | (cond 104 | ((> 0 depth1) 'error:_stack_underflow) 105 | ((eq? (car oplst) #.SEL) 106 | (begin 107 | (define thendepth 108 | (secd-ctrl-fold iteration depth2 (cadr oplst))) 109 | (define elsedepth 110 | (secd-ctrl-fold iteration depth2 (caddr oplst))) 111 | (if (eq? thendepth elsedepth) 112 | thendepth 113 | 'err:_then_else_disbalance))) 114 | (else depth2))) 115 | depth)))) 116 | (secd-ctrl-fold iteration 0 ctrl))) 117 | 118 | (define (valid-stack clos) 119 | (eq? 1 (secd-stack-depth (closure-ctrl clos)))) 120 | 121 | (define (bound-variables func) 122 | (let ((ht (make-hashtable))) 123 | (begin ;; using (hashtable-size) as counter: 124 | (for-each 125 | (lambda (arg) (hashtable-set! ht arg (hashtable-size ht))) 126 | (secd-func-args func)) 127 | ht))) 128 | 129 | ;; takes a compiled function definition (func part of a closure) 130 | ;; returns hashtable with FV set as keys 131 | (define (free-variables func) 132 | (let ((bv-ht (bound-variables func)) 133 | (dumrap (vector #f #f))) 134 | (letrec 135 | ((save-freevar 136 | (lambda (ht var) 137 | (cond 138 | ((hashtable-exists? bv-ht var) #f) 139 | ((hashtable-exists? ht var) #f) 140 | (else 141 | (let ((dr-vars (vector-ref dumrap 0))) 142 | (let ((the-ht (if dr-vars dr-vars ht))) 143 | (hashtable-set! the-ht var (- -1 (hashtable-size the-ht))))))))) 144 | (process-opcode 145 | (lambda (fv-ht oplst info) 146 | (begin 147 | ;(display ";; process-opcode: ") (display oplst) (newline) 148 | (cond 149 | ((eq? (car oplst) #.LD) 150 | (save-freevar fv-ht (cadr oplst))) 151 | ((eq? (car oplst) #.SEL) 152 | (begin 153 | (secd-ctrl-fold process-opcode fv-ht (cadr oplst)) 154 | (secd-ctrl-fold process-opcode fv-ht (caddr oplst)))) 155 | ((eq? (car oplst) #.LDF) 156 | ;; descend into the lambda recursively 157 | (let ((subfunc (cadr oplst))) 158 | (cond ((vector-ref dumrap 0) 159 | (vector-set! dumrap 1 subfunc))) 160 | (for-each 161 | (lambda (k) (save-freevar fv-ht k)) 162 | (hashtable-keys (free-variables subfunc))))) 163 | ((eq? (car oplst) #.DUM) 164 | (begin 165 | ;(display ";; free-variables: DUM\n") 166 | (vector-set! dumrap 0 (make-hashtable)))) 167 | ((eq? (car oplst) #.RAP) 168 | (let ((dr-vars (vector-ref dumrap 0)) 169 | (dr-bv (bound-variables (vector-ref dumrap 1)))) 170 | ;(display ";; free-variables: RAP\n") 171 | (vector-set! dumrap 0 #f) 172 | (for-each 173 | (lambda (k) 174 | (if (hashtable-exists? dr-bv k) #f (save-freevar fv-ht k))) 175 | (hashtable-keys dr-vars)))) 176 | ) 177 | fv-ht)))) 178 | (secd-ctrl-fold process-opcode (make-hashtable) (secd-func-ctrl func))))) 179 | 180 | -------------------------------------------------------------------------------- /tests/test1.secd: -------------------------------------------------------------------------------- 1 | ( 2 | ; an anonymous square function applied to value 12 3 | LDC (12) ; this is argvals 4 | LDF ((x) (LD x LD x MUL RTN)) ; LDF (argnames body) 5 | AP ; apply top of the stack to the list of arguments below 6 | ) 7 | -------------------------------------------------------------------------------- /tests/test2.secd: -------------------------------------------------------------------------------- 1 | ; make a lambda and pass it to a function which applies it 2 | ( 3 | ; make a list of arguments: ((lambda (x) (* x x))) 4 | LD NIL 5 | LDF ((x) (LD x LD x MUL RTN)) 6 | CONS 7 | 8 | ; apply lambda: (lambda (f) (f 12)) 9 | LDF ((f) (LD NIL LDC 12 CONS LD f AP RTN)) 10 | AP 11 | ) 12 | -------------------------------------------------------------------------------- /tests/test_fact.secd: -------------------------------------------------------------------------------- 1 | ;;; this is a test for recursion: factorial(4) 2 | 3 | (DUM 4 | LDC () ; the same as LD NIL 5 | ;; factorial body: 6 | LDF ((n) 7 | (LD n LDC 0 EQ 8 | SEL (LDC 1 JOIN) 9 | (LDC () LDC 1 LD n SUB CONS 10 | LD fact AP 11 | LD n MUL 12 | JOIN) 13 | RTN)) 14 | CONS 15 | 16 | ;; factorial(6): 17 | LDF ((fact) 18 | (LDC () LDC 6 CONS 19 | LD fact AP RTN)) 20 | RAP STOP) 21 | -------------------------------------------------------------------------------- /tests/test_io.secd: -------------------------------------------------------------------------------- 1 | ;;; READ->PROCESS->PRINT loop test 2 | 3 | (DUM 4 | LDC () 5 | LDF (() 6 | (LDC () READ CONS 7 | LDF ((inp) ( 8 | LDC () LD inp CONS 9 | LD eof-object? AP 10 | SEL (STOP JOIN) 11 | (LD inp 12 | ATOM 13 | SEL 14 | (LDC (It looks like an atom) JOIN) 15 | (LDC (I doubt it`s an atom) JOIN) 16 | PRINT 17 | LD loop 18 | AP 19 | JOIN) 20 | RTN)) 21 | AP 22 | RTN)) 23 | CONS 24 | 25 | ;; the call 26 | LDF ((loop) 27 | (LDC () 28 | LD loop 29 | AP RTN)) 30 | RAP) 31 | -------------------------------------------------------------------------------- /tests/test_tco.secd: -------------------------------------------------------------------------------- 1 | ;;; this is a test for recursion: factorial(4) 2 | 3 | (DUM 4 | LDC () ; the same as LD NIL 5 | ;; factorial body: 6 | LDF ((n acc) 7 | (LD n LDC 0 EQ 8 | SEL (LD acc 9 | JOIN) 10 | (LDC () 11 | LD acc LD n MUL 12 | CONS 13 | LDC 1 LD n SUB 14 | CONS 15 | LD fact 16 | AP 17 | JOIN) 18 | RTN)) 19 | CONS 20 | 21 | ;; factorial(6): 22 | LDF ((fact) 23 | (LDC () LDC 1 CONS LDC 6 CONS 24 | LD fact AP RTN)) 25 | RAP 26 | STOP) 27 | -------------------------------------------------------------------------------- /tests/ukrainian.scm: -------------------------------------------------------------------------------- 1 | ;; This is a half-humorous exercise to translate Scheme core into 2 | ;; Ukrainian. It is not supposed to be used for anything useful, 3 | ;; I just can't resist temptation to see limits of Ukrainian 4 | ;; (in)expressiveness as a programming language. 5 | 6 | ;; Also this file is a nice stress test for heavy macro usage 7 | 8 | (define-macro (означ-макрос що чим) (list 'define-macro що чим)) 9 | 10 | (означ-макрос (означ що чим) 11 | (cond 12 | ((pair? що) 13 | (let ((name (car що)) (args (cdr що))) 14 | (list 'secd-bind! `(quote ,name) (list 'lambda args чим)))) 15 | ((symbol? що) 16 | (list 'secd-bind! `(quote ,що) чим)))) 17 | 18 | (означ-макрос (список . елементи) (cons 'list елементи)) 19 | 20 | (означ-макрос (цит що) (list 'quote що)) 21 | (означ-макрос (квцит що) (list 'quasiquote що)) 22 | 23 | (означ-макрос (виконай . що) (cons 'eval що)) 24 | (означ-макрос (виклик чого аргументи) (list 'secd-apply чого аргументи)) 25 | (означ-макрос (вихід) '(quit)) 26 | ;; виклик-з-поточним-продовженням: 27 | (означ-макрос (викл-пп дія) (cons 'call/cc дія)) 28 | 29 | ;; списки 30 | ;; cons - КЛіТинка 31 | (означ-макрос (клт голова хвіст) `(cons ,голова ,хвіст)) 32 | ;; car - ПеРШе зі списку 33 | (означ-макрос (прш клт) `(car ,клт)) 34 | ;; cdr - РеШТа списку 35 | (означ-макрос (ршт клт) `(cdr ,клт)) 36 | 37 | ;; два синоніми для lambda 38 | (означ-макрос (функція аргументи . тіло) 39 | (cons 'lambda (cons аргументи тіло))) 40 | (означ-макрос (дія аргументи . тіло) 41 | (cons 'lambda (cons аргументи тіло))) 42 | 43 | (означ (переписати-означення вирази) 44 | (map 45 | (lambda (expr) 46 | (cond 47 | ((pair? expr) 48 | (if (eq? (car expr) 'означ) (cons 'define (cdr expr)) expr)) 49 | (else expr))) 50 | вирази)) 51 | 52 | (означ-макрос (блок . тіло) (cons 'begin (переписати-означення тіло))) 53 | (означ-макрос (якщо умова то інакше) 54 | (list 'if умова то інакше)) 55 | (означ-макрос (умовно . гілки) (cons 'cond гілки)) 56 | 57 | (означ-макрос (введи) '(read)) 58 | (означ-макрос (виведи що) (list 'write що)) 59 | (означ-макрос (друк . що) (cons 'display що)) 60 | 61 | (означ-макрос (хай змінні . вирази) 62 | (cons 'let (cons змінні (переписати-означення вирази)))) 63 | (означ-макрос (нехай змінні . вирази) 64 | (cons 'letrec (cons змінні (переписати-означення вирази)))) 65 | 66 | (означ-макрос (екв? перше друге) (list 'eq? перше друге)) 67 | 68 | (означ-макрос (залишок ділене дільник) (list 'remainder ділене дільник)) 69 | 70 | (означ Так #t) 71 | (означ Ні #f) 72 | (означ-макрос (не вираз) (list 'not вираз)) 73 | 74 | (означ-макрос (по-списку дія список) (list 'for-each дія список)) 75 | 76 | (означ унарні-функції 77 | '((пусте? . null?) 78 | (пара? . pair?) 79 | (число? . number?) 80 | (символ? . symbol?))) 81 | 82 | ;(по-списку 83 | ; (дія (пара) 84 | ; (хай ((переклад (прш пара)) (оригінал (ршт пара))) 85 | ; (означ-макрос (переклад аргумент) (list оригінал аргумент)))) 86 | ; унарні-функції) 87 | -------------------------------------------------------------------------------- /vm/env.c: -------------------------------------------------------------------------------- 1 | #include "secd/secd.h" 2 | #include "secd/secd_io.h" 3 | 4 | #include "env.h" 5 | #include "memory.h" 6 | 7 | #include 8 | 9 | static hash_t stdinhash; 10 | static hash_t stdouthash; 11 | static hash_t stddbghash; 12 | 13 | /* 14 | * Environment 15 | */ 16 | 17 | void secd_print_env(secd_t *secd) { 18 | cell_t *env = secd->env; 19 | int i = 0; 20 | secd_printf(secd, ";;Environment:\n"); 21 | while (not_nil(env)) { 22 | secd_printf(secd, ";; Frame #%d:\n", i++); 23 | cell_t *frame = get_car(env); 24 | cell_t *symlist = get_car(frame); 25 | cell_t *vallist = get_cdr(frame); 26 | 27 | while (not_nil(symlist)) { 28 | if (is_symbol(symlist)) { 29 | secd_printf(secd, ";; . %s\t=>\t", symname(symlist)); 30 | dbg_print_cell(secd, vallist); 31 | break; 32 | } 33 | cell_t *sym = get_car(symlist); 34 | cell_t *val = get_car(vallist); 35 | if (!is_symbol(sym)) { 36 | errorf("print_env: not a symbol at *%p in symlist\n", sym); 37 | dbg_printc(secd, sym); 38 | } 39 | secd_printf(secd, ";; %s\t=>\t", symname(sym)); 40 | dbg_print_cell(secd, val); 41 | 42 | symlist = list_next(secd, symlist); 43 | vallist = list_next(secd, vallist); 44 | } 45 | 46 | env = list_next(secd, env); 47 | } 48 | } 49 | 50 | cell_t *make_native_frame(secd_t *secd, 51 | const native_binding_t *binding) 52 | { 53 | int i; 54 | cell_t *symlist = SECD_NIL; 55 | cell_t *vallist = SECD_NIL; 56 | 57 | for (i = 0; binding[i].name; ++i) { 58 | cell_t *sym = new_symbol(secd, binding[i].name); 59 | cell_t *val = new_const_clone(secd, binding[i].val); 60 | if (not_nil(val)) 61 | sym->nref = val->nref = DONT_FREE_THIS; 62 | symlist = new_cons(secd, sym, symlist); 63 | vallist = new_cons(secd, val, vallist); 64 | } 65 | 66 | return new_frame(secd, symlist, vallist); 67 | } 68 | 69 | void secd_init_env(secd_t *secd) { 70 | /* initialize global values */ 71 | stdinhash = secd_strhash(SECD_FAKEVAR_STDIN); 72 | stdouthash = secd_strhash(SECD_FAKEVAR_STDOUT); 73 | stddbghash = secd_strhash(SECD_FAKEVAR_STDDBG); 74 | 75 | /* initialize the first frame */ 76 | cell_t *frame = make_native_frame(secd, native_functions); 77 | 78 | cell_t *frame_io = new_cons(secd, secd->input_port, secd->output_port); 79 | frame->as.frame.io = share_cell(secd, frame_io); 80 | 81 | /* ready */ 82 | cell_t *env = new_cons(secd, frame, SECD_NIL); 83 | 84 | secd->env = share_cell(secd, env); 85 | secd->global_env = secd->env; 86 | } 87 | 88 | static cell_t *lookup_fake_variables(secd_t *secd, const char *sym) { 89 | hash_t symh = secd_strhash(sym); 90 | if ((symh == stdinhash) && str_eq(sym, SECD_FAKEVAR_STDIN)) 91 | return secd->input_port; 92 | if ((symh == stdouthash) && str_eq(sym, SECD_FAKEVAR_STDOUT)) 93 | return secd->output_port; 94 | if ((symh == stddbghash) && str_eq(sym, SECD_FAKEVAR_STDDBG)) 95 | return secd->debug_port; 96 | return SECD_NIL; 97 | } 98 | 99 | cell_t *lookup_env(secd_t *secd, const char *symbol, cell_t **symc) { 100 | cell_t *env = secd->env; 101 | assert(cell_type(env) == CELL_CONS, 102 | "lookup_env: environment is not a list"); 103 | 104 | cell_t *res = lookup_fake_variables(secd, symbol); 105 | if (not_nil(res)) 106 | return res; 107 | 108 | hash_t symh = secd_strhash(symbol); 109 | 110 | while (not_nil(env)) { // walk through frames 111 | cell_t *frame = get_car(env); 112 | if (is_nil(frame)) { 113 | /* skip omega-frame */ 114 | env = list_next(secd, env); 115 | continue; 116 | } 117 | 118 | cell_t *symlist = get_car(frame); 119 | cell_t *vallist = get_cdr(frame); 120 | 121 | while (not_nil(symlist)) { // walk through symbols 122 | if (is_symbol(symlist)) { 123 | if (symh == symhash(symlist) && str_eq(symbol, symname(symlist))) { 124 | if (symc != NULL) *symc = symlist; 125 | return vallist; 126 | } 127 | break; 128 | } 129 | 130 | cell_t *curc = get_car(symlist); 131 | assert(is_symbol(curc), 132 | "lookup_env: variable at [%ld] is not a symbol\n", 133 | cell_index(secd, curc)); 134 | 135 | if (symh == symhash(curc) && str_eq(symbol, symname(curc))) { 136 | if (symc != NULL) *symc = curc; 137 | return get_car(vallist); 138 | } 139 | 140 | symlist = list_next(secd, symlist); 141 | vallist = list_next(secd, vallist); 142 | } 143 | 144 | env = list_next(secd, env); 145 | } 146 | //errorf(";; error in lookup_env(): %s not found\n", symbol); 147 | return new_error(secd, SECD_NIL, "Lookup failed for: '%s'", symbol); 148 | } 149 | 150 | static cell_t * 151 | check_io_args(secd_t *secd, cell_t *sym, cell_t *val, cell_t **args_io) { 152 | /* check for overriden *stdin* or *stdout* */ 153 | hash_t symh = symhash(sym); 154 | if ((symh == stdinhash) 155 | && str_eq(symname(sym), SECD_FAKEVAR_STDIN)) 156 | { 157 | assert(cell_type(val) == CELL_PORT, "*stdin* must bind a port"); 158 | if (is_nil(*args_io)) 159 | *args_io = new_cons(secd, val, SECD_NIL); 160 | else 161 | (*args_io)->as.cons.car = share_cell(secd, val); 162 | } else 163 | if ((symh == stdouthash) 164 | && str_eq(symname(sym), SECD_FAKEVAR_STDOUT)) 165 | { 166 | assert(cell_type(val) == CELL_PORT, "*stdout* must bind a port"); 167 | if (is_nil(*args_io)) 168 | *args_io = new_cons(secd, SECD_NIL, val); 169 | else 170 | (*args_io)->as.cons.cdr = share_cell(secd, val); 171 | } 172 | return SECD_NIL; 173 | } 174 | 175 | /* check arity; 176 | * possibly rewrite dot-lists into regular arguments; 177 | * look for overriden *stdin*|*stdout* */ 178 | static cell_t * 179 | walk_through_arguments(secd_t *secd, cell_t *frame, cell_t **args_io) { 180 | cell_t *symlist = get_car(frame); 181 | cell_t *vallist = get_cdr(frame); 182 | 183 | size_t valcount = 0; 184 | 185 | while (not_nil(symlist)) { 186 | if (is_symbol(symlist)) { 187 | break; 188 | } 189 | 190 | if (is_nil(vallist)) { 191 | errorf(";; arity mismatch: %zd argument(s) is not enough\n", valcount); 192 | return new_error(secd, SECD_NIL, 193 | "arity mismatch: %zd argument(s) is not enough", valcount); 194 | } 195 | 196 | cell_t *sym = get_car(symlist); 197 | 198 | check_io_args(secd, sym, get_car(vallist), args_io); 199 | 200 | cell_t *nextsyms = list_next(secd, symlist); 201 | cell_t *nextvals = list_next(secd, vallist); 202 | 203 | ++valcount; 204 | 205 | symlist = nextsyms; 206 | vallist = nextvals; 207 | } 208 | 209 | return SECD_NIL; 210 | } 211 | 212 | /* use *args_io to override *stdin* | *stdout* if not NIL */ 213 | static cell_t *new_frame_io(secd_t *secd, cell_t *args_io, cell_t *prevenv) { 214 | cell_t *prev_io = get_car(prevenv)->as.frame.io; 215 | if (is_nil(args_io)) 216 | return prev_io; /* share previous i/o */ 217 | 218 | if (is_nil(get_car(args_io))) 219 | args_io->as.cons.car = share_cell(secd, get_car(prev_io)); 220 | if (is_nil(get_cdr(args_io))) 221 | args_io->as.cons.cdr = share_cell(secd, get_cdr(prev_io)); 222 | return args_io; /* set a new i/o */ 223 | } 224 | 225 | cell_t *setup_frame(secd_t *secd, cell_t *argnames, cell_t *argvals, cell_t *env) { 226 | cell_t *args_io = SECD_NIL; 227 | 228 | /* setup the new frame */ 229 | cell_t *frame = new_frame(secd, argnames, argvals); 230 | 231 | cell_t *ret = walk_through_arguments(secd, frame, &args_io); 232 | assert_cell(ret, "setup_frame: argument check failed"); 233 | 234 | cell_t *new_io = new_frame_io(secd, args_io, env); 235 | assert_cell(new_io, "setup_frame: failed to set new frame I/O\n"); 236 | 237 | frame->as.frame.io = share_cell(secd, new_io); 238 | secd->input_port = get_car(new_io); 239 | secd->output_port = get_cdr(new_io); 240 | 241 | return frame; 242 | } 243 | 244 | cell_t *secd_insert_in_frame(secd_t *secd, cell_t *frame, cell_t *sym, cell_t *val) { 245 | cell_t *old_syms = get_car(frame); 246 | cell_t *old_vals = get_cdr(frame); 247 | 248 | // an interesting side effect: since there's no check for 249 | // re-binding an existing symbol, we can create multiple 250 | // copies of it on the frame, the last added is found 251 | // during value lookup, but the old ones are persistent 252 | frame->as.cons.car = share_cell(secd, new_cons(secd, sym, old_syms)); 253 | frame->as.cons.cdr = share_cell(secd, new_cons(secd, val, old_vals)); 254 | 255 | drop_cell(secd, old_syms); drop_cell(secd, old_vals); 256 | return frame; 257 | } 258 | -------------------------------------------------------------------------------- /vm/env.h: -------------------------------------------------------------------------------- 1 | #ifndef __SECD_ENV_H__ 2 | #define __SECD_ENV_H__ 3 | 4 | #define SECD_FAKEVAR_STDIN "*stdin*" 5 | #define SECD_FAKEVAR_STDOUT "*stdout*" 6 | #define SECD_FAKEVAR_STDDBG "*stddbg*" 7 | 8 | #define SECD_EXC_HANDLERS "*secd-exception-handlers*" 9 | #define SECD_EXC_BACKTRACE "*secd-exception-backtrace*" 10 | 11 | typedef struct { 12 | const char *name; 13 | const cell_t *val; 14 | } native_binding_t; 15 | 16 | extern const native_binding_t native_functions[]; 17 | 18 | cell_t * make_frame_of_natives(secd_t *secd); 19 | 20 | void secd_print_env(secd_t *secd); 21 | void secd_init_env(secd_t *secd); 22 | 23 | cell_t *setup_frame(secd_t *secd, cell_t *argnames, cell_t *argsvals, cell_t *env); 24 | cell_t *secd_insert_in_frame(secd_t *secd, cell_t *frame, cell_t *sym, cell_t *val); 25 | 26 | cell_t *lookup_env(secd_t *secd, const char *symbol, cell_t **symc); 27 | 28 | #endif //__SECD_ENV_H__ 29 | -------------------------------------------------------------------------------- /vm/machine.c: -------------------------------------------------------------------------------- 1 | #include "secd/secd.h" 2 | #include "secd/secd_io.h" 3 | 4 | #include "memory.h" 5 | #include "env.h" 6 | #include "secdops.h" 7 | 8 | #if (TIMING) 9 | # include 10 | #endif 11 | 12 | int secd_dump_state(secd_t *secd, cell_t *fname); 13 | 14 | /* 15 | * SECD machine 16 | */ 17 | 18 | secd_t * init_secd(secd_t *secd, cell_t *heap, size_t ncells) { 19 | secd->free = SECD_NIL; 20 | secd->stack = secd->dump = 21 | secd->control = secd->env = SECD_NIL; 22 | 23 | secd->tick = 0; 24 | secd->postop = SECD_NOPOST; 25 | 26 | secd_init_mem(secd, heap, ncells); 27 | 28 | secd->truth_value = share_cell(secd, new_symbol(secd, SECD_TRUE)); 29 | secd->false_value = share_cell(secd, new_symbol(secd, SECD_FALSE)); 30 | 31 | secd_init_ports(secd); 32 | secd_init_env(secd); 33 | 34 | return secd; 35 | } 36 | 37 | static bool handle_exception(secd_t *secd, cell_t *exc) { 38 | return !is_error(secd_raise(secd, exc)); 39 | } 40 | 41 | static cell_t *fatal_exception(secd_t *secd, cell_t *exc, int opind) { 42 | errorf("****************\n"); 43 | secd_print_env(secd); 44 | errorf("****************\n"); 45 | errorf("FATAL EXCEPTION: %s failed\n", opcode_table[ opind ].name); 46 | return exc; 47 | } 48 | 49 | static void run_postop(secd_t *secd) { 50 | cell_t *tmp; 51 | switch (secd->postop) { 52 | case SECDPOST_GC: 53 | secd_mark_and_sweep_gc(secd); 54 | break; 55 | case SECDPOST_MACHINE_DUMP: 56 | tmp = new_string(secd, "secdstate.dump"); 57 | share_cell(secd, tmp); 58 | secd_dump_state(secd, tmp); 59 | drop_cell(secd, tmp); 60 | break; 61 | case SECD_NOPOST: 62 | break; 63 | } 64 | secd->postop = SECD_NOPOST; 65 | } 66 | 67 | static bool about_to_halt(secd_t *secd, int opind, cell_t **ret) { 68 | switch (opind) { 69 | case SECD_STOP: 70 | *ret = SECD_NIL; 71 | return true; 72 | 73 | case SECD_RTN: 74 | if (not_nil(secd->dump) && is_nil(get_car(secd->dump))) { 75 | pop_dump(secd); 76 | /* return into native code */ 77 | if (is_nil(secd->stack)) { 78 | *ret = new_error(secd, SECD_NIL, 79 | "secd_run: No value on stack to return"); 80 | } else { 81 | *ret = list_head(secd->stack); 82 | } 83 | return true; 84 | } 85 | } 86 | return false; 87 | } 88 | 89 | #if (TIMING) 90 | # define TIMING_DECLARATIONS(ts_then, ts_now) \ 91 | struct timeval ts_then, ts_now; 92 | 93 | # define TIMING_START_OPERATION(ts_then) \ 94 | gettimeofday(&ts_then, NULL); 95 | 96 | # define TIMING_END_OPERATION(ts_then, ts_now) \ 97 | gettimeofday(&ts_now, NULL); \ 98 | int usec = ts_now.tv_usec - ts_then.tv_usec;\ 99 | if (usec < 0) usec += 1000000; \ 100 | ctrldebugf(" 0.%06d s elapsed\n", usec); 101 | 102 | #else 103 | # define TIMING_DECLARATIONS(ts_then, ts_now) 104 | # define TIMING_START_OPERATION(ts_then) 105 | # define TIMING_END_OPERATION(ts_then, ts_now) 106 | #endif 107 | 108 | cell_t * run_secd(secd_t *secd, cell_t *ctrl) { 109 | cell_t *op, *ret; 110 | TIMING_DECLARATIONS(ts_then, ts_now); 111 | 112 | share_cell(secd, ctrl); 113 | set_control(secd, &ctrl); 114 | 115 | while (true) { 116 | TIMING_START_OPERATION(ts_then); 117 | 118 | op = pop_control(secd); 119 | assert_cell(op, "run: no command"); 120 | if (cell_type(op) != CELL_OP) { 121 | errorf("run: not an opcode at [%ld]\n", cell_index(secd, op)); 122 | dbg_printc(secd, op); 123 | continue; 124 | } 125 | 126 | int opind = op->as.op; 127 | if (about_to_halt(secd, opind, &ret)) 128 | return ret; 129 | 130 | secd_opfunc_t callee = (secd_opfunc_t) opcode_table[ opind ].fun; 131 | 132 | ret = callee(secd); 133 | if (is_error(ret)) 134 | if (!handle_exception(secd, ret)) 135 | return fatal_exception(secd, ret, opind); 136 | 137 | drop_cell(secd, op); 138 | 139 | TIMING_END_OPERATION(ts_then, ts_now) 140 | 141 | run_postop(secd); 142 | 143 | ++secd->tick; 144 | } 145 | } 146 | 147 | /* 148 | * Serialization 149 | */ 150 | const char * secd_type_names[] = { 151 | [CELL_UNDEF] = "void", 152 | [CELL_CONS] = "cons", 153 | [CELL_ARRAY] = "vect", 154 | [CELL_STR] = "str", 155 | [CELL_BYTES] = "bvect", 156 | [CELL_FRAME] = "frame", 157 | [CELL_KONT] = "kont", 158 | [CELL_ARRMETA] = "meta", 159 | [CELL_FREE] = "free", 160 | [CELL_REF] = "ref", 161 | [CELL_SYM] = "sym", 162 | [CELL_INT] = "int", 163 | [CELL_CHAR] = "char", 164 | [CELL_OP] = "op", 165 | [CELL_FUNC] = "func", 166 | [CELL_PORT] = "port", 167 | [CELL_ERROR] = "err" 168 | }; 169 | 170 | cell_t *secd_type_sym(secd_t *secd, const cell_t *cell) { 171 | const char *type = "unknown"; 172 | enum cell_type t = cell_type(cell); 173 | assert(t <= CELL_ERROR, "secd_type_sym: type is invalid"); 174 | type = secd_type_names[t]; 175 | assert(type, "secd_type_names: unknown type of %d", t); 176 | return new_symbol(secd, type); 177 | } 178 | 179 | static cell_t *chain_index(secd_t *secd, const cell_t *cell, cell_t *prev) { 180 | return new_cons(secd, new_number(secd, cell_index(secd, cell)), prev); 181 | } 182 | static cell_t *chain_string(secd_t *secd, const char *str, cell_t *prev) { 183 | return new_cons(secd, new_string(secd, str), prev); 184 | } 185 | static cell_t *chain_sym(secd_t *secd, const char *str, cell_t *prev) { 186 | return new_cons(secd, new_symbol(secd, str), prev); 187 | } 188 | 189 | cell_t *serialize_cell(secd_t *secd, cell_t *cell) { 190 | cell_t *opt = SECD_NIL; 191 | switch (cell_type(cell)) { 192 | case CELL_CONS: { 193 | cell_t *cdrc = chain_index(secd, get_cdr(cell), SECD_NIL); 194 | opt = chain_index(secd, get_car(cell), cdrc); 195 | } break; 196 | case CELL_PORT: 197 | opt = secd_pserialize(secd, cell); 198 | break; 199 | case CELL_SYM: 200 | opt = new_cons(secd, cell, SECD_NIL); 201 | break; 202 | case CELL_INT: case CELL_CHAR: 203 | opt = new_cons(secd, cell, SECD_NIL); 204 | break; 205 | case CELL_OP: { 206 | cell_t *namec = new_symbol(secd, opcode_table[ cell->as.op ].name); 207 | opt = new_cons(secd, namec, SECD_NIL); 208 | } break; 209 | case CELL_FUNC: 210 | opt = new_cons(secd, new_number(secd, (long)cell->as.ptr), SECD_NIL); 211 | break; 212 | case CELL_ARRMETA: { 213 | cell_t *typec = chain_sym(secd, 214 | (cell->as.mcons.cells ? "cell" : "byte"), 215 | SECD_NIL); 216 | cell_t *nextc = chain_index(secd, mcons_next(cell), typec); 217 | opt = chain_index(secd, mcons_prev(cell), nextc); 218 | } break; 219 | case CELL_FRAME: { 220 | cell_t *ioc = chain_index(secd, cell->as.frame.io, SECD_NIL); 221 | cell_t *nextc = chain_index(secd, cell->as.frame.cons.cdr, ioc); 222 | opt = chain_index(secd, cell->as.frame.cons.car, nextc); 223 | } break; 224 | case CELL_KONT: { 225 | cell_t *kctrl = chain_index(secd, cell->as.kont.ctrl, SECD_NIL); 226 | cell_t *kenv = chain_index(secd, cell->as.kont.env, kctrl); 227 | opt = chain_index(secd, cell->as.kont.stack, kenv); 228 | } break; 229 | case CELL_FREE: { 230 | cell_t *nextc = chain_index(secd, get_cdr(cell), SECD_NIL); 231 | opt = chain_index(secd, get_car(cell), nextc); 232 | } break; 233 | case CELL_REF: opt = chain_index(secd, cell->as.ref, SECD_NIL); break; 234 | case CELL_ERROR: opt = chain_string(secd, errmsg(cell), SECD_NIL); break; 235 | case CELL_UNDEF: opt = SECD_NIL; break; 236 | case CELL_ARRAY: 237 | opt = chain_index(secd, arr_val(cell, -1), SECD_NIL); 238 | break; 239 | case CELL_STR: case CELL_BYTES: 240 | opt = chain_index(secd, arr_meta((cell_t *)strmem(cell)), SECD_NIL); 241 | break; 242 | } 243 | opt = new_cons(secd, secd_type_sym(secd, cell), opt); 244 | cell_t *refc = new_cons(secd, new_number(secd, cell->nref), opt); 245 | return new_cons(secd, new_number(secd, cell - secd->begin), refc); 246 | } 247 | 248 | cell_t *secd_mem_info(secd_t *secd) { 249 | cell_t *arrptr 250 | = new_cons(secd, new_number(secd, secd->arrayptr - secd->begin), SECD_NIL); 251 | cell_t *fxdptr 252 | = new_cons(secd, new_number(secd, secd->fixedptr - secd->begin), arrptr); 253 | cell_t *freec = 254 | new_cons(secd, new_number(secd, secd->stat.free_cells), fxdptr); 255 | return new_cons(secd, new_number(secd, secd->end - secd->begin), freec); 256 | } 257 | 258 | int secd_dump_state(secd_t *secd, cell_t *fname) { 259 | cell_t *p = secd_newport(secd, "w", "file", fname); 260 | secd_pprintf(secd, p, 261 | ";; secd->fixedptr = %ld\n", cell_index(secd, secd->fixedptr)); 262 | secd_pprintf(secd, p, 263 | ";; secd->arrayptr = %ld\n", cell_index(secd, secd->arrayptr)); 264 | secd_pprintf(secd, p, 265 | ";; secd->end = %ld\n", cell_index(secd, secd->end)); 266 | secd_pprintf(secd, p, ";; secd->input_port = %ld, secd->output_port = %ld\n", 267 | cell_index(secd, secd->input_port), cell_index(secd, secd->output_port)); 268 | secd_pprintf(secd, p, ";; SECD = (%ld, %ld, %ld, %ld)\n", 269 | cell_index(secd, secd->stack), cell_index(secd, secd->env), 270 | cell_index(secd, secd->control), cell_index(secd, secd->dump)); 271 | secd_pprintf(secd, p, ";; secd->free = %ld (%ld free)\n", 272 | cell_index(secd, secd->free), secd->stat.free_cells); 273 | /* dump fixed heap */ 274 | long i; 275 | long n_fixed = secd->fixedptr - secd->begin; 276 | secd_pprintf(secd, p, "\n;; SECD persistent heap:\n"); 277 | for (i = 0; i < n_fixed; ++i) { 278 | cell_t *cell_info = serialize_cell(secd, secd->begin + i); 279 | sexp_pprint(secd, p, cell_info); 280 | secd_pprintf(secd, p, "\n"); 281 | free_cell(secd, cell_info); 282 | } 283 | 284 | secd_pprintf(secd, p, "\n;; SECD array heap:\n"); 285 | cell_t *mcons = secd->arrlist; 286 | while (mcons_next(mcons)) { 287 | cell_t *cell_info = serialize_cell(secd, mcons); 288 | sexp_pprint(secd, p, cell_info); 289 | if (!mcons->as.mcons.free) 290 | secd_pdump_array(secd, p, mcons); 291 | secd_pprintf(secd, p, "\n"); 292 | free_cell(secd, cell_info); 293 | 294 | mcons = mcons_next(mcons); 295 | } 296 | 297 | secd_pclose(secd, p); 298 | free_cell(secd, p); 299 | return 0; 300 | } 301 | 302 | -------------------------------------------------------------------------------- /vm/memory.h: -------------------------------------------------------------------------------- 1 | #ifndef __SECD_MEM_H__ 2 | #define __SECD_MEM_H__ 3 | 4 | #include "secd/secd.h" 5 | #include "secd/secd_io.h" 6 | 7 | /* 8 | * Allocation 9 | */ 10 | 11 | cell_t *new_cons(secd_t *secd, cell_t *car, cell_t *cdr); 12 | cell_t *new_frame(secd_t *secd, cell_t *syms, cell_t *vals); 13 | cell_t *new_number(secd_t *secd, int num); 14 | cell_t *new_char(secd_t *secd, int chr); 15 | cell_t *new_symbol(secd_t *secd, const char *sym); 16 | 17 | cell_t *new_array(secd_t *secd, size_t size); 18 | 19 | cell_t *new_string(secd_t *secd, const char *str); 20 | cell_t *new_string_of_size(secd_t *secd, size_t size); 21 | cell_t *new_strref(secd_t *secd, cell_t *mem, size_t size); 22 | 23 | cell_t *new_bytevector_of_size(secd_t *secd, size_t size); 24 | 25 | cell_t *new_ref(secd_t *secd, cell_t *to); 26 | cell_t *new_op(secd_t *secd, opindex_t opind); 27 | 28 | cell_t *new_port(secd_t *secd, int pty); 29 | 30 | cell_t *new_const_clone(secd_t *secd, const cell_t *from); 31 | cell_t *new_clone(secd_t *secd, cell_t *from); 32 | 33 | cell_t *new_error(secd_t *secd, cell_t *info, const char *fmt, ...); 34 | cell_t *new_continuation(secd_t *secd, cell_t *s, cell_t *e, cell_t *c); 35 | cell_t *new_current_continuation(secd_t *secd); 36 | 37 | cell_t *copy_value( 38 | secd_t *secd, 39 | cell_t *__restrict cell, 40 | const cell_t *__restrict with); 41 | cell_t *drop_value(secd_t *secd, cell_t *c); 42 | 43 | cell_t *free_cell(secd_t *, cell_t *c); 44 | 45 | cell_t *push_stack(secd_t *secd, cell_t *newc); 46 | cell_t *pop_stack(secd_t *secd); 47 | 48 | cell_t *set_control(secd_t *secd, cell_t **opcons); 49 | cell_t *pop_control(secd_t *secd); 50 | 51 | cell_t *push_dump(secd_t *secd, cell_t *cell); 52 | cell_t *pop_dump(secd_t *secd); 53 | 54 | /* 55 | * Reference-counting 56 | */ 57 | 58 | inline static cell_t *share_cell(secd_t __unused *secd, cell_t *c) { 59 | if (not_nil(c)) { 60 | ++c->nref; 61 | memtracef("share[%ld] %ld\n", cell_index(c), c->nref); 62 | } else { 63 | memtracef("share[NIL]\n"); 64 | } 65 | return c; 66 | } 67 | 68 | inline static int drop_cell(secd_t *secd, cell_t *c) { 69 | if (is_nil(c)) { 70 | memtracef("drop [NIL]\n"); 71 | return 1; 72 | } 73 | if (c->nref <= 0) { 74 | errorf(";; %lu | error in drop_cell[%ld]: negative nref\n", 75 | secd->tick, cell_index(secd, c)); 76 | return -1; 77 | } 78 | 79 | -- c->nref; 80 | memtracef("drop [%ld] %ld\n", cell_index(c), c->nref); 81 | if (c->nref) return 0; 82 | free_cell(secd, c); 83 | return 0; 84 | } 85 | 86 | inline static cell_t *assign_cell(secd_t *secd, cell_t **cell, cell_t *what) { 87 | cell_t *oldval = *cell; 88 | *cell = share_cell(secd, what); 89 | drop_cell(secd, oldval); 90 | return *cell; 91 | } 92 | 93 | cell_t *secd_referers_for(secd_t *secd, cell_t *cell); 94 | void secd_owned_cell_for(secd_t *secd, cell_t *cell, cell_t **ref1, cell_t **ref2, cell_t **ref3); 95 | 96 | /* 97 | * Array routines 98 | */ 99 | static inline size_t arrmeta_size(secd_t *secd, const cell_t *metacons) { 100 | asserti(cell_type(metacons) == CELL_ARRMETA, "arrmeta_size: not a meta"); 101 | if (metacons == secd->arrlist) return 0; 102 | return metacons->as.mcons.prev - metacons - 1; 103 | } 104 | 105 | static inline cell_t *arr_meta(cell_t *mem) { 106 | if (cell_type(mem - 1) != CELL_ARRMETA) { 107 | return SECD_NIL; 108 | } 109 | return mem - 1; 110 | } 111 | 112 | static inline cell_t *meta_mem(cell_t *meta) { 113 | if (cell_type(meta) != CELL_ARRMETA) { 114 | return SECD_NIL; 115 | } 116 | return meta + 1; 117 | } 118 | 119 | static inline cell_t *arr_mem(const cell_t *arr) { 120 | if (cell_type(arr) != CELL_ARRAY) { 121 | return SECD_NIL; 122 | } 123 | return arr->as.arr.data; 124 | } 125 | 126 | static inline size_t mem_size(const cell_t *str) { 127 | switch (cell_type(str)) { 128 | case CELL_STR: case CELL_BYTES: break; 129 | default: return -1; 130 | } 131 | return str->as.str.size; 132 | } 133 | 134 | static inline const cell_t * 135 | arr_val(const cell_t *arr, size_t index) { 136 | if (cell_type(arr) != CELL_ARRAY) { 137 | return SECD_NIL; 138 | } 139 | return arr->as.arr.data + index; 140 | } 141 | 142 | static inline cell_t * 143 | arr_ref(cell_t *arr, size_t index) { 144 | return arr_mem(arr) + index; 145 | } 146 | 147 | static inline cell_t * 148 | arr_get(secd_t *secd, cell_t *arr, size_t index) { 149 | return new_clone(secd, arr_ref(arr, index)); 150 | } 151 | 152 | static inline cell_t * 153 | arr_set(secd_t *secd, cell_t *arr, size_t index, const cell_t *val) { 154 | cell_t *ref = arr_ref(arr, index); 155 | drop_value(secd, ref); 156 | copy_value(secd, ref, val); 157 | return arr; 158 | } 159 | 160 | static inline size_t arr_size(secd_t *secd, const cell_t *arr) { 161 | return arrmeta_size(secd, arr_val(arr, -1)); 162 | } 163 | 164 | cell_t *fill_array(secd_t *secd, cell_t *arr, cell_t *with); 165 | cell_t *clear_array(secd_t *secd, cell_t *arr, size_t len); 166 | 167 | /* 168 | * Global machine operations 169 | */ 170 | 171 | void secd_mark_and_sweep_gc(secd_t *secd); 172 | 173 | void secd_init_mem(secd_t *secd, cell_t *heap, size_t size); 174 | 175 | /* 176 | * Hashtables 177 | */ 178 | 179 | bool secdht_is(secd_t *secd, cell_t *obj); 180 | 181 | cell_t *secdht_new(secd_t *secd, int initcap, cell_t *eqfun, cell_t *hashfun); 182 | 183 | cell_t *secdht_insert(secd_t *secd, cell_t *ht, cell_t *key, cell_t *val); 184 | 185 | bool secdht_lookup(secd_t *secd, cell_t *ht, cell_t *key, cell_t **val); 186 | 187 | cell_t *secdht_fold(secd_t *secd, cell_t *ht, cell_t *val, cell_t *iter); 188 | 189 | /* 190 | * UTF-8 191 | */ 192 | typedef unsigned int unichar_t; 193 | 194 | char *utf8cpy(char *to, unichar_t ucs); 195 | unichar_t utf8get(const char *u8, const char **next); 196 | 197 | size_t list_length(secd_t *secd, cell_t *lst); 198 | cell_t *list_to_vector(secd_t *secd, cell_t *lst); 199 | cell_t *vector_to_list(secd_t *secd, cell_t *vct, int start, int end); 200 | 201 | #endif // __SECD_MEM_H__ 202 | -------------------------------------------------------------------------------- /vm/ports.c: -------------------------------------------------------------------------------- 1 | #include "secd/secd.h" 2 | #include "secd/secd_io.h" 3 | 4 | #include "memory.h" 5 | 6 | #include 7 | #include 8 | 9 | portops_t * secd_strportops(); 10 | portops_t * secd_fileportops(); 11 | 12 | /* 13 | * Generic port interface 14 | */ 15 | 16 | #define io_assert(cond, ...) \ 17 | if (!(cond)) { \ 18 | errorf(__VA_ARGS__); \ 19 | return -1; \ 20 | } 21 | 22 | const char * secd_porttyname(secd_t *secd, int ty) { 23 | portops_t *ops = secd->portops[ty]; 24 | if (!ops) return ""; 25 | 26 | portinfo_func_t pinfo = ops->pinfo; 27 | if (!pinfo) return ""; 28 | 29 | return pinfo(secd, SECD_NIL, NULL); 30 | } 31 | 32 | static portops_t * secd_portops(secd_t *secd, cell_t *port) { 33 | return secd->portops[ port->as.port.type ]; 34 | } 35 | 36 | static int secd_porttype(secd_t *secd, const char *pname) { 37 | int i = 0; 38 | for (i = 0; i < SECD_PORTTYPES_MAX; ++i) { 39 | if (!strcmp(pname, secd_porttyname(secd, i))) 40 | return i; 41 | } 42 | errorf("porttype %s not found", pname); 43 | return -1; 44 | } 45 | 46 | static cell_t *init_port_mode(secd_t *secd, cell_t *cell, const char *mode) { 47 | switch (mode[0]) { 48 | case 'r': 49 | cell->as.port.input = true; 50 | if (mode[1] == '+') { 51 | cell->as.port.output = true; 52 | ++mode; 53 | } else 54 | cell->as.port.output = false; 55 | if (mode[1] == '\0') 56 | return cell; 57 | break; 58 | 59 | case 'w': case 'a': 60 | cell->as.port.output = true; 61 | if (mode[1] == '+') { 62 | cell->as.port.input = true; 63 | ++mode; 64 | } else 65 | cell->as.port.input = false; 66 | if (mode[1] == '\0') 67 | return cell; 68 | } 69 | // otherwise fail: 70 | drop_cell(secd, cell); 71 | errorf("new_fileport: failed to parse mode\n"); 72 | return new_error(secd, SECD_NIL, "new_port: failed to parse mode"); 73 | } 74 | 75 | 76 | cell_t *secd_newport(secd_t *secd, const char *mode, const char *ty, cell_t *params) { 77 | int pty = secd_porttype(secd, ty); 78 | assert(0 <= pty && pty < SECD_PORTTYPES_MAX, 79 | "secd_newport: not a valid porttype"); 80 | 81 | cell_t *p = new_port(secd, pty); 82 | init_port_mode(secd, p, mode); 83 | secd_popen(secd, p, mode, params); 84 | assert_cell(p, "secd_newport: failed to create a port"); 85 | return p; 86 | } 87 | 88 | cell_t *secd_newport_by_name(secd_t *secd, const char *mode, const char *ty, const char * name) { 89 | cell_t *fname = share_cell(secd, new_string(secd, name)); 90 | cell_t *p = secd_newport(secd, mode, ty, fname); 91 | drop_cell(secd, fname); 92 | return p; 93 | } 94 | 95 | static cell_t * search_stdport(secd_t *secd, enum secd_portstd stdno) { 96 | int i = 0; 97 | for (i = 0; i < SECD_PORTTYPES_MAX; ++i) { 98 | portops_t *ops = secd->portops[i]; 99 | if (!ops) continue; 100 | 101 | portstd_func_t pstd = ops->pstd; 102 | if (!pstd) continue; 103 | 104 | cell_t *stdp = pstd(secd, stdno); 105 | if (not_nil(stdp)) 106 | return stdp; 107 | } 108 | return SECD_NIL; 109 | } 110 | 111 | cell_t *secd_stdin(secd_t *secd) { 112 | return search_stdport(secd, SECD_STDIN); 113 | } 114 | 115 | cell_t *secd_stdout(secd_t *secd) { 116 | return search_stdport(secd, SECD_STDOUT); 117 | } 118 | 119 | cell_t *secd_stderr(secd_t *secd) { 120 | return search_stdport(secd, SECD_STDERR); 121 | } 122 | 123 | cell_t *secd_stddbg(secd_t __unused *secd) { 124 | return search_stdport(secd, SECD_STDDBG); 125 | } 126 | 127 | cell_t *secd_setport(secd_t *secd, enum secd_portstd std, cell_t *port) { 128 | cell_t **stdp = SECD_NIL; 129 | switch (std) { 130 | case SECD_STDIN: stdp = &secd->input_port; break; 131 | case SECD_STDOUT: stdp = &secd->output_port; break; 132 | case SECD_STDERR: stdp = &secd->error_port; break; 133 | case SECD_STDDBG: stdp = &secd->debug_port; break; 134 | default: return SECD_NIL; 135 | } 136 | return assign_cell(secd, stdp, port); 137 | } 138 | 139 | 140 | cell_t *secd_port_owns(secd_t *secd, cell_t *p, 141 | cell_t **r1, cell_t **r2, cell_t **r3 142 | ) { 143 | assert(is_closed(p), "secd_popen: port is already opened"); 144 | 145 | portowns_func_t powns = secd_portops(secd, p)->powns; 146 | if (powns) 147 | return powns(secd, p, r1, r2, r3); 148 | *r1 = *r2 = *r3 = SECD_NIL; 149 | return p; 150 | } 151 | 152 | 153 | int secd_popen(secd_t *secd, cell_t *p, const char *mode, cell_t *info) { 154 | portopen_func_t popen = secd_portops(secd, p)->popen; 155 | if (popen) 156 | return popen(secd, p, mode, info); 157 | return 0; 158 | } 159 | 160 | int secd_pclose(secd_t *secd, cell_t *port) { 161 | io_assert(cell_type(port) == CELL_PORT, "secd_pclose: not a port\n"); 162 | io_assert(!is_closed(port), "secd_pclose: already closed\n"); 163 | 164 | int ret = 0; 165 | 166 | portclose_func_t pclose = secd_portops(secd, port)->pclose; 167 | if (pclose) 168 | ret = pclose(secd, port); 169 | 170 | port->as.port.input = false; 171 | port->as.port.output = false; 172 | return ret; 173 | } 174 | 175 | int secd_pgetc(secd_t __unused *secd, cell_t *port) { 176 | io_assert(cell_type(port) == CELL_PORT, "secd_getc: not a port\n"); 177 | io_assert(is_input(port), "secd_getc: not an input port\n"); 178 | io_assert(!is_closed(port), "secd_getc: port is closed\n"); 179 | 180 | portgetc_func_t pgetc = secd_portops(secd, port)->pgetc; 181 | if (!pgetc) return -1; 182 | 183 | return pgetc(secd, port); 184 | } 185 | 186 | size_t secd_pread(secd_t *secd, cell_t *port, char *s, int size) { 187 | io_assert(cell_type(port) == CELL_PORT, "secd_fread: not a port\n"); 188 | io_assert(is_input(port), "secd_fread: not an input port\n"); 189 | io_assert(!is_closed(port), "secd_getc: port is closed\n"); 190 | 191 | portread_func_t pread = secd_portops(secd, port)->pread; 192 | if (!pread) return 0; 193 | 194 | return pread(secd, port, size, s); 195 | } 196 | 197 | long secd_portsize(secd_t *secd, cell_t *port) { 198 | io_assert(cell_type(port) == CELL_PORT, "secd_portsize: not a port\n"); 199 | 200 | portsize_func_t psize = secd_portops(secd, port)->psize; 201 | if (!psize) return -1; 202 | 203 | return psize(secd, port); 204 | } 205 | 206 | int secd_vpprintf(secd_t *secd, cell_t *port, const char *format, va_list ap) { 207 | io_assert(cell_type(port) == CELL_PORT, "vpprintf: not a port\n"); 208 | io_assert(is_output(port), "vpprintf: not an output port\n"); 209 | io_assert(!is_closed(port), "secd_getc: port is closed\n"); 210 | 211 | portvprintf_func_t vprintf = secd_portops(secd, port)->pvprintf; 212 | if (!vprintf) return -1; 213 | 214 | return vprintf(secd, port, format, ap); 215 | } 216 | 217 | inline int 218 | secd_pprintf(secd_t *secd, cell_t *port, const char *format, ...) { 219 | va_list ap; 220 | 221 | va_start(ap, format); 222 | int ret = secd_vpprintf(secd, port, format, ap); 223 | va_end(ap); 224 | 225 | return ret; 226 | } 227 | 228 | int secd_printf(secd_t *secd, const char *format, ...) { 229 | va_list ap; 230 | 231 | va_start(ap, format); 232 | int ret = secd_vpprintf(secd, secd->output_port, format, ap); 233 | va_end(ap); 234 | 235 | return ret; 236 | } 237 | 238 | int secd_errorf(secd_t *secd, const char *format, ...) { 239 | va_list ap; 240 | 241 | va_start(ap, format); 242 | int ret = secd_vpprintf(secd, secd->error_port, format, ap); 243 | va_end(ap); 244 | 245 | return ret; 246 | } 247 | 248 | /* print port description into port */ 249 | void sexp_pprint_port(secd_t *secd, cell_t *outp, const cell_t *port) { 250 | secd_pprintf(secd, outp, "##port%s%s@%ld", 251 | (is_input(port)? "r" : ""), 252 | (is_output(port)? "w" : ""), 253 | cell_index(secd, port)); 254 | } 255 | 256 | 257 | int secd_register_porttype(secd_t *secd, portops_t *ops) { 258 | int i; 259 | int avail = -1; 260 | portinfo_func_t pinfo = ops->pinfo; 261 | io_assert(pinfo, "failed to register porttype: no name"); 262 | 263 | const char *newpty = ops->pinfo(secd, NULL, NULL); 264 | for (i = 0; i < SECD_PORTTYPES_MAX; ++i) { 265 | if (secd->portops[i] == NULL) { 266 | avail = i; 267 | continue; 268 | } 269 | 270 | int cmp = strcmp(newpty, secd->portops[i]->pinfo(secd, NULL, NULL)); 271 | io_assert(cmp, "failed to register porttype: name already taken"); 272 | } 273 | 274 | io_assert(avail >= 0, 275 | "failed to register porttype: no slots left (max %d)", 276 | SECD_PORTTYPES_MAX); 277 | secd->portops[avail] = ops; 278 | return avail; 279 | } 280 | 281 | void secd_init_ports(secd_t *secd) { 282 | int i; 283 | for (i = 0; i < SECD_PORTTYPES_MAX; ++i) 284 | secd->portops[i] = NULL; 285 | 286 | secd_register_porttype(secd, secd_strportops()); 287 | secd_register_porttype(secd, secd_fileportops()); 288 | 289 | secd->input_port = share_cell(secd, secd_stdin(secd)); 290 | secd->output_port = share_cell(secd, secd_stdout(secd)); 291 | secd->error_port = share_cell(secd, secd_stderr(secd)); 292 | secd->debug_port = SECD_NIL; 293 | } 294 | 295 | cell_t *secd_pserialize(secd_t *secd, cell_t *port) { 296 | (void)secd; 297 | (void)port; 298 | #warning "TODO: secd_pserialize" 299 | return SECD_NIL; 300 | } 301 | 302 | /* 303 | * String ports 304 | */ 305 | typedef struct strport strport_t; 306 | struct strport { 307 | cell_t *str; 308 | }; 309 | 310 | static const char *strport_info( 311 | secd_t __unused *secd, cell_t __unused *p, cell_t __unused **pinfo 312 | ) { 313 | return "str"; 314 | } 315 | 316 | static int 317 | strport_open(secd_t *secd, cell_t *p, const char __unused *mode, cell_t *info) { 318 | strport_t *sp = (strport_t *)p->as.port.data; 319 | io_assert(sp->str, "strport_open: no string"); 320 | 321 | io_assert(cell_type(info) == CELL_STR, "strport_open: not a string"); 322 | sp->str = share_cell(secd, info); 323 | return 0; 324 | } 325 | 326 | static int strport_close(secd_t *secd, cell_t *p) { 327 | strport_t *sp = (strport_t *)p->as.port.data; 328 | asserti(sp->str, "strport_close: no string"); 329 | 330 | drop_cell(secd, sp->str); 331 | sp->str = SECD_NIL; 332 | return 0; 333 | } 334 | 335 | static int strport_getc(secd_t __unused *secd, cell_t *p) { 336 | strport_t *sp = (strport_t *)p->as.port.data; 337 | asserti(sp->str, "strport_size: no string"); 338 | 339 | cell_t *str = sp->str; 340 | size_t size = mem_size(str); 341 | if (str->as.str.offset >= (int)size) 342 | return EOF; 343 | 344 | char c = strmem(str)[str->as.str.offset]; 345 | if (c == '\0') 346 | return SECD_EOF; 347 | ++str->as.str.offset; 348 | return (int)c; 349 | } 350 | 351 | static size_t strport_read(secd_t __unused *secd, cell_t *p, size_t count, char *buf) { 352 | strport_t *sp = (strport_t *)p->as.port.data; 353 | asserti(sp->str, "strport_size: no string"); 354 | 355 | cell_t *str = sp->str; 356 | 357 | size_t size = count; 358 | size_t srcsize = mem_size(str); 359 | if (srcsize < count) 360 | size = srcsize; 361 | 362 | memcpy(buf, strmem(str), size); 363 | return size; 364 | } 365 | 366 | static int strport_vprintf(secd_t __unused *secd, cell_t *p, const char *fmt, va_list va) { 367 | strport_t *sp = (strport_t *)p->as.port.data; 368 | asserti(sp->str, "strport_size: no string"); 369 | 370 | cell_t *str = sp->str; 371 | 372 | char *mem = strmem(str); 373 | size_t offset = str->as.str.offset; 374 | size_t size = mem_size(str) - offset; 375 | int ret = vsnprintf(mem, size, fmt, va); 376 | if (ret == (int)size) { 377 | errorf("vpprintf: string is too small"); 378 | errorf("vpprintf: TODO: resize string"); 379 | return -1; 380 | } 381 | return ret; 382 | } 383 | 384 | static long strport_size(secd_t __unused *secd, cell_t *p) { 385 | strport_t *sp = (strport_t *)p->as.port.data; 386 | asserti(sp->str, "strport_size: no string"); 387 | 388 | return mem_size(sp->str); 389 | } 390 | 391 | static cell_t * 392 | strport_owns(secd_t __unused *secd, cell_t *p, cell_t **ref1, cell_t **r2, cell_t **r3) { 393 | strport_t *sp = (strport_t *)p->as.port.data; 394 | asserti(sp->str, "strport_size: no string"); 395 | 396 | *ref1 = arr_meta(arr_mem(sp->str)); 397 | *r2 = *r3 = SECD_NIL; 398 | return p; 399 | } 400 | 401 | portops_t strops = { 402 | .pinfo = strport_info, 403 | .popen = strport_open, 404 | .pgetc = strport_getc, 405 | .pread = strport_read, 406 | .pvprintf = strport_vprintf, 407 | .psize = strport_size, 408 | .pclose = strport_close, 409 | .powns = strport_owns, 410 | .pstd = NULL, 411 | }; 412 | 413 | portops_t * secd_strportops() { 414 | return &strops; 415 | } 416 | 417 | /* 418 | * File ports 419 | */ 420 | 421 | #include 422 | #include 423 | 424 | typedef struct fileport fileport_t; 425 | struct fileport { 426 | FILE *f; 427 | }; 428 | 429 | static const char * fileport_info(secd_t __unused *secd, 430 | cell_t __unused *p, cell_t __unused **pinfo 431 | ) { 432 | return "file"; 433 | } 434 | 435 | static int fileport_open(secd_t __unused *secd, cell_t * port, const char *mode, cell_t *info) { 436 | fileport_t *fp = (fileport_t *)port->as.port.data; 437 | 438 | io_assert(cell_type(info) == CELL_STR, "secd_fopen: filename not a string"); 439 | const char *fname = info->as.str.data; 440 | 441 | if (!strcmp(fname, "stdin")) { 442 | fp->f = stdin; 443 | return 0; 444 | } else if (!strcmp(fname, "stdout")) { 445 | fp->f = stdout; 446 | return 0; 447 | } else if (!strcmp(fname, "stderr")) { 448 | fp->f = stderr; 449 | return 0; 450 | } 451 | 452 | FILE *f = fopen(fname, mode); 453 | io_assert(f, "secd_fopen('%s'): %s\n", fname, strerror(errno)); 454 | 455 | fp->f = f; 456 | return 0; 457 | } 458 | 459 | static int fileport_close(secd_t __unused *secd, cell_t *p) { 460 | fileport_t *fp = (fileport_t *)p->as.port.data; 461 | io_assert(fp->f, "fileport_close: no file"); 462 | 463 | int ret = fclose(fp->f); 464 | fp->f = NULL; 465 | return ret; 466 | } 467 | 468 | static int fileport_getc(secd_t __unused *secd, cell_t *p) { 469 | fileport_t *fp = (fileport_t *)p->as.port.data; 470 | io_assert(fp->f, "fileport_close: no file"); 471 | 472 | int c = fgetc(fp->f); 473 | if (c == EOF) 474 | return SECD_EOF; 475 | return c; 476 | } 477 | 478 | static size_t fileport_read(secd_t __unused *secd, cell_t *p, size_t count, char *buf) { 479 | fileport_t *fp = (fileport_t *)p->as.port.data; 480 | asserti(fp->f, "fileport_close: no file"); 481 | 482 | return fread(buf, count, 1, fp->f);; 483 | } 484 | 485 | static int fileport_vprintf(secd_t __unused *secd, cell_t *p, const char *fmt, va_list ap) { 486 | fileport_t *fp = (fileport_t *)p->as.port.data; 487 | asserti(fp->f, "fileport_close: no file"); 488 | 489 | return vfprintf(fp->f, fmt, ap); 490 | } 491 | 492 | static long fileport_size(secd_t __unused *secd, cell_t *p) { 493 | fileport_t *fp = (fileport_t *)p->as.port.data; 494 | asserti(fp->f, "fileport_size: no file"); 495 | 496 | FILE *f = fp->f; 497 | long curpos = ftell(f); 498 | 499 | if (!fseek(f, 0, SEEK_END)) 500 | return -1; /* file is not seekable */ 501 | 502 | long endpos = ftell(f); 503 | fseek(f, curpos, SEEK_SET); 504 | return endpos; 505 | } 506 | 507 | static cell_t *fileport_std(secd_t *secd, enum secd_portstd stdno) { 508 | switch (stdno) { 509 | case SECD_STDIN: 510 | return secd_newport_by_name(secd, "r", "file", "stdin"); 511 | case SECD_STDOUT: 512 | return secd_newport_by_name(secd, "w", "file", "stdout"); 513 | case SECD_STDERR: 514 | return secd_newport_by_name(secd, "w", "file", "stderr"); 515 | //case SECD_STDDBG: 516 | default: 517 | return SECD_NIL; 518 | } 519 | } 520 | 521 | portops_t fileops = { 522 | .pinfo = fileport_info, 523 | .popen = fileport_open, 524 | .pgetc = fileport_getc, 525 | .pread = fileport_read, 526 | .pvprintf = fileport_vprintf, 527 | .psize = fileport_size, 528 | .pclose = fileport_close, 529 | .pstd = fileport_std, 530 | }; 531 | 532 | portops_t * secd_fileportops() { 533 | return &fileops; 534 | } 535 | -------------------------------------------------------------------------------- /vm/readparse.c: -------------------------------------------------------------------------------- 1 | #include "secd/secd.h" 2 | #include "secd/secd_io.h" 3 | 4 | #include "secdops.h" 5 | #include "memory.h" 6 | 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | void sexp_print_opcode(secd_t *secd, cell_t *port, opindex_t op) { 13 | if (op < SECD_LAST) { 14 | secd_pprintf(secd, port, "#.%s ", opcode_table[op].name); 15 | return; 16 | } 17 | secd_pprintf(secd, port, "#.[%d] ", op); 18 | } 19 | 20 | void dbg_print_cell(secd_t *secd, const cell_t *c) { 21 | if (is_nil(c)) { 22 | secd_printf(secd, "NIL\n"); 23 | return; 24 | } 25 | char buf[128]; 26 | if (c->nref > DONT_FREE_THIS - 100000) strncpy(buf, "-", 64); 27 | else snprintf(buf, 128, "%ld", (long)c->nref); 28 | printf("[%ld]^%s: ", cell_index(secd, c), buf); 29 | 30 | switch (cell_type(c)) { 31 | case CELL_CONS: 32 | printf("CONS([%ld], [%ld])\n", 33 | cell_index(secd, get_car(c)), cell_index(secd, get_cdr(c))); 34 | break; 35 | case CELL_FRAME: 36 | printf("FRAME(syms: [%ld], vals: [%ld])\n", 37 | cell_index(secd, get_car(c)), cell_index(secd, get_cdr(c))); 38 | break; 39 | case CELL_INT: printf("%d\n", c->as.num); break; 40 | case CELL_CHAR: 41 | if (isprint(c->as.num)) printf("#\\%c\n", (char)c->as.num); 42 | else printf("#x%x\n", c->as.num); 43 | break; 44 | case CELL_OP: 45 | sexp_print_opcode(secd, secd->output_port, c->as.op); 46 | printf("\n"); 47 | break; 48 | case CELL_FUNC: printf("*%p()\n", c->as.ptr); break; 49 | case CELL_KONT: printf("KONT[%ld, %ld, %ld]\n", 50 | cell_index(secd, c->as.kont.stack), 51 | cell_index(secd, c->as.kont.env), 52 | cell_index(secd, c->as.kont.ctrl)); break; 53 | case CELL_ARRAY: printf("ARR[%ld]\n", 54 | cell_index(secd, arr_val(c, 0))); break; 55 | case CELL_STR: printf("STR[%ld\n", 56 | cell_index(secd, (cell_t*)strval(c))); break; 57 | case CELL_SYM: printf("SYM[%08x]='%s'\n", 58 | symhash(c), symname(c)); break; 59 | case CELL_BYTES: printf("BVECT[%ld]\n", 60 | cell_index(secd, (cell_t*)strval(c))); break; 61 | case CELL_REF: printf("REF[%ld]\n", 62 | cell_index(secd, c->as.ref)); break; 63 | case CELL_ERROR: printf("ERR[%s]\n", errmsg(c)); break; 64 | case CELL_ARRMETA: printf("META[%ld, %ld]\n", 65 | cell_index(secd, mcons_prev((cell_t*)c)), 66 | cell_index(secd, mcons_next((cell_t*)c))); break; 67 | case CELL_UNDEF: printf("#?\n"); break; 68 | case CELL_FREE: printf("FREE\n"); break; 69 | default: printf("unknown type: %d\n", cell_type(c)); 70 | } 71 | } 72 | 73 | void dbg_print_list(secd_t *secd, cell_t *list) { 74 | printf(" -= "); 75 | while (not_nil(list)) { 76 | assertv(is_cons(list), 77 | "Not a cons at [%ld]\n", cell_index(secd, list)); 78 | printf("[%ld]:%ld\t", 79 | cell_index(secd, list), 80 | cell_index(secd, get_car(list))); 81 | dbg_print_cell(secd, get_car(list)); 82 | printf(" -> "); 83 | list = list_next(secd, list); 84 | } 85 | printf("NIL\n"); 86 | } 87 | 88 | void dbg_printc(secd_t *secd, cell_t *c) { 89 | if (is_cons(c)) 90 | dbg_print_list(secd, c); 91 | else 92 | dbg_print_cell(secd, c); 93 | } 94 | 95 | void sexp_print_array(secd_t *secd, cell_t *p, const cell_t *cell) { 96 | const cell_t *arr = arr_val(cell, 0); 97 | const size_t len = arr_size(secd, cell); 98 | size_t i; 99 | 100 | secd_pprintf(secd, p, "#("); 101 | for (i = cell->as.arr.offset; i < len; ++i) { 102 | sexp_pprint(secd, p, arr + i); 103 | secd_pprintf(secd, p, " "); 104 | } 105 | secd_pprintf(secd, p, ")"); 106 | } 107 | 108 | void sexp_print_bytes(secd_t __unused *secd, cell_t *p, const char *arr, size_t len) { 109 | size_t i; 110 | const unsigned char *arru = (unsigned char *)arr; 111 | 112 | secd_pprintf(secd, p, "#u8("); 113 | for (i = 0; i < len; ++i) { 114 | secd_pprintf(secd, p, "#x%02x ", (unsigned)arru[i]); 115 | } 116 | secd_pprintf(secd, p, ")"); 117 | } 118 | 119 | static void sexp_print_list(secd_t *secd, cell_t *port, const cell_t *cell) { 120 | secd_pprintf(secd, port, "("); 121 | const cell_t *iter = cell; 122 | while (not_nil(iter)) { 123 | if (iter != cell) secd_pprintf(secd, port, " "); 124 | if (cell_type(iter) != CELL_CONS) { 125 | secd_pprintf(secd, port, ". "); 126 | sexp_pprint(secd, port, iter); break; 127 | } 128 | 129 | cell_t *head = get_car(iter); 130 | sexp_pprint(secd, port, head); 131 | iter = list_next(secd, iter); 132 | } 133 | secd_pprintf(secd, port, ") "); 134 | } 135 | 136 | int secd_pdump_array(secd_t *secd, cell_t *p, cell_t *mcons) { 137 | if (mcons->as.mcons.cells) { 138 | secd_pprintf(secd, p, " #("); 139 | cell_t *mem = meta_mem(mcons); 140 | size_t len = arrmeta_size(secd, mcons); 141 | size_t i; 142 | for (i = 0; i < len; ++i) { 143 | cell_t *item_info = serialize_cell(secd, mem + i); 144 | sexp_pprint(secd, p, item_info); 145 | free_cell(secd, item_info); 146 | } 147 | secd_pprintf(secd, p, ")"); 148 | } else { 149 | sexp_print_bytes(secd, p, (char *)(mcons + 1), 150 | sizeof(cell_t) * arrmeta_size(secd, mcons)); 151 | } 152 | return 0; 153 | } 154 | 155 | 156 | /* machine printing, (write) */ 157 | void sexp_pprint(secd_t* secd, cell_t *port, const cell_t *cell) { 158 | switch (cell_type(cell)) { 159 | case CELL_UNDEF: secd_pprintf(secd, port, "#?"); break; 160 | case CELL_INT: secd_pprintf(secd, port, "%d", cell->as.num); break; 161 | case CELL_CHAR: 162 | if (isprint(cell->as.num)) 163 | secd_pprintf(secd, port, "#\\%c", (char)cell->as.num); 164 | else 165 | secd_pprintf(secd, port, "#\\x%x", numval(cell)); 166 | break; 167 | case CELL_OP: sexp_print_opcode(secd, port, cell->as.op); break; 168 | case CELL_FUNC: secd_pprintf(secd, port, "##func*%p", cell->as.ptr); break; 169 | case CELL_FRAME: secd_pprintf(secd, port, 170 | "##frame@%ld ", cell_index(secd, cell)); break; 171 | case CELL_KONT: secd_pprintf(secd, port, 172 | "##kont@%ld ", cell_index(secd, cell)); break; 173 | case CELL_CONS: sexp_print_list(secd, port, cell); break; 174 | case CELL_ARRAY: sexp_print_array(secd, port, cell); break; 175 | case CELL_STR: secd_pprintf(secd, port, "\"%s\"", strval(cell) + cell->as.str.offset); break; 176 | case CELL_SYM: secd_pprintf(secd, port, "%s", symname(cell)); break; 177 | case CELL_BYTES: sexp_print_bytes(secd, port, strval(cell), mem_size(cell)); break; 178 | case CELL_ERROR: secd_pprintf(secd, port, "#!\"%s\"", errmsg(cell)); break; 179 | case CELL_PORT: sexp_pprint_port(secd, port, cell); break; 180 | case CELL_REF: sexp_pprint(secd, port, cell->as.ref); break; 181 | default: errorf("sexp_print: unknown cell type %d", (int)cell_type(cell)); 182 | } 183 | } 184 | 185 | void sexp_print(secd_t *secd, const cell_t *cell) { 186 | sexp_pprint(secd, secd->output_port, cell); 187 | } 188 | 189 | /* human-readable, (display) */ 190 | void sexp_display(secd_t *secd, cell_t *port, cell_t *cell) { 191 | switch (cell_type(cell)) { 192 | case CELL_STR: 193 | secd_pprintf(secd, port, "%s", strval(cell)); 194 | break; 195 | default: sexp_pprint(secd, port, cell); 196 | } 197 | } 198 | 199 | 200 | /* 201 | * SECD parser 202 | * A parser of a simple Lisp subset 203 | */ 204 | #define MAX_LEXEME_SIZE 256 205 | 206 | typedef int token_t; 207 | typedef struct secd_parser secd_parser_t; 208 | 209 | enum { 210 | TOK_EOF = -1, 211 | TOK_SYM = -2, 212 | TOK_NUM = -3, 213 | TOK_STR = -4, 214 | TOK_CHAR = -5, 215 | 216 | TOK_QUOTE = -6, 217 | TOK_QQ = -7, 218 | TOK_UQ = -8, 219 | TOK_UQSPL = -9, 220 | 221 | TOK_ERR = -65536 222 | }; 223 | 224 | const char not_symbol_chars[] = " ();\n\t"; 225 | 226 | struct secd_parser { 227 | secd_t *secd; 228 | token_t token; 229 | 230 | int line; 231 | int pos; 232 | /* lexer guts */ 233 | int lc; // lex char 234 | int numtok; 235 | char symtok[MAX_LEXEME_SIZE]; 236 | char issymbc[UCHAR_MAX + 1]; 237 | 238 | cell_t *strtok; 239 | 240 | int nested; 241 | }; 242 | 243 | cell_t *sexp_read(secd_t *secd, secd_parser_t *p); 244 | cell_t *read_list(secd_t *secd, secd_parser_t *p); 245 | 246 | static cell_t *read_token(secd_t *secd, secd_parser_t *p); 247 | 248 | secd_parser_t *init_parser(secd_t *secd, secd_parser_t *p) { 249 | p->lc = ' '; 250 | p->nested = 0; 251 | p->secd = secd; 252 | p->line = 1; p->pos = 0; 253 | 254 | memset(p->issymbc, false, 0x20); 255 | memset(p->issymbc + 0x20, true, UCHAR_MAX - 0x20); 256 | const char *s = not_symbol_chars; 257 | while (*s) 258 | p->issymbc[(unsigned char)*s++] = false; 259 | return p; 260 | } 261 | 262 | inline static int nextchar(secd_parser_t *p) { 263 | secd_t *secd = p->secd; 264 | p->lc = secd_pgetc(secd, secd->input_port); 265 | if (p->lc == '\n') { 266 | ++p->line; 267 | p->pos = 0; 268 | } else 269 | ++p->pos; 270 | return p->lc; 271 | } 272 | 273 | inline static bool isbasedigit(int c, int base) { 274 | switch (base) { 275 | case 2: return (c == '0') || (c == '1'); 276 | case 8: return ('0' <= c) && (c < '8'); 277 | case 10: return isdigit(c); 278 | case 16: return isxdigit(c); 279 | } 280 | return false; 281 | } 282 | 283 | inline static token_t lexnumber(secd_parser_t *p, int base) { 284 | char *s = p->symtok; 285 | do { 286 | *s++ = p->lc; 287 | nextchar(p); 288 | } while (isbasedigit(p->lc, base)); 289 | *s = '\0'; 290 | 291 | char *end = NULL; 292 | p->numtok = (int)strtol(p->symtok, &end, base); 293 | if (end[0] != '\0') 294 | return (p->token = TOK_ERR); 295 | return (p->token = TOK_NUM); 296 | } 297 | 298 | inline static token_t lexsymbol(secd_parser_t *p) { 299 | char *s = p->symtok; 300 | size_t read_count = 1; 301 | do { 302 | *s++ = p->lc; 303 | nextchar(p); 304 | if (++read_count >= MAX_LEXEME_SIZE) { 305 | *s = '\0'; 306 | secd_errorf(p->secd, "lexnext: lexeme is too large: %s\n", p->symtok); 307 | return (p->token = TOK_ERR); 308 | } 309 | } while (p->issymbc[(unsigned char)p->lc]); 310 | *s = '\0'; 311 | 312 | /* try to convert symbol into number */ 313 | if (p->symtok[0] == '-' || p->symtok[0] == '+') { 314 | char *end = NULL; 315 | p->numtok = (int)strtol(p->symtok, &end, 10); 316 | if ((p->symtok[0] != '\0') && (end[0] == '\0')) 317 | return (p->token = TOK_NUM); 318 | } 319 | 320 | return (p->token = TOK_SYM); 321 | } 322 | 323 | inline static token_t lexstring(secd_parser_t *p) { 324 | size_t bufsize = 32; /* initial size since string size is not limited */ 325 | size_t read_count = 0; 326 | 327 | /* to be freed after p->strtok is consumed: */ 328 | cell_t *strbuf = new_string_of_size(p->secd, bufsize); 329 | share_cell(p->secd, strbuf); 330 | char *buf = strmem(strbuf); 331 | 332 | while (1) { 333 | nextchar(p); 334 | switch (p->lc) { 335 | case '\\': 336 | nextchar(p); 337 | switch (p->lc) { 338 | case 'a' : buf[read_count++] = '\x07'; break; 339 | case 'b' : buf[read_count++] = '\x08'; break; 340 | case 't' : buf[read_count++] = '\x09'; break; 341 | case 'n' : buf[read_count++] = '\x0A'; break; 342 | case 'x': { 343 | char hexbuf[10]; 344 | char *hxb = hexbuf; 345 | 346 | nextchar(p); 347 | if (!isxdigit(p->lc)) 348 | goto cleanup_and_exit; 349 | do { 350 | *hxb++ = p->lc; 351 | nextchar(p); 352 | } while ((hxb - hexbuf < 9) && isxdigit(p->lc)); 353 | if (p->lc != ';') 354 | goto cleanup_and_exit; 355 | 356 | *hxb = '\0'; 357 | unichar_t charcode = (int)strtol(hexbuf, NULL, 16); 358 | char *after = utf8cpy(buf + read_count, charcode); 359 | if (!after) 360 | goto cleanup_and_exit; 361 | 362 | read_count = after - buf; 363 | } break; 364 | default: 365 | buf[read_count++] = p->lc; 366 | } 367 | break; 368 | case '"': 369 | nextchar(p); 370 | buf[read_count] = '\0'; 371 | p->strtok = strbuf; /* don't forget to free */ 372 | return (p->token = TOK_STR); 373 | default: 374 | buf[read_count] = p->lc; 375 | ++read_count; 376 | } 377 | 378 | if (read_count + 4 >= bufsize) { // +4 because of utf8cpy 379 | /* reallocate */ 380 | size_t newbufsize = 2 * bufsize; 381 | cell_t *newstrbuf = new_string_of_size(p->secd, newbufsize); 382 | if (is_error(newstrbuf)) { 383 | secd_errorf(p->secd, "lexstring: not enough memory for a string\n"); 384 | goto cleanup_and_exit; 385 | } 386 | 387 | //errorf(";# reallocating string to %lu", newbufsize); 388 | char *newbuf = strmem(newstrbuf); 389 | memcpy(newbuf, buf, bufsize); 390 | 391 | assign_cell(p->secd, &strbuf, newstrbuf); 392 | buf = newbuf; 393 | bufsize = newbufsize; 394 | } 395 | } 396 | cleanup_and_exit: 397 | drop_cell(p->secd, strbuf); 398 | return (p->token = TOK_ERR); 399 | } 400 | 401 | const struct { 402 | const char *name; 403 | int chr; 404 | } scheme_chars_names[] = { 405 | { "alarm", '\x07' }, 406 | { "backspace", '\x08' }, 407 | { "delete", '\x7f' }, 408 | { "escape", '\x1b' }, 409 | { "newline", '\x0a' }, 410 | { "null", '\x00' }, 411 | { "return", '\x0d' }, 412 | { "space", ' ' }, 413 | { "tab", '\t' }, 414 | 415 | { NULL, 0 } 416 | }; 417 | 418 | token_t lexchar(secd_parser_t *p) { 419 | char *s = p->symtok; 420 | while (p->issymbc[p->lc] 421 | && ((s - p->symtok) < MAX_LEXEME_SIZE)) 422 | { 423 | *s++ = p->lc; 424 | nextchar(p); 425 | } 426 | *s = '\0'; 427 | 428 | if (p->symtok[0] == '\0') { 429 | p->numtok = p->lc; 430 | nextchar(p); 431 | return (p->token = TOK_CHAR); 432 | } 433 | if (p->symtok[1] == '\0') { 434 | p->numtok = p->symtok[0]; 435 | return (p->token = TOK_CHAR); 436 | } 437 | if (p->symtok[0] == 'x') { 438 | char *end = NULL; 439 | p->numtok = (int)strtol(p->symtok + 1, &end, 16); 440 | if (end && (end[0] == '\0')) 441 | return (p->token = TOK_CHAR); 442 | } 443 | int i = 0; 444 | for (i = 0; scheme_chars_names[i].name; ++i) { 445 | if (scheme_chars_names[i].name[0] > p->symtok[0]) 446 | break; 447 | if (str_eq(scheme_chars_names[i].name, p->symtok)) { 448 | p->numtok = scheme_chars_names[i].chr; 449 | return (p->token = TOK_CHAR); 450 | } 451 | } 452 | 453 | return (p->token = TOK_ERR); 454 | } 455 | 456 | static void lex_mltln_comment(secd_parser_t *p) { 457 | while (true) { 458 | nextchar(p); 459 | switch (p->lc) { 460 | case '"': 461 | lexstring(p); 462 | break; 463 | case '#': 464 | if (nextchar(p) == '|') 465 | lex_mltln_comment(p); 466 | break; 467 | case '|': 468 | if (nextchar(p) == '#') { 469 | nextchar(p); 470 | return; 471 | } 472 | break; 473 | } 474 | } 475 | } 476 | 477 | token_t lexnext(secd_parser_t *p) { 478 | /* skip spaces */ 479 | while (isspace(p->lc)) 480 | nextchar(p); 481 | 482 | switch (p->lc) { 483 | case EOF: return (p->token = TOK_EOF); 484 | case ';': 485 | /* consume comment */ 486 | do nextchar(p); while (p->lc != '\n'); 487 | return lexnext(p); 488 | 489 | case '(': case ')': 490 | p->token = p->lc; 491 | nextchar(p); 492 | return p->token; 493 | 494 | case '#': 495 | /* one-char tokens */ 496 | p->token = p->lc; 497 | nextchar(p); 498 | switch (p->lc) { 499 | case 'f': case 't': 500 | p->symtok[0] = '#'; 501 | p->symtok[1] = p->lc; 502 | p->symtok[2] = '\0'; 503 | nextchar(p); 504 | return (p->token = TOK_SYM); 505 | case ';': 506 | nextchar(p); 507 | free_cell(p->secd, read_token(p->secd, p)); 508 | return lexnext(p); 509 | case '|': 510 | lex_mltln_comment(p); 511 | return lexnext(p); 512 | case '!': 513 | do { 514 | nextchar(p); 515 | } while (p->lc != '\n'); 516 | return lexnext(p); 517 | /* chars */ 518 | case '\\': nextchar(p); return lexchar(p); 519 | /* numbers */ 520 | case 'x': case 'X': nextchar(p); return lexnumber(p, 16); 521 | case 'o': case 'O': nextchar(p); return lexnumber(p, 8); 522 | case 'b': case 'B': nextchar(p); return lexnumber(p, 2); 523 | case 'd': case 'D': nextchar(p); return lexnumber(p, 10); 524 | } 525 | return p->token; 526 | case '\'': 527 | nextchar(p); 528 | return (p->token = TOK_QUOTE); 529 | case '`': 530 | nextchar(p); 531 | return (p->token = TOK_QQ); 532 | case ',': 533 | /* may be ',' or ',@' */ 534 | nextchar(p); 535 | if (p->lc == '@') { 536 | nextchar(p); 537 | return (p->token = TOK_UQSPL); 538 | } 539 | return (p->token = TOK_UQ); 540 | case '"': 541 | return lexstring(p); 542 | } 543 | 544 | if (isdigit(p->lc)) 545 | return lexnumber(p, 10); 546 | 547 | if (p->issymbc[(unsigned char)p->lc]) 548 | return lexsymbol(p); 549 | 550 | return TOK_ERR; /* nothing fits */ 551 | } 552 | 553 | static const char * special_form_for(int token) { 554 | switch (token) { 555 | case TOK_QUOTE: return "quote"; 556 | case TOK_QQ: return "quasiquote"; 557 | case TOK_UQ: return "unquote"; 558 | case TOK_UQSPL: return "unquote-splicing"; 559 | } 560 | return NULL; 561 | } 562 | 563 | static cell_t *read_bytevector(secd_parser_t *p) { 564 | secd_t *secd = p->secd; 565 | assert(p->token == '(', "read_bytevector: '(' expected"); 566 | cell_t *tmplist = SECD_NIL; 567 | cell_t *cur; 568 | size_t len = 0; 569 | while (lexnext(p) == TOK_NUM) { 570 | assert((0 <= p->numtok) && (p->numtok < 256), 571 | "read_bytevector: out of range"); 572 | 573 | cell_t *newc = new_cons(secd, new_number(secd, p->numtok), SECD_NIL); 574 | if (not_nil(tmplist)) { 575 | cur->as.cons.cdr = share_cell(secd, newc); 576 | cur = newc; 577 | } else { 578 | tmplist = cur = newc; 579 | } 580 | ++len; 581 | } 582 | 583 | cell_t *bvect = new_bytevector_of_size(secd, len); 584 | assert_cell(bvect, "read_bytevector: failed to allocate"); 585 | unsigned char *mem = (unsigned char *)strmem(bvect); 586 | 587 | cur = tmplist; 588 | size_t i; 589 | for (i = 0; i < len; ++i) { 590 | mem[i] = (unsigned char)numval(list_head(cur)); 591 | cur = list_next(secd, cur); 592 | } 593 | 594 | free_cell(secd, tmplist); 595 | return bvect; 596 | } 597 | 598 | static cell_t *read_token(secd_t *secd, secd_parser_t *p) { 599 | int tok; 600 | cell_t *inp = NULL; 601 | switch (tok = p->token) { 602 | case '(': 603 | ++p->nested; 604 | inp = read_list(secd, p); 605 | if (p->token != ')') 606 | goto error_exit; 607 | return inp; 608 | case TOK_NUM: 609 | return new_number(secd, p->numtok); 610 | case TOK_CHAR: 611 | return new_char(secd, p->numtok); 612 | case TOK_SYM: 613 | return new_symbol(secd, p->symtok); 614 | case TOK_STR: 615 | inp = new_string(secd, strmem(p->strtok)); 616 | drop_cell(secd, p->strtok); 617 | return inp; 618 | case TOK_EOF: 619 | return new_symbol(secd, EOF_OBJ); 620 | 621 | case TOK_QUOTE: case TOK_QQ: 622 | case TOK_UQ: case TOK_UQSPL: { 623 | const char *formname = special_form_for(tok); 624 | assert(formname, "No special form for token=%d\n", tok); 625 | inp = sexp_read(secd, p); 626 | assert_cell(inp, "sexp_read: reading subexpression failed"); 627 | return new_cons(secd, new_symbol(secd, formname), 628 | new_cons(secd, inp, SECD_NIL)); 629 | } 630 | 631 | case '#': 632 | switch (tok = lexnext(p)) { 633 | case '(': { 634 | cell_t *tmplist = read_list(secd, p); 635 | if (p->token != ')') { 636 | free_cell(secd, tmplist); 637 | goto error_exit; 638 | } 639 | inp = list_to_vector(secd, tmplist); 640 | free_cell(secd, tmplist); 641 | return inp; 642 | } 643 | case TOK_SYM: { 644 | if (p->symtok[0] == '.') { 645 | int op = secdop_by_name(p->symtok + 1); 646 | if (op < 0) 647 | goto error_exit; 648 | 649 | return new_op(secd, op); 650 | } 651 | if (str_eq(p->symtok, "u8")) { 652 | lexnext(p); 653 | inp = read_bytevector(p); 654 | if (p->token != ')') 655 | goto error_exit; 656 | return inp; 657 | } 658 | } 659 | } 660 | errorf("Unknown suffix for #\n"); 661 | } 662 | 663 | error_exit: 664 | if (inp) free_cell(secd, inp); 665 | errorf("read_token: failed\n"); 666 | return new_error(secd, SECD_NIL, 667 | "read_token: failed on token %1$d '%1$c'", p->token); 668 | } 669 | 670 | cell_t *read_list(secd_t *secd, secd_parser_t *p) { 671 | const char *parse_err = NULL; 672 | cell_t *head = SECD_NIL; 673 | cell_t *tail = SECD_NIL; 674 | 675 | cell_t *newtail, *val; 676 | 677 | while (true) { 678 | int tok = lexnext(p); 679 | switch (tok) { 680 | case TOK_EOF: case ')': 681 | -- p->nested; 682 | return head; 683 | 684 | case '(': 685 | ++ p->nested; 686 | val = read_list(secd, p); 687 | if (p->token == TOK_ERR) { 688 | parse_err = "read_list: error reading subexpression"; 689 | goto error_exit; 690 | } 691 | if (p->token != ')') { 692 | parse_err = "read_list: TOK_EOF, ')' expected"; 693 | goto error_exit; 694 | } 695 | break; 696 | 697 | default: 698 | val = read_token(secd, p); 699 | if (is_error(val)) { 700 | parse_err = "read_list: read_token failed"; 701 | goto error_exit; 702 | } 703 | /* reading dot-lists */ 704 | if (is_symbol(val) && (str_eq(symname(val), "."))) { 705 | free_cell(secd, val); 706 | 707 | switch (lexnext(p)) { 708 | case TOK_ERR: case ')': 709 | parse_err = "read_list: failed to read a token after dot"; 710 | goto error_exit; 711 | case '(': 712 | /* there may be a list after dot */ 713 | val = read_list(secd, p); 714 | if (p->token != ')') { 715 | parse_err = "read_list: expected a ')' reading sublist after dot"; 716 | goto error_exit; 717 | } 718 | lexnext(p); // consume ')' 719 | break; 720 | 721 | default: 722 | val = read_token(secd, p); 723 | lexnext(p); 724 | } 725 | 726 | if (is_nil(head)) /* Guile-like: (. val) returns val */ 727 | return val; 728 | tail->as.cons.cdr = share_cell(secd, val); 729 | return head; 730 | } 731 | } 732 | 733 | newtail = new_cons(secd, val, SECD_NIL); 734 | if (not_nil(head)) { 735 | tail->as.cons.cdr = share_cell(secd, newtail); 736 | tail = newtail; 737 | } else { 738 | head = tail = newtail; 739 | } 740 | } 741 | error_exit: 742 | free_cell(secd, head); 743 | errorf("read_list: TOK_ERR, %s\n", parse_err); 744 | return new_error(secd, SECD_NIL, parse_err); 745 | } 746 | 747 | cell_t *sexp_read(secd_t *secd, secd_parser_t *p) { 748 | lexnext(p); 749 | return read_token(secd, p); 750 | } 751 | 752 | static inline cell_t * 753 | new_lexeme(secd_t *secd, const char *type, cell_t *contents) { 754 | cell_t *contc = new_cons(secd, contents, SECD_NIL); 755 | return new_cons(secd, new_symbol(secd, type), contc); 756 | } 757 | 758 | cell_t *sexp_lexeme(secd_t *secd, int line, int pos, int prevchar) { 759 | cell_t *result; 760 | secd_parser_t p; 761 | 762 | init_parser(secd, &p); 763 | p.line = line; 764 | p.pos = pos; 765 | p.lc = prevchar; 766 | 767 | lexnext(&p); 768 | 769 | switch (p.token) { 770 | case TOK_EOF: 771 | return new_symbol(secd, EOF_OBJ); 772 | case TOK_SYM: 773 | result = new_lexeme(secd, "sym", new_symbol(secd, p.symtok)); 774 | break; 775 | case TOK_NUM: 776 | result = new_lexeme(secd, "int", new_number(secd, p.numtok)); 777 | break; 778 | case TOK_STR: 779 | result = new_lexeme(secd, "str", new_string(secd, strmem(p.strtok))); 780 | drop_cell(secd, p.strtok); 781 | break; 782 | case TOK_CHAR: 783 | result = new_lexeme(secd, "char", new_char(secd, p.numtok)); 784 | break; 785 | case TOK_QUOTE: case TOK_QQ: 786 | case TOK_UQ: case TOK_UQSPL: 787 | result = new_lexeme(secd, special_form_for(p.token), SECD_NIL); 788 | break; 789 | case TOK_ERR: 790 | result = new_lexeme(secd, "syntax error", SECD_NIL); 791 | break; 792 | default: 793 | result = new_lexeme(secd, "token", new_char(secd, p.token)); 794 | } 795 | cell_t *pcharc = new_cons(secd, new_char(secd, p.lc), result); 796 | cell_t *posc = new_cons(secd, new_number(secd, p.pos), pcharc); 797 | cell_t *linec = new_cons(secd, new_number(secd, p.line), posc); 798 | return linec; 799 | } 800 | 801 | cell_t *sexp_parse(secd_t *secd, cell_t *port) { 802 | cell_t *prevport = SECD_NIL; 803 | if (not_nil(port)) { 804 | assert(cell_type(port) == CELL_PORT, "sexp_parse: not a port"); 805 | prevport = secd->input_port; // share_cell, drop_cell 806 | secd->input_port = share_cell(secd, port); 807 | } 808 | 809 | secd_parser_t p; 810 | init_parser(secd, &p); 811 | cell_t *res = sexp_read(secd, &p); 812 | 813 | if (not_nil(prevport)) { 814 | secd->input_port = prevport; //share_cell back 815 | drop_cell(secd, port); 816 | } 817 | return res; 818 | } 819 | 820 | -------------------------------------------------------------------------------- /vm/secdops.h: -------------------------------------------------------------------------------- 1 | #ifndef __SECD_OPS_H__ 2 | #define __SECD_OPS_H__ 3 | 4 | 5 | typedef struct { 6 | const char *name; 7 | secd_opfunc_t fun; 8 | int args; // takes 'args' control cells after the opcode 9 | int stackuse; // changes of stack size 10 | } opcode_t; 11 | 12 | extern const opcode_t opcode_table[]; 13 | extern size_t opcode_count(void); 14 | 15 | cell_t * compile_ctrl(secd_t *secd, cell_t **ctrl); 16 | 17 | int secdop_by_name(const char *name); 18 | 19 | #endif //__SECD_OPS_H__ 20 | --------------------------------------------------------------------------------