git @ Cat's Eye Technologies Kosheri / f3a6969
Initial import of Kosheri sources. Cat's Eye Technologies 12 years ago
52 changed file(s) with 6140 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+318
-0
README.markdown less more
0 Kosheri
1 =======
2
3 Kosheri is a stack-based virtual machine. Here's what it offers:
4
5 * Garbage-collection, tagged tuples, dictionaries, function values,
6 coroutines, lightweight processes, textual and binary serialization,
7 and an assembler and disassembler. See "Features", below, for
8 more information.
9 * A really small code footprint. On Ubuntu 10.04 LTS, a minimal VM
10 executor compiles to an executable less than 16K in size.
11 * A clean, almost pedantic implementation. See "Implementation", below.
12 * Very few build dependencies. See "Build requirements", below.
13 * An extremely orthogonal architecture. See "Architecture", below.
14 * A reasonably efficient implementation. See "Performance", below.
15
16 Features
17 --------
18
19 * Ability to manipulate values of boolean, 32-bit integer,
20 process reference ("pid"), immutable string ("symbol"), and
21 tagged tuple type.
22 * Support for manipulating certain tagged tuple types:
23 dictionaries, function values, and activation records.
24 * Support for closures and coroutines via appropriate use of
25 activation records. (ARs retain some state after being
26 called; if this is not cleared, they can be continued.)
27 * A simple, mark-and-sweep garbage collector (for tuples and
28 symbols; everything else lives on the stack.)
29 * Concurrent operation. Each lightweight process can be a
30 VM process or a native process. Native processes are used to
31 implement interfaces to the rest of the world. Multitasking
32 is pre-emptive for VM processes, and co-operative for native
33 processes. Concurrency is implemented in the VM; system threads
34 and processes are not used. Interprocess communication is done
35 with Erlang-style messaging to processes' mailboxes.
36
37 Implementation
38 --------------
39
40 The code is generally written in BSD style(9). It compiles under
41 `-ansi -pedantic` with almost all `gcc` warnings enabled and treated as
42 errors. The core interfaces are `const`ified. `assert`s are
43 plentiful. I've tried to limit the amount of typecasting used in the
44 code, but of course there are some places where it is necessary.
45
46 Functions are often written in a straightforward, almost pedantic
47 fashion; there are of course some exceptions here too, like the
48 direct threading support.
49
50 Build requirements
51 ------------------
52
53 Only the following tools are required to build the VM and its tools:
54
55 * an ANSI C compiler (default is `gcc`) and linker (`ranlib`, `ar`)
56 * GNU Make
57
58 I have vague plans to remove even the dependency on GNU Make (the
59 code is so small that rebuilding the whole thing is not a huge burden,
60 so it could be done with a shell script or a custom build tool.)
61
62 Even `libc` is not a strict requirement for building the VM; a
63 few functions from `libc` that the code uses are implemented
64 independently in the code. The `standalone` target builds the
65 system with `-nostdlib`. However, while it builds it currently
66 does not link, as it requires some memory allocator to link to,
67 and it doesn't have one... yet.
68
69 Architecture
70 ------------
71
72 From inside the virtual machine, it's a truism that "everything's
73 a value, and every value that's not an atomic value is a tagged tuple."
74 The latter is true even for VM code and activation records and
75 dictionaries.
76
77 Moreover, this truism largely holds in the C code as well. In many
78 places in the assembler and elsewhere, we don't just use C structs
79 to hold our data, we use `struct value`s.
80
81 Every value has defined external representations, in human-readable and
82 compact binary forms, which can be generated and parsed.
83
84 The rest of this section is kind of scattered...
85
86 Some more notes on how the runtime is written in C...
87
88 Every C function in the Kosheri runtime is run in some environment.
89
90 We try to assume as little about the surrounding environment (e.g., OS)
91 as possible, and to present the world to these functions in as Kosheri-
92 like a way as possible.
93
94 Maybe not every function, but lots of functions. The ones that really
95 matter. Top-level functions especially -- (the ones that would be
96 command-line utilities in a Unix system.)
97
98 Every such function is passed a runtime environment. This runtime
99 environment consist of:
100
101 -- arguments that were passed to the function in the form of a Kosheri
102 dictionary (value_dict). The function may also have a data structure
103 associated with it (the "argdecl") that facilitates checking these
104 arguments for syntactic correctness and automatically returning an error
105 if they don't meet those checks. (this part's not done yet)
106
107 -- environment variables that were made available to the function.
108 (This is possibly not OK. Environment variables have a way of hanging
109 around that arguments don't. Some kind of adapter is called for that
110 translates (relevant) env vars to arguments first.)
111
112 -- streams available to the function, in the form of Kosheri processes.
113 The function should not assume the presence of a particular stream, or
114 at least, a function which does assume the presence of a particular
115 stream should not be assumed to always work. The function should also
116 not assume that the streams that are made available to it behave in a
117 particular way (for example, that a stream is directed to a vt100
118 terminal.) Instead it should look for a stream that abstractly presents
119 the behaviour that it wants.
120
121 Performance
122 -----------
123
124 Kosheri was designed to be reasonably efficient, for a virtual machine
125 without a JIT compiler.
126
127 The design decisions for performance are kind of all over the place,
128 sometimes being extremely optimized, sometimes sacrificing pure
129 performance for flexibility.
130
131 * "Direct threading" is possible with C compilers that support it,
132 such as `gcc`. This basically optimizes the main instruction-
133 selection `switch` into a computed `goto`.
134
135 * The compiled VM is small, really small. This means it can usually
136 fit entirely in the cache, and stay there. This can sometimes result
137 in a significant performance benefit.
138
139 On the other hand...
140
141 * The orthogonality of "everything is a tuple" extends far and wide.
142 All values are 8 bytes, including VM instructions. VM code size
143 could be reduced by packing 2 or 4 instructions into that 8 bytes,
144 but we don't do that yet.
145
146 * Input and output are modelled as processes, which means there is
147 some small overhead (to pack and unpack a message) added to I/O;
148 but I/O is I/O-bound anyway, so this is probably not something to
149 worry about.
150
151
152 Tour of the distribution
153 ------------------------
154
155 bin/
156
157 Where compiled binaries go.
158
159 eg/
160
161 Example assembly language files.
162
163 lib/
164
165 Where compiled libraries (static and dynamic) go.
166
167 src/
168
169 Source code for the virtual machine and tools.
170
171 src/build/
172
173 Source code for tools used during build-time, and not thereafter.
174
175 tests/
176
177 Tests.
178
179
180 Tour of the source
181 ------------------
182
183 assemble.c
184
185 Main program for the assembler.
186
187 chain.c
188 chain.h
189
190 Utilities to accumulate a linked list of values, then turn them
191 into a tuple when accumulation has finished.
192
193 cmdline.c
194 cmdline.h
195
196 Harness which translates command-line arguments to dictionaries,
197 and otherwise provides facilities so that programs can be written
198 in a "Kosheri view" of the outside world.
199
200 disasm.c
201
202 Main program for the disassembler.
203
204 discern.c
205 discern.h
206
207 Routines to parse human-readable representation of tuples into
208 the internal format.
209
210 file.c
211 file.h
212
213 Native implementation of processes supporting the stream-like interface
214 and which are backed with C's stdio.
215
216 freeze.c
217
218 Main program for the human-readable-value-to-compact-binary
219 serializer.
220
221 gen.c
222 gen.h
223
224 Routines for generating VM instructions (used by assembler, but
225 would also be useful for compilers targeting this VM.)
226
227 geninstr.c
228
229 A build tool which generates instrtab.c and instrenum.h from
230 vm.c.
231
232 instrtab.h
233
234 Header file for the generated instrtab.c.
235
236 lib.c
237 lib.h
238
239 Clean-room re-implementations of the few libc-supplied functions
240 which the VM uses.
241
242 load.c
243 load.h
244
245 Routines to parse (unserialize) the compact binary representation
246 of values.
247
248 portray.c
249 portray.h
250
251 Routines to format values into a human-readable representation.
252
253 process.c
254 process.h
255
256 Routines for communicating and switching between co-operative
257 lightweight concurrent processes.
258
259 render.c
260 render.h
261
262 Routines for rendering terms to file-like processes.
263
264 report.c
265 report.h
266
267 Routines for reporting errors, successes, etc. for the assembler,
268 disassembler, freezer and thawer.
269
270 run.c
271
272 Main program for the VM runner. Takes a VM program in the compact
273 binary representation and executes it.
274
275 save.c
276 save.h
277
278 Routines to generate (serialize) the compact binary representation
279 of values.
280
281 scan.c
282 scan.h
283
284 Lexical scanner, used by the assembler, and by the discern routines.
285 Fairly general, so could also be used to parse a language being
286 compiled to the VM.
287
288 stream.c
289 stream.h
290
291 Routines to communicate with processes which support the stream-like
292 interface; you can read from them, write to them, check for eof, and
293 close them.
294
295 thaw.c
296
297 Main program for the compact-binary-to-human-readable-value
298 unserializer.
299
300 value.c
301 value.h
302
303 Data structure (and associated functions) which internally
304 represents values, including atomic values (booleans, integers,
305 process id's, direct-threaded opcodes) and structured values
306 (tagged tuples and symbols.)
307
308 vm.c
309 vm.h
310
311 The virtual machine implementation itself.
312
313 vmproc.c
314 vmproc.h
315
316 The implementation of lightweight processes which uses the virtual machine
317 to execute the process.
+88
-0
TODO.markdown less more
0 TODO
1 ====
2
3 Correctness
4 -----------
5
6 * RECV instruction.
7
8 * Investigate why seemingly big-enough ARs are actually not big enough.
9
10 * Immutable values. This will help solve the problems of using
11 values as keys in a dictionary, and the problem of (not) sharing
12 data between processes.
13
14 * (BIG) Stack type checker in assembler.
15
16 * (BIG) Fix file processes to really be concurrent, esp. in read.
17 Use `select` (maybe export fd's to the scheduler.)
18
19 * (BIG) Error handling. Instead of just `assert()` (which isn't even there
20 when you define `NDEBUG`), throw an exception if the unexpected
21 happens. Or, send a message to the process which created this
22 process. (This will require `self` be accessible throughout the code
23 somehow.)
24
25 Testing
26 -------
27
28 * Falderal tests for all variants of conditionals.
29
30 * Falderal test for closures.
31
32 * Falderal test for sending and receiving messages.
33
34 * Falderal tests for dictionaries.
35
36 * Falderal test for portraying cyclic values.
37
38 * Falderal test for saving cycling values.
39
40 Accessibility
41 -------------
42
43 * Document C APIs (header files).
44
45 * enum success { SUCCESS = 1; FAILURE = 0; } and return this instead of int.
46
47 * Portray values from stream_render: %v or similar.
48
49 * Figure out way to debug messages received by file process
50 (can't write to file process, or you'll get an infinite loop.)
51
52 Portability
53 -----------
54
55 * Measure sizeof struct value et al in buildinfo. Spit out defines.
56 Think about how 64-bit systems will handle all this.
57
58 Footprint
59 ---------
60
61 * "small immediates" embedded in appropriate VM instructions.
62
63 * Go back to having "functional values", but basically say
64 that these are ARs with zero space allocated for arguments / locals.
65 Then have a VM instruction to create an AR from a functional value.
66 (Maybe also have a VM instruction to create a full AR instead of a
67 functional value, from a label, for when you want to call it one-off.)
68
69 Performance
70 -----------
71
72 * Allow symbols (/strings) to be interned. There is of course a
73 tradeoff here, so "allow" rather than "require".
74 Maybe have VALUE_TAG being "small strings" (fit in a struct value,
75 so, like, 7 characters). Then many problems go away...?
76
77 * Option to create a (non-interned) symbol from a const string in
78 a way that does not copy the const string.
79
80 * More efficient access of free variables. Split each AR into two sections: bound variables
81 and free variables. The bound variables are stored in the AR itself. Free variables are
82 stored in some other AR; pointers to them are stored in this AR. Then accessing a bound
83 variable is only a single indirection. Tradeoff is that more work needs to be done when
84 creating a functional value.
85
86 * In ARs, store top-of-stack pointer as a machine pointer,
87 not a tuple index.
+14
-0
debug.sh less more
0 #!/bin/sh
1
2 cd src
3 echo "Building 'debug' version..."
4 make clean debug >ERRORS 2>&1
5 if [ $? != 0 ]; then
6 cat ERRORS
7 rm -f ERRORS
8 exit 1
9 fi
10 rm -f ERRORS
11 ./assemble --asmfile ../$1 --vmfile out.kvm
12 gdb --args ./run --vmfile out.kvm
13 rm -f out.kvm
+37
-0
eg/callfunc2.kas less more
0 NEW_AR #10
1 GOTO :past_q
2 :q
3 ; no need to reserve space for parameters
4 GETI #0 ; local #0 = 1st parameter = a
5 STDOUT
6 PORTRAY
7
8 GETI #1 ; local #1 = 2nd parameter = b
9 STDOUT
10 PORTRAY
11
12 GETI #0
13 GETI #1
14 ADD_INT
15
16 YIELD #1 ; pass the result back to our caller
17 RET ; end of this function
18
19 :past_q
20
21 PUSH #1
22
23 PUSH #2
24 PUSH #3
25 PUSH #10 ; this function will need 4 slots: 2 args, 2 stack
26 FUN :q ; push a closure for q onto the stack
27 CALL #2 ; call it with two args
28
29 PUSH #10 ; this function will need 4 slots: 2 args, 2 stack
30 FUN :q ; push a closure for q onto the stack
31 CALL #2 ; call it with two args
32
33 STDOUT
34 PORTRAY
35
36 HALT
+14
-0
eg/countdown.kas less more
0 NEW_AR #3
1 PUSH #11 ; statically initialize our local
2 :label
3 GETI #0
4 STDOUT
5 PORTRAY
6 GETI #0
7 PUSH #1
8 SUB_INT
9 SETI #0
10 GETI #0
11 PUSH #0
12 JNE :label
13 HALT
+13
-0
eg/spawn.kas less more
0 NEW_AR #7
1 SPAWN :label
2 REST
3 PUSH #main
4 STDOUT
5 PORTRAY
6 HALT
7 :label
8 NEW_AR #7
9 PUSH #worker
10 STDOUT
11 PORTRAY
12 HALT
+133
-0
src/Makefile less more
0 # Makefile for Kosheri.
1 # $Id: Makefile 146 2008-12-06 19:59:54Z catseye $
2
3 CC?=gcc
4 AR?=ar
5 RANLIB?=ranlib
6
7 O?=.o
8 EXE?=
9
10 OD?=./
11
12 DEBUG_PORTRAY_O?=
13
14 WARNS= -Werror -W -Wall -Wstrict-prototypes -Wmissing-prototypes \
15 -Wpointer-arith -Wno-uninitialized -Wreturn-type -Wcast-qual \
16 -Wwrite-strings -Wswitch -Wshadow -Wcast-align -Wchar-subscripts \
17 -Winline -Wnested-externs -Wredundant-decls
18 LIBS=-L. -lruntime
19 CFLAGS+=-ansi -pedantic ${WARNS} ${EXTRA_CFLAGS}
20
21 RUNTIME_OBJS= ${OD}lib${O} ${OD}value${O} \
22 ${OD}process${O} ${OD}file${O} ${OD}stream${O} \
23 ${DEBUG_PORTRAY_O} \
24 ${OD}render${O}
25 # ${OD}portray${O}
26
27 # portray and save are only needed for non-raw output
28 # instrtab is only needed for direct threading conversion
29 RUN_OBJS= ${OD}run${O} \
30 ${OD}load${O} \
31 ${OD}vm${O} ${OD}vmproc${O} \
32 ${OD}instrtab${O} \
33 ${OD}portray${O} \
34 ${OD}save${O} \
35 ${OD}cmdline${O}
36
37 ASSEMBLE_OBJS= ${OD}assemble${O} \
38 ${OD}instrtab${O} \
39 ${OD}report${O} ${OD}scan${O} ${OD}discern${O} ${OD}chain${O} \
40 ${OD}gen${O} ${OD}save${O} \
41 ${OD}portray${O} \
42 ${OD}cmdline${O}
43
44 DISASM_OBJS= ${OD}disasm${O} \
45 ${OD}instrtab${O} \
46 ${OD}report${O} \
47 ${OD}load${O} \
48 ${OD}portray${O} \
49 ${OD}chain${O} \
50 ${OD}cmdline${O}
51
52 FREEZE_OBJS= ${OD}freeze${O} \
53 ${OD}save${O} \
54 ${OD}report${O} ${OD}scan${O} \
55 ${OD}discern${O} ${OD}chain${O} \
56 ${OD}cmdline${O}
57
58 THAW_OBJS= ${OD}thaw${O} \
59 ${OD}load${O} \
60 ${OD}report${O} \
61 ${OD}portray${O} \
62 ${OD}cmdline${O}
63
64 BUILDINFO_OBJS= ${OD}buildinfo${O} \
65 ${OD}process${O} \
66 ${OD}cmdline${O}
67
68 PROGS=run${EXE} assemble${EXE} disasm${EXE} freeze${EXE} thaw${EXE} \
69 buildinfo${EXE}
70
71 all: ${PROGS}
72
73 geninstr${EXE}: geninstr.o
74 ${CC} geninstr.o -o geninstr${EXE}
75
76 instrtab.c instrenum.h instrlab.h localtypes.h: vm.c geninstr
77 ./geninstr vm.c
78
79 value.h: localtypes.h
80
81 value.c: value.h
82
83 vm.h: instrenum.h instrlab.h value.h
84
85 libruntime.a: ${RUNTIME_OBJS}
86 ${AR} rc libruntime.a ${RUNTIME_OBJS}
87 ${RANLIB} libruntime.a
88
89 run.c: vm.h
90
91 run${EXE}: ${RUN_OBJS} libruntime.a
92 ${CC} ${RUN_OBJS} ${LIBS} -o run${EXE}
93 assemble${EXE}: ${ASSEMBLE_OBJS} libruntime.a
94 ${CC} ${ASSEMBLE_OBJS} ${LIBS} -o assemble${EXE}
95 disasm${EXE}: ${DISASM_OBJS} libruntime.a
96 ${CC} ${DISASM_OBJS} ${LIBS} -o disasm${EXE}
97 freeze${EXE}: ${FREEZE_OBJS} libruntime.a
98 ${CC} ${FREEZE_OBJS} ${LIBS} -o freeze${EXE}
99 thaw${EXE}: ${THAW_OBJS} libruntime.a
100 ${CC} ${THAW_OBJS} ${LIBS} -o thaw${EXE}
101
102 buildinfo${EXE}: ${BUILDINFO_OBJS} libruntime.a
103 ${CC} ${BUILDINFO_OBJS} ${LIBS} -o buildinfo${EXE}
104
105
106 # when DEBUG is defined, save.o, load.o, and parse.o depend on portray.o
107 debug: clean
108 ${MAKE} DEBUG_PORTRAY_O="${OD}portray${O}" \
109 EXTRA_CFLAGS="-g -DDEBUG"
110
111 profiled: clean
112 ${MAKE} EXTRA_CFLAGS="-pg"
113
114 tool: clean
115 ${MAKE} EXTRA_CFLAGS="-DNDEBUG -Os" LIBS="-L. -lruntime -s"
116
117 # -finline-functions ?
118
119 static: clean
120 ${MAKE} EXTRA_CFLAGS="-DNDEBUG -Os" LIBS="-L. -lruntime -s -static"
121
122 standalone: clean
123 ${MAKE} EXTRA_CFLAGS="-DNDEBUG -DSTANDALONE -DCTYPE_IS_BUILTIN -Os -static -nostdlib" LIBS="-L. -lruntime -nostdlib -s"
124
125 win: clean
126 ${MAKE} EXE=.exe EXTRA_CFLAGS="-DNDEBUG -mno-cygwin" all
127
128 wintool: clean
129 ${MAKE} EXE=.exe EXTRA_CFLAGS="-DNDEBUG -Os -static -mno-cygwin" LIBS="-L. -lruntime -s"
130
131 clean:
132 rm -rf ${OD}*${O} *.so *.a *.core *.vm *.exe instrtab.c instrenum.h instrlab.h geninstr *.stackdump ${PROGS} foo.* LISTING OUTPUT
+165
-0
src/assemble.c less more
0 /*
1 * assemble.c
2 * Assembler for virtual machine.
3 * $Id: assemble.c 146 2008-12-06 19:59:54Z catseye $
4 */
5
6 #include "lib.h"
7 #include "cmdline.h"
8 #include "value.h"
9
10 #include "stream.h"
11 #include "file.h"
12
13 #include "scan.h"
14 #include "discern.h"
15
16 #include "report.h"
17
18 #include "gen.h"
19 #include "instrtab.h"
20 #include "save.h"
21
22 static struct value labels;
23
24 /* Routines */
25
26 static struct value *
27 fetch_label(const char *token, unsigned int length)
28 {
29 struct value lab_text;
30
31 value_symbol_new(&lab_text, token, length);
32 return value_dict_fetch(&labels, &lab_text);
33 }
34
35 static void
36 store_label(const char *token, unsigned int length, struct value *label)
37 {
38 struct value lab_text;
39
40 value_symbol_new(&lab_text, token, length);
41 value_dict_store(&labels, &lab_text, label);
42 }
43
44 static void
45 assemble(struct scanner *sc, struct value *gen)
46 {
47 struct opcode_entry *oe;
48 struct value label;
49 int count;
50
51 while (!scanner_eof(sc)) {
52 if (scanner_tokeq(sc, ";")) { /* A comment - ignore rest of line. */
53 scanner_scanline(sc);
54 continue;
55 }
56 if (scanner_tokeq(sc, ":")) { /* A label - associate string with addr. */
57 const char *str;
58 int len;
59
60 scanner_scan(sc);
61 str = scanner_token_string(sc);
62 len = scanner_token_length(sc);
63 value_copy(&label, fetch_label(str, len));
64 /* This may cause backpatching */
65 if (gen_define_label(gen, &label)) {
66 store_label(str, len, &label);
67 } else {
68 scanner_report(sc, REPORT_ERROR, "Label already defined");
69 }
70 scanner_scan(sc);
71 continue;
72 }
73
74 for (oe = opcode_table; oe->token != NULL; oe++) {
75 if (scanner_tokeq(sc, oe->token))
76 break;
77 }
78 if (oe->token == NULL) {
79 scanner_report(sc, REPORT_ERROR, "Unrecognized token");
80 scanner_scan(sc);
81 continue;
82 }
83
84 gen_integer(gen, oe->opcode);
85 scanner_scan(sc);
86
87 for (count = 0; count < oe->arity; count++) {
88 if (scanner_tokeq(sc, ":")) {
89 const char *str;
90 int len;
91
92 scanner_scan(sc);
93 str = scanner_token_string(sc);
94 len = scanner_token_length(sc);
95 value_copy(&label, fetch_label(str, len));
96 gen_gen_label_ref(gen, &label);
97 store_label(str, len, &label);
98 scanner_scan(sc);
99 continue;
100 } else if (scanner_tokeq(sc, "#")) {
101 struct value v;
102
103 scanner_scan(sc);
104 value_discern(&v, sc);
105 gen_value(gen, &v);
106 continue;
107 } else {
108 scanner_report(sc, REPORT_WARNING,
109 "Unrecognized argument");
110 scanner_scan(sc);
111 }
112 }
113 }
114 }
115
116 static void
117 assemble_main(struct value *args, struct value *result)
118 {
119 struct process *out;
120 struct scanner *sc;
121 struct reporter *r;
122 struct value gen, flat; /* the generator that we will use to build vm code */
123 struct value *asmfile, *vmfile;
124 struct value asmfile_sym, vmfile_sym;
125
126 r = reporter_new("Assembly", NULL, 1);
127
128 value_symbol_new(&asmfile_sym, "asmfile", 7);
129 value_symbol_new(&vmfile_sym, "vmfile", 6);
130
131 assert(value_is_tuple(args));
132 asmfile = value_dict_fetch(args, &asmfile_sym);
133 vmfile = value_dict_fetch(args, &vmfile_sym);
134
135 /*
136 * Generate.
137 */
138 sc = scanner_new(r);
139
140 if (!scanner_open(sc, value_symbol_get_token(asmfile))) {
141 value_integer_set(result, 1);
142 return;
143 }
144
145 gen_new_default(&gen);
146 value_dict_new(&labels, 8);
147 assemble(sc, &gen);
148 gen_integer(&gen, INSTR_EOF);
149 scanner_close(sc);
150 scanner_free(sc);
151
152 /*
153 * Write out.
154 */
155 out = file_open(value_symbol_get_token(vmfile), "w");
156 gen_flatten(&gen, &flat);
157 value_save(out, &flat);
158 stream_close(NULL, out);
159
160 value_integer_set(result, reporter_has_errors(r) ? 1 : 0);
161 reporter_free(r);
162 }
163
164 MAIN(assemble_main)
+28
-0
src/buildinfo.c less more
0 /*
1 * buildinfo.c
2 * Show some info about the built binary (also test for process-based I/O)
3 */
4
5 #include "lib.h"
6
7 #include "render.h"
8 #include "cmdline.h"
9
10 #include "process.h"
11 #include "file.h"
12
13 /* Main Program / Driver */
14
15 static void
16 buildinfo_main(struct value *args, struct value *result)
17 {
18 struct process *out;
19
20 out = file_open("*stdout", "w");
21 args = args;
22 process_render(out,
23 "sizeof(struct value) == %d\n", sizeof(struct value));
24 value_integer_set(result, 0);
25 }
26
27 MAIN(buildinfo_main)
+63
-0
src/chain.c less more
0 /*
1 * chain.c
2 * Routines for collecting chains.
3 * $Id: chain.c 143 2008-07-18 06:42:22Z catseye $
4 */
5
6 #include "lib.h"
7 #include "chain.h"
8 #include "value.h"
9
10 struct chain {
11 struct chain *next;
12 struct value value;
13 };
14
15 struct chain *
16 add_to_chain(struct chain *c, struct value *v)
17 {
18 struct chain *n;
19
20 n = malloc(sizeof(struct chain));
21 n->next = NULL;
22 value_copy(&n->value, v);
23 if (c != NULL) {
24 c->next = n;
25 }
26 return n;
27 }
28
29 void
30 populate_tuple_from_chain(struct value *v, struct chain *c)
31 {
32 unsigned int i = 0;
33
34 while (c != NULL) {
35 value_tuple_store(v, i, &c->value);
36 i++;
37 c = c->next;
38 }
39 }
40
41 struct value *
42 search_chain(struct chain *c, struct value *f)
43 {
44 while (c != NULL) {
45 if (value_equal(f, &c->value))
46 return &c->value;
47 c = c->next;
48 }
49 return NULL;
50 }
51
52 void
53 free_chain(struct chain *c)
54 {
55 struct chain *next;
56
57 while (c != NULL) {
58 next = c->next;
59 free(c);
60 c = next;
61 }
62 }
+18
-0
src/chain.h less more
0 /*
1 * chain.h
2 * Prototypes for chains.
3 */
4
5 #ifndef __CHAIN_H_
6 #define __CHAIN_H_
7
8 #include "value.h"
9
10 struct chain;
11
12 struct chain *add_to_chain(struct chain *, struct value *);
13 void populate_tuple_from_chain(struct value *, struct chain *);
14 struct value *search_chain(struct chain *, struct value *);
15 void free_chain(struct chain *);
16
17 #endif /* !__CHAIN_H_ */
+75
-0
src/cmdline.c less more
0 /*
1 * cmdline.c
2 * Implementation of common command-line parsing functionality.
3 * $Id$
4 */
5
6 #include "lib.h"
7 #include "render.h"
8 #include "process.h"
9 #include "file.h"
10
11 #include "cmdline.h"
12
13 struct process *process_std = NULL;
14 struct process *process_err = NULL;
15
16 /*
17 static const char *progname = NULL;
18 static const struct argdecl *argdecl = NULL;
19 */
20
21 /* eventually this should parse an optional cmdline schema to validate the cmd line */
22 /* const struct argdecl *ad, */
23
24 int
25 cmdline_parse(struct value *dict, int argc, char **argv)
26 {
27 unsigned int arg_count, i;
28 struct value name, value;
29
30 assert(argc > 0);
31 arg_count = (unsigned int)argc;
32
33 value_dict_new(dict, 16); /* xxx */
34
35 for (i = 1; i < arg_count; i++) {
36 if (strlen(argv[i]) > 2 && argv[i][0] == '-' && argv[i][1] == '-') {
37 const char *arg_name = argv[i] + (2 * sizeof(char));
38 value_symbol_new(&name, arg_name, strlen(arg_name));
39 i++;
40 if (i < arg_count) {
41 value_symbol_new(&value, argv[i], strlen(argv[i]));
42 value_dict_store(dict, &name, &value);
43 } else {
44 /* complain */
45 }
46 } else {
47 /* complain */
48 }
49 }
50
51 return 1;
52 }
53
54 /* eventually this should parse an optional cmdline schema to validate the cmd line */
55
56 void
57 cmdline_usage(void)
58 {
59 exit(1);
60 }
61
62 int
63 cmdline_driver(void (*main)(struct value *, struct value *),
64 int argc, char **argv)
65 {
66 struct value cmdline, result;
67
68 cmdline_parse(&cmdline, argc, argv);
69 assert(value_is_tuple(&cmdline));
70
71 main(&cmdline, &result);
72
73 return value_get_integer(&result);
74 }
+59
-0
src/cmdline.h less more
0 /*
1 * cmdline.h
2 * Prototypes for common command-line parsing functionality.
3 * $Id$
4 */
5
6 /*
7 * In the future, this should be progenv.h, which determines a
8 * program environment. This should include an "entry point"
9 * (not necessarily "main", since it should be able to operate
10 * in standalone and other contexts where a "command line" is
11 * not meaningful.)
12 */
13
14 #ifndef __CMDLINE_H_
15 #define __CMDLINE_H_
16
17 #include "value.h"
18
19 #include "file.h" /* ... because. */
20
21 struct process;
22
23 struct runenv {
24 struct handler *handler_std;
25 /*
26 struct stream *stream_std;
27 struct stream *stream_err;
28 */
29 const char *progname;
30 };
31
32 extern struct process *process_err;
33
34 int cmdline_driver(void (*)(struct value *, struct value *),
35 int, char **);
36 int cmdline_parse(struct value *, int, char **);
37 void cmdline_usage(void);
38
39 /*
40 * STANDALONE no longer supported / not yet re-supported
41 */
42 #ifdef STANDALONE
43 #define MAIN(function) \
44 int main(int argc, char **argv) \
45 { \
46 process_err = NULL; \
47 return cmdline_driver(function, argc, argv); \
48 }
49 #else
50 #define MAIN(function) \
51 int main(int argc, char **argv) \
52 { \
53 process_err = file_open("*stderr", "w"); \
54 return cmdline_driver(function, argc, argv); \
55 }
56 #endif /* STANDALONE */
57
58 #endif /* !__CMDLINE_H_ */
+146
-0
src/disasm.c less more
0 /*
1 * disasm.c
2 * Disassembler for virtual machine.
3 */
4
5 #include "lib.h"
6 #include "cmdline.h"
7
8 #include "value.h"
9 #include "chain.h"
10
11 #include "file.h"
12 #include "stream.h"
13 #include "render.h"
14
15 #include "report.h"
16 #include "instrtab.h"
17 #include "load.h"
18 #include "portray.h"
19
20 /* Routines */
21
22 static void
23 disassemble(struct reporter *r, struct process *p, struct value *code)
24 {
25 struct opcode_entry *oe;
26 int count, pc, opcode;
27 struct value *val;
28 struct value t;
29 struct chain *back, *front;
30
31 value_integer_set(&t, 0);
32
33 /* first pass: find label destination */
34
35 pc = 0;
36 back = front = add_to_chain(NULL, &t);
37 for (;;) {
38 val = value_tuple_fetch(code, pc);
39 if (value_is_integer(val)) {
40 opcode = value_get_integer(val);
41 if (opcode < 0 || opcode > INSTR_EOF) {
42 report(r, REPORT_ERROR, "Opcode not in range 0..%d", INSTR_EOF);
43 pc++;
44 } else if (opcode == INSTR_EOF) {
45 break;
46 } else {
47 oe = &opcode_table[opcode];
48 count = oe->arity;
49 pc++;
50 val = value_tuple_fetch(code, pc);
51 while (count > 0) {
52 if (oe->optype == OPTYPE_ADDR)
53 back = add_to_chain(back, val);
54 pc++;
55 val = value_tuple_fetch(code, pc);
56 count--;
57 }
58 }
59 } else {
60 report(r, REPORT_ERROR, "Opcode is not an integer");
61 pc++;
62 }
63 }
64
65 if (reporter_has_errors(r))
66 return;
67
68 /* second pass */
69 pc = 0;
70 for (;;) {
71 val = value_tuple_fetch(code, pc);
72 opcode = value_get_integer(val);
73 if (opcode == INSTR_EOF)
74 break;
75
76 value_integer_set(&t, pc);
77 if (search_chain(front, &t) != NULL) {
78 process_render(p, ":L%d\n", pc);
79 }
80
81 oe = &opcode_table[opcode];
82 process_render(p, "%s ", oe->token);
83 count = oe->arity;
84
85 pc++;
86 val = value_tuple_fetch(code, pc);
87
88 if (count == -1) {
89 report(r, REPORT_WARNING, "Unrecognized opcode");
90 process_render(p, "??? ");
91 } else {
92 while (count > 0) {
93 if (oe->optype == OPTYPE_ADDR) {
94 process_render(p, ":L%d ",
95 value_get_integer(val)
96 );
97 } else {
98 process_render(p, "#");
99 value_portray(p, val);
100 }
101 pc++;
102 val = value_tuple_fetch(code, pc);
103 count--;
104 }
105 }
106
107 process_render(p, "\n");
108 }
109
110 free_chain(front);
111 }
112
113 static void
114 disassemble_main(struct value *args, struct value *result)
115 {
116 struct reporter *r;
117 struct process *p;
118 struct value code; /* virtual machine code we will dump */
119 struct value *asmfile, *vmfile;
120 struct value asmfile_sym, vmfile_sym;
121
122 value_symbol_new(&asmfile_sym, "asmfile", 7);
123 value_symbol_new(&vmfile_sym, "vmfile", 6);
124
125 asmfile = value_dict_fetch(args, &asmfile_sym);
126 vmfile = value_dict_fetch(args, &vmfile_sym);
127
128 r = reporter_new("Disassembly", NULL, 1);
129
130 /*
131 * Load.
132 */
133 p = file_open(value_symbol_get_token(vmfile), "r");
134 value_load(&code, p);
135 stream_close(NULL, p);
136
137 p = file_open(value_symbol_get_token(asmfile), "w");
138 disassemble(r, p, &code);
139 stream_close(NULL, p);
140
141 value_integer_set(result, reporter_has_errors(r) ? 1 : 0);
142 reporter_free(r);
143 }
144
145 MAIN(disassemble_main)
+107
-0
src/discern.c less more
0 /*
1 * discern.c
2 * Routines for parsing values (only; not program source) from a file-like process.
3 * $Id: discern.c 143 2008-07-18 06:42:22Z catseye $
4 */
5
6 #include "lib.h"
7
8 #include "scan.h"
9 #include "value.h"
10 #include "discern.h"
11 #include "chain.h"
12
13 /*
14 * A parser for values, inspired somewhat by Scheme/LISP S-expressions
15 * and Prolog/Erlang terms.
16 */
17 int
18 value_discern(struct value *top, struct scanner *sc)
19 {
20 if (scanner_tokeq(sc, "<")) {
21 struct chain *front, *back;
22 struct value tag, inner;
23 unsigned int size = 1;
24
25 /* Tuple. */
26 scanner_scan(sc);
27 value_discern(&tag, sc);
28 scanner_expect(sc, ":");
29 value_discern(&inner, sc);
30 back = front = add_to_chain(NULL, &inner);
31 while (scanner_tokeq(sc, ",")) {
32 scanner_scan(sc);
33 value_discern(&inner, sc);
34 back = add_to_chain(back, &inner);
35 size++;
36 }
37 scanner_expect(sc, ">");
38 value_tuple_new(top, &tag, size);
39 populate_tuple_from_chain(top, front);
40 free_chain(front);
41 return 1;
42 } else if (scanner_tokeq(sc, "[")) {
43 struct value inner, *left, right;
44
45 /* List: Sequence of tail-nested Pairs. */
46 scanner_scan(sc);
47 if (scanner_tokeq(sc, "]")) {
48 scanner_scan(sc);
49 value_copy(top, &VNULL);
50 return 1;
51 }
52 value_tuple_new(top, &tag_list, 2);
53 value_discern(&inner, sc);
54 value_tuple_store(top, 0, &inner);
55 /*value_tuple_store(top, 1, VNULL);*/
56 left = top;
57 while (scanner_tokeq(sc, ",")) {
58 scanner_scan(sc);
59 value_tuple_new(&right, &tag_list, 2);
60 value_discern(&inner, sc);
61 value_tuple_store(&right, 0, &inner);
62 /*value_set_index(right, 1, VNULL);*/
63 value_tuple_store(left, 1, &right);
64 left = value_tuple_fetch(left, 1);
65 }
66 if (scanner_tokeq(sc, "|")) {
67 scanner_scan(sc);
68 value_discern(&right, sc);
69 value_tuple_store(left, 1, &right);
70 }
71 scanner_expect(sc, "]");
72 return 1;
73 } else if (scanner_tokeq(sc, "{")) {
74 struct value left, right;
75
76 /* Dictionary: associations between keys and values. */
77 scanner_scan(sc);
78 value_dict_new(top, 31);
79
80 value_discern(&left, sc);
81 scanner_expect(sc, "=");
82 value_discern(&right, sc);
83 value_dict_store(top, &left, &right);
84 while (scanner_tokeq(sc, ",")) {
85 scanner_scan(sc);
86 value_discern(&left, sc);
87 scanner_expect(sc, "=");
88 value_discern(&right, sc);
89 value_dict_store(top, &left, &right);
90 }
91 scanner_expect(sc, "}");
92 return 1;
93 } else if (k_isdigit(scanner_token_string(sc)[0])) {
94 /* Integer. */
95 value_integer_set(top, k_atoi(scanner_token_string(sc),
96 scanner_token_length(sc)));
97 scanner_scan(sc);
98 return 1;
99 } else {
100 /* Symbol. */
101 value_symbol_new(top, scanner_token_string(sc),
102 scanner_token_length(sc));
103 scanner_scan(sc);
104 return 1;
105 }
106 }
+15
-0
src/discern.h less more
0 /*
1 * discern.h
2 * Prototypes and structures for parsing values (only; not full
3 * program source code) from textual streams.
4 */
5
6 #ifndef __DISCERN_H_
7 #define __DISCERN_H_
8
9 struct value;
10 struct scanner;
11
12 int value_discern(struct value *, struct scanner *);
13
14 #endif /* !__DISCERN_H_ */
+113
-0
src/file.c less more
0 /*
1 * file.c
2 * Native processes for communicating with (reading, writing) files,
3 * exposing a stream-like interface.
4 */
5
6 #include <stdio.h>
7
8 #include "lib.h"
9 #include "process.h"
10 #include "file.h"
11
12 #ifdef DEBUG
13 #include "stream.h"
14 #include "portray.h"
15 #include "cmdline.h"
16 #endif
17
18 static void run(struct process *p)
19 {
20 struct value msg;
21 struct value response;
22 struct process *sender;
23 size_t result;
24 char *buffer;
25 size_t size;
26
27 assert(p != NULL);
28 assert(p->aux != NULL);
29
30 while (process_dequeue(p, &msg)) {
31 #ifdef DEBUG
32 /*
33 stream_write(NULL, process_err, "-->", 3);
34 value_portray(process_err, &msg);
35 stream_write(NULL, process_err, "<--", 3);
36 */
37 #endif
38 if (value_is_tuple(&msg)) {
39 const char *tag = value_symbol_get_token(value_tuple_get_tag(&msg));
40 if (strcmp(tag, "write") == 0) {
41 struct value *payload = value_tuple_fetch(&msg, 0);
42
43 result = fwrite(
44 value_symbol_get_token(payload),
45 value_symbol_get_length(payload),
46 1, (FILE *)p->aux
47 );
48 if (result) {
49 /* some kind of error occurred */
50 }
51 } else if (strcmp(tag, "read") == 0) {
52 sender = value_get_process(value_tuple_fetch(&msg, 0));
53 size = value_get_integer(value_tuple_fetch(&msg, 1));
54
55 buffer = value_symbol_new_buffer(&response, size);
56 result = fread(buffer, size, 1, (FILE *)p->aux);
57 if (result) {
58 /* some kind of error occurred, or we just need more */
59 }
60 process_enqueue(sender, &response);
61 } else if (strcmp(tag, "eof") == 0) {
62 sender = value_get_process(value_tuple_fetch(&msg, 0));
63
64 value_boolean_set(&response, feof((FILE *)p->aux));
65 process_enqueue(sender, &response);
66 } else if (strcmp(tag, "close") == 0) {
67 fclose((FILE *)p->aux);
68 p->aux = NULL;
69 }
70 }
71 }
72
73 p->waiting = 1;
74 }
75
76 static struct process *
77 file_fopen(FILE *file)
78 {
79 struct process *p;
80
81 p = process_new();
82 p->run = run;
83 p->aux = file;
84
85 return p;
86 }
87
88 struct process *
89 file_open(const char *locator, const char *mode)
90 {
91 FILE *f;
92
93 if (strcmp(locator, "*stdin") == 0) {
94 return file_fopen(stdin);
95 }
96 if (strcmp(locator, "*stdout") == 0) {
97 return file_fopen(stdout);
98 }
99 if (strcmp(locator, "*stderr") == 0) {
100 return file_fopen(stderr);
101 }
102
103 if ((f = fopen(locator, mode)) == NULL) {
104 /* XXX only if mode contains a 'strict' char flag... */
105 /* XXX this should use report.c somehow someday */
106 fprintf(stderr,
107 "Could not open '%s' in mode '%s'", locator, mode);
108 exit(1);
109 }
110
111 return file_fopen(f);
112 }
+14
-0
src/file.h less more
0 /*
1 * file.h
2 * Native processes for communicating with (reading, writing) files,
3 * exposing a stream-like interface.
4 */
5
6 #ifndef __FILE_H_
7 #define __FILE_H_
8
9 struct process;
10
11 struct process *file_open(const char *, const char *);
12
13 #endif /* !__FILE_H_ */
+73
-0
src/freeze.c less more
0 /*
1 * freeze.c
2 * Parse a constant term from a text file and
3 * write it out to a binary termfile.
4 * $Id: freeze.c 146 2008-12-06 19:59:54Z catseye $
5 */
6
7 #include "lib.h"
8 #include "cmdline.h"
9
10 #include "stream.h"
11 #include "file.h"
12
13 #include "report.h"
14 #include "value.h"
15
16 #include "discern.h"
17 #include "scan.h"
18 #include "save.h"
19
20 /* Main Program / Driver */
21
22 static void
23 freeze_main(struct value *args, struct value *result)
24 {
25 struct process *p;
26 struct scanner *sc;
27 struct reporter *r;
28 struct value term;
29
30 struct value *termfile, *binfile;
31 struct value termfile_sym, binfile_sym;
32
33 value_symbol_new(&termfile_sym, "termfile", 8);
34 value_symbol_new(&binfile_sym, "binfile", 7);
35 termfile = value_dict_fetch(args, &termfile_sym);
36 binfile = value_dict_fetch(args, &binfile_sym);
37
38 r = reporter_new("Freezing", NULL, 1);
39
40 /*
41 * Parse.
42 */
43 sc = scanner_new(r);
44 if (!scanner_open(sc, value_symbol_get_token(termfile))) {
45 value_integer_set(result, 1);
46 return;
47 }
48 if (!value_discern(&term, sc)) {
49 report(r, REPORT_ERROR, "Could not parse input term");
50 }
51
52 /*
53 * Write out.
54 */
55 p = file_open(value_symbol_get_token(binfile), "w");
56 if (!value_save(p, &term)) {
57 report(r, REPORT_ERROR,
58 "Could not write term to '%s'", binfile);
59 }
60 stream_close(NULL, p);
61
62 /*
63 * Finish up.
64 */
65 scanner_close(sc);
66 scanner_free(sc);
67
68 value_integer_set(result, reporter_has_errors(r) ? 1 : 0);
69 reporter_free(r);
70 }
71
72 MAIN(freeze_main)
+270
-0
src/gen.c less more
0 /*
1 * gen.c
2 * Accumulate values in tuples with extents.
3 */
4
5 #include "lib.h"
6
7 #include "gen.h"
8
9 #ifdef DEBUG
10 #include "cmdline.h"
11 #include "portray.h"
12 #include "render.h"
13 #endif
14
15 /*
16 * This was originally intended to generate VM instructions, however
17 * it has more general applicability.
18 */
19
20 #define GEN_ROOT_TUPLE 0 /* The top tuple of the hierarchy */
21 #define GEN_CURRENT_TUPLE 1 /* The tuple currently being gen'ed into */
22 #define GEN_GLOBAL_POS 2 /* The global position to be gen'ed into */
23 #define GEN_LOCAL_POS 3 /* Gen offset into current tuple */
24
25 #define GEN_SIZE 4
26
27 int
28 gen_new(struct value *gen, struct value *tuple, unsigned int pos)
29 {
30 struct value gen_tag;
31
32 value_symbol_new(&gen_tag, "gen", 3);
33 if (!value_tuple_new(gen, &gen_tag, GEN_SIZE))
34 return 0;
35 value_tuple_store(gen, GEN_ROOT_TUPLE, tuple);
36 value_tuple_store(gen, GEN_CURRENT_TUPLE, tuple);
37 value_tuple_store_integer(gen, GEN_GLOBAL_POS, pos);
38 value_tuple_store_integer(gen, GEN_LOCAL_POS, pos);
39 return 1;
40 }
41
42 int
43 gen_new_default(struct value *gen)
44 {
45 struct value tuple, code_sym;
46
47 value_symbol_new(&code_sym, "code", 4);
48 value_tuple_new(&tuple, &code_sym, 8192);
49 return gen_new(gen, &tuple, 0);
50 }
51
52 /*
53 * Accumulate a value to a tuple.
54 */
55 void
56 gen_value(struct value *gen, struct value *value)
57 {
58 unsigned int pos = value_tuple_fetch_integer(gen, GEN_LOCAL_POS);
59 struct value *tuple = value_tuple_fetch(gen, GEN_CURRENT_TUPLE);
60 unsigned int size = value_tuple_get_size(tuple);
61 struct value new_tuple;
62
63 if (pos == (size - 1)) {
64 /* Last slot. Allocate a new tuple of twice the running size and plug it in. */
65 struct value *tag = value_tuple_get_tag(tuple);
66
67 value_tuple_new(&new_tuple, tag, size * 2);
68 value_tuple_store(tuple, pos, &new_tuple);
69 value_tuple_store(gen, GEN_CURRENT_TUPLE, &new_tuple);
70 pos = 0;
71 tuple = &new_tuple;
72 }
73 value_tuple_store(tuple, pos, value);
74 pos++;
75 value_tuple_store_integer(gen, GEN_LOCAL_POS, pos);
76
77 pos = value_tuple_fetch_integer(gen, GEN_GLOBAL_POS);
78 pos++;
79 value_tuple_store_integer(gen, GEN_GLOBAL_POS, pos);
80 }
81
82 /*
83 * Accumulate a value to a tuple.
84 */
85 void
86 gen_integer(struct value *gen, int i)
87 {
88 struct value val;
89
90 value_integer_set(&val, i);
91 gen_value(gen, &val);
92 }
93
94 /*
95 * Labels - forward reference and backpatching mechanism.
96 * This is designed to be used internally. External clients
97 * (that is, where labels must be human-readable, such as the
98 * assembler) should maintain a dictionary associating strings
99 * with labels.
100 *
101 * Use cases:
102 *
103 * 1) Backward reference (requires no backpatching):
104 *
105 * label = gen_define_label(gen, NULL);
106 * ...
107 * gen_integer(gen, INSTR_GOTO);
108 * gen_gen_label_ref(gen, label);
109 *
110 * 2) Forward reference (requires backpatching):
111 *
112 * gen_integer(gen, INSTR_GOTO);
113 * label = gen_gen_label_ref(gen, NULL);
114 * ...
115 * gen_define_label(gen, label);
116 *
117 */
118
119 #define GEN_LABEL_TUPLE 0 /* Tuple into which the label points */
120 #define GEN_LABEL_LOCAL_POS 1 /* local pos to which label refers */
121 #define GEN_LABEL_GLOBAL_POS 2 /* global pos to which label refers */
122 #define GEN_LABEL_NEXT 3 /* list of backpatches to apply */
123
124 #define GEN_LABEL_SIZE 4
125
126 static int
127 gen_label_new(struct value *gen_label)
128 {
129 struct value gen_label_tag;
130
131 value_symbol_new(&gen_label_tag, "genlab", 3);
132 if (!value_tuple_new(gen_label, &gen_label_tag, GEN_LABEL_SIZE))
133 return 0;
134 value_tuple_store(gen_label, GEN_LABEL_TUPLE, &VNULL);
135 value_tuple_store_integer(gen_label, GEN_LABEL_LOCAL_POS, 0);
136 value_tuple_store_integer(gen_label, GEN_LABEL_GLOBAL_POS, 0);
137 value_tuple_store(gen_label, GEN_LABEL_NEXT, &VNULL);
138
139 return 1;
140 }
141
142 /*
143 * Generate a reference to a label into the tuple, for instance as the
144 * immediate argument of a branch instruction. If the label parameter
145 * is NULL, this will generate and return a forward reference which
146 * should be resolved by subsequently passing it to gen_define_label().
147 */
148 void
149 gen_gen_label_ref(struct value *gen, struct value *gen_label)
150 {
151 struct value *bp;
152 struct value next;
153 int global_pos;
154
155 assert(gen_label != NULL);
156
157 if (value_is_null(gen_label)) {
158 /* Not yet allocated, so allocate a new undefined one. */
159 gen_label_new(gen_label);
160 }
161
162 global_pos = value_tuple_fetch_integer(gen_label, GEN_LABEL_GLOBAL_POS);
163 if (global_pos != 0) {
164 /* Already defined, so just use it. */
165 gen_integer(gen, global_pos);
166 return;
167 }
168
169 /*
170 * The label is newly allocated, or at least has not been defined
171 * yet. So, we remember that we will need to backpatch here in the
172 * future (by adding an entry to the label's backpatch list) and,
173 * for now, generate a NULL in its slot.
174 */
175
176 value_copy(&next, value_tuple_fetch(gen_label, GEN_LABEL_NEXT));
177 bp = value_tuple_fetch(gen_label, GEN_LABEL_NEXT);
178 gen_label_new(bp);
179 value_tuple_store(bp, GEN_LABEL_TUPLE, value_tuple_fetch(gen, GEN_CURRENT_TUPLE));
180 value_tuple_store(bp, GEN_LABEL_LOCAL_POS, value_tuple_fetch(gen, GEN_LOCAL_POS));
181 value_tuple_store(bp, GEN_LABEL_GLOBAL_POS, value_tuple_fetch(gen, GEN_GLOBAL_POS));
182 value_tuple_store(bp, GEN_LABEL_NEXT, &next);
183
184 gen_value(gen, &VNULL);
185 }
186
187 /*
188 * Define a label. If the label is already allocated, this will
189 * cause previously-generated forward references to this label to be
190 * backpatched with the now-known location.
191 */
192 int
193 gen_define_label(struct value *gen, struct value *gen_label)
194 {
195 struct value *tuple = value_tuple_fetch(gen, GEN_CURRENT_TUPLE);
196 unsigned int local_pos = value_tuple_fetch_integer(gen, GEN_LOCAL_POS);
197 unsigned int global_pos = value_tuple_fetch_integer(gen, GEN_GLOBAL_POS);
198
199 struct value *bp;
200
201 assert(gen_label != NULL);
202
203 if (value_is_null(gen_label)) {
204 /* Not yet allocated, so allocate a new undefined one. */
205 gen_label_new(gen_label);
206 } else {
207 /* Fail if we try to redefine a label. */
208 if (value_tuple_fetch_integer(gen_label, GEN_LABEL_GLOBAL_POS) != 0) {
209 return 0;
210 }
211 }
212
213 value_tuple_store(gen_label, GEN_LABEL_TUPLE, tuple);
214 value_tuple_store_integer(gen_label, GEN_LABEL_LOCAL_POS, local_pos);
215 value_tuple_store_integer(gen_label, GEN_LABEL_GLOBAL_POS, global_pos);
216
217 /*
218 * Resolve any previous forward references by backpatching.
219 */
220 bp = value_tuple_fetch(gen_label, GEN_LABEL_NEXT);
221 while (!value_is_null(bp)) {
222 /*
223 * Backpatch, by placing the current global position into
224 * the slot named by the bp entry, then remove entry from list.
225 */
226 value_tuple_store_integer(
227 value_tuple_fetch(bp, GEN_LABEL_TUPLE),
228 value_tuple_fetch_integer(bp, GEN_LABEL_LOCAL_POS),
229 global_pos
230 );
231 value_tuple_store(gen_label, GEN_LABEL_NEXT,
232 value_tuple_fetch(bp, GEN_LABEL_NEXT));
233 bp = value_tuple_fetch(gen_label, GEN_LABEL_NEXT);
234 }
235
236 return 1;
237 }
238
239 /*
240 * Return a single tuple containing the contents of the gen'ed tuple chain.
241 */
242 void
243 gen_flatten(struct value *gen, struct value *dest)
244 {
245 unsigned int dest_size = value_tuple_fetch_integer(gen, GEN_GLOBAL_POS);
246 struct value *current = value_tuple_fetch(gen, GEN_ROOT_TUPLE);
247 unsigned int j = 0;
248
249 value_tuple_new(dest, value_tuple_get_tag(current), dest_size);
250
251 while (!value_is_null(current)) {
252 unsigned int i = 0;
253 unsigned int current_size = value_tuple_get_size(current);
254 struct value *x;
255 for (i = 0; i < (current_size - 1) && i < dest_size; i++) {
256 x = value_tuple_fetch(current, i);
257
258 #ifdef DEBUG
259 process_render(process_err, "(flatten %d/%d -> %d/%d: ", i, current_size, j, dest_size);
260 value_portray(process_err, x);
261 process_render(process_err, ")\n");
262 #endif
263
264 value_tuple_store(dest, j, x);
265 j++;
266 }
267 current = value_tuple_fetch(current, (current_size - 1));
268 }
269 }
+20
-0
src/gen.h less more
0 /*
1 * gen.h
2 * Accumulate values in tuples with extents.
3 * $Id: gen.h 144 2008-07-19 01:57:04Z catseye $
4 */
5
6 #ifndef __GEN_H_
7 #define __GEN_H_
8
9 #include "value.h"
10
11 int gen_new(struct value *, struct value *, unsigned int);
12 int gen_new_default(struct value *);
13 void gen_value(struct value *, struct value *);
14 void gen_integer(struct value *, int);
15 int gen_define_label(struct value *, struct value *);
16 void gen_gen_label_ref(struct value *, struct value *);
17 void gen_flatten(struct value *, struct value *);
18
19 #endif /* !__GEN_H_ */
+159
-0
src/geninstr.c less more
0 /*
1 * geninstr.c
2 */
3
4 #include <ctype.h>
5 #include <stdio.h>
6 #include <stdlib.h>
7
8 static int
9 parse_descriptor_line(const char *line, char *name, char *mode)
10 {
11 while (isspace((int)*line) && (*line != '\0')) {
12 line++;
13 }
14 if (*line != '%')
15 return 0;
16 line++;
17 while (isspace((int)*line) && (*line != '\0')) {
18 line++;
19 }
20 while (!isspace((int)*line) && (*line != '\0')) {
21 *name = *line;
22 name++;
23 line++;
24 }
25 *name = '\0';
26 while (isspace((int)*line) && (*line != '\0')) {
27 line++;
28 }
29 while (!isspace((int)*line) && (*line != '\0')) {
30 *mode = *line;
31 mode++;
32 line++;
33 }
34 *mode = '\0';
35 return 1;
36 }
37
38 int
39 main(int argc, char **argv)
40 {
41 FILE *instrtab, *instrenum, *instrlab, *vm, *localtypes;
42 static char line[512], name[80], mode[80];
43
44 argc = argc;
45 argv = argv;
46
47 if ((instrtab = fopen("instrtab.c", "w")) == NULL) {
48 perror("Couldn't open instrtab.c for writing");
49 exit(1);
50 }
51 if ((instrenum = fopen("instrenum.h", "w")) == NULL) {
52 perror("Couldn't open instrenum.h for writing");
53 exit(1);
54 }
55 if ((instrlab = fopen("instrlab.h", "w")) == NULL) {
56 perror("Couldn't open instrlab.h for writing");
57 exit(1);
58 }
59 if ((vm = fopen("vm.c", "r")) == NULL) {
60 perror("Couldn't open vm.c for reading");
61 exit(1);
62 }
63 fputs(
64 "/*\n"
65 " * instrtab.c\n"
66 " * Table of VM instructions, mapping names to opcodes.\n"
67 " * NOTE: THIS FILE WAS AUTOMATICALLY GENERATED from vm.c by geninstr\n"
68 " */\n"
69 "\n"
70 "#include \"lib.h\"\n"
71 "\n"
72 "#include \"instrtab.h\"\n"
73 "\n"
74 "struct opcode_entry opcode_table[] = {\n", instrtab);
75 fputs(
76 "/*\n"
77 " * instrenum.h\n"
78 " * C 'enum' type for VM instructions.\n"
79 " * NOTE: THIS FILE WAS AUTOMATICALLY GENERATED from vm.c by geninstr\n"
80 " */\n"
81 "\n"
82 "#ifndef __INSTRENUM_H_\n"
83 "#define __INSTRENUM_H_\n"
84 "\n"
85 "enum opcode {\n", instrenum);
86 fputs(
87 "/*\n"
88 " * instrlab.h\n"
89 " * gcc labels for VM instructions, to support direct threading.\n"
90 " * NOTE: THIS FILE WAS AUTOMATICALLY GENERATED from vm.c by geninstr\n"
91 " */\n"
92 "\n"
93 "#ifndef __INSTRLAB_H_\n"
94 "#define __INSTRLAB_H_\n"
95 "\n"
96 "static clabel instr_label[] = {\n", instrlab);
97
98 while (fgets(line, 510, vm)) {
99 int arity = 1;
100 const char *optype = "NONE";
101
102 if (!parse_descriptor_line(line, name, mode))
103 continue;
104
105 switch (mode[0]) {
106 case 'i':
107 optype = "INT";
108 break;
109 case 'a':
110 optype = "ADDR";
111 break;
112 case 'v':
113 optype = "VALUE";
114 break;
115 default:
116 arity = 0;
117 break;
118 }
119
120 fprintf(instrtab, "\t{ \"%s\",\tINSTR_%s,\t%d,\tOPTYPE_%s\t},\n",
121 name, name, arity, optype);
122 fprintf(instrenum, "\tINSTR_%s,\n", name);
123 fprintf(instrlab, "\t&&LABEL_INSTR_%s,\n", name);
124 }
125 fclose(vm);
126 fputs("\t{ NULL,\t\tINSTR_NULL,\t0,\tOPTYPE_NONE }\n};\n", instrtab);
127 fclose(instrtab);
128 fputs("\tINSTR_NULL\n};\n\n#endif /* !__INSTRENUM_H_ */\n", instrenum);
129 fclose(instrenum);
130 fputs("\tNULL\n};\n\n#endif /* !__INSTRLAB_H_ */\n", instrlab);
131 fclose(instrlab);
132
133 if ((localtypes = fopen("localtypes.h", "w")) == NULL) {
134 perror("Couldn't open localtypes.h for writing");
135 exit(1);
136 }
137 fputs(
138 "/*\n"
139 " * localtypes.h\n"
140 " * Define some types for the local system.\n"
141 " * NOTE: THIS FILE WAS AUTOMATICALLY GENERATED by geninstr\n"
142 " */\n"
143 "\n"
144 "#ifndef __LOCALTYPES_H_\n"
145 "#define __LOCALTYPES_H_\n"
146 "\n", localtypes);
147 if (sizeof(void *) == sizeof(unsigned int)) {
148 fputs("#define PTR_INT unsigned int\n", localtypes);
149 } else if (sizeof(void *) == sizeof(unsigned long int)) {
150 fputs("#define PTR_INT unsigned long int\n", localtypes);
151 } else {
152 fputs("#define PTR_INT not_supported\n", localtypes);
153 }
154 fputs("\n#endif /* !__LOCALTYPES_H_ */\n", localtypes);
155 fclose(localtypes);
156
157 exit(0);
158 }
+28
-0
src/instrtab.h less more
0 /*
1 * instrtab.h
2 * Table of VM instructions, mapping names to opcodes.
3 * $Id: instrtab.h 95 2006-02-14 01:33:18Z catseye $
4 */
5
6 #ifndef __INSTRTAB_H_
7 #define __INSTRTAB_H_
8
9 #include "instrenum.h"
10
11 enum optype {
12 OPTYPE_NONE,
13 OPTYPE_INT,
14 OPTYPE_ADDR,
15 OPTYPE_VALUE
16 };
17
18 struct opcode_entry {
19 const char *token;
20 enum opcode opcode;
21 int arity;
22 enum optype optype;
23 };
24
25 extern struct opcode_entry opcode_table[];
26
27 #endif /* !__INSTRTAB_H_ */
+94
-0
src/lib.c less more
0 /*
1 * lib.c
2 * Common functions.
3 * $Id: lib.c 114 2007-02-27 02:09:02Z catseye $
4 */
5
6 #include "lib.h"
7
8 #ifdef STANDALONE
9 /*
10 * To quote the FreeBSD manpage (despite that this is a reimplementation):
11 * The strncpy() function copies not more than len characters from src into
12 * dst, appending `\0' characters if src is less than len characters long,
13 * and not terminating dst otherwise.
14 */
15 #ifndef USE_SYSTEM_STRNCPY
16 char *
17 strncpy(char *dst, const char *src, unsigned int len)
18 {
19 char *r = dst;
20
21 while (*src != '\0' && len > 0) {
22 *dst = *src;
23 dst++;
24 src++;
25 len--;
26 }
27 while (len > 0) {
28 /* append \0 characters */
29 *dst = '\0';
30 dst++;
31 len--;
32 }
33
34 return r;
35 }
36 #endif /* !USE_SYSTEM_STRNCPY */
37
38 int
39 k_isspace(char c)
40 {
41 return c == ' ' || c == '\t' || c == '\n' || c == '\r';
42 }
43
44 int
45 k_isdigit(char c)
46 {
47 return c >= '0' && c <= '9';
48 }
49
50 int
51 k_isalpha(char c)
52 {
53 return (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z');
54 }
55
56 #ifndef USE_SYSTEM_STRCMP
57 int
58 strcmp(const char *s1, const char *s2)
59 {
60 while (*s1 == *s2 && *s1 != '\0' && *s2 != '\0') {
61 s1++;
62 s2++;
63 }
64 if (*s1 == '\0' && *s2 == '\0') {
65 return 0;
66 }
67 if (*s1 > *s2) {
68 return 1;
69 } else {
70 return -1;
71 }
72 }
73 #endif /* !USE_SYSTEM_STRCMP */
74
75 #endif /* STANDALONE */
76
77 int
78 k_atoi(const char *s, unsigned int len)
79 {
80 int acc = 0;
81
82 while (k_isspace(*s) && len > 0) {
83 s++;
84 len--;
85 }
86 while (k_isdigit(*s) && len > 0) {
87 acc = acc * 10 + (*s - '0');
88 s++;
89 len--;
90 }
91
92 return acc;
93 }
+56
-0
src/lib.h less more
0 /*
1 * lib.h
2 * Common definitions and function prototypes.
3 * $Id: lib.h 145 2008-11-26 10:05:16Z catseye $
4 */
5
6 #ifndef __LIB_H_
7 #define __LIB_H_
8
9 #ifndef NULL
10 #define NULL 0
11 #endif
12
13 #ifndef NDEBUG
14 #include <stdio.h>
15 #define assert(cond) { \
16 if (!(cond)) { \
17 fprintf(stderr, \
18 "assertion failed (" __FILE__ "): " #cond "\n"); \
19 abort(); \
20 } \
21 }
22 #else
23 #define assert(cond)
24 #endif
25
26 #ifdef STANDALONE
27 /* stdlib.h */
28 void *malloc(unsigned int);
29 void free(void *);
30 void exit(int);
31 void abort(void);
32
33 /* string.h */
34 int strcmp(const char *, const char *);
35 int strncmp(const char *, const char *, unsigned int);
36 char *strncpy(char *, const char *, unsigned int);
37 int strlen(const char *);
38 void *memset(void *, int, unsigned int);
39
40 /* ctype.h */
41 int k_isspace(char);
42 int k_isdigit(char);
43 int k_isalpha(char);
44 #else
45 #include <stdlib.h>
46 #include <string.h>
47 #include <ctype.h>
48 #define k_isspace(x) isspace((int)x)
49 #define k_isdigit(x) isdigit((int)x)
50 #define k_isalpha(x) isalpha((int)x)
51 #endif
52
53 int k_atoi(const char *, unsigned int);
54
55 #endif /* !__LIB_H_ */
+89
-0
src/load.c less more
0 /*
1 * load.c
2 * Load values from a stream-like process.
3 */
4
5 #include "lib.h"
6
7 #include "load.h"
8 #include "value.h"
9 #include "stream.h"
10
11 #ifdef DEBUG
12 #include "cmdline.h"
13 #include "portray.h"
14 #include "render.h"
15 #endif
16
17 int
18 value_load(struct value *value, struct process *p)
19 {
20 unsigned int length, i;
21 char *buffer;
22 unsigned char squeeze;
23
24 stream_read(NULL, p, &squeeze, sizeof(squeeze));
25 value->type = (enum value_type)squeeze;
26
27 #ifdef DEBUG
28 process_render(process_err, "(load:%s ", type_name_table[value->type]);
29 #endif
30
31 if ((value->type & VALUE_STRUCTURED) == 0) {
32 stream_read(NULL, p, &value->value, sizeof(value->value));
33 } else {
34 switch (value->type) {
35 case VALUE_SYMBOL:
36 {
37 stream_read(NULL, p, &length, sizeof(length));
38 buffer = malloc(length);
39 stream_read(NULL, p, buffer, sizeof(char) * length);
40 if (!value_symbol_new(value, buffer, length)) {
41 free(buffer);
42 return 0;
43 }
44 free(buffer);
45 break;
46 }
47 case VALUE_TUPLE:
48 {
49 struct value tag;
50 if (!value_load(&tag, p))
51 return 0;
52 /* XXX should eventually dispatch to a handler based on tag? */
53 if (value_equal(&tag, &tag_dict)) {
54 struct value key, val;
55
56 stream_read(NULL, p, &length, sizeof(length)); /* length is layer_size here */
57 value_dict_new(value, length); /* xxx */
58 stream_read(NULL, p, &length, sizeof(length)); /* length is num entries here */
59 for (i = 0; i < length; i++) {
60 value_load(&key, p);
61 value_load(&val, p);
62 value_dict_store(value, &key, &val);
63 }
64 } else {
65 struct value val;
66
67 stream_read(NULL, p, &length, sizeof(length));
68 value_tuple_new(value, &tag, length);
69 for (i = 0; i < length; i++) {
70 value_load(&val, p);
71 value_tuple_store(value, i, &val);
72 }
73 }
74 break;
75 }
76 default:
77 assert(value->type == VALUE_SYMBOL ||
78 value->type == VALUE_TUPLE);
79 return 0;
80 }
81 }
82
83 #ifdef DEBUG
84 value_portray(process_err, value);
85 process_render(process_err, ")\n");
86 #endif
87 return 1;
88 }
+15
-0
src/load.h less more
0 /*
1 * load.h
2 * Structures and prototypes for loading values from file-like processes.
3 * $Id: load.h 107 2006-03-16 23:55:56Z catseye $
4 */
5
6 #ifndef __LOAD_H_
7 #define __LOAD_H_
8
9 struct process;
10 struct value;
11
12 int value_load(struct value *, struct process *);
13
14 #endif /* !__LOAD_H_ */
+104
-0
src/portray.c less more
0 /*
1 * portray.c
2 * Routines for parsing and rendering values.
3 * $Id: portray.c 143 2008-07-18 06:42:22Z catseye $
4 */
5
6 #include "lib.h"
7
8 #include "value.h"
9 #include "portray.h"
10 #include "render.h"
11
12 static void value_portray_nodups(struct process *, struct value *, struct value *);
13
14 /*
15 * Portray a value (i.e. render it in a human-readable way) to a process.
16 */
17 void
18 value_portray(struct process *p, struct value *v)
19 {
20 struct value seen;
21 value_dict_new(&seen, 31);
22 value_portray_nodups(p, v, &seen);
23 }
24
25 /*
26 * Recursive portion of value_portray(). Tracks a dictionary of all
27 * tuple values that have been seen, to avoid recursing infinitely
28 * into cyclic chains of nested tuples.
29 */
30 static void
31 value_portray_nodups(struct process *p, struct value *v, struct value *seen)
32 {
33 switch (v->type) {
34 case VALUE_NULL:
35 process_render(p, "[]");
36 break;
37 case VALUE_INTEGER:
38 process_render(p, "%d", value_get_integer(v));
39 break;
40 case VALUE_BOOLEAN:
41 process_render(p, "%s", value_get_boolean(v) ? "true" : "false");
42 break;
43 case VALUE_PROCESS:
44 process_render(p, "PROCESS#[0x%08x]", (long int)value_get_process(v));
45 break;
46 case VALUE_LABEL:
47 process_render(p, "LABEL#[0x%08x]", (long int)value_get_label(v));
48 break;
49 case VALUE_SYMBOL:
50 process_render(p, "%s", value_symbol_get_token(v));
51 break;
52 case VALUE_TUPLE:
53 {
54 struct value *tag = value_tuple_get_tag(v);
55 unsigned int max = value_tuple_get_size(v);
56 unsigned int i;
57
58 if (!value_is_null(seen))
59 value_dict_store(seen, v, &VTRUE);
60
61 /* XXX should eventually dispatch to a handler based on tag. */
62 if (value_equal(tag, &tag_dict)) {
63 struct value dict_iter;
64 struct value *key;
65
66 value_dict_new_iter(&dict_iter, v);
67
68 process_render(p, "{");
69 key = value_dict_iter_get_current_key(&dict_iter);
70 while (!value_is_null(key)) {
71 value_portray_nodups(p, key, seen);
72 process_render(p, "=");
73 /* XXX not so good; use iter */
74 value_portray_nodups(p, value_dict_fetch(v, key), seen);
75 value_dict_iter_advance(&dict_iter);
76 key = value_dict_iter_get_current_key(&dict_iter);
77 if (!value_is_null(key)) {
78 process_render(p, ", ");
79 }
80 }
81 process_render(p, "}");
82 } else {
83 process_render(p, "<");
84 value_portray(p, value_tuple_get_tag(v));
85 process_render(p, ": ");
86 for (i = 0; i < max; i++) {
87 struct value *k = value_tuple_fetch(v, i);
88 if (value_is_null(seen) ||
89 value_is_null(value_dict_fetch(seen, k))) {
90 value_portray_nodups(p, k, seen);
91 } else {
92 process_render(p, "TUPLE#[0x%08x]",
93 value_get_unique_id(v));
94 }
95 if (i < (max - 1))
96 process_render(p, ", ");
97 }
98 process_render(p, ">");
99 }
100 break;
101 }
102 }
103 }
+15
-0
src/portray.h less more
0 /*
1 * portray.h
2 * Prototypes and structures for rendering values to processes.
3 * $Id: portray.h 107 2006-03-16 23:55:56Z catseye $
4 */
5
6 #ifndef __PORTRAY_H_
7 #define __PORTRAY_H_
8
9 struct value;
10 struct process;
11
12 void value_portray(struct process *, struct value *);
13
14 #endif /* !__PORTRAY_H_ */
+87
-0
src/process.c less more
0 /*
1 * process.c
2 * Cooperative processes.
3 */
4
5
6 #include "lib.h"
7
8 #include "process.h"
9
10 struct process *
11 process_new(void)
12 {
13 struct process *p;
14
15 p = malloc(sizeof(struct process));
16 p->head = NULL;
17 p->tail = NULL;
18 p->run = NULL;
19 p->aux = NULL;
20 p->waiting = 0;
21 p->done = 0;
22 p->next = NULL;
23
24 return p;
25 }
26
27 void
28 process_enqueue(struct process *p, const struct value *v)
29 {
30 struct message *m;
31
32 m = malloc(sizeof(struct message));
33 value_copy(&m->value, v);
34 m->prev = NULL;
35 m->next = p->head;
36 if (p->head != NULL)
37 p->head->prev = m;
38 p->head = m;
39 if (p->tail == NULL)
40 p->tail = m;
41 }
42
43 int
44 process_dequeue(struct process *p, struct value *v)
45 {
46 struct message *m;
47
48 m = p->tail;
49 if (m == NULL)
50 return 0;
51 value_copy(v, &m->value);
52
53 /* remove message from queue */
54 assert(m->next == NULL);
55 if (m->prev == NULL)
56 p->head = NULL;
57 else
58 m->prev->next = NULL;
59 p->tail = m->prev;
60
61 free(m);
62
63 return 1;
64 }
65
66 void
67 process_run(struct process *p)
68 {
69 assert(p->run != NULL);
70 p->run(p);
71 }
72
73 void
74 process_free(struct process *p)
75 {
76 struct message *m, *n;
77
78 /* assert(p->done); */
79 m = p->head;
80 while (m != NULL) {
81 n = m->next;
82 free(m);
83 m = n;
84 }
85 free(p);
86 }
+65
-0
src/process.h less more
0 /*
1 * process.h
2 * Cooperative concurrent processes.
3 */
4
5 #ifndef __PROCESS_H_
6 #define __PROCESS_H_
7
8 #include "value.h"
9
10 struct process;
11
12 typedef void (*runfunc)(struct process *);
13
14 struct process {
15 int waiting;
16 int done;
17 runfunc run;
18 void *aux;
19 struct value aux_value;
20 struct message *head;
21 struct message *tail;
22 struct process *next;
23 };
24
25 struct message {
26 struct message *next;
27 struct message *prev;
28 struct value value;
29 };
30
31 /* Prototypes */
32
33 struct process *process_new(void);
34
35 /*
36 * places the value in the process's mailbox. This is what the VM instruction SEND
37 * does. SEND also checks if the destination process is currently waiting, (and if
38 * its mailbox is empty?), and if it is, it wakes it up so that it can deal immediately
39 * with the message. Maybe. I mean, this behaviour sounds good, but maybe we shouldn't
40 * guarantee it.
41 *
42 * We should also prevent side-effecting of that value. Maybe values can be "owned"...
43 */
44 void process_enqueue(struct process *, const struct value *);
45
46 /*
47 * retrieves a value from the process's mailbox. p should be self. This is what
48 * the RECV VM instruction does. If there is no message, the process should set its
49 * waiting flag to true, and yield.
50 */
51 int process_dequeue(struct process *, struct value *);
52
53 /*
54 * Let the process p execute for a bit. Concurrency is cooperative here, so p promises
55 * that it will return from this function "in a little while". For the VM, this is not
56 * hard; we return after executing 100 or so instructions. For native code, it should
57 * be carefully written!
58 */
59 void process_run(struct process *);
60
61 void process_free(struct process *);
62
63 #endif /* !__PROCESS_H_ */
64
+127
-0
src/render.c less more
0 /*
1 * render.c
2 * printf-like formatting to a stream-like process.
3 */
4
5 #include <stdarg.h>
6
7 #include "lib.h"
8 #include "stream.h"
9
10 #include "render.h"
11
12 static unsigned int
13 extract_int(const char *str, unsigned int *pos)
14 {
15 unsigned int val = 0;
16
17 while (k_isdigit(str[*pos])) {
18 val = val * 10 + (str[*pos] - '0');
19 (*pos)++;
20 }
21
22 return val;
23 }
24
25 /*
26 * Note that there is no trailing NUL in the buf!
27 */
28 static unsigned int
29 render_int(char *buf, unsigned int bufsize, int val)
30 {
31 int pos = bufsize - 1;
32 int sign = 0;
33
34 if (val == 0) {
35 buf[pos] = '0';
36 return pos;
37 }
38 if (val < 0) {
39 val *= -1;
40 sign = -1;
41 }
42 while (pos >= 0 && val > 0) {
43 buf[pos] = (char)((val % 10) + '0');
44 pos--;
45 val = val / 10;
46 }
47 if (pos >= 0 && sign == -1) {
48 buf[pos] = '-';
49 pos--;
50 }
51 if (pos < 0) {
52 buf[0] = '?'; /* signify incorrectly rendered number */
53 }
54
55 return pos + 1;
56 }
57
58 #define MAX_DIGITS 32
59
60 /*
61 * Similar to, but different from, C's printf().
62 * The size specifier of each field gives the maximum number
63 * of characters that will be rendered into that field, but
64 * does not (at the moment) cause the field to have a fixed
65 * display width.
66 */
67 void
68 process_render(struct process *p, const char *fmt, ...)
69 {
70 unsigned int pos = 0, length;
71 va_list args;
72
73 assert(p != NULL);
74 va_start(args, fmt);
75
76 while (fmt[pos] != '\0') {
77 if (fmt[pos] != '%') {
78 stream_write(NULL, p, &fmt[pos], 1);
79 pos++;
80 continue;
81 }
82
83 /* found a %. now get length */
84 pos++;
85 length = extract_int(fmt, &pos);
86 length = length;
87 /* find formatting code and select formatting */
88 switch (fmt[pos]) {
89 case '%':
90 stream_write(NULL, p, &fmt[pos], 1);
91 break;
92 case 'c':
93 {
94 char c = (char)va_arg(args, int);
95
96 stream_write(NULL, p, &c, 1);
97 break;
98 }
99 case 's':
100 {
101 char *arg = va_arg(args, char *);
102
103 stream_write(NULL, p, arg, strlen(arg));
104 break;
105 }
106 case 'd': case 'x': /* XXX for now! */
107 {
108 int val = va_arg(args, int);
109 unsigned int digit_pos;
110 char *digits;
111
112 digits = malloc(MAX_DIGITS);
113 digit_pos = render_int(digits, MAX_DIGITS, val);
114 stream_write(NULL, p, (digits + digit_pos), (MAX_DIGITS - digit_pos));
115 free(digits);
116
117 break;
118 }
119 default:
120 assert("undefined formatting code" == NULL);
121 break;
122 }
123
124 pos++;
125 }
126 }
+14
-0
src/render.h less more
0 /*
1 * render.h
2 * Prototypes for stream rendering (printf-like formatting).
3 * $Id: stream.h 116 2007-03-26 00:43:44Z catseye $
4 */
5
6 #ifndef __RENDER_H_
7 #define __RENDER_H_
8
9 struct process;
10
11 void process_render(struct process *, const char *, ...);
12
13 #endif /* !__RENDER_H_ */
+140
-0
src/report.c less more
0 /*
1 * report.c
2 * Error/warning reporter.
3 * $Id: report.c 139 2008-07-16 09:56:31Z catseye $
4 */
5
6 #include <stdarg.h>
7
8 #include "lib.h"
9
10 #include "process.h"
11 #include "stream.h"
12 #include "file.h"
13
14 #include "render.h"
15
16 #include "report.h"
17
18 struct reporter {
19 int finished;
20 int verbose;
21 int errors;
22 int warnings;
23 struct process *stream;
24 const char *phase;
25 };
26
27 /*
28 * phase should always point to a literal constant string like "Parsing"
29 */
30 struct reporter *
31 reporter_new(const char *phase, struct process *stream, int verbose)
32 {
33 struct reporter *r;
34
35 if ((r = malloc(sizeof(struct reporter))) == NULL) {
36 return NULL;
37 }
38
39 r->verbose = verbose;
40 r->errors = 0;
41 r->warnings = 0;
42 r->finished = 0;
43 r->stream = stream;
44 if (r->stream == NULL) {
45 r->stream = file_open("*stderr", "w");
46 }
47 r->phase = phase;
48
49 return r;
50
51 if (verbose) {
52 process_render(r->stream, "%s started\n", r->phase);
53 }
54 }
55
56 void
57 reporter_free(struct reporter *r)
58 {
59 if (!r->finished) {
60 reporter_finish(r);
61 }
62 stream_close(NULL, r->stream);
63 free(r);
64 }
65
66 int
67 reporter_finish(struct reporter *r)
68 {
69 if (r->verbose) {
70 process_render(r->stream,
71 "%s finished with %d errors and %d warnings\n",
72 r->phase, r->errors, r->warnings);
73 }
74 r->phase = NULL;
75 r->finished = 1;
76 return r->errors;
77 }
78
79 struct process *
80 reporter_stream(struct reporter *r)
81 {
82 return r->stream;
83 }
84
85 int
86 reporter_has_errors(struct reporter *r)
87 {
88 return r->errors > 0;
89 }
90
91 void
92 report(struct reporter *r, enum report_type rtype, const char *fmt, ...)
93 {
94 va_list args;
95
96 va_start(args, fmt);
97 report_va_list(r, rtype, fmt, args);
98 va_end(args);
99 }
100
101 void
102 report_va_list(struct reporter *r, enum report_type rtype, const char *fmt, va_list args)
103 {
104 int i;
105
106 assert(!r->finished);
107
108 process_render(r->stream, "%s %s: ",
109 r->phase, rtype == REPORT_ERROR ? "Error" : "Warning");
110
111 for (i = 0; fmt[i] != '\0'; i++) {
112 if (fmt[i] == '%') {
113 i++;
114 switch (fmt[i]) {
115 case 's':
116 process_render(r->stream, "%s",
117 va_arg(args, char *));
118 break;
119 case 'd':
120 process_render(r->stream, "%d",
121 va_arg(args, int));
122 break;
123 }
124 } else {
125 process_render(r->stream, "%c", fmt[i]);
126 }
127 }
128
129 process_render(r->stream, ".\n");
130
131 switch (rtype) {
132 case REPORT_ERROR:
133 r->errors++;
134 break;
135 case REPORT_WARNING:
136 r->warnings++;
137 break;
138 }
139 }
+31
-0
src/report.h less more
0 /*
1 * report.h
2 * Error/warning reporter.
3 * $Id: report.h 139 2008-07-16 09:56:31Z catseye $
4 */
5
6 #ifndef __REPORT_H_
7 #define __REPORT_H_
8
9 #include <stdarg.h>
10
11 struct process;
12
13 enum report_type {
14 REPORT_WARNING,
15 REPORT_ERROR
16 };
17
18 struct reporter;
19
20 struct reporter *reporter_new(const char *, struct process *, int);
21 int reporter_finish(struct reporter *);
22 void reporter_free(struct reporter *);
23
24 struct process *reporter_stream(struct reporter *);
25 int reporter_has_errors(struct reporter *);
26
27 void report(struct reporter *, enum report_type, const char *, ...);
28 void report_va_list(struct reporter *, enum report_type, const char *, va_list);
29
30 #endif /* !__REPORT_H_ */
+68
-0
src/run.c less more
0 /*
1 * run.c
2 * Main program segment of Kosheri virtual machine.
3 */
4
5 #include "lib.h"
6 #include "file.h"
7 #include "stream.h"
8 #include "cmdline.h"
9
10 #include "process.h"
11 #include "vmproc.h"
12 #include "load.h"
13
14 #include "value.h"
15
16 #ifdef DEBUG
17 #include "render.h"
18 #endif
19
20 static void
21 run_main(struct value *args, struct value *result)
22 {
23 struct value vm; /* virtual machine we will run */
24 struct value vmfile_sym;
25
26 struct value code; /* code for the virtual machine */
27 struct process *in; /* file process we will load it from */
28 struct process *first; /* main process the VM will run in */
29 struct process *curr; /* current process in our schedule */
30 struct process *next;
31 struct value *vmfile;
32
33 value_symbol_new(&vmfile_sym, "vmfile", 6);
34 vmfile = value_dict_fetch(args, &vmfile_sym);
35
36 in = file_open(value_symbol_get_token(vmfile), "r");
37 value_load(&code, in);
38 stream_close(NULL, in);
39
40 value_vm_new(&vm, &code);
41 curr = first = vmproc_new(&vm);
42 while (first != NULL) {
43 #ifdef DEBUG
44 process_render(process_err, "Running process %d\n", curr);
45 #endif
46 process_run(curr);
47 next = curr->next;
48 while (next != NULL && next->done) {
49 curr->next = next->next;
50 process_free(next);
51 next = curr->next;
52 }
53 curr = next;
54 if (curr == NULL) {
55 while (first != NULL && first->done) {
56 next = first->next;
57 process_free(first);
58 first = next;
59 }
60 curr = first;
61 }
62 }
63
64 value_integer_set(result, 0);
65 }
66
67 MAIN(run_main)
+88
-0
src/save.c less more
0 /*
1 * save.c
2 * Save values to a stream-like process.
3 */
4
5 #include "lib.h"
6 #include "stream.h"
7
8 #include "save.h"
9 #include "value.h"
10
11 #ifdef DEBUG
12 #include "cmdline.h"
13 #include "portray.h"
14 #include "render.h"
15 #endif
16
17 int
18 value_save(struct process *p, struct value *value)
19 {
20 unsigned char squeeze = (unsigned char)value->type;
21
22 #ifdef DEBUG
23 process_render(process_err, "(save:%s ", type_name_table[(int)squeeze]);
24 if (value->type == VALUE_SYMBOL) {
25 process_render(process_err, "[%d] ", value_symbol_get_length(value));
26 }
27 value_portray(process_err, value);
28 process_render(process_err, ")\n");
29 #endif
30
31 stream_write(NULL, p, &squeeze, sizeof(squeeze));
32
33 if ((value->type & VALUE_STRUCTURED) == 0) {
34 stream_write(NULL, p, &value->value, sizeof(value->value));
35 } else {
36 unsigned int length, i;
37
38 switch (value->type) {
39 case VALUE_SYMBOL:
40 {
41 const char *token = value_symbol_get_token(value);
42 length = value_symbol_get_length(value);
43 stream_write(NULL, p, &length, sizeof(length));
44 stream_write(NULL, p, token, sizeof(char) * length);
45 break;
46 }
47 case VALUE_TUPLE:
48 {
49 struct value *tag = value_tuple_get_tag(value);
50 value_save(p, tag);
51 /* XXX should eventually dispatch to a handler based on tag. */
52 if (value_equal(tag, &tag_dict)) {
53 struct value dict_iter;
54 struct value *key;
55
56 value_dict_new_iter(&dict_iter, value);
57
58 length = value_dict_get_layer_size(value);
59 stream_write(NULL, p, &length, sizeof(length));
60 length = value_dict_get_length(value);
61 stream_write(NULL, p, &length, sizeof(length));
62
63 key = value_dict_iter_get_current_key(&dict_iter);
64 while (!value_is_null(key)) {
65 value_save(p, key);
66 value_save(p, value_dict_fetch(value, key)); /* XXX not so good; use iter */
67 value_dict_iter_advance(&dict_iter);
68 key = value_dict_iter_get_current_key(&dict_iter);
69 }
70 } else {
71 length = value_tuple_get_size(value);
72 stream_write(NULL, p, &length, sizeof(length));
73 for (i = 0; i < length; i++) {
74 value_save(p, value_tuple_fetch(value, i));
75 }
76 }
77 break;
78 }
79 default:
80 assert(value->type == VALUE_SYMBOL ||
81 value->type == VALUE_TUPLE);
82 break;
83 }
84 }
85
86 return 1;
87 }
+14
-0
src/save.h less more
0 /*
1 * save.h
2 * Structures and prototypes for saving values to processes.
3 */
4
5 #ifndef __SAVE_H_
6 #define __SAVE_H_
7
8 struct process;
9 struct value;
10
11 int value_save(struct process *, struct value *);
12
13 #endif /* !__SAVE_H_ */
+374
-0
src/scan.c less more
0 /*
1 * scan.c
2 * Lexical scanner.
3 * $Id: scan.c 139 2008-07-16 09:56:31Z catseye $
4 */
5
6 #include <stdarg.h>
7
8 #include "lib.h"
9
10 #include "stream.h"
11 #include "file.h"
12
13 #include "scan.h"
14 #include "report.h"
15 #include "render.h"
16
17 enum token_type {
18 TOKEN_EOF,
19 TOKEN_NUMBER,
20 TOKEN_BAREWORD,
21 TOKEN_SYMBOL,
22 TOKEN_QUOTED_STRING
23 };
24
25 struct scanner {
26 struct reporter *reporter;
27 struct process *input; /* file process from which we are scanning */
28 const char *filename; /* name of file scanning from */
29 char *token; /* text content of token we just scanned */
30 enum token_type token_type; /* type of token that was scanned */
31 unsigned int token_length; /* length of the token that was scanned */
32 int line; /* current line number, 1-based */
33 int column; /* current column number, 1-based */
34 int last_column; /* for putback */
35 char *putback_buf; /* buffer of characters put back */
36 int putback_pos; /* position within putback buffer */
37 };
38
39 #define PUTBACK_SIZE 80
40
41 struct scanner *
42 scanner_new(struct reporter *r)
43 {
44 struct scanner *sc;
45
46 if ((sc = malloc(sizeof(struct scanner))) == NULL) {
47 return NULL;
48 }
49 if ((sc->token = malloc(256 * sizeof(char))) == NULL) {
50 free(sc);
51 return NULL;
52 }
53
54 sc->reporter = r;
55 sc->filename = NULL;
56 sc->input = NULL;
57 sc->putback_buf = malloc(PUTBACK_SIZE * sizeof(char));
58 sc->putback_pos = 0;
59
60 return sc;
61 }
62
63 void
64 scanner_free(struct scanner *sc)
65 {
66 scanner_close(sc);
67 free(sc->token);
68 free(sc);
69 }
70
71 void
72 scanner_reset(struct scanner *sc)
73 {
74 sc->line = 1;
75 sc->column = 1;
76 sc->last_column = 0;
77 scanner_scan(sc); /* prime the pump */
78 }
79
80 /*
81 * caller is responsible for freeing the filename
82 */
83 int
84 scanner_open(struct scanner *sc, const char *filename)
85 {
86 sc->filename = filename;
87 if ((sc->input = file_open(filename, "r")) == NULL) {
88 scanner_report(sc, REPORT_ERROR,
89 "Can't open '%s' for reading", filename);
90 return 0;
91 }
92 scanner_reset(sc);
93 return 1;
94 }
95
96 /*
97 * caller is responsible for freeing the filename
98 */
99 int
100 scanner_attach(struct scanner *sc, struct process *p, const char *filename)
101 {
102 sc->filename = filename;
103 sc->input = p;
104 scanner_reset(sc);
105 return 1;
106 }
107
108 void
109 scanner_close(struct scanner *sc)
110 {
111 if (sc->filename != NULL) {
112 sc->filename = NULL;
113 }
114 if (sc->input != NULL) {
115 stream_close(NULL, sc->input);
116 sc->input = NULL; /* ? */
117 }
118 }
119
120 /*
121 * x is not a string, it is a pointer to a single character.
122 */
123 static void
124 scan_char(struct scanner *sc, char *x)
125 {
126 sc->last_column = sc->column;
127
128 /* do a 'getc' */
129 if (sc->putback_pos > 0) {
130 *x = sc->putback_buf[sc->putback_pos--];
131 } else {
132 stream_read(NULL, sc->input, x, sizeof(char));
133 }
134
135 if (*x == '\n') {
136 sc->column = 1;
137 sc->line++;
138 } else if (*x == '\t') {
139 sc->column++;
140 while (sc->column % 8 != 0)
141 sc->column++;
142 } else {
143 sc->column++;
144 }
145 }
146
147 static void
148 putback(struct scanner *sc, char x)
149 {
150 if (stream_is_at_end(NULL, sc->input))
151 return;
152
153 /* do a 'ungetc' */
154 if (sc->putback_pos < (PUTBACK_SIZE - 1)) {
155 sc->putback_buf[++sc->putback_pos] = x;
156 } else {
157 scanner_report(sc, REPORT_ERROR,
158 "Putback buffer size exceeded on '%s'", sc->filename);
159 }
160
161 sc->column = sc->last_column;
162 if (x == '\n')
163 sc->line--;
164 }
165
166 static void
167 real_scan(struct scanner *sc)
168 {
169 char x;
170 int i = 0;
171
172 sc->token[0] = '\0';
173 sc->token_length = 0;
174 if (stream_is_at_end(NULL, sc->input)) {
175 sc->token_type = TOKEN_EOF;
176 return;
177 }
178
179 scan_char(sc, &x);
180
181 /* Skip whitespace. */
182
183 top:
184 while (k_isspace(x) && !stream_is_at_end(NULL, sc->input)) {
185 scan_char(sc, &x);
186 }
187
188 /* Skip comments. */
189
190 if (x == '/') {
191 scan_char(sc, &x);
192 if (x == '/') {
193 while (x != '\n' && !stream_is_at_end(NULL, sc->input)) {
194 scan_char(sc, &x);
195 }
196 goto top;
197 } else {
198 putback(sc, x);
199 x = '/';
200 /* falls through to the bottom of scan() */
201 }
202 }
203
204 if (stream_is_at_end(NULL, sc->input)) {
205 sc->token[0] = '\0';
206 sc->token_type = TOKEN_EOF;
207 return;
208 }
209
210 /*
211 * Scan decimal numbers. Must start with a
212 * digit (not a sign or decimal point.)
213 */
214 if (k_isdigit(x)) {
215 while ((k_isdigit(x) || x == '.') && !stream_is_at_end(NULL, sc->input)) {
216 sc->token[i++] = x;
217 sc->token_length++;
218 scan_char(sc, &x);
219 }
220 putback(sc, x);
221 sc->token[i] = '\0';
222 sc->token_type = TOKEN_NUMBER;
223 return;
224 }
225
226 /*
227 * Scan quoted strings.
228 */
229 if (x == '"') {
230 scan_char(sc, &x);
231 while (x != '"' && !stream_is_at_end(NULL, sc->input) && i < 255) {
232 sc->token[i++] = x;
233 sc->token_length++;
234 scan_char(sc, &x);
235 }
236 sc->token[i] = '\0';
237 sc->token_type = TOKEN_QUOTED_STRING;
238 return;
239 }
240
241 /*
242 * Scan alphanumeric ("bareword") tokens.
243 */
244 if (k_isalpha(x) || x == '_') {
245 while ((k_isalpha(x) || k_isdigit(x) || x == '_') && !stream_is_at_end(NULL, sc->input)) {
246 sc->token[i++] = x;
247 sc->token_length++;
248 scan_char(sc, &x);
249 }
250 putback(sc, x);
251 sc->token[i] = '\0';
252 sc->token_type = TOKEN_BAREWORD;
253 return;
254 }
255
256 /*
257 * Scan multi-character symbols.
258 */
259 if (x == '>' || x == '<' || x == '!') {
260 sc->token[i++] = x;
261 sc->token_length++;
262 scan_char(sc, &x);
263 if (x == '=' && !stream_is_at_end(NULL, sc->input)) {
264 sc->token[i++] = x;
265 sc->token_length++;
266 scan_char(sc, &x);
267 } else {
268 putback(sc, x);
269 }
270 sc->token[i] = '\0';
271 sc->token_type = TOKEN_SYMBOL;
272 return;
273 }
274
275 /*
276 * Degenerate case: scan single symbols.
277 */
278 sc->token[0] = x;
279 sc->token[1] = '\0';
280 sc->token_length = 1;
281 sc->token_type = TOKEN_SYMBOL;
282 }
283
284 void
285 scanner_scan(struct scanner *sc)
286 {
287 real_scan(sc);
288 #ifdef DEBUG
289 printf("scanned -> '%s'\n", sc->token);
290 #endif
291 }
292
293 void
294 scanner_expect(struct scanner *sc, const char *x)
295 {
296 if (strcmp(sc->token, x) == 0) {
297 scanner_scan(sc);
298 } else {
299 scanner_report(sc, REPORT_ERROR, "Expected '%s'", x);
300 }
301 }
302
303 void
304 scanner_scanline(struct scanner *sc)
305 {
306 char x;
307
308 scan_char(sc, &x);
309 while (x != '\n' && !stream_is_at_end(NULL, sc->input)) {
310 scan_char(sc, &x);
311 }
312 real_scan(sc);
313 }
314
315 int
316 scanner_tokeq(struct scanner *sc, const char *token)
317 {
318 return strcmp(sc->token, token) == 0;
319 }
320
321 const char *
322 scanner_token_string(struct scanner *sc)
323 {
324 return sc->token;
325 }
326
327 int
328 scanner_token_length(struct scanner *sc)
329 {
330 return sc->token_length;
331 }
332
333 int
334 scanner_eof(struct scanner *sc)
335 {
336 return sc->token_type == TOKEN_EOF;
337 }
338
339 const char *
340 scanner_filename(struct scanner *sc)
341 {
342 return sc->filename != NULL ? sc->filename : "<no file>";
343 }
344
345 int
346 scanner_line(struct scanner *sc)
347 {
348 return sc->line;
349 }
350
351 int
352 scanner_column(struct scanner *sc)
353 {
354 return sc->column;
355 }
356
357 void
358 scanner_report(struct scanner *sc, enum report_type rtype, const char *fmt, ...)
359 {
360 va_list args;
361
362 /*
363 * Breaking abstraction just to have a nicely-formatted error message...
364 */
365 process_render(reporter_stream(sc->reporter),
366 "(%s, line %d, column %d, token '%s'): ",
367 scanner_filename(sc), scanner_line(sc),
368 scanner_column(sc), scanner_token_string(sc));
369
370 va_start(args, fmt);
371 report_va_list(sc->reporter, rtype, fmt, args);
372 va_end(args);
373 }
+37
-0
src/scan.h less more
0 /*
1 * scan.h
2 * Lexical scanner structures and prototypes.
3 * $Id: scan.h 139 2008-07-16 09:56:31Z catseye $
4 */
5
6 #ifndef __SCAN_H_
7 #define __SCAN_H_
8
9 #include "report.h"
10
11 struct scanner;
12
13 struct scanner *scanner_new(struct reporter *);
14 void scanner_free(struct scanner *);
15
16 void scanner_reset(struct scanner *);
17 int scanner_attach(struct scanner *, struct process *, const char *);
18 int scanner_open(struct scanner *, const char *);
19 void scanner_close(struct scanner *);
20
21 void scanner_scan(struct scanner *);
22 void scanner_expect(struct scanner *, const char *);
23 void scanner_scanline(struct scanner *);
24
25 int scanner_tokeq(struct scanner *, const char *);
26 const char *scanner_token_string(struct scanner *);
27 int scanner_token_length(struct scanner *);
28
29 int scanner_eof(struct scanner *);
30 const char *scanner_filename(struct scanner *);
31 int scanner_line(struct scanner *);
32 int scanner_column(struct scanner *);
33
34 void scanner_report(struct scanner *, enum report_type, const char *, ...);
35
36 #endif /* !__SCAN_H_ */
+152
-0
src/stream.c less more
0 /*
1 * stream.c
2 * Routines for communicating with stream-like processes.
3 */
4
5 #include "lib.h"
6
7 #include "process.h"
8
9 #include "stream.h"
10
11 static void
12 read_receiver_run(struct process *self)
13 {
14 struct value msg;
15 const char *token;
16 int length;
17 int i;
18
19 assert(self != NULL);
20 assert(self->aux != NULL);
21
22 while (process_dequeue(self, &msg)) {
23 token = value_symbol_get_token(&msg);
24 length = value_symbol_get_length(&msg);
25 for (i = 0; i < length; i++) {
26 ((char *)self->aux)[i] = token[i];
27 }
28 /* XXX assert the queue is empty? */
29 }
30 }
31
32 static struct process *
33 read_receiver_new(void *buffer)
34 {
35 struct process *p;
36
37 p = process_new();
38 p->run = read_receiver_run;
39 p->aux = buffer;
40
41 return p;
42 }
43
44 static void
45 eof_receiver_run(struct process *self)
46 {
47 struct value msg;
48
49 assert(self != NULL);
50 assert(self->aux != NULL);
51
52 while (process_dequeue(self, &msg)) {
53 *(int *)(self->aux) = value_get_boolean(&msg);
54 /* XXX assert the queue is empty? */
55 }
56 }
57
58 static struct process *
59 eof_receiver_new(int *result)
60 {
61 struct process *p;
62
63 p = process_new();
64 p->run = eof_receiver_run;
65 p->aux = result;
66
67 return p;
68 }
69
70 void
71 stream_write(struct process *self, struct process *p, const void *data, unsigned int size)
72 {
73 struct value msg, tag;
74
75 self = self;
76
77 value_symbol_new(&tag, "write", 5);
78 value_tuple_new(&msg, &tag, 1);
79 value_symbol_new(value_tuple_fetch(&msg, 0), data, size);
80 process_enqueue(p, &msg);
81 process_run(p);
82 }
83
84 void
85 stream_read(struct process *self, struct process *p, void *buffer, unsigned int size)
86 {
87 struct value msg, tag;
88 struct process *receiver;
89
90 if (self == NULL) {
91 receiver = read_receiver_new(buffer);
92 } else {
93 receiver = self;
94 }
95
96 value_symbol_new(&tag, "read", 4);
97 value_tuple_new(&msg, &tag, 2);
98 value_process_set(value_tuple_fetch(&msg, 0), receiver);
99 value_integer_set(value_tuple_fetch(&msg, 1), size);
100 process_enqueue(p, &msg);
101 process_run(p);
102
103 if (receiver == self) {
104 return;
105 }
106
107 process_run(receiver);
108 process_free(receiver);
109 }
110
111 int
112 stream_is_at_end(struct process *self, struct process *p)
113 {
114 struct value msg, tag;
115 struct process *receiver;
116 int result;
117
118 if (self == NULL) {
119 receiver = eof_receiver_new(&result);
120 } else {
121 receiver = self;
122 }
123
124 value_symbol_new(&tag, "eof", 3);
125 value_tuple_new(&msg, &tag, 1);
126 value_process_set(value_tuple_fetch(&msg, 0), receiver);
127 process_enqueue(p, &msg);
128 process_run(p);
129
130 if (receiver == self) {
131 return 0;
132 }
133
134 process_run(receiver);
135 process_free(receiver);
136
137 return result;
138 }
139
140 void
141 stream_close(struct process *self, struct process *p)
142 {
143 struct value msg, tag;
144
145 self = self;
146
147 value_symbol_new(&tag, "close", 5);
148 value_tuple_new(&msg, &tag, 0);
149 process_enqueue(p, &msg);
150 process_run(p);
151 }
+45
-0
src/stream.h less more
0 /*
1 * stream.h
2 * Routines for communicating with stream-like processes.
3 */
4
5 #ifndef __STREAM_H_
6 #define __STREAM_H_
7
8 struct process;
9
10 /*
11 * The first argument is the process that is calling the stream-
12 * like process, a.k.a. "self". It may be NULL, to communicate
13 * with a stream from a non-process context.
14 */
15
16 /*
17 * Send a message of the form <write: data-in-symbol-form> to the stream.
18 */
19 void stream_write(struct process *, struct process *, const void *, unsigned int);
20
21 /*
22 * Send a message of the form <read: receiver, length> to the stream.
23 * If self was given, it will be used as the receiver, and it will receive
24 * a response message in the form of a symbol.
25 * If self is NULL, a provisional pseudo-receiver process will be supplied
26 * by this function, and data will be returned in the void *.
27 */
28 void stream_read(struct process *, struct process *, void *, unsigned int);
29
30 /*
31 * Send a message of the form <eof: receiver> to the stream.
32 * If self was given, it will be used as the receiver, and it will receive
33 * a response message in the form of a boolean.
34 * If self is NULL, a provisional pseudo-receiver process will be supplied
35 * by this function, and the boolean will be returned by the function.
36 */
37 int stream_is_at_end(struct process *, struct process *);
38
39 /*
40 * Send a message of the form <close:> to the stream.
41 */
42 void stream_close(struct process *, struct process *);
43
44 #endif /* !__FILE_H_ */
+59
-0
src/thaw.c less more
0 /*
1 * thaw.c
2 * Load a term from a binary termfile and
3 * write out a textual version.
4 */
5
6 #include "lib.h"
7 #include "cmdline.h"
8
9 #include "stream.h"
10 #include "file.h"
11
12 #include "report.h"
13 #include "value.h"
14
15 #include "load.h"
16 #include "portray.h"
17
18 /* Main Program / Driver */
19
20 static void
21 thaw_main(struct value *args, struct value *result)
22 {
23 struct process *p;
24 struct reporter *r;
25 struct value term;
26
27 struct value *termfile, *binfile;
28 struct value termfile_sym, binfile_sym;
29
30 value_symbol_new(&termfile_sym, "termfile", 8);
31 value_symbol_new(&binfile_sym, "binfile", 7);
32 termfile = value_dict_fetch(args, &termfile_sym);
33 binfile = value_dict_fetch(args, &binfile_sym);
34
35 r = reporter_new("Thawing", NULL, 1);
36
37 /*
38 * Read in.
39 */
40 p = file_open(value_symbol_get_token(binfile), "r");
41 value_load(&term, p);
42 stream_close(NULL, p);
43
44 /*
45 * Write out.
46 */
47 p = file_open(value_symbol_get_token(termfile), "w");
48 value_portray(p, &term);
49 stream_close(NULL, p);
50
51 /*
52 * Finish up.
53 */
54 value_integer_set(result, reporter_has_errors(r) ? 1 : 0);
55 reporter_free(r);
56 }
57
58 MAIN(thaw_main)
+906
-0
src/value.c less more
0 /*
1 * value.c
2 * Values.
3 */
4
5 #include "lib.h"
6
7 #include "value.h"
8
9 #ifdef DEBUG
10 #include "cmdline.h"
11 #include "portray.h"
12 #include "render.h"
13 #endif
14
15 /*
16 * Structured values - strings, function values, and the like.
17 * These are dynamically allocated, garbage collected, and so forth.
18 */
19 struct structured_value {
20 unsigned char admin; /* ADMIN_ flags */
21 struct structured_value *next;
22 };
23
24 #define ADMIN_FREE 1 /* on the free list */
25 #define ADMIN_MARKED 2 /* marked, during gc */
26
27 struct value VNULL = { VALUE_NULL, { 0 } };
28
29 struct value VFALSE = { VALUE_BOOLEAN, { 0 } };
30 struct value VTRUE = { VALUE_BOOLEAN, { 1 } };
31
32 struct value tag_vm = { VALUE_INTEGER, { 1 } };
33 struct value tag_ar = { VALUE_INTEGER, { 3 } };
34 struct value tag_dict = { VALUE_INTEGER, { 4 } };
35 struct value tag_list = { VALUE_INTEGER, { 5 } };
36 struct value tag_iter = { VALUE_INTEGER, { 6 } };
37
38 #ifdef DEBUG
39 const char *type_name_table[] = {
40 "NULL",
41 "INTEGER",
42 "BOOLEAN",
43 "PROCESS",
44 "LABEL",
45 "???5???",
46 "???6???",
47 "???7???",
48 "???8???",
49 "SYMBOL",
50 "TUPLE"
51 };
52 #endif
53
54 /*
55 * List of structured values; used for sweep phase of GC.
56 */
57 static struct structured_value *sv_head = NULL;
58
59 /*** unstructured values ***/
60
61 void
62 value_integer_set(struct value *v, int i)
63 {
64 v->type = VALUE_INTEGER;
65 v->value.integer = i;
66 }
67
68 void
69 value_boolean_set(struct value *v, int b)
70 {
71 v->type = VALUE_BOOLEAN;
72 v->value.boolean = b;
73 }
74
75 void
76 value_process_set(struct value *v, struct process *p)
77 {
78 v->type = VALUE_PROCESS;
79 v->value.process = p;
80 }
81
82 void
83 value_label_set(struct value *v, clabel l)
84 {
85 v->type = VALUE_LABEL;
86 v->value.label = l;
87 }
88
89 /*** structured values ***/
90
91 /*
92 * Initialize a structured value by link it up into the
93 * garbage-collection list.
94 */
95 static void
96 structured_value_init(struct structured_value *sv)
97 {
98 sv->admin = 0;
99 sv->next = sv_head;
100 sv_head = sv;
101 }
102
103 /***** symbols *****/
104
105 struct symbol {
106 struct structured_value sv;
107 unsigned int length; /* number of characters in symbol */
108 /* char token[]; */ /* lexeme of this symbol */
109 };
110
111 int
112 value_symbol_new(struct value *v, const char *token, unsigned int len)
113 {
114 char *buffer;
115
116 assert(token != NULL);
117
118 buffer = value_symbol_new_buffer(v, len);
119 if (buffer == NULL)
120 return 0;
121 strncpy(buffer, token, len);
122
123 return 1;
124 }
125
126 char *
127 value_symbol_new_buffer(struct value *v, unsigned int len)
128 {
129 struct symbol *sym;
130
131 assert(v != NULL);
132
133 sym = malloc(sizeof(struct symbol) + len + 1);
134 if (sym == NULL)
135 return NULL;
136 sym->length = len;
137 ((char *)(sym + 1))[len] = '\0';
138
139 v->type = VALUE_SYMBOL;
140 v->value.structured = (struct structured_value *)sym;
141 structured_value_init((struct structured_value *)sym);
142
143 return (char *)(sym + 1);
144 }
145
146
147 /*
148 * Returned string is NUL-terminated.
149 */
150 const char *
151 value_symbol_get_token(const struct value *v)
152 {
153 struct symbol *sym;
154
155 assert(v->type == VALUE_SYMBOL);
156 assert(v->value.structured != NULL);
157 sym = (struct symbol *)v->value.structured;
158 return ((const char *)(sym + 1));
159 }
160
161 unsigned int
162 value_symbol_get_length(const struct value *v)
163 {
164 struct symbol *sym;
165
166 assert(v->type == VALUE_SYMBOL);
167 assert(v->value.structured != NULL);
168 sym = (struct symbol *)v->value.structured;
169 return sym->length;
170 }
171
172 /***** tuples *****/
173
174 struct tuple {
175 struct structured_value sv;
176 struct value tag;
177 unsigned int size; /* in # of values contained */
178 /* struct value vector[]; */
179 };
180
181 int
182 value_tuple_new(struct value *v, struct value *tag, unsigned int size)
183 {
184 struct tuple *tuple;
185
186 unsigned int bytes = sizeof(struct tuple) +
187 sizeof(struct value) * size;
188
189 if ((tuple = malloc(bytes)) == NULL)
190 return 0;
191
192 memset(tuple, 0, bytes);
193 value_copy(&tuple->tag, tag);
194 tuple->size = size;
195
196 v->type = VALUE_TUPLE;
197 v->value.structured = (struct structured_value *)tuple;
198 structured_value_init((struct structured_value *)tuple);
199
200 return 1;
201 }
202
203 int
204 value_is_tuple(const struct value *v)
205 {
206 return v->type == VALUE_TUPLE;
207 }
208
209 static struct tuple *
210 value_get_tuple(const struct value *v)
211 {
212 assert(value_is_tuple(v));
213 assert(v->value.structured != NULL);
214 return (struct tuple *)v->value.structured;
215 }
216
217 struct value *
218 value_tuple_get_tag(const struct value *v)
219 {
220 struct tuple *t = value_get_tuple(v);
221 return &t->tag;
222 }
223
224 unsigned int
225 value_tuple_get_size(const struct value *v)
226 {
227 struct tuple *t = value_get_tuple(v);
228 return t->size;
229 }
230
231 struct value *
232 value_tuple_fetch(const struct value *v, unsigned int at)
233 {
234 struct tuple *t = value_get_tuple(v);
235 assert(at < t->size);
236 return (struct value *)(t + 1) + at;
237 }
238
239 void
240 value_tuple_store(struct value *v, unsigned int at, const struct value *src)
241 {
242 struct value *dst = value_tuple_fetch(v, at);
243
244 value_copy(dst, src);
245 }
246
247 int
248 value_tuple_fetch_integer(const struct value *v, unsigned int at)
249 {
250 struct tuple *t = value_get_tuple(v);
251 assert(at < t->size);
252 assert(((struct value *)(t + 1) + at)->type == VALUE_INTEGER);
253 return ((struct value *)(t + 1) + at)->value.integer;
254 }
255
256 clabel
257 value_tuple_fetch_label(const struct value *v, unsigned int at)
258 {
259 struct tuple *t = value_get_tuple(v);
260 assert(at < t->size);
261 assert(((struct value *)(t + 1) + at)->type == VALUE_LABEL);
262 return ((struct value *)(t + 1) + at)->value.label;
263 }
264
265 /*
266 * Convenience method to directly store an integer in a tuple.
267 */
268 void
269 value_tuple_store_integer(struct value *v, unsigned int at, int src)
270 {
271 struct value *dst = value_tuple_fetch(v, at);
272
273 value_integer_set(dst, src);
274 }
275
276 /*** ACCESSORS ***/
277
278 /* Unstructured values */
279
280 int
281 value_get_integer(const struct value *v)
282 {
283 assert(v->type == VALUE_INTEGER);
284 return v->value.integer;
285 }
286
287 int
288 value_is_integer(const struct value *v)
289 {
290 return v->type == VALUE_INTEGER;
291 }
292
293 int
294 value_get_boolean(const struct value *v)
295 {
296 assert(v->type == VALUE_BOOLEAN);
297 return v->value.boolean;
298 }
299
300 struct process *
301 value_get_process(const struct value *v)
302 {
303 assert(v->type == VALUE_PROCESS);
304 return v->value.process;
305 }
306
307 clabel
308 value_get_label(const struct value *v)
309 {
310 assert(v->type == VALUE_LABEL);
311 return v->value.label;
312 }
313
314 PTR_INT
315 value_get_unique_id(const struct value *v)
316 {
317 assert(v->type & VALUE_STRUCTURED);
318 return (PTR_INT)v->value.structured;
319 }
320
321
322 /* Tuples as activation records */
323
324 int
325 value_ar_new(struct value *v, unsigned int size,
326 struct value *caller, struct value *enclosing, unsigned int pc)
327 {
328 if (!value_tuple_new(v, &tag_ar, size + AR_HEADER_SIZE))
329 return 0;
330
331 value_tuple_store(v, AR_CALLER, caller);
332 value_tuple_store(v, AR_ENCLOSING, enclosing);
333 value_tuple_store_integer(v, AR_PC, pc);
334 value_tuple_store_integer(v, AR_TOP, AR_HEADER_SIZE);
335
336 return 1;
337 }
338
339 struct value *
340 value_ar_pop(struct value *ar)
341 {
342 int idx;
343 struct value *v;
344
345 idx = value_tuple_fetch_integer(ar, AR_TOP);
346 v = value_tuple_fetch(ar, --idx);
347 value_tuple_store_integer(ar, AR_TOP, idx);
348
349 return v;
350 }
351
352 void
353 value_ar_push(struct value *ar, struct value *v)
354 {
355 int idx;
356
357 assert(value_is_tuple(ar));
358 idx = value_tuple_fetch_integer(ar, AR_TOP);
359 value_tuple_store(ar, idx++, v);
360 value_tuple_store_integer(ar, AR_TOP, idx);
361 }
362
363 void
364 value_ar_xfer(struct value *from, struct value *to, int count)
365 {
366 int i;
367 int from_top = value_tuple_fetch_integer(from, AR_TOP);
368 int to_top = value_tuple_fetch_integer(to, AR_TOP);
369
370 for (i = 0; i < count; i++) {
371 value_tuple_store(to, to_top + i,
372 value_tuple_fetch(from, (from_top - count) + i));
373 }
374
375 value_tuple_store_integer(to, AR_TOP, to_top + count);
376 value_tuple_store_integer(from, AR_TOP, from_top - count);
377 }
378
379 /***** tuples as dictionaries *****/
380
381 /*
382 * Dictionaries are implemented with "layered" hash tables.
383 * A layered hash table works like so:
384 *
385 * Instead of N chains of buckets, there are arrays of size N, called
386 * 'layers'. Each layer is chained together. This is wasteful in
387 * space when there are only a few entries AND they hash-collide, since
388 * there may be one (or rarely, more) layers which are mostly empty.
389 * BUT, this is possibly not as bad as it sounds:
390 *
391 * - When there are fewer than N entries, and there are no collisions,
392 * space usage is less than the chained version - because the chained
393 * version needs an array of N bucket-heads which is the same size as
394 * a layer - while it also needs buckets.
395 * - For M * N entries with no collisions, there are M layers allocated,
396 * and only 2 * M pointers; in the chained version, there are M * N
397 * (next-bucket) pointers allocated.
398 * - Allocations for large items (layers) happen less often than
399 * allocations for small items (buckets,) so this may be an advantage
400 * if malloc() is on the slow side.
401 */
402
403 /*
404 * Each layer of a dictionary is represented by a tuple with the
405 * following components:
406 *
407 * <usage-count, next-layer, ...>
408 *
409 * where ... represents the actual entries.
410 */
411
412 #define LAYER_USAGE 0
413 #define LAYER_NEXT 1
414 #define LAYER_HEADER_SIZE 2
415
416 /*
417 * Compute the hash value of the given value.
418 */
419 static unsigned int
420 value_hash(const struct value *v)
421 {
422 switch (v->type) {
423 case VALUE_NULL:
424 return 0;
425 case VALUE_INTEGER:
426 return (unsigned int)v->value.integer;
427 case VALUE_BOOLEAN:
428 return (unsigned int)v->value.boolean;
429 case VALUE_PROCESS:
430 /* XXX not stable between load/save */
431 return (PTR_INT)v->value.process;
432 case VALUE_LABEL:
433 /* XXX not stable between load/save */
434 return (PTR_INT)v->value.label;
435 case VALUE_SYMBOL:
436 {
437 unsigned int i, hash_val = 0, len = value_symbol_get_length(v);
438 const char *str = value_symbol_get_token(v);
439
440 for (i = 0; i < len; i++) {
441 hash_val += str[i] << (i & 0xf);
442 }
443
444 return hash_val;
445 }
446 case VALUE_TUPLE:
447 /* XXX not stable between load/save */
448 return (PTR_INT)v->value.structured;
449 }
450 /* should never be reached */
451 assert(v->type == VALUE_NULL);
452 return 0;
453 }
454
455 int
456 value_dict_new(struct value *table, unsigned int layer_size)
457 {
458 if (!value_tuple_new(table, &tag_dict,
459 layer_size + LAYER_HEADER_SIZE)) {
460 return 0;
461 }
462
463 value_tuple_store_integer(table, LAYER_USAGE, 0);
464 value_tuple_store(table, LAYER_NEXT, &VNULL);
465
466 return 1;
467 }
468
469 static struct value *
470 value_fetch_hash(const struct value *dict, const struct value *key,
471 unsigned int (*hash_fn)(const struct value *))
472 {
473 const struct value *layer;
474 unsigned int layer_size;
475 unsigned int slot;
476
477 layer = dict;
478 layer_size = value_tuple_get_size(layer) - LAYER_HEADER_SIZE;
479 slot = (hash_fn(key) % (layer_size >> 1)) << 1;
480 slot += LAYER_HEADER_SIZE; /* skip over administrivia in tuple */
481
482 while (!value_is_null(layer)) {
483 if (value_equal(key, value_tuple_fetch(layer, slot)))
484 return value_tuple_fetch(layer, slot + 1);
485 layer = value_tuple_fetch(layer, LAYER_NEXT);
486 assert(value_is_null(layer) || value_is_tuple(layer));
487 }
488
489 return &VNULL;
490 }
491
492 struct value *
493 value_dict_fetch(const struct value *dict, const struct value *key)
494 {
495 assert(value_is_tuple(dict));
496 return value_fetch_hash(dict, key, value_hash);
497 }
498
499 static void
500 value_store_hash(struct value *dict, struct value *key, struct value *value,
501 unsigned int (*hash_fn)(const struct value *))
502 {
503 struct value *layer = dict;
504 struct value *prev_layer = &VNULL;
505 struct value *next_layer = &VNULL;
506 struct value new_layer;
507 unsigned int layer_size = value_tuple_get_size(layer) - LAYER_HEADER_SIZE;
508 unsigned int slot = (hash_fn(key) % (layer_size >> 1)) << 1;
509 int usage;
510 int delta = 0;
511
512 slot += LAYER_HEADER_SIZE; /* skip over administrivia in tuple */
513
514 for (;;) {
515 struct value *v = value_tuple_fetch(layer, slot);
516 if (value_is_null(v)) {
517 /*
518 * Okay to insert into empty slot, so
519 * just break out of the loop.
520 */
521 if (!value_is_null(value)) {
522 delta = 1; /* insert */
523 }
524 break;
525 }
526 if (value_equal(key, v)) {
527 /*
528 * Okay to overwrite, so
529 * just break out of the loop.
530 */
531 if (value_is_null(value)) {
532 delta = -1; /* delete */
533 }
534 break;
535 }
536 prev_layer = layer;
537 next_layer = value_tuple_fetch(layer, LAYER_NEXT);
538 assert(value_is_null(layer) || value_is_tuple(layer));
539 if (!value_is_null(next_layer)) {
540 layer = next_layer;
541 /* and try again */
542 continue;
543 } else {
544 value_dict_new(&new_layer, layer_size);
545 assert(value_is_tuple(&new_layer));
546 value_tuple_store(layer, LAYER_NEXT, &new_layer);
547 layer = &new_layer;
548 delta = 1; /* insert */
549 break;
550 }
551 }
552
553 value_tuple_store(layer, slot, key);
554 value_tuple_store(layer, slot + 1, value);
555
556 if (delta != 0) {
557 usage = value_tuple_fetch_integer(layer, LAYER_USAGE);
558 usage += delta;
559 assert (usage >= 0);
560 if (usage == 0) {
561 /*
562 * This layer is now empty. Unlink it,
563 * and the garbage collector will delete it.
564 */
565 if (!value_is_null(prev_layer)) {
566 value_tuple_store(prev_layer, LAYER_NEXT,
567 value_tuple_fetch(layer, LAYER_NEXT));
568 }
569 } else {
570 value_tuple_store_integer(layer, LAYER_USAGE, usage);
571 }
572 }
573 }
574
575 void
576 value_dict_store(struct value *dict, struct value *key, struct value *value)
577 {
578 assert(value_is_tuple(dict));
579 value_store_hash(dict, key, value, value_hash);
580 }
581
582 unsigned int
583 value_dict_get_length(const struct value *dict)
584 {
585 const struct value *layer = dict;
586 unsigned int size = 0;
587
588 while (!value_is_null(layer)) {
589 size += value_tuple_fetch_integer(layer, LAYER_USAGE);
590 layer = value_tuple_fetch(layer, LAYER_NEXT);
591 }
592
593 return size;
594 }
595
596 unsigned int
597 value_dict_get_layer_size(const struct value *dict)
598 {
599 return value_tuple_get_size(dict) - LAYER_HEADER_SIZE;
600 }
601
602 #define DICT_ITER_LAYER 0
603 #define DICT_ITER_POS 1
604
605 int
606 value_dict_new_iter(struct value *v, struct value *dict)
607 {
608 if (!value_tuple_new(v, &tag_iter, 2))
609 return 0;
610
611 value_tuple_store(v, DICT_ITER_LAYER, dict);
612 value_tuple_store_integer(v, DICT_ITER_POS, LAYER_HEADER_SIZE);
613
614 return 1;
615 }
616
617 /* returns VNULL if there are no (more) entries in the dict. */
618 struct value *
619 value_dict_iter_get_current_key(struct value *dict_iter)
620 {
621 struct value *layer = value_tuple_fetch(dict_iter, DICT_ITER_LAYER);
622 unsigned int pos = value_tuple_fetch_integer(dict_iter, DICT_ITER_POS);
623 unsigned int layer_size = value_tuple_get_size(layer);
624 struct value *key;
625
626 if (pos >= layer_size) {
627 layer = value_tuple_fetch(layer, LAYER_NEXT);
628 if (value_is_null(layer)) {
629 return &VNULL;
630 }
631 pos = LAYER_HEADER_SIZE;
632 }
633
634 key = value_tuple_fetch(layer, pos);
635 while (value_is_null(key)) {
636 pos += 2;
637 if (pos >= layer_size) {
638 layer = value_tuple_fetch(layer, LAYER_NEXT);
639 if (value_is_null(layer)) {
640 return &VNULL;
641 }
642 pos = LAYER_HEADER_SIZE;
643 }
644 key = value_tuple_fetch(layer, pos);
645 }
646
647 value_tuple_store(dict_iter, DICT_ITER_LAYER, layer);
648 value_tuple_store_integer(dict_iter, DICT_ITER_POS, pos);
649
650 return key;
651 }
652
653 void
654 value_dict_iter_advance(struct value *dict_iter)
655 {
656 unsigned int pos = value_tuple_fetch_integer(dict_iter, DICT_ITER_POS);
657
658 value_tuple_store_integer(dict_iter, DICT_ITER_POS, pos + 2);
659 }
660
661 /***** tuples as virtual machines *****/
662
663 int
664 value_vm_new(struct value *vm, struct value *code_tuple)
665 {
666 if (!value_tuple_new(vm, &tag_vm, VM_SIZE))
667 return 0;
668
669 value_tuple_store(vm, VM_CODE, code_tuple);
670 value_tuple_store(vm, VM_IS_DIRECT, &VFALSE);
671 value_vm_reset(vm);
672
673 return 1;
674 }
675
676 void
677 value_vm_reset(struct value *vm)
678 {
679 value_tuple_store_integer(vm, VM_PC, 0);
680 value_tuple_store(vm, VM_AR, &VNULL);
681 }
682
683 /*** GENERAL OPERATIONS ***/
684
685 void
686 value_copy(struct value *dst, const struct value *src)
687 {
688 dst->type = src->type;
689 dst->value = src->value;
690 }
691
692 int
693 value_is_null(const struct value *v)
694 {
695 return v->type == VALUE_NULL;
696 }
697
698 static enum comparison
699 value_compare_nodups(const struct value *a, const struct value *b, struct value *seen)
700 {
701 unsigned int i;
702 struct value hidden_a, hidden_b;
703
704 if (a->type != b->type)
705 return CMP_INCOMPARABLE;
706
707 switch (a->type) {
708 case VALUE_NULL:
709 return CMP_EQ;
710 case VALUE_INTEGER:
711 if (a->value.integer > b->value.integer) {
712 return CMP_GT;
713 }
714 if (a->value.integer < b->value.integer) {
715 return CMP_LT;
716 }
717 return CMP_EQ;
718 case VALUE_BOOLEAN:
719 if (a->value.boolean == b->value.boolean) {
720 return CMP_EQ;
721 }
722 return CMP_INCOMPARABLE;
723 case VALUE_PROCESS:
724 if (a->value.process == b->value.process) {
725 return CMP_EQ;
726 }
727 return CMP_INCOMPARABLE;
728 case VALUE_LABEL:
729 if (a->value.label == b->value.label) {
730 return CMP_EQ;
731 }
732 return CMP_INCOMPARABLE;
733 case VALUE_SYMBOL:
734 {
735 int k = strcmp(value_symbol_get_token(a),
736 value_symbol_get_token(b));
737 if (k > 0) {
738 return CMP_GT;
739 }
740 if (k < 0) {
741 return CMP_LT;
742 }
743 return CMP_EQ;
744 }
745 case VALUE_TUPLE:
746 /*
747 * First, to handle the case where tuples contain
748 * cyclic links, check to see if these are, in fact,
749 * the same tuple.
750 */
751 if ((struct tuple *)(a->value.structured) ==
752 (struct tuple *)(b->value.structured))
753 return CMP_EQ;
754
755 /*
756 * XXX I would almost think that if the tags are not
757 * the same, then the tuples are incomparable...
758 */
759 switch (value_compare(value_tuple_get_tag(a), value_tuple_get_tag(b))) {
760 case CMP_GT:
761 return CMP_GT;
762 case CMP_LT:
763 return CMP_LT;
764 case CMP_INCOMPARABLE:
765 return CMP_INCOMPARABLE;
766 case CMP_EQ:
767 break;
768 }
769
770 if (((struct tuple *)(a->value.structured))->size >
771 ((struct tuple *)(b->value.structured))->size) {
772 return CMP_GT;
773 }
774 if (((struct tuple *)(a->value.structured))->size <
775 ((struct tuple *)(b->value.structured))->size) {
776 return CMP_LT;
777 }
778
779 /*
780 * This more prudent check keeps in mind that we are
781 * recursively testing for equality, and stores
782 * tuples in a 'have seen' dictionary, later recursing
783 * into them only if they have not yet been seen.
784 *
785 * Note, however, that because value_dict_store() internally
786 * uses value_equal(), we can get into a different kind
787 * of inifnite cycle - mutual recursion. To avoid that,
788 * we store encoded values based on the tuples, instead
789 * of the tuples themselves, in the 'have seen' dict.
790 */
791 value_process_set(&hidden_a, (struct process *)value_get_unique_id(a));
792 value_process_set(&hidden_b, (struct process *)value_get_unique_id(b));
793 value_dict_store(seen, &hidden_a, &VTRUE);
794 value_dict_store(seen, &hidden_b, &VTRUE);
795
796 for (i = 0; i < ((struct tuple *)(a->value.structured))->size; i++) {
797 struct value *na = value_tuple_fetch(a, i);
798 struct value *nb = value_tuple_fetch(b, i);
799 enum comparison c;
800
801 if ((!value_is_null(value_dict_fetch(seen, na))) ||
802 (!value_is_null(value_dict_fetch(seen, nb))))
803 return CMP_INCOMPARABLE; /* XXX ? */
804
805 c = value_compare(na, nb);
806 if (c != CMP_EQ)
807 return c;
808 }
809 return CMP_EQ;
810 }
811 /* should never be reached */
812 assert(a->type == VALUE_NULL);
813 return 0;
814 }
815
816 enum comparison
817 value_compare(const struct value *a, const struct value *b)
818 {
819 struct value d;
820 value_dict_new(&d, 31);
821 return value_compare_nodups(a, b, &d);
822 }
823
824 int
825 value_equal(const struct value *a, const struct value *b)
826 {
827 return value_compare(a, b) == CMP_EQ;
828 }
829
830 /***** gc *****/
831
832 /*
833 * Garbage collector. Not a cheesy little reference counter, but
834 * a real meat-and-potatoes mark-and-sweep.
835 *
836 * This is not particularly sophisticated; I'm more concerned with
837 * correctness than performance here.
838 */
839
840 static void
841 mark_tuple(struct value *v)
842 {
843 struct value *k;
844 unsigned int i;
845
846 assert(value_is_tuple(v));
847 for (i = 0; i < value_tuple_get_size(v); i++) {
848 k = value_tuple_fetch(v, i);
849 /*
850 * If the contained value is also structured,
851 * and it hasn't been marked yet, mark it too.
852 */
853 if (k->type & VALUE_STRUCTURED) {
854 struct structured_value *sv = k->value.structured;
855 if (k->type == VALUE_TUPLE &&
856 (!(sv->admin & ADMIN_MARKED))) {
857 /*
858 * It can contain other values and
859 * it hasn't been marked yet, so
860 * recursively mark its contents.
861 */
862 mark_tuple(k);
863 } else {
864 sv->admin |= ADMIN_MARKED;
865 }
866 }
867 }
868 }
869
870 /*
871 * Public interface to garbage collector.
872 */
873
874 void
875 value_gc(struct value *root)
876 {
877 struct structured_value *sv, *sv_next, *temp_sv_head = NULL;
878
879 /*
880 * Mark...
881 */
882 mark_tuple(root);
883
884 /*
885 * ...and sweep
886 */
887 for (sv = sv_head; sv != NULL; sv = sv_next) {
888 sv_next = sv->next;
889 if (sv->admin & ADMIN_MARKED) {
890 sv->admin &= ~ADMIN_MARKED;
891 sv->next = temp_sv_head;
892 temp_sv_head = sv;
893 } else {
894 /*
895 * Found an unreachable SV!
896 * Not much special knowledge is required to
897 * free a structured value block, so we just
898 * (un-abstractedly) inline the process here.
899 */
900 free(sv);
901 }
902 }
903
904 sv_head = temp_sv_head;
905 }
+210
-0
src/value.h less more
0 /*
1 * value.h
2 * Values.
3 */
4
5 #ifndef __VALUE_H_
6 #define __VALUE_H_
7
8 #include "localtypes.h"
9
10 /*
11 * Types of values.
12 */
13 #define VALUE_STRUCTURED 8
14 enum value_type {
15 VALUE_NULL = 0,
16 VALUE_INTEGER = 1,
17 VALUE_BOOLEAN = 2,
18 VALUE_PROCESS = 3,
19 VALUE_LABEL = 4,
20
21 VALUE_SYMBOL = (VALUE_STRUCTURED | 1),
22 VALUE_TUPLE = (VALUE_STRUCTURED | 2)
23 };
24
25 #ifdef DEBUG
26 extern const char *type_name_table[];
27 #endif
28
29 typedef void * clabel;
30
31 struct process;
32
33 /*
34 * Simple values.
35 * These exist directly on the stack, and are not garbage-collected.
36 */
37 struct value {
38 enum value_type type; /* VALUE_ */
39 union {
40 int integer;
41 int boolean;
42 struct process *process;
43 clabel label;
44 struct structured_value *structured;
45 } value;
46 };
47
48 extern struct value VNULL;
49 extern struct value VFALSE;
50 extern struct value VTRUE;
51
52 extern struct value tag_ar;
53 extern struct value tag_dict;
54 extern struct value tag_list;
55 extern struct value tag_vm;
56
57 /*
58 * Describe how two values compare.
59 */
60 enum comparison {
61 CMP_EQ,
62 CMP_LT,
63 CMP_GT,
64 CMP_INCOMPARABLE
65 };
66
67 /* Prototypes */
68
69 /*
70 * 'struct value *' parameters may NEVER be NULL.
71 *
72 * Only functions whose names end in _new allocate a struct value.
73 */
74
75 /*
76 * General functions.
77 */
78 void value_copy(struct value *, const struct value *);
79
80 int value_is_null(const struct value *);
81 int value_is_integer(const struct value *);
82 int value_is_tuple(const struct value *);
83
84 int value_equal(const struct value *, const struct value *);
85 enum comparison value_compare(const struct value *, const struct value *);
86
87 /* public interface to garbage collector */
88 void value_gc(struct value *);
89
90 /*
91 * Unstructured values.
92 */
93
94 void value_integer_set(struct value *, int);
95 void value_boolean_set(struct value *, int);
96 void value_process_set(struct value *, struct process *);
97 void value_label_set(struct value *, clabel);
98
99 int value_get_integer(const struct value *);
100 int value_get_boolean(const struct value *);
101 clabel value_get_label(const struct value *);
102 struct process *value_get_process(const struct value *);
103
104 /*
105 * Structured values.
106 */
107
108 /*
109 * Retrieve an integer code that uniquely identifies this value.
110 * Intended for debug output only.
111 * Precondition: value is a structured value.
112 */
113 PTR_INT value_get_unique_id(const struct value *);
114
115 /*
116 * Symbols.
117 */
118
119 /*
120 * Allocate a new symbol value, with the given character string
121 * (with the given length) as its token, and set the given value to it.
122 * Returns true upon success, false if memory could not be allocated.
123 * Precondition: value is not null, and the token is not null.
124 */
125 int value_symbol_new(struct value *, const char *, unsigned int);
126
127 /*
128 * Allocate a new symbol value with the given length and set the
129 * given value to it. Return a pointer to the start of the character
130 * data for the symbol, for later population by the caller.
131 * Returns null if memory could not be allocated.
132 * Precondition: value is not null, and the token is not null.
133 */
134 char *value_symbol_new_buffer(struct value *, unsigned int);
135 const char *value_symbol_get_token(const struct value *);
136 unsigned int value_symbol_get_length(const struct value *);
137
138 /*
139 * Tuples.
140 */
141
142 int value_tuple_new(struct value *, struct value *, unsigned int);
143 struct value *value_tuple_get_tag(const struct value *);
144 unsigned int value_tuple_get_size(const struct value *);
145 struct value *value_tuple_fetch(const struct value *, unsigned int);
146 void value_tuple_store(struct value *, unsigned int, const struct value *);
147 int value_tuple_fetch_integer(const struct value *, unsigned int);
148 void value_tuple_store_integer(struct value *, unsigned int, int);
149 clabel value_tuple_fetch_label(const struct value *, unsigned int);
150
151 /*
152 * Dictionaries.
153 * Dictionaries are represented by a linked list of "layers", where
154 * each layer is a tuple of the given size plus some header slots.
155 */
156
157 int value_dict_new(struct value *, unsigned int);
158 struct value *value_dict_fetch(const struct value *, const struct value *);
159 void value_dict_store(struct value *, struct value *, struct value *);
160 unsigned int value_dict_get_length(const struct value *);
161 unsigned int value_dict_get_layer_size(const struct value *);
162
163 /*
164 * Dictionary iterators.
165 */
166
167 int value_dict_new_iter(struct value *, struct value *);
168 struct value *value_dict_iter_get_current_key(struct value *);
169 void value_dict_iter_advance(struct value *);
170
171 /*
172 * Activation records.
173 * Activation records are represented by tuple with 4 header entries.
174 * The remainder of the entries are local variables stored in the AR.
175 */
176
177 #define AR_CALLER 0 /* ar: the ar that called us */
178 #define AR_ENCLOSING 1 /* ar: the ar lexically outside us */
179 #define AR_PC 2 /* integer: code pos when resumed */
180 #define AR_TOP 3 /* integer: current top of stack (init. 4) */
181
182 #define AR_HEADER_SIZE 4
183
184 int value_ar_new(struct value *, unsigned int, struct value *, struct value *, unsigned int);
185 struct value *value_ar_pop(struct value *);
186 void value_ar_push(struct value *, struct value *);
187 void value_ar_xfer(struct value *, struct value *, int);
188
189 /*
190 * Virtual machines.
191 * A virtual machine is represented by a tuple with 4 entries:
192 * - the first is an integer offset: the program counter
193 * - the second is a tuple representing the current activation record
194 * - the third is a boolean: is this code direct-threaded or not?
195 * - the fourth is a tuple containing the code as VM instructions
196 */
197
198 #define VM_PC 0
199 #define VM_AR 1
200 #define VM_IS_DIRECT 2
201 #define VM_CODE 3
202
203 #define VM_SIZE 4
204
205 int value_vm_new(struct value *, struct value *);
206 void value_vm_reset(struct value *);
207
208 #endif /* !__VALUE_H_ */
209
+825
-0
src/vm.c less more
0 /*
1 * vm.c
2 * Virtual machine.
3 */
4
5 #include "lib.h"
6 #include "process.h"
7 #include "stream.h"
8 #include "file.h"
9 #include "vmproc.h"
10
11 #include "vm.h"
12 #include "value.h"
13 #include "portray.h"
14 #include "save.h"
15
16 #include "instrenum.h"
17
18 #ifdef DEBUG
19 #include "cmdline.h" /* for process_err */
20 #include "render.h"
21 #define VM_DEBUG(x) process_render(process_err, "EXEC: %s\n", # x);
22 #define VM_DEBUG_PC() process_render(process_err, "VM PC: %04d --> ", pc);
23 #define VM_DUMP_AR() \
24 if (value_is_null(&ar)) { \
25 process_render(process_err, "(NO AR) "); \
26 } else { \
27 process_render(process_err, "AR: "); \
28 value_portray(process_err, &ar); \
29 process_render(process_err, " "); \
30 }
31 #else
32 #define VM_DEBUG(x)
33 #define VM_DEBUG_PC()
34 #define VM_DUMP_AR()
35 #endif
36
37 #ifdef DIRECT_THREADING
38
39 #include "instrtab.h"
40
41 #define VM_TOP() TOP:
42 #define VM_BEGIN_DISPATCH() goto *value_tuple_fetch_label(code, pc);
43 #define VM_END_DISPATCH()
44 #define VM_OPLAB(x) LABEL_ ## x: VM_DEBUG(x)
45 #define VM_NEXT() goto TOP;
46 #define VM_STOP() cycles = 1; goto TOP;
47
48 #else
49
50 #define VM_TOP()
51 #define VM_BEGIN_DISPATCH() switch (value_tuple_fetch_integer(code, pc)) {
52 #define VM_END_DISPATCH() }
53 #define VM_OPLAB(x) case x: VM_DEBUG(x)
54 #define VM_NEXT() break;
55 #define VM_STOP() cycles = 1; break;
56
57 #endif
58
59 #define POP_VALUE() value_ar_pop(&ar)
60 #define PUSH_VALUE(v) value_ar_push(&ar, v)
61
62 #define GET_VALUE(i) value_ar_push(&ar, \
63 value_tuple_fetch(&ar, \
64 i + AR_HEADER_SIZE))
65 #define SET_VALUE(i) value_tuple_store(&ar, \
66 i + AR_HEADER_SIZE, \
67 value_ar_pop(&ar))
68
69 #define XFER_VALUES(from, to, count) value_ar_xfer(from, to, count)
70
71 #define IMM_VAL() (value_tuple_fetch(code, pc))
72 #define IMM_INT() (value_tuple_fetch_integer(code, pc))
73 #define IMM_ADDR() (value_tuple_fetch_integer(code, pc))
74
75 void
76 vm_run(struct value *vm, struct process *self, unsigned int cycles)
77 {
78 struct value t1; /* temporary */
79
80 struct value *a; /* register, generally used for 1st argument */
81 struct value *b; /* register, generally used for 2nd argument */
82 struct value *v; /* register, generally used for result */
83
84 struct value ar; /* contains currently active activation record */
85 struct value *code; /* tuple containing VM instructions */
86
87 unsigned int pc; /* pointer into code to currently exec instr */
88
89 #ifdef DIRECT_THREADING
90 #include "instrlab.h"
91
92 if (!value_get_boolean(value_tuple_fetch(vm, VM_IS_DIRECT))) {
93 struct opcode_entry *oe;
94 enum opcode opcode;
95
96 /* convert opcodes to labels */
97 pc = 0;
98 code = value_tuple_fetch(vm, VM_CODE);
99 a = value_tuple_fetch(code, pc);
100 opcode = (enum opcode)value_get_integer(a);
101 while (opcode != INSTR_EOF) {
102 value_label_set(a, instr_label[value_get_integer(a)]);
103 #ifdef DEBUG
104 process_render(process_err, "At %d, replaced %d with ", pc, opcode);
105 value_portray(process_err, value_tuple_fetch(code, pc));
106 process_render(process_err, "\n");
107 #endif
108 pc += opcode_table[opcode].arity;
109 pc++;
110 a = value_tuple_fetch(code, pc);
111 opcode = (enum opcode)value_get_integer(a);
112 }
113 value_tuple_store(vm, VM_IS_DIRECT, &VTRUE);
114 }
115 #endif
116
117 value_copy(&ar, value_tuple_fetch(vm, VM_AR));
118 code = value_tuple_fetch(vm, VM_CODE);
119 pc = value_tuple_fetch_integer(vm, VM_PC);
120 pc--;
121
122 for (;;) {
123 VM_TOP()
124
125 pc++;
126 if (--cycles == 0) break;
127 VM_DEBUG_PC()
128 VM_DUMP_AR()
129
130 VM_BEGIN_DISPATCH()
131
132 /*** STACK MANIPULATION ***/
133
134 /*
135 % PUSH v : -> v
136 * Push the immediate value onto the stack.
137 */
138 VM_OPLAB(INSTR_PUSH)
139 pc++;
140 PUSH_VALUE(IMM_VAL());
141 VM_NEXT()
142
143 /*
144 % POP : v ->
145 * Pop a value off the stack and discard it.
146 */
147 VM_OPLAB(INSTR_POP)
148 POP_VALUE();
149 VM_NEXT()
150
151 /*
152 % GET : i -> v
153 * Push the value of a local variable, given
154 * by the index popped from the stack, onto the
155 * stack. i = 0 indicates the first local,
156 * which is stored at the bottom of the stack.
157 */
158 VM_OPLAB(INSTR_GET)
159 a = POP_VALUE();
160 GET_VALUE(value_get_integer(a));
161 VM_NEXT()
162
163 /*
164 % SET : v i ->
165 * Alter the value of a local variable, given
166 * by the index popped from the stack, to be
167 * the value subsequently popped from the stack.
168 */
169 VM_OPLAB(INSTR_SET)
170 a = POP_VALUE();
171 SET_VALUE(value_get_integer(a));
172 VM_NEXT()
173
174 /*
175 % GETI i : -> v
176 * Push the value of a local variable, given
177 * by the immediate integer index, onto the stack.
178 */
179 VM_OPLAB(INSTR_GETI)
180 pc++;
181 GET_VALUE(IMM_INT());
182 VM_NEXT()
183
184 /*
185 % SETI i : v ->
186 * Alter the value of a local variable, given
187 * by the immediate integer index, to be
188 * the value popped from the stack.
189 */
190 VM_OPLAB(INSTR_SETI)
191 pc++;
192 SET_VALUE(IMM_INT());
193 VM_NEXT()
194
195 /*** TUPLE OPERATIONS ***/
196
197 /*
198 % NEW_TUPLE i : v -> t
199 * Push a new, empty tuple onto the stack.
200 * The immediate integer gives the size.
201 * The value on the stack gives the tuple's tag.
202 */
203 VM_OPLAB(INSTR_NEW_TUPLE)
204 pc++;
205 value_tuple_new(&t1, POP_VALUE(), IMM_INT());
206 PUSH_VALUE(&t1);
207 VM_NEXT()
208
209 /*
210 % FETCH_TUPLE : i t -> v
211 * Pop a tuple value from the stack, then
212 * an integer index value, then push the
213 * value stored at that index in the tuple.
214 */
215 VM_OPLAB(INSTR_FETCH_TUPLE)
216 a = POP_VALUE(); /* tuple */
217 b = POP_VALUE(); /* index */
218 PUSH_VALUE(value_tuple_fetch(a, value_get_integer(b)));
219 VM_NEXT()
220
221 /*
222 % STORE_TUPLE : v i t ->
223 * Pop a tuple value from the stack, then
224 * an integer index value, then a target value;
225 * store the target in the tuple at that index.
226 */
227 VM_OPLAB(INSTR_STORE_TUPLE)
228 a = POP_VALUE(); /* tuple */
229 b = POP_VALUE(); /* index */
230 v = POP_VALUE(); /* value */
231 value_tuple_store(a, value_get_integer(b), v);
232 VM_NEXT()
233
234 /*** DICTIONARY OPERATIONS ***/
235
236 /*
237 % NEW_DICT i : -> d
238 * Push a new, empty dictionary onto the stack.
239 * The immediate integer gives the load factor.
240 */
241 VM_OPLAB(INSTR_NEW_DICT)
242 pc++;
243 value_dict_new(&t1, IMM_INT());
244 PUSH_VALUE(&t1);
245 VM_NEXT()
246
247 /*
248 % FETCH_DICT : k d -> v
249 * Pop a dictionary value from the stack, then
250 * a key value, then push the associated stored
251 * value retrieved from the dictionary onto the
252 * stack.
253 */
254 VM_OPLAB(INSTR_FETCH_DICT)
255 a = POP_VALUE(); /* dictionary */
256 b = POP_VALUE(); /* key */
257 PUSH_VALUE(value_dict_fetch(a, b));
258 VM_NEXT()
259
260 /*
261 % STORE_DICT : v k d ->
262 * Pop a dictionary value from the stack, then
263 * a key value, then a target value; associate
264 * the key with the target in the dictionary.
265 */
266 VM_OPLAB(INSTR_STORE_DICT)
267 a = POP_VALUE(); /* dictionary */
268 b = POP_VALUE(); /* key */
269 v = POP_VALUE(); /* value */
270 value_dict_store(a, b, v);
271 VM_NEXT()
272
273 /*** BOOLEAN OPERATORS ***/
274
275 /*
276 % NOT : b -> b
277 * Pop a boolean, and push Boolean NOT of it.
278 */
279 VM_OPLAB(INSTR_NOT)
280 a = POP_VALUE();
281 value_boolean_set(&t1, !value_get_boolean(a));
282 PUSH_VALUE(&t1);
283 VM_NEXT()
284
285 /*
286 % AND : b b -> b
287 * Pop two booleans, and push Boolean AND of them.
288 */
289 VM_OPLAB(INSTR_AND)
290 b = POP_VALUE();
291 a = POP_VALUE();
292 value_boolean_set(&t1,
293 value_get_boolean(a) && value_get_boolean(b)
294 );
295 PUSH_VALUE(&t1);
296 VM_NEXT()
297
298 /*
299 % OR : b b -> b
300 * Pop two booleans, and push Boolean OR of them.
301 */
302 VM_OPLAB(INSTR_OR)
303 b = POP_VALUE();
304 a = POP_VALUE();
305 value_boolean_set(&t1,
306 value_get_boolean(a) || value_get_boolean(b)
307 );
308 PUSH_VALUE(&t1);
309 VM_NEXT()
310
311 /*** COMPARISON OPERATORS ***/
312
313 /*
314 % EQU : v v -> b
315 * Pop two value, and push a new boolean value;
316 * true if the two values are equal, false if not.
317 */
318 VM_OPLAB(INSTR_EQU)
319 b = POP_VALUE();
320 a = POP_VALUE();
321 value_boolean_set(&t1,
322 value_equal(a, b)
323 );
324 PUSH_VALUE(&t1);
325 VM_NEXT()
326
327 /*
328 % NEQ : v v -> b
329 * Shorthand for EQU NOT.
330 */
331 VM_OPLAB(INSTR_NEQ)
332 b = POP_VALUE();
333 a = POP_VALUE();
334 value_boolean_set(&t1,
335 !value_equal(a, b)
336 );
337 PUSH_VALUE(&t1);
338 VM_NEXT()
339
340 /*** ARITHMETIC OPERATORS ***/
341
342 /*
343 % ADD_INT : i i -> i
344 * Pop two integers, and push their sum as an integer.
345 */
346 VM_OPLAB(INSTR_ADD_INT)
347 b = POP_VALUE();
348 a = POP_VALUE();
349 value_integer_set(&t1,
350 value_get_integer(a) + value_get_integer(b)
351 );
352 PUSH_VALUE(&t1);
353 VM_NEXT()
354
355 /*
356 % MUL_INT : i i -> i
357 * Pop two integers, and push their product as an integer.
358 */
359 VM_OPLAB(INSTR_MUL_INT)
360 b = POP_VALUE();
361 a = POP_VALUE();
362 value_integer_set(&t1,
363 value_get_integer(a) * value_get_integer(b)
364 );
365 PUSH_VALUE(&t1);
366 VM_NEXT()
367
368 /*
369 % SUB_INT : i i -> i
370 * Pop two integers, and push their difference as an integer.
371 * The difference is the second popped minus the first.
372 */
373 VM_OPLAB(INSTR_SUB_INT)
374 b = POP_VALUE();
375 a = POP_VALUE();
376 value_integer_set(&t1,
377 value_get_integer(a) - value_get_integer(b)
378 );
379 PUSH_VALUE(&t1);
380 VM_NEXT()
381
382 /*
383 % DIV_INT : i i -> i
384 * Pop two integers, and push their quotient as an integer.
385 * The quotient is the second popped divided by the first.
386 */
387 VM_OPLAB(INSTR_DIV_INT)
388 b = POP_VALUE();
389 a = POP_VALUE();
390 value_integer_set(&t1,
391 value_get_integer(a) / value_get_integer(b)
392 );
393 PUSH_VALUE(&t1);
394 VM_NEXT()
395
396 /*
397 % MOD_INT : i i -> i
398 * Pop two integers, and push their remainder as an integer.
399 * The remainder is what is left over after dividing the
400 * second value popped by the first value popped.
401 */
402 VM_OPLAB(INSTR_MOD_INT)
403 b = POP_VALUE();
404 a = POP_VALUE();
405 value_integer_set(&t1,
406 value_get_integer(a) % value_get_integer(b)
407 );
408 PUSH_VALUE(&t1);
409 VM_NEXT()
410
411 /*** CONTROL FLOW INSTRUCTIONS ***/
412
413 /*
414 % GOTO a : ->
415 * Unilaterally transfer control to a different
416 * code address. This does not change the
417 * stack or activation record in any way.
418 */
419 VM_OPLAB(INSTR_GOTO)
420 pc++;
421 pc = IMM_ADDR();
422 pc--;
423 VM_NEXT()
424
425 /*
426 % FUN a : i -> f
427 * Create a new "functional value" (initial AR) from
428 * the code address given by the operand, the size of
429 * the activation record that will be required when it is
430 * invoked (given on the stack,) and the current
431 * activation record, (considered to be this fun's
432 * "enclosing" AR.) Push this new fun onto the stack.
433 */
434 VM_OPLAB(INSTR_FUN)
435 pc++;
436 a = POP_VALUE();
437 value_ar_new(&t1, value_get_integer(a),
438 &VNULL, /* not set until called */
439 &ar, IMM_ADDR());
440 PUSH_VALUE(&t1);
441 VM_NEXT()
442
443 /*
444 % NEW_AR i : ->
445 * Create a new activation record and use it for our
446 * execution context (stack etc.)
447 *
448 * This is generally only needed in the global
449 * scope, since INSTR_CALL takes care of creating
450 * AR's for itself.
451 *
452 * This implementation uses the 't1' value register
453 * temporarily to store the new AR.
454 */
455 VM_OPLAB(INSTR_NEW_AR)
456 pc++;
457 value_ar_new(&ar, IMM_INT(), &ar, &VNULL, pc);
458 VM_NEXT()
459
460 /*
461 % CALL i : X v ->
462 * Pop a function-value from the stack and call
463 * it, passing a number of arguments given by
464 * the immediate integer.
465 */
466 VM_OPLAB(INSTR_CALL)
467 /*
468 * XXX should assert that it's an AR here.
469 */
470 v = POP_VALUE();
471 assert(value_is_tuple(v));
472
473 pc++; /* point at operand */
474
475 /*
476 * Save the current program position in
477 * the current activation record.
478 */
479 value_tuple_store_integer(&ar, AR_PC, pc + 1);
480
481 value_tuple_store(v, AR_CALLER, &ar);
482
483 /*
484 * Pass parameters to the new AR.
485 */
486 XFER_VALUES(&ar, v, IMM_INT());
487
488 /*
489 * Set the activation record and program
490 * counter up as our own.
491 */
492 value_copy(&ar, v);
493 pc = value_tuple_fetch_integer(&ar, AR_PC);
494 pc--;
495 VM_NEXT()
496
497 /*
498 % RESUME i : X v ->
499 * Pop an AR from the stack and resume
500 * it, passing a number of arguments given by
501 * the immediate integer.
502 */
503 VM_OPLAB(INSTR_RESUME)
504 /*
505 * XXX should assert that it's right kind of tuple here.
506 */
507 v = POP_VALUE();
508
509 pc++; /* point at operand */
510
511 /*
512 * Save the current program position in
513 * the current activation record.
514 */
515 value_tuple_store_integer(&ar, AR_PC, pc + 1);
516
517 /*
518 * Use the existing AR for this fun.
519 */
520
521 /*
522 * Pass parameters to the new AR.
523 * XXX note we should deal with
524 * resumes more cleanly.
525 */
526 XFER_VALUES(&ar, v, IMM_INT());
527
528 value_copy(&ar, v);
529 pc = value_tuple_fetch_integer(v, AR_PC);
530 pc--;
531 VM_NEXT()
532
533 /*
534 % YIELD i : X ->
535 * Transfer a number of values, given by the
536 * immediate integer, back up to the caller.
537 */
538 VM_OPLAB(INSTR_YIELD)
539 pc++;
540 XFER_VALUES(&ar, value_tuple_fetch(&ar, AR_CALLER),
541 IMM_INT());
542 VM_NEXT()
543
544 /*
545 % RET : ->
546 * Transfer control back to the caller.
547 */
548 VM_OPLAB(INSTR_RET)
549 value_tuple_store_integer(&ar, AR_PC, pc + 1); /* save pc in our ar */
550 value_copy(&ar, value_tuple_fetch(&ar, AR_CALLER)); /* switch ar to caller */
551 pc = value_tuple_fetch_integer(&ar, AR_PC); /* move pc to caller */
552 pc--; /* adjust for advance */
553 VM_NEXT()
554
555 /*
556 % REST : ->
557 * Yield to other processes in the system
558 */
559 VM_OPLAB(INSTR_REST)
560 VM_STOP()
561
562 /*
563 % HALT : ->
564 * Stop this virtual machine.
565 */
566 VM_OPLAB(INSTR_HALT)
567 self->done = 1;
568 VM_STOP()
569
570 /*** CONDITIONAL CONTROL FLOW INSTRUCTIONS ***/
571
572 /*
573 % JEQ a : v v ->
574 * Pop two values from the stack, and if they are
575 * equal, branch to a new location in the program
576 * given by the immediate address.
577 */
578 VM_OPLAB(INSTR_JEQ)
579 b = POP_VALUE();
580 a = POP_VALUE();
581 pc++;
582 if (value_equal(a, b)) {
583 pc = IMM_ADDR();
584 pc--;
585 }
586 VM_NEXT()
587
588 /*
589 % JNE a : v v ->
590 * Pop two values from the stack, and if they are not
591 * equal, branch to a new location in the program
592 * given by the immediate address.
593 */
594 VM_OPLAB(INSTR_JNE)
595 b = POP_VALUE();
596 a = POP_VALUE();
597 pc++;
598 if (!value_equal(a, b)) {
599 pc = IMM_ADDR();
600 pc--;
601 }
602 VM_NEXT()
603
604 /*
605 % JLT a : v v ->
606 * Pop two values from the stack, and if the second is
607 * less than the first, branch to a new location in the
608 * program given by the immediate address.
609 */
610 VM_OPLAB(INSTR_JLT)
611 b = POP_VALUE();
612 a = POP_VALUE();
613 pc++;
614 if (value_compare(a, b) == CMP_LT) {
615 pc = IMM_ADDR();
616 pc--;
617 }
618 VM_NEXT()
619
620 /*
621 % JLE a : v v ->
622 * Pop two values from the stack, and if the second is
623 * less than or equal to the first, branch to a new
624 * location in the program given by the immediate address.
625 */
626 VM_OPLAB(INSTR_JLE)
627 b = POP_VALUE();
628 a = POP_VALUE();
629 pc++;
630 if (value_compare(a, b) != CMP_GT) { /* XXX */
631 pc = IMM_ADDR();
632 pc--;
633 }
634 VM_NEXT()
635
636 /*
637 % JGT a : v v ->
638 * Pop two values from the stack, and if the second is
639 * greater than the first, branch to a new location in
640 * the program given by the immediate address.
641 */
642 VM_OPLAB(INSTR_JGT)
643 b = POP_VALUE();
644 a = POP_VALUE();
645 pc++;
646 if (value_compare(a, b) == CMP_GT) {
647 pc = IMM_ADDR();
648 pc--;
649 }
650 VM_NEXT()
651
652 /*
653 % JGE a : v v ->
654 * Pop two values from the stack, and if the second is
655 * greater than or equal to the first, branch to a new
656 * location in the program given by the immediate address.
657 */
658 VM_OPLAB(INSTR_JGE)
659 b = POP_VALUE();
660 a = POP_VALUE();
661 pc++;
662 if (value_compare(a, b) != CMP_LT) { /* XXX */
663 pc = IMM_ADDR();
664 pc--;
665 }
666 VM_NEXT()
667
668 /*** PROCESSES ***/
669
670 /*
671 % OPEN : n n -> p
672 * Pop a name and a mode off the stack, open a
673 * file process for that name, and push it onto the
674 * stack.
675 */
676 VM_OPLAB(INSTR_OPEN)
677 {
678 struct process *p;
679
680 b = POP_VALUE(); /* mode */
681 a = POP_VALUE(); /* name */
682 p = file_open(value_symbol_get_token(a), value_symbol_get_token(b));
683 value_process_set(&t1, p);
684 PUSH_VALUE(&t1);
685 }
686 VM_NEXT()
687
688 /*
689 % STDOUT : -> p
690 * Push a stream process representing the "standard" output
691 * onto the stack. Note that this is not a good
692 * interface, and should be replaced asap, possibly
693 * by OPEN "*stdout" or something.
694 */
695 VM_OPLAB(INSTR_STDOUT)
696 {
697 struct process *p = file_open("*stdout", "w");
698
699 value_process_set(&t1, p);
700 PUSH_VALUE(&t1);
701 }
702 VM_NEXT()
703
704 /*
705 % CLOSE : p ->
706 * Pop a stream process off the stack and close it.
707 */
708 VM_OPLAB(INSTR_CLOSE)
709 a = POP_VALUE();
710 stream_close(self, value_get_process(a));
711 VM_NEXT()
712
713 /*
714 % SPAWN a : -> p
715 * Create a new VM process based on the current
716 * process and start it in the scheduler. The new
717 * process will share the code from this VM and
718 * will begin executing at the given address, but
719 * will not have any ARs of its own, nor will it have
720 * access to this process's ARs.
721 */
722 VM_OPLAB(INSTR_SPAWN)
723 {
724 struct process *spawned;
725
726 value_vm_new(&t1, value_tuple_fetch(vm, VM_CODE));
727 value_tuple_store(&t1, VM_AR, &VNULL);
728 value_tuple_store(&t1, VM_IS_DIRECT, value_tuple_fetch(vm, VM_IS_DIRECT));
729 pc++;
730 value_tuple_store_integer(&t1, VM_PC, IMM_ADDR());
731
732 spawned = vmproc_new(&t1);
733 /* schedule!! */
734 spawned->next = self->next;
735 self->next = spawned;
736
737 value_process_set(&t1, spawned);
738 PUSH_VALUE(&t1);
739 }
740 VM_NEXT()
741
742 /*** INTER-PROCESS COMMUNICATION ***/
743
744 /*
745 % WRITE : v s ->
746 * Pop a stream and a value from the stack
747 * and write the value in a 'raw' manner into
748 * the stream. The value must be a tuple of
749 * small integers, which are interpreted as bytes.
750 * TODO: could also be a symbol, eh?
751 */
752 VM_OPLAB(INSTR_WRITE)
753 {
754 unsigned int i;
755 unsigned char c;
756
757 a = POP_VALUE();
758 v = POP_VALUE();
759
760 /*
761 * XXX this could certainly be optimized
762 * to use scatter/gather I/O and such
763 */
764 for (i = 0; i < value_tuple_get_size(v); i++) {
765 c = (unsigned char)value_get_integer(
766 value_tuple_fetch(v, i)
767 );
768 stream_write(self, value_get_process(a), &c, 1);
769 }
770 }
771 VM_NEXT()
772
773 /*
774 % SEND : v p ->
775 * Pop a process and a value from the stack
776 * and send the value to the process. The value
777 * will be packaged in such a way that a Kosheri
778 * process on the other end will be able to easily
779 * unpackage it to retrieve an exact copy of the
780 * original value.
781 */
782 VM_OPLAB(INSTR_SEND)
783 a = POP_VALUE();
784 v = POP_VALUE();
785
786 value_save(value_get_process(a), v);
787 VM_NEXT()
788
789 /*
790 % PORTRAY : v s ->
791 * Pop a stream and a value from the stack
792 * and render the value in a human-readable
793 * way, into the stream.
794 */
795 VM_OPLAB(INSTR_PORTRAY)
796 a = POP_VALUE();
797 v = POP_VALUE();
798 value_portray(value_get_process(a), v);
799 VM_NEXT()
800
801 /*** ADMINISTRATIVE ***/
802
803 /*
804 % NOP : ->
805 * Explicitly do nothing. Used for padding.
806 */
807 VM_OPLAB(INSTR_NOP)
808 VM_NEXT()
809
810 /*
811 % EOF : ->
812 * Used to indicate the end of the VM bytecode array
813 * in certain contexts. Should never be executed.
814 */
815 VM_OPLAB(INSTR_EOF)
816 assert(IMM_INT() != INSTR_EOF);
817 VM_NEXT()
818
819 VM_END_DISPATCH()
820 }
821
822 value_tuple_store(vm, VM_AR, &ar);
823 value_tuple_store_integer(vm, VM_PC, pc);
824 }
+16
-0
src/vm.h less more
0 /*
1 * vm.h
2 * Virtual machine structures and prototypes.
3 * $Id: vm.h 100 2006-02-25 02:20:09Z catseye $
4 */
5
6 #ifndef __VM_H_
7 #define __VM_H_
8
9 #include "value.h"
10
11 struct process;
12
13 void vm_run(struct value *, struct process *, unsigned int);
14
15 #endif /* !__VM_H_ */
+30
-0
src/vmproc.c less more
0 /*
1 * vmproc.c
2 * Virtual machine code backed processes.
3 */
4
5 #include "lib.h"
6
7 #include "vmproc.h"
8
9 #include "process.h"
10 #include "vm.h"
11
12 static void
13 run(struct process *p)
14 {
15 vm_run(&p->aux_value, p, 100);
16 }
17
18 struct process *
19 vmproc_new(struct value *vm)
20 {
21 struct process *p;
22
23 p = process_new();
24 p->run = run;
25 value_copy(&p->aux_value, vm);
26 p->waiting = 0;
27
28 return p;
29 }
+15
-0
src/vmproc.h less more
0 /*
1 * vmproc.h
2 * Virtual machine code backed processes.
3 */
4
5 #ifndef __VMPROC_H_
6 #define __VMPROC_H_
7
8 struct value;
9 struct process;
10
11 struct process *vmproc_new(struct value *);
12
13 #endif /* !__VMPROC_H_ */
14
+49
-0
test.sh less more
0 #!/bin/sh
1
2 cd src
3
4 make clean all >ERRORS 2>&1
5 if [ $? != 0 ]; then
6 cat ERRORS
7 rm -f ERRORS
8 exit 1
9 fi
10 echo "Testing default build..."
11 falderal -b test ../tests/Assembly.markdown ../tests/Term.markdown
12
13 make clean all CFLAGS=-DDIRECT_THREADING >ERRORS 2>&1
14 if [ $? != 0 ]; then
15 cat ERRORS
16 rm -f ERRORS
17 exit 1
18 fi
19 echo "Testing direct threading build..."
20 falderal -b test ../tests/Assembly.markdown ../tests/Term.markdown
21
22 make clean tool >ERRORS 2>&1
23 if [ $? != 0 ]; then
24 cat ERRORS
25 rm -f ERRORS
26 exit 1
27 fi
28 echo "Testing 'tool' build..."
29 falderal -b test ../tests/Assembly.markdown ../tests/Term.markdown
30
31 make clean static >ERRORS 2>&1
32 if [ $? != 0 ]; then
33 cat ERRORS
34 rm -f ERRORS
35 exit 1
36 fi
37 echo "Testing 'static' build..."
38 falderal -b test ../tests/Assembly.markdown ../tests/Term.markdown
39
40 echo "Building 'debug' version..."
41 make clean debug >ERRORS 2>&1
42 if [ $? != 0 ]; then
43 cat ERRORS
44 rm -f ERRORS
45 exit 1
46 fi
47 make clean
48 rm -f ERRORS
+425
-0
tests/Assembly.markdown less more
0 Kosheri Assembly
1 ================
2
3 -> Functionality "Round-trip Kosheri Assembly" is implemented by shell command
4 -> "./assemble --asmfile %(test-file) --vmfile foo.kvm && ./disasm --vmfile foo.kvm --asmfile %(output-file)"
5
6 -> Tests for functionality "Round-trip Kosheri Assembly"
7
8 | NEW_AR #10
9 | GOTO :past_q
10 | :q
11 | ; no need to reserve space for parameters
12 | GETI #0 ; local #0 = 1st parameter = a
13 | STDOUT
14 | PORTRAY
15 |
16 | GETI #1 ; local #1 = 2nd parameter = b
17 | STDOUT
18 | PORTRAY
19 |
20 | GETI #0
21 | GETI #1
22 | ADD_INT
23 |
24 | YIELD #1 ; pass the result back to our caller
25 | RET ; end of this function
26 |
27 | :past_q
28 |
29 | PUSH #1
30 |
31 | PUSH #2
32 | PUSH #3
33 | PUSH #10 ; this function will need 4 slots: 2 args, 2 stack
34 | FUN :q ; push a closure for q onto the stack
35 | CALL #2 ; call it with two args
36 |
37 | PUSH #10 ; this function will need 4 slots: 2 args, 2 stack
38 | FUN :q ; push a closure for q onto the stack
39 | CALL #2 ; call it with two args
40 |
41 | STDOUT
42 | PORTRAY
43 |
44 | HALT
45 = :L0
46 = NEW_AR #10
47 = GOTO :L20
48 = :L4
49 = GETI #0
50 = STDOUT
51 = PORTRAY
52 = GETI #1
53 = STDOUT
54 = PORTRAY
55 = GETI #0
56 = GETI #1
57 = ADD_INT
58 = YIELD #1
59 = RET
60 = :L20
61 = PUSH #1
62 = PUSH #2
63 = PUSH #3
64 = PUSH #10
65 = FUN :L4
66 = CALL #2
67 = PUSH #10
68 = FUN :L4
69 = CALL #2
70 = STDOUT
71 = PORTRAY
72 = HALT
73 =
74
75 Unused labels aren't produced by the disassembler.
76
77 | NEW_AR #5
78 | :here
79 | PUSH #123
80 | STDOUT
81 | PORTRAY
82 | HALT
83 = :L0
84 = NEW_AR #5
85 = PUSH #123
86 = STDOUT
87 = PORTRAY
88 = HALT
89 =
90
91 Redefining a label is an error.
92
93 | NEW_AR #5
94 | :here
95 | PUSH #123
96 | STDOUT
97 | PORTRAY
98 | :here
99 | HALT
100 ? line 6, column 6, token 'here'): Assembly Error: Label already defined.
101 ? Assembly finished with 1 errors and 0 warnings
102
103 You can include literal terms of all kinds in an assembly file.
104
105 | NEW_AR #5
106 | PUSH #<tuple: THIS, IS, 1, TUPLE>
107 | STDOUT
108 | PORTRAY
109 | HALT
110 = :L0
111 = NEW_AR #5
112 = PUSH #<tuple: THIS, IS, 1, TUPLE>
113 = STDOUT
114 = PORTRAY
115 = HALT
116 =
117
118 -> Functionality "Run Kosheri Assembly" is implemented by shell command
119 -> "./assemble --asmfile %(test-file) --vmfile foo.kvm >/dev/null 2>&1 && ./run --vmfile foo.kvm"
120
121 -> Tests for functionality "Run Kosheri Assembly"
122
123 Hello, world-ing
124 ----------------
125
126 You can include literal terms of all kinds in an assembly file.
127
128 | NEW_AR #5
129 | PUSH #<tuple: THIS, IS, 1, TUPLE>
130 | STDOUT
131 | PORTRAY
132 | HALT
133 = <tuple: THIS, IS, 1, TUPLE>
134
135 Basic Arithmetic
136 ----------------
137
138 Add eight to two and output the answer.
139
140 | NEW_AR #2
141 | PUSH #8
142 | PUSH #2
143 | ADD_INT
144 | STDOUT
145 | PORTRAY
146 | HALT
147 = 10
148
149 Subtract three from twelve and output the answer.
150
151 | NEW_AR #2
152 | PUSH #12
153 | PUSH #3
154 | SUB_INT
155 | STDOUT
156 | PORTRAY
157 | HALT
158 = 9
159
160 Multiply 6 by 7.
161
162 | NEW_AR #2
163 | PUSH #6
164 | PUSH #7
165 | MUL_INT
166 | STDOUT
167 | PORTRAY
168 | HALT
169 = 42
170
171 Divide 40 by 5.
172
173 | NEW_AR #2
174 | PUSH #40
175 | PUSH #5
176 | DIV_INT
177 | STDOUT
178 | PORTRAY
179 | HALT
180 = 8
181
182 Basic Looping
183 -------------
184
185 Count down from 11 to 1.
186
187 | NEW_AR #3
188 | PUSH #11 ; statically initialize our local
189 | :label
190 | GETI #0
191 | STDOUT
192 | PORTRAY
193 | GETI #0
194 | PUSH #1
195 | SUB_INT
196 | SETI #0
197 | GETI #0
198 | PUSH #0
199 | JNE :label
200 | HALT
201 = 1110987654321
202
203 Function calling
204 ----------------
205
206 Call a simple function.
207
208 local q = function(a)
209 print a
210 return 5
211 end
212 print q(4)
213
214 | NEW_AR #5
215 | PUSH #0 ; move stack pointer up for one local, q
216 | GOTO :past_q
217 | :q
218 | ; no need to reserve space for parameters
219 | GETI #0 ; local #0 = 1st parameter = a
220 | STDOUT
221 | PORTRAY
222 |
223 | PUSH #5
224 | YIELD #1 ; pass the result back to our caller
225 | RET ; end of this function
226 |
227 | :past_q
228 | PUSH #5 ; this function will need 2 slots: 1 arg, 1 stack
229 | FUN :q ; push a closure for q onto the stack
230 | SETI #0 ; set local #0 = q
231 |
232 | PUSH #4 ; put argument to pass on the stack
233 | GETI #0 ; put function (AR) to call (activate) on the stack
234 | CALL #1 ; call function, with one argument
235 |
236 | STDOUT ; return value is on the stack. print it
237 | PORTRAY
238 |
239 | HALT
240 = 45
241
242 Make two calls to a function.
243
244 local q = function(a, b)
245 print a
246 print b
247 return a + b
248 end
249 print q(1, q(2, 3))
250
251 | NEW_AR #10
252 | GOTO :past_q
253 | :q
254 | ; no need to reserve space for parameters
255 | GETI #0 ; local #0 = 1st parameter = a
256 | STDOUT
257 | PORTRAY
258 |
259 | GETI #1 ; local #1 = 2nd parameter = b
260 | STDOUT
261 | PORTRAY
262 |
263 | GETI #0
264 | GETI #1
265 | ADD_INT
266 |
267 | YIELD #1 ; pass the result back to our caller
268 | RET ; end of this function
269 |
270 | :past_q
271 |
272 | PUSH #1
273 |
274 | PUSH #2
275 | PUSH #3
276 | PUSH #10 ; this function will need 4 slots: 2 args, 2 stack
277 | FUN :q ; push a closure for q onto the stack
278 | CALL #2 ; call it with two args
279 |
280 | PUSH #10 ; this function will need 4 slots: 2 args, 2 stack
281 | FUN :q ; push a closure for q onto the stack
282 | CALL #2 ; call it with two args
283 |
284 | STDOUT
285 | PORTRAY
286 |
287 | HALT
288 = 23156
289
290 Call an iterator.
291
292 local q = function()
293 yield 1
294 yield 3
295 yield 5
296 end
297 print q()
298 print q()
299 print q()
300
301 | NEW_AR #7
302 | PUSH #0 ; move stack pointer up for one local, q
303 | GOTO :past_q
304 | :q
305 | PUSH #1
306 | YIELD #1 ; yield one value
307 | RET
308 | PUSH #3
309 | YIELD #1 ; yield another value
310 | RET
311 | PUSH #5
312 | YIELD #1
313 | RET
314 |
315 | :past_q
316 | PUSH #7 ; this function will need 1 local
317 | FUN :q ; push a closure for q onto the stack
318 | SETI #0 ; set local #0 = q
319 |
320 | GETI #0 ; call q three times; should get a different
321 | CALL #0 ; result each time.
322 | STDOUT
323 | PORTRAY
324 |
325 | GETI #0
326 | RESUME #0
327 | STDOUT
328 | PORTRAY
329 |
330 | GETI #0
331 | RESUME #0
332 | STDOUT
333 | PORTRAY
334 |
335 | HALT
336 = 135
337
338 Return a function from a function.
339
340 local f = function(a)
341 print a
342 local g = function(b)
343 return b
344 end
345 return g
346 end
347 h = f(3)
348 print h(9)
349
350 | NEW_AR #7
351 | PUSH #0
352 | PUSH #0
353 | GOTO :past_f
354 | :f
355 | GETI #0
356 | STDOUT
357 | PORTRAY
358 |
359 | GOTO :past_g
360 | :g
361 | GETI #0
362 | YIELD #1
363 | RET
364 |
365 | :past_g
366 | PUSH #7
367 | FUN :g
368 | YIELD #1
369 | RET
370 |
371 | :past_f
372 |
373 | PUSH #7 ; this function will need 1 local
374 | FUN :f ; push a closure for f onto the stack
375 | SETI #0
376 |
377 | PUSH #3
378 | GETI #0
379 | CALL #1 ; now we'll have a fun on the stack
380 |
381 | SETI #1
382 | PUSH #9
383 | GETI #1
384 | CALL #1
385 |
386 | STDOUT
387 | PORTRAY
388 |
389 | HALT
390 = 39
391
392 Call a closure.
393
394 local f = function(a)
395 local g = function(b)
396 return a + b
397 end
398 return g
399 end
400 h = f(3)
401 print h(9)
402
403 | HALT
404 =
405
406 Spawn a process!
407
408 The behaviour of this might rely on multithreading details...
409 like that we execute 100 cycles before switching.
410
411 | NEW_AR #7
412 | SPAWN :label
413 | REST
414 | PUSH #main
415 | STDOUT
416 | PORTRAY
417 | HALT
418 | :label
419 | NEW_AR #7
420 | PUSH #worker
421 | STDOUT
422 | PORTRAY
423 | HALT
424 = workermain
+20
-0
tests/Term.markdown less more
0 Kosheri Terms
1 =============
2
3 -> Functionality "Freeze and Thaw Kosheri Term" is implemented by shell command
4 -> "./freeze --termfile %(test-file) --binfile foo.bin && ./thaw --binfile foo.bin --termfile %(output-file)"
5
6 -> Tests for functionality "Freeze and Thaw Kosheri Term"
7
8 Freeze and thaw a well-formed, complex term.
9
10 | [150, symbol, <tuple: THIS, IS, A, TUPLE > , 611,
11 | <0: 1, <snaaa: 2, <pair: 3, 5>, <singleton: t>, <singleton: t>>>,
12 | <0: 1, 2, 3, <0: 2, 3, <pair: 3, snaaa>, 4, 5>>,
13 | [8, 9, 10, jack, queen | king],
14 | 999
15 | ]
16 = <5: 150, <5: symbol, <5: <tuple: THIS, IS, A, TUPLE>, <5: 611, <5: <0: 1, <snaaa: 2, <pair: 3, 5>, <singleton: t>, <singleton: t>>>, <5: <0: 1, 2, 3, <0: 2, 3, <pair: 3, snaaa>, 4, 5>>, <5: <5: 8, <5: 9, <5: 10, <5: jack, <5: queen, king>>>>>, <5: 999, []>>>>>>>>
17
18 | { dict = wonderful, powerful = 3, nested = { dict = 5, pict = rict }, 7 = quaint }
19 = {nested={pict=rict, dict=5}, 7=quaint, powerful=3, dict=wonderful}