diff --git a/.gitignore b/.gitignore index 2979d3d0..e7da217f 100644 --- a/.gitignore +++ b/.gitignore @@ -7,4 +7,5 @@ fasl/bootp.fasl fasl/ol.fasl tmp bin/ol +bin/ol-old bin/vm diff --git a/Makefile b/Makefile index 55b1cadf..8fe7b033 100644 --- a/Makefile +++ b/Makefile @@ -19,15 +19,15 @@ fasl/boot.fasl: fasl/init.fasl # start bootstrapping with the bundled init.fasl image cp fasl/init.fasl fasl/boot.fasl -fasl/ol.fasl: bin/vm fasl/boot.fasl owl/*.scm scheme/*.scm +fasl/ol.fasl: bin/vm fasl/boot.fasl owl/*.scm scheme/*.scm tests/*.scm tests/*.sh # selfcompile boot.fasl until a fixed point is reached bin/vm fasl/boot.fasl --run owl/ol.scm -s none -o fasl/bootp.fasl - ls -la fasl/bootp.fasl + ls -l fasl/bootp.fasl # check that the new image passes tests - CC="$(CC)" tests/run all bin/vm fasl/bootp.fasl + CC="$(CC)" sh tests/run all bin/vm fasl/bootp.fasl # copy new image to ol.fasl if it is a fixed point, otherwise recompile - diff -q fasl/boot.fasl fasl/bootp.fasl && cp fasl/bootp.fasl fasl/ol.fasl || cp fasl/bootp.fasl fasl/boot.fasl && make fasl/ol.fasl - + cmp -s fasl/boot.fasl fasl/bootp.fasl && cp fasl/bootp.fasl fasl/ol.fasl || cp fasl/bootp.fasl fasl/boot.fasl && make fasl/ol.fasl + ## building just the virtual machine to run fasl images @@ -46,6 +46,12 @@ c/vm.c: c/ovm.c echo "unsigned char *heap = 0;" > c/vm.c cat c/ovm.c >> c/vm.c +manual.md: doc/manual.md owl/*.scm scheme/*.scm + cat doc/manual.md > manual.md + bin/find-documentation.sh >> manual.md + +manual.pdf: manual.md + pandoc --latex-engine xelatex -o manual.pdf manual.md ## building standalone image out of the fixed point fasl image @@ -59,7 +65,7 @@ c/diet-ol.c: fasl/ol.fasl bin/ol: c/ol.c # compile the real owl repl binary $(CC) $(CFLAGS) $(LDFLAGS) -o bin/olp c/ol.c - CC="$(CC)" CFLAGS="$(CFLAGS)" LDFLAGS="$(LDFLAGS)" tests/run all bin/olp + CC="$(CC)" CFLAGS="$(CFLAGS)" LDFLAGS="$(LDFLAGS)" sh tests/run all bin/olp test -f bin/ol && mv bin/ol bin/ol-old || true mv bin/olp bin/ol @@ -67,14 +73,14 @@ bin/ol: c/ol.c ## running unit tests manually fasltest: bin/vm fasl/ol.fasl - CC="$(CC)" tests/run all bin/vm fasl/ol.fasl + CC="$(CC)" sh tests/run all bin/vm fasl/ol.fasl test: bin/ol - CC="$(CC)" tests/run all bin/ol + CC="$(CC)" sh tests/run all bin/ol random-test: bin/vm bin/ol fasl/ol.fasl - CC="$(CC)" tests/run random bin/vm fasl/ol.fasl - CC="$(CC)" tests/run random bin/ol + CC="$(CC)" sh tests/run random bin/vm fasl/ol.fasl + CC="$(CC)" sh tests/run random bin/ol ## data @@ -127,4 +133,3 @@ todo: bin/vm bin/vm fasl/ol.fasl -n owl/*.scm | less .PHONY: all owl install uninstall todo test fasltest random-test owl standalone fasl-update clean simple-ol - diff --git a/README.md b/README.md index c875bdda..10bb5c51 100644 --- a/README.md +++ b/README.md @@ -87,7 +87,8 @@ functions. To make programs run faster, one can use for example: For further documentation and updates, see: - https://haltp.org/n/owl - https://github.com/aoh/owl-lisp + + https://haltp.org/f/owl-manual.pdf + diff --git a/THANKS b/THANKS index 4f7ad326..26706a61 100644 --- a/THANKS +++ b/THANKS @@ -3,8 +3,9 @@ has gotten many useful bug reports, suggestions and patches during the course of development. Here is a partial list of people who have helped in the development: + Jo Henke A ton of improvements Doug Currie GC improvements, data representation optimizations, etc. - Jown Cowan A slew of filed bugs. + John Cowan A slew of filed bugs. Pekka Pietikäinen Portability suggestions and patches. Erno Kuusela Portability suggestions and general insight. diff --git a/bench/indexed.owl b/bench/indexed.owl index f306a493..00c675ba 100644 --- a/bench/indexed.owl +++ b/bench/indexed.owl @@ -10,12 +10,12 @@ ; - iff (integer finite map) ; - rlist (random access list) ; - vector (a wide-branched tree) -; +; ; notice that these are not otherwise equal data structures ; rlists have O(1) cons, vectors O(1) length, iffs can be ; sparse but take a bit more memory etc. still, useful to ; know how they do for reading. -; +; (define cutoff-time 50) ; run each test until elaped time is over >cutoff-time ms @@ -85,7 +85,7 @@ (define (battle len participants ordered? op) ;(print* (list (if ordered? "in order " "random access ") "read of " len " elems")) - (mail 1 (render (length participants) '())) (flush-port 1) + (mail 1 (render (length participants) '())) (if (null? participants) (begin (print ")") @@ -112,13 +112,11 @@ numbers can be before reading/writing each value once takes over " cutoff-time "ms.")) (print "--- READ BENCHMARK ----------------------------") (display " - in-order access (") - (flush-port 1) (for-each (λ (p) (print* (list " + " (cdr p) " " (car p)))) (battle 1 '(list rlist vector iff) #t read-each)) (print "") (display " - random access (") - (flush-port 1) (for-each (λ (p) (print* (list " + " (cdr p) " " (car p)))) (battle 1 '(list rlist vector iff) #f read-each)) @@ -126,12 +124,10 @@ over " cutoff-time "ms.")) (print "--- WRITE BENCHMARK ----------------------------") (print "vectors have no write yet..") (display " - in-order write (") - (flush-port 1) (for-each (λ (p) (print* (list " + " (cdr p) " " (car p)))) (battle 1 '(list rlist iff) #t write-each)) (display " - random order write (") - (flush-port 1) (for-each (λ (p) (print* (list " + " (cdr p) " " (car p)))) (battle 1 '(list rlist iff) #f write-each)) diff --git a/bin/builder b/bin/builder index a087e318..f78a6ac2 100755 --- a/bin/builder +++ b/bin/builder @@ -4,8 +4,6 @@ # and run randomized tests in the meantime. # you probably don't want to run this. -renice +20 $$ - DELAY=60 # sleep n seconds between test runs TESTMINS=15 # minutes of random unit tests THEOREMS=5000 # iterations of theorem test @@ -18,11 +16,13 @@ MD5=md5sum echo "" | $MD5 | grep -q 68b329da9893e34099c7d8ad5cb9c940 || MD5="md5" ME=$($MD5 < bin/builder) -echo "My version is $ME" +die() { + echo "$@" + exit 1 +} fail() { - echo "error: $@" - exit 1 + die "ERROR: $@" } check_exe() { @@ -32,7 +32,7 @@ check_exe() { notify() { echo "MAIL: $@" - mailx -S "from=Note <$(whoami)@$(hostname --long)>" -S smtp=$SMTP -s "$(echo $@)" $EMAIL + heirloom-mailx -S "from=Note <$(whoami)@$(hostname --long)>" -S smtp=$SMTP -s "$(echo $@)" $EMAIL } notify_irc() { @@ -49,8 +49,24 @@ thisgit() { git log | head -n 1 | sed -e 's/.* \(......\).*/\1.../' } +confirm_or_exit() { + echo "$@" + read -p "yes/no? " RESPONSE + echo $RESPONSE | grep -Eqi "^y(es)?$" || die "taking that as a no" +} + +# check that user knows what this script does and really wants to run it +# unless --really is given as first argument + +test "$1" = "--really" \ + || confirm_or_exit "Owl is built with make. This script starts continuous builds and related tool tests at $WORK. Is this what you are trying to do?" + +echo "My version is $ME" + +renice +20 $$ + echo "Checking deps:" -for DEP in nc $MD5 mailx +for DEP in nc $MD5 heirloom-mailx do check_exe $DEP done @@ -70,8 +86,7 @@ esac date | notify "Builder.sh started on $(hostname)" date | notify_irc "builder started on $(hostname) ($(uname), $(uname -m), $(echo $ME | dd bs=1 count=5 2>/dev/null))" -test -d $WORK || fail "work directory '$WORK' doesn't exist" - +mkdir -p $WORK || die "cannot have $WORK" cd $WORK echo "*** GETTING SOURCES ***" @@ -79,6 +94,7 @@ for project in owl-lisp $RELATEDPROJECTS do echo " - $project" test -d $project || git clone https://github.com/aoh/$project.git + cd $project && git checkout develop || echo "no develop branch for $project" done while true @@ -94,7 +110,7 @@ do git pull NEWME=$($MD5 < bin/builder) echo "old me $ME, new me $NEWME" - test "$ME" = "$NEWME" || { notify_irc "I sense bin/builder has changed."; cd "$MYDIR"; git pull; exec bin/builder; } + test "$ME" = "$NEWME" || { notify_irc "I sense bin/builder has changed."; cd "$MYDIR"; git pull; exec bin/builder --really; } make clean >/dev/null 2>&1 VERSION=$(thisgit) echo building owl @@ -118,6 +134,7 @@ do echo "*** BUILDING SIDE PROJECTS ***" for project in $RELATEDPROJECTS do + mkdir -p $HOME/ram cd $HOME/ram echo " - fresh $project build" cd $project diff --git a/bin/find-documentation.sh b/bin/find-documentation.sh new file mode 100755 index 00000000..792e42f0 --- /dev/null +++ b/bin/find-documentation.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +for FILE in owl/*.scm scheme/*.scm +do + head -n 1 "$FILE" | grep -q "^;;; " || continue + NAME=$(grep "^(define-library " $FILE | head -n 1 | sed -e 's/.define-library //') + echo "## $NAME" + echo "" + grep "^;;;" "$FILE" | sed -re 's/;;; ?//' + echo "" + echo +done diff --git a/c/lib.c b/c/lib.c new file mode 100644 index 00000000..e290ed8c --- /dev/null +++ b/c/lib.c @@ -0,0 +1,60 @@ +/* library mode init */ +void init() { + int nobjs=0, nwords=0; + hp = (byte *) &heap; /* builtin heap */ + state = IFALSE; + heap_metrics(&nwords, &nobjs); + max_heap_mb = (W == 4) ? 4096 : 65535; + nwords += nobjs + INITCELLS; + memstart = genstart = fp = (word *) realloc(NULL, (nwords + MEMPAD)*W); + if (!memstart) exit(4); + memend = memstart + nwords - MEMPAD; + state = (word) load_heap(nobjs); +} + +/* bvec → value library call test with preserved state */ +word library_call(size_t len, char *ptr) { + char *pos; + int pads; + word *bvec; + word res; + word program_state = state; + int size; + state = IFALSE; + if (program_state == IFALSE) { + printf("no program state - cannot continue"); + exit(1); + } + if (len > FMAX) { + return (char *) NULL; + } + size = ((len % W) == 0) ? (len/W)+1 : (len/W) + 2; + printf("making an argument byte vector with %d bytes in %d words\n", len, size); + pads = (size-1)*W - len; + bvec = fp; + fp += size; + printf("libary call from state %d\n", state); + *bvec = make_raw_header(size, TBVEC, pads); + pos = ((byte *) bvec) + W; + while(len--) *pos++ = *ptr++; + res = vm(program_state, bvec); + if(fixnump(res)) { + printf("Returned %d\n", fixval(res)); + } else { + printf("Returned descriptor %d\n", res); + } + return res; +} + +int main(int nargs, char **argv) { + init(); + char foo[] = {1, 2, 3}; // 0 + char bar[] = {4, 5}; // 6 + char baz[] = {6, 7, 8, 9}; // 15 + library_call(3, &foo); + library_call(2, &bar); + library_call(4, &baz); + return 0; +} + + diff --git a/c/ovm.c b/c/ovm.c index 437f16f1..6371ba31 100644 --- a/c/ovm.c +++ b/c/ovm.c @@ -14,64 +14,105 @@ #include #include #include -#include #include #include -#ifndef O_BINARY -#define O_BINARY 0 +#ifndef EMULTIHOP +#define EMULTIHOP -1 +#endif +#ifndef ENODATA +#define ENODATA -1 +#endif +#ifndef ENOLINK +#define ENOLINK -1 +#endif +#ifndef ENOSR +#define ENOSR -1 +#endif +#ifndef ENOSTR +#define ENOSTR -1 +#endif +#ifndef ETIME +#define ETIME -1 +#endif +#ifndef F_DUPFD_CLOEXEC +#define F_DUPFD_CLOEXEC -1 +#endif +#ifndef O_CLOEXEC +#define O_CLOEXEC 0 +#endif +#ifndef O_EXEC +#define O_EXEC 0 +#endif +#ifndef O_NOFOLLOW +#define O_NOFOLLOW 0 +#endif +#ifndef O_RSYNC +#define O_RSYNC 0 +#endif +#ifndef O_SEARCH +#define O_SEARCH 0 +#endif +#ifndef O_TTY_INIT +#define O_TTY_INIT 0 +#endif +#ifdef __APPLE__ +#define st_atim st_atimespec +#define st_mtim st_mtimespec +#define st_ctim st_ctimespec #endif typedef uintptr_t word; typedef uint8_t byte; -#ifdef _LP64 -typedef int64_t wdiff; -#else -typedef int32_t wdiff; -#endif +typedef intptr_t wdiff; /*** Macros ***/ #define IPOS 8 /* offset of immediate payload */ #define SPOS 16 /* offset of size bits in header immediate values */ #define TPOS 2 /* offset of type bits in header */ -#define V(ob) *((word *) (ob)) -#define W sizeof(word) +#define V(ob) (*(word *)(ob)) +#define W ((unsigned int)sizeof(word)) #define NWORDS 1024*1024*8 /* static malloc'd heap size if used as a library */ #define FBITS 24 /* bits in fixnum, on the way to 24 and beyond */ #define FMAX ((1<> IPOS) -#define fixnump(desc) (((desc)&255) == 2) -#define fliptag(ptr) ((word)ptr^2) /* make a pointer look like some (usually bad) immediate object */ +#define immval(desc) ((desc) >> IPOS) +#define fixnump(desc) (((desc) & 255) == 2) #define NR 190 /* fixme, should be ~32, see n-registers in register.scm */ -#define header(x) *((word *)x) +#define header(x) V(x) #define imm_type(x) (((x) >> TPOS) & 63) -#define imm_val(x) ((x) >> IPOS) -#define hdrsize(x) ((((word)x) >> SPOS) & MAXOBJ) -#define immediatep(x) (((word)x)&2) +#define is_type(x, t) (((x) & (63 << TPOS | 2)) == ((t) << TPOS | 2)) +#define hdrsize(x) (((word)(x) >> SPOS) & MAXOBJ) +#define immediatep(x) ((word)(x) & 2) #define allocp(x) (!immediatep(x)) -#define rawp(hdr) ((hdr)&RAWBIT) +#define rawp(hdr) ((hdr) & RAWBIT) #define NEXT(n) ip += n; op = *ip++; goto main_dispatch /* default NEXT, smaller vm */ #define NEXT_ALT(n) ip += n; op = *ip++; EXEC /* more branch predictor friendly, bigger vm */ -#define PAIRHDR make_header(3,1) -#define NUMHDR make_header(3,40) /* <- on the way to 40, see type-int+ in defmac.scm */ -#define pairp(ob) (allocp(ob) && V(ob)==PAIRHDR) -#define INULL make_immediate(0,13) -#define IFALSE make_immediate(1,13) -#define ITRUE make_immediate(2,13) -#define IEMPTY make_immediate(3,13) /* empty ff */ -#define IEOF make_immediate(4,13) -#define IHALT make_immediate(5,13) +#define PAIRHDR make_header(3, 1) +#define NUMHDR make_header(3, 40) /* <- on the way to 40, see type-int+ in defmac.scm */ +#define NUMNHDR make_header(3, 41) +#define pairp(ob) (allocp(ob) && V(ob) == PAIRHDR) +#define cons(a, d) mkpair(PAIRHDR, a, d) +#define INULL make_immediate(0, 13) +#define IFALSE make_immediate(1, 13) +#define ITRUE make_immediate(2, 13) +#define IEMPTY make_immediate(3, 13) /* empty ff */ +#define IEOF make_immediate(4, 13) +#define IHALT make_immediate(5, 13) +#define TNUM 0 #define TTUPLE 2 +#define TSTRING 3 +#define TPORT 12 #define TTHREAD 31 +#define TNUMN 32 #define TFF 24 #define FFRIGHT 1 #define FFRED 2 @@ -79,28 +120,32 @@ typedef int32_t wdiff; #define TBYTECODE 16 #define TPROC 17 #define TCLOS 18 -#define cont(n) V((word)n&(~1)) -#define flagged(n) (n&1) -#define flag(n) (((word)n)^1) -#define A0 R[*ip] +#define F(value) make_immediate(value, TNUM) +#define stringp(ob) (allocp(ob) && (V(ob) & make_header(0, 63)) == make_header(0, TSTRING)) +#define FLAG 1 +#define cont(n) V((word)(n) & ~FLAG) +#define flag(n) ((word)(n) ^ FLAG) +#define flagged(n) ((word)(n) & FLAG) +#define flagged_or_raw(n) ((word)(n) & (RAWBIT | FLAG)) +#define TBIT 0x1000 +#define teardown_needed(hdr) ((word)(hdr) & TBIT) +#define A0 R[*ip] #define A1 R[ip[1]] #define A2 R[ip[2]] #define A3 R[ip[3]] #define A4 R[ip[4]] #define A5 R[ip[5]] -#define G(ptr,n) ((word *)(ptr))[n] -#define flagged_or_raw(hdr) (hdr&(RAWBIT|1)) -#define TICKS 10000 /* # of function calls in a thread quantum */ -#define allocate(size, to) to = fp; fp += size; -#define error(opcode, a, b) R[4] = F(opcode); R[5] = (word) a; R[6] = (word) b; goto invoke_mcp; -#define assert(exp,val,code) if(!(exp)) {error(code, val, ITRUE);} -#define assert_not(exp,val,code) if(exp) {error(code, val, ITRUE);} -#define RET(n) ob=(word *)R[3]; R[3] = R[n]; acc = 1; goto apply -#define MEMPAD (NR+2)*8 /* space at end of heap for starting GC */ -#define MINGEN 1024*32 /* minimum generation size before doing full GC */ +#define G(ptr, n) (((word *)(ptr))[n]) +#define TICKS 10000 /* # of function calls in a thread quantum */ +#define allocate(size, to) (to = fp, fp += size) +#define error(opcode, a, b) R[4] = F(opcode); R[5] = (word)a; R[6] = (word)b; goto invoke_mcp; +#define assert(exp, val, code) if (!(exp)) { error(code, val, ITRUE); } +#define assert_not(exp, val, code) if (exp) { error(code, val, ITRUE); } +#define MEMPAD (NR + 2) * 8 /* space at end of heap for starting GC */ +#define MINGEN 1024 * 32 /* minimum generation size before doing full GC */ #define INITCELLS 100000 -#define OCLOSE(proctype) { word size = *ip++, tmp; word *ob; allocate(size, ob); tmp = R[*ip++]; tmp = ((word *) tmp)[*ip++]; *ob = make_header(size, proctype); ob[1] = tmp; tmp = 2; while(tmp != size) { ob[tmp++] = R[*ip++]; } R[*ip++] = (word) ob; } -#define CLOSE1(proctype) { word size = *ip++, tmp; word *ob; allocate(size, ob); tmp = R[1]; tmp = ((word *) tmp)[*ip++]; *ob = make_header(size, proctype); ob[1] = tmp; tmp = 2; while(tmp != size) { ob[tmp++] = R[*ip++]; } R[*ip++] = (word) ob; } +#define OCLOSE(proctype) { word size = *ip++, tmp; word *ob; allocate(size, ob); tmp = R[*ip++]; tmp = G(tmp, *ip++); *ob = make_header(size, proctype); ob[1] = tmp; tmp = 2; while (tmp != size) ob[tmp++] = R[*ip++]; R[*ip++] = (word)ob; } +#define CLOSE1(proctype) { word size = *ip++, tmp; word *ob; allocate(size, ob); tmp = R[1]; tmp = G(tmp, *ip++); *ob = make_header(size, proctype); ob[1] = tmp; tmp = 2; while (tmp != size) ob[tmp++] = R[*ip++]; R[*ip++] = (word)ob; } #define EXEC switch(op&63) { \ case 0: goto op0; case 1: goto op1; case 2: goto op2; case 3: goto op3; case 4: goto op4; case 5: goto op5; \ case 6: goto op6; case 7: goto op7; case 8: goto op8; case 9: goto op9; \ @@ -117,6 +162,8 @@ typedef int32_t wdiff; /*** Globals and Prototypes ***/ +extern char **environ; + /* memstart <= genstart <= memend */ static word *genstart; static word *memstart; @@ -131,10 +178,10 @@ byte *file_heap; word vm(word *ob, word *arg); void exit(int rval); void *realloc(void *ptr, size_t size); -void *malloc(size_t size); void free(void *ptr); char *getenv(const char *name); int setenv(const char *name, const char *value, int overwrite); +int unsetenv(const char *); DIR *opendir(const char *name); DIR *fdopendir(int fd); pid_t fork(void); @@ -144,20 +191,19 @@ int select(int nfds, fd_set *readfds, fd_set *writefds, fd_set *exceptfds, struc int execv(const char *path, char *const argv[]); struct termios tsettings; - /*** Garbage Collector, based on "Efficient Garbage Compaction Algorithm" by Johannes Martin (1982) ***/ static __inline__ void rev(word pos) { word val = V(pos); word next = cont(val); - *(word *) pos = next; - cont(val) = (val&1)^(pos|1); + V(pos) = next; + cont(val) = (pos | FLAG) ^ (val & FLAG); } static __inline__ word *chase(word *pos) { word val = cont(pos); while (allocp(val) && flagged(val)) { - pos = (word *) val; + pos = (word *)val; val = cont(pos); } return pos; @@ -166,16 +212,16 @@ static __inline__ word *chase(word *pos) { static void mark(word *pos, word *end) { while (pos != end) { word val = *pos; - if (allocp(val) && val >= ((word) genstart)) { + if (allocp(val) && val >= (word)genstart) { if (flagged(val)) { - pos = ((word *) flag(chase((word *) val))) - 1; + pos = (word *)flag(chase((word *)val)) - 1; } else { word hdr = V(val); rev((word) pos); if (flagged_or_raw(hdr)) { pos--; } else { - pos = ((word *) val) + (hdrsize(hdr)-1); + pos = (word *)val + hdrsize(hdr) - 1; } } } else { @@ -189,15 +235,13 @@ static word *compact() { word *old = new; word *end = memend - 1; while (((word)old) < ((word)end)) { - if (flagged(*old)) { + word val = *old; + if (flagged(val)) { word h; - *new = *old; - while (flagged(*new)) { + *new = val; + do { /* unthread */ rev((word) new); - if (immediatep(*new) && flagged(*new)) { - *new = flag(*new); - } - } + } while (flagged(*new)); h = hdrsize(*new); if (old == new) { old += h; @@ -208,14 +252,17 @@ static word *compact() { new++; } } else { - old += hdrsize(*old); + if (teardown_needed(val)) { + printf("gc: would teardown\n"); + } + old += hdrsize(val); } } - return new; + return new; } -void fix_pointers(word *pos, wdiff delta, word *end) { - while(1) { +void fix_pointers(word *pos, wdiff delta) { + for (;;) { word hdr = *pos; int n = hdrsize(hdr); if (hdr == 0) return; /* end marker reached. only dragons beyond this point.*/ @@ -234,14 +281,14 @@ void fix_pointers(word *pos, wdiff delta, word *end) { } } -/* emulate sbrk with malloc'd memory, becuse sbrk is no longer properly supported */ -/* n-cells-wanted → heap-delta (to be added to pointers), updates memstart and memend */ -wdiff adjust_heap(int cells) { +/* emulate sbrk with malloc'd memory, because sbrk is no longer properly supported */ +/* n-cells-wanted → heap-delta (to be added to pointers), updates memstart and memend */ +wdiff adjust_heap(wdiff cells) { word *old = memstart; word nwords = memend - memstart + MEMPAD; /* MEMPAD is after memend */ - word new_words = nwords + ((cells > 0xffffff) ? 0xffffff : cells); /* limit heap growth speed */ + word new_words = nwords + (cells > 0xffffff ? 0xffffff : cells); /* limit heap growth speed */ if (((cells > 0) && (new_words*W < nwords*W)) || ((cells < 0) && (new_words*W > nwords*W))) - return 0; /* don't try to adjust heap if the size_t would overflow in realloc */ + return 0; /* don't try to adjust heap, if the size_t would overflow in realloc */ memstart = realloc(memstart, new_words*W); if (memstart == old) { /* whee, no heap slide \o/ */ memend = memstart + new_words - MEMPAD; /* leave MEMPAD words alone */ @@ -249,7 +296,7 @@ wdiff adjust_heap(int cells) { } else if (memstart) { /* d'oh! we need to O(n) all the pointers... */ wdiff delta = (word)memstart - (word)old; memend = memstart + new_words - MEMPAD; /* leave MEMPAD words alone */ - fix_pointers(memstart, delta, memend); + fix_pointers(memstart, delta); return delta; } else { breaked |= 8; /* will be passed over to mcp at thread switch*/ @@ -262,26 +309,25 @@ wdiff adjust_heap(int cells) { static word *gc(int size, word *regs) { word *root; word *realend = memend; - int nfree; + wdiff nfree; fp = regs + hdrsize(*regs); root = fp+1; *root = (word) regs; memend = fp; mark(root, fp); fp = compact(); - regs = (word *) *root; + regs = (word *)*root; memend = realend; nfree = (word)memend - (word)regs; if (genstart == memstart) { word heapsize = (word) memend - (word) memstart; word nused = heapsize - nfree; - if ((heapsize/(1024*1024)) > max_heap_mb) { - breaked |= 8; /* will be passed over to mcp at thread switch*/ - } - nfree -= size*W + MEMPAD; /* how much really could be snipped off */ + if (heapsize / (1024 * 1024) > max_heap_mb) + breaked |= 8; /* will be passed over to mcp at thread switch */ + nfree -= size*W + MEMPAD; /* how much really could be snipped off */ if (nfree < (heapsize / 5) || nfree < 0) { /* increase heap size if less than 20% is free by ~10% of heap size (growth usually implies more growth) */ - regs[hdrsize(*regs)] = 0; /* use an invalid descriptor to denote end live heap data */ + regs[hdrsize(*regs)] = 0; /* use an invalid descriptor to denote end live heap data */ regs = (word *) ((word)regs + adjust_heap(size*W + nused/10 + 4096)); nfree = memend - regs; if (nfree <= size) { @@ -289,15 +335,15 @@ static word *gc(int size, word *regs) { } } else if (nfree > (heapsize/3)) { /* decrease heap size if more than 33% is free by 10% of the free space */ - int dec = -(nfree/10); - int new = nfree - dec; + wdiff dec = -(nfree / 10); + wdiff new = nfree - dec; if (new > size*W*2 + MEMPAD) { regs[hdrsize(*regs)] = 0; /* as above */ regs = (word *) ((word)regs + adjust_heap(dec+MEMPAD*W)); - heapsize = (word) memend - (word) memstart; - nfree = (word) memend - (word) regs; - } - } + heapsize = (word)memend - (word)memstart; + nfree = (word)memend - (word)regs; + } + } genstart = regs; /* always start new generation */ } else if (nfree < MINGEN || nfree < size*W*2) { genstart = memstart; /* start full generation */ @@ -310,16 +356,12 @@ static word *gc(int size, word *regs) { /*** OS Interaction and Helpers ***/ -void toggle_blocking(int sock, int blockp) { - fcntl(sock, F_SETFL, fcntl(sock, F_GETFD)^O_NONBLOCK); -} - void signal_handler(int signal) { switch(signal) { - case SIGINT: + case SIGINT: breaked |= 2; break; case SIGPIPE: break; /* can cause loop when reporting errors */ - default: + default: breaked |= 4; } } @@ -337,13 +379,20 @@ unsigned int lenn(byte *pos, unsigned int max) { /* added here, strnlen was miss /* list length, no overflow or valid termination checks */ int llen(word *ptr) { int len = 0; - while(allocp(ptr) && *ptr == PAIRHDR) { + while(pairp(ptr)) { len++; ptr = (word *) ptr[2]; } return len; } +static word payl_len(word hdr) { + word len = (hdrsize(hdr) - 1) * W; + if (rawp(hdr)) + len -= (hdr >> 8) & 7; + return len; +} + void set_signal_handler() { struct sigaction sa; sa.sa_handler = signal_handler; @@ -353,39 +402,43 @@ void set_signal_handler() { sigaction(SIGPIPE, &sa, NULL); } +static word mkpair(word h, word a, word d) { + word *pair; + allocate(3, pair); + pair[0] = h; + pair[1] = a; + pair[2] = d; + return (word)pair; +} + /* make a byte vector object to hold len bytes (compute size, advance fp, set padding count) */ -static word *mkbvec(int len, int type) { - int nwords = (len/W) + ((len % W) ? 2 : 1); +static word *mkbvec(size_t len, int type) { + int nwords = OBJWORDS(len); int pads = (nwords-1)*W - len; - word *ob = fp; - fp += nwords; + word *ob; + byte *end; + allocate(nwords, ob); + end = (byte *)ob + W + len; *ob = make_raw_header(nwords, type, pads); + while (pads--) + *end++ = 0; /* clear the padding bytes */ return ob; } -/* map a null or C-string to False, Null or owl-string, false being null or too large string */ -word strp2owl(byte *sp) { - int len; - word *res; - if (!sp) return IFALSE; - len = lenn(sp, FMAX+1); - if (len == FMAX+1) return INULL; /* can't touch this */ - res = mkbvec(len, TBVEC); /* make a bvec instead of a string since we don't know the encoding */ - bytecopy(sp, ((byte *)res)+W, len); - return (word)res; -} - /*** Primops called from VM and generated C-code ***/ -static word prim_connect(word *host, word port) { +static word prim_connect(word *host, word port, word type) { int sock; - byte *ip = ((unsigned char *) host) + W; + byte *ip = (unsigned char *)host + W; unsigned long ipfull; struct sockaddr_in addr; - port = fixval(port); - if (!allocp(host)) /* bad host type */ + char udp = (immval(type) == 1); + port = immval(port); + if ((sock = socket(PF_INET, (udp ? SOCK_DGRAM : SOCK_STREAM), (udp ? IPPROTO_UDP : 0))) == -1) return IFALSE; - if ((sock = socket(PF_INET, SOCK_STREAM, 0)) == -1) + if (udp) + return make_immediate(sock, TPORT); + if (!allocp(host)) /* bad host type */ return IFALSE; addr.sin_family = AF_INET; addr.sin_port = htons(port); @@ -396,8 +449,7 @@ static word prim_connect(word *host, word port) { close(sock); return IFALSE; } - toggle_blocking(sock,0); - return F(sock); + return make_immediate(sock, TPORT); } static word prim_less(word a, word b) { @@ -411,20 +463,21 @@ static word prim_less(word a, word b) { static word prim_get(word *ff, word key, word def) { /* ff assumed to be valid */ while((word) ff != IEMPTY) { /* ff = [header key value [maybe left] [maybe right]] */ word this = ff[1], hdr; - if (this == key) + if (this == key) return ff[2]; hdr = *ff; switch(hdrsize(hdr)) { - case 3: return def; + case 3: + return def; case 4: if (key < this) { - ff = (word *) ((hdr & (1 << TPOS)) ? IEMPTY : ff[3]); + ff = (word *)(hdr & (1 << TPOS) ? IEMPTY : ff[3]); } else { - ff = (word *) ((hdr & (1 << TPOS)) ? ff[3] : IEMPTY); + ff = (word *)(hdr & (1 << TPOS) ? ff[3] : IEMPTY); } break; default: - ff = (word *) ((key < this) ? ff[3] : ff[4]); + ff = (word *)(key < this ? ff[3] : ff[4]); } } return def; @@ -432,42 +485,36 @@ static word prim_get(word *ff, word key, word def) { /* ff assumed to be valid * static word prim_cast(word *ob, int type) { if (immediatep((word)ob)) { - return make_immediate(imm_val((word)ob), type); + return make_immediate(immval((word)ob), type & 63); } else { /* make a clone of more desired type */ word hdr = *ob++; int size = hdrsize(hdr); word *new, *res; /* <- could also write directly using *fp++ */ allocate(size, new); res = new; - /* (hdr & 0b...11111111111111111111100000000111) | tttttttt000 */ - //*new++ = (hdr&(~2040))|(type<= payl_len(header(pword))) return IFALSE; - hdr = *ob; - hsize = ((hdrsize(hdr)-1)*W) - ((hdr>>8)&7); /* bytes - pads */ - if (pos >= hsize) - return IFALSE; - return F(((byte *) ob)[pos+W]); + return F(((byte *)pword)[W + pos]); } -static word prim_ref(word pword, word pos) { - word *ob = (word *) pword; +static word prim_ref(word pword, word pos) { + word *ob = (word *)pword; word hdr, size; - pos = fixval(pos); - if(immediatep(ob)) { return IFALSE; } + pos = immval(pos); + if (immediatep(ob)) + return IFALSE; hdr = *ob; - if (rawp(hdr)) { /* raw data is #[hdrbyte{W} b0 .. bn 0{0,W-1}] */ - size = ((hdrsize(hdr)-1)*W) - ((hdr>>8)&7); - if (pos >= size) { return IFALSE; } + if (rawp(hdr)) { /* raw data is #[hdrbyte{W} b0 .. bn 0{0,W-1}] */ + size = payl_len(hdr); + if (pos >= size) + return IFALSE; return F(((byte *) ob)[pos+W]); } size = hdrsize(hdr); @@ -477,104 +524,100 @@ static word prim_ref(word pword, word pos) { } static int64_t cnum(word a) { - if(allocp(a)) { - int64_t x = 0; - int shift = 0; - word *p = (word *) a; - while(a != INULL) { - x |= F(p[1]) << shift; + uint64_t x; + if (allocp(a)) { + word *p = (word *)a; + unsigned int shift = 0; + x = 0; + do { + x |= immval(p[1]) << shift; shift += FBITS; - p = (word *) p[2]; - } - return x; - } else { - return fixval(a); + p = (word *)p[2]; + } while (shift < 64 && allocp(p)); + return header(a) == NUMNHDR ? -x : x; } + x = immval(a); + return is_type(a, TNUMN) ? -x : x; } -static word onum(int64_t a) { - if (a < 0) { - if (a < 0-FMAX) - exit(42); - return FN(0-a); - } else if (a > FMAX) { - word *r = fp; - if (a >= ((int64_t)1 << FBITS*2)) - exit(42); - r[0] = make_header(3, 40); - r[4] = F(a>>FBITS); - r[2] = (word) (r + 3); - r[3] = make_header(3, 40); - r[1] = F(a&FMAX); - r[5] = INULL; - fp += 6; - return (word) r; +static word onum(int64_t a, int s) { + uint64_t x = a; + word h = NUMHDR, t = TNUM; + if (s && a < 0) { + h = NUMNHDR; + t = TNUMN; + x = -a; } - return F(a); + if (x > FMAX) { + word p = INULL; + unsigned int shift = (63 / FBITS) * FBITS; + while (!(x & ((uint64_t)FMAX << shift))) + shift -= FBITS; + do { + p = mkpair(NUMHDR, F((x >> shift) & FMAX), p); + shift -= FBITS; + } while (shift + FBITS); + header(p) = h; + return p; + } + return make_immediate(x, t); } static word prim_set(word wptr, word pos, word val) { - word *ob = (word *) wptr; - word hdr; + word *ob = (word *)wptr; + word hdr, p; word *new; - int p = 0; - pos = fixval(pos); - if(immediatep(ob)) { return IFALSE; } + pos = immval(pos); + if (immediatep(ob)) + return IFALSE; hdr = *ob; - if (rawp(hdr) || hdrsize(hdr) < pos) { return IFALSE; } + if (rawp(hdr) || hdrsize(hdr) < pos) + return IFALSE; hdr = hdrsize(hdr); allocate(hdr, new); - while(p <= hdr) { + for (p = 0; p <= hdr; ++p) new[p] = (pos == p && p) ? val : ob[p]; - p++; - } return (word) new; } +void setdown() { + tcsetattr(0, TCSANOW, &tsettings); /* return stdio settings */ +} + /* system- and io primops */ static word prim_sys(int op, word a, word b, word c) { switch(op) { - case 0: { /* 0 fsend fd buff len r → n if wrote n, 0 if busy, False if error (argument or write) */ - int fd = fixval(a); - word *buff = (word *) b; - int wrote, size, len = fixval(c); - if (immediatep(buff)) return IFALSE; - size = (hdrsize(*buff)-1)*W; - if (len > size) return IFALSE; - wrote = write(fd, ((byte *)buff)+W, len); - if (wrote > 0) return F(wrote); - if (errno == EAGAIN || errno == EWOULDBLOCK) return F(0); - return IFALSE; } - case 1: { /* 1 = fopen */ - char *path = (char *) a; - int mode = fixval(b); - int val = 0; - struct stat sb; - if (!(allocp(path) && imm_type(header(a)) == 3)) - return IFALSE; - val |= ((mode & 1) ? O_WRONLY : O_RDONLY) \ - | ((mode & 2) ? O_TRUNC : 0) \ - | ((mode & 4) ? O_APPEND : 0) \ - | ((mode & 8) ? O_CREAT : 0); - val = open(((char *) path) + W, val, (S_IRUSR|S_IWUSR)); - if (val < 0 || fstat(val, &sb) == -1 || sb.st_mode & S_IFDIR) { - close(val); - return IFALSE; + case 0: /* write fd data len | #f → nbytes | #f */ + if (is_type(a, TPORT) && allocp(b)) { + size_t len, size = payl_len(header(b)); + len = c != IFALSE ? cnum(c) : size; + if (len <= size) { + len = write(immval(a), (const word *)b + 1, len); + if (len != (size_t)-1) + return onum(len, 0); + } } - toggle_blocking(val,0); - return F(val); } - case 2: - return close(fixval(a)) ? IFALSE : ITRUE; - case 3: { /* 3 = sopen port type -> False | fd */ - int port = fixval(a); - int type = fixval(b); + return IFALSE; + case 1: /* open path flags mode → port | #f */ + if (stringp(a)) { + int fd = open((const char *)a + W, cnum(b), immval(c)); + if (fd != -1) + return make_immediate(fd, TPORT); + } + return IFALSE; + case 2: + return BOOL(close(immval(a)) == 0); + case 3: { /* 3 = sopen port 0=tcp|1=udp -> False | fd */ + int port = immval(a); + int type = immval(b); int s; int opt = 1; /* TRUE */ + char udp = (type == 1); struct sockaddr_in myaddr; myaddr.sin_family = AF_INET; myaddr.sin_port = htons(port); myaddr.sin_addr.s_addr = INADDR_ANY; - s = socket(AF_INET, ((type == 1) ? SOCK_DGRAM : SOCK_STREAM), 0); + s = socket(AF_INET, (udp ? SOCK_DGRAM : SOCK_STREAM), (udp ? IPPROTO_UDP : 0)); if (s < 0) return IFALSE; if (type != 1) { @@ -584,130 +627,129 @@ static word prim_sys(int op, word a, word b, word c) { close(s); return IFALSE; } + } else { + if (bind(s, (struct sockaddr *) &myaddr, sizeof(myaddr)) != 0) { + close(s); + return IFALSE; + } } - toggle_blocking(s,0); - return F(s); } + return make_immediate(s, TPORT); } case 4: { /* 4 = accept port -> rval=False|(ip . fd) */ - int sock = fixval(a); + int sock = immval(a); struct sockaddr_in addr; socklen_t len = sizeof(addr); int fd; - word *pair; - byte *ipa; + word *ipa; fd = accept(sock, (struct sockaddr *)&addr, &len); if (fd < 0) return IFALSE; - toggle_blocking(fd,0); - ipa = (byte *) &addr.sin_addr; - *fp = make_raw_header(2, TBVEC, 4%W); - bytecopy(ipa, ((byte *) fp) + W, 4); - fp[2] = PAIRHDR; - fp[3] = (word) fp; - fp[4] = F(fd); - pair = fp+2; - fp += 5; - return (word)pair; } - case 5: { /* fread fd max -> obj | eof | F (read error) | T (would block) */ - word fd = fixval(a); - word max = fixval(b); - word *res; - int n, nwords = (max/W) + 2; - allocate(nwords, res); - n = read(fd, ((byte *) res) + W, max); - if (n > 0) { /* got some bytes */ - word read_nwords = (n/W) + ((n%W) ? 2 : 1); - int pads = (read_nwords-1)*W - n; - fp = res + read_nwords; - *res = make_raw_header(read_nwords, TBVEC, pads); - return (word)res; + ipa = mkbvec(4, TBVEC); + bytecopy((byte *)&addr.sin_addr, (byte *)ipa + W, 4); + return cons((word)ipa, make_immediate(fd, TPORT)); } + case 5: /* read fd len -> bvec | EOF | #f */ + if (is_type(a, TPORT)) { + size_t len = memend - fp; + const size_t max = len > MAXOBJ ? MAXPAYL : (len - 1) * W; + len = cnum(b); + len = read(immval(a), fp + 1, len < max ? len : max); + if (len == 0) + return IEOF; + if (len != (size_t)-1) + return (word)mkbvec(len, TBVEC); } - fp = res; - if (n == 0) - return IEOF; - return BOOL(errno == EAGAIN || errno == EWOULDBLOCK); } + return IFALSE; case 6: - tcsetattr(0, TCSANOW, &tsettings); - exit(fixval(a)); /* stop the press */ + setdown(); + exit(immval(a)); /* stop the press */ case 7: /* set memory limit (in mb) */ - max_heap_mb = fixval(a); + max_heap_mb = immval(a); return a; - case 8: /* get machine word size (in bytes) */ - return F(W); - case 9: /* get memory limit (in mb) */ - return F(max_heap_mb); - /* dirops only to be used via exposed functions */ - case 11: { /* sys-opendir path _ _ -> False | dirobjptr */ - char *path = W + (char *) a; /* skip header */ - DIR *dirp = opendir(path); - if(!dirp) return IFALSE; - return fliptag(dirp); } - case 12: { /* sys-readdir dirp _ _ -> bvec | eof | False */ - DIR *dirp = (DIR *)fliptag(a); - word *res; - unsigned int len; - struct dirent *dire = readdir(dirp); - if (!dire) return IEOF; /* eof at end of dir stream */ - len = lenn((byte *)dire->d_name, FMAX+1); - if (len == FMAX+1) return IFALSE; /* false for errors, like too long file names */ - res = mkbvec(len, 3); /* make a fake raw string (OS may not use valid UTF-8) */ - bytecopy((byte *)&dire->d_name, (byte *) (res + 1), len); /* *no* terminating null, this is an owl bvec */ - return (word)res; } - case 13: /* sys-closedir dirp _ _ -> ITRUE */ - closedir((DIR *)fliptag(a)); - return ITRUE; - case 14: { /* unused */ - exit(42); - break; } - case 15: { /* 0 fsocksend fd buff len r → n if wrote n, 0 if busy, False if error (argument or write) */ - int fd = fixval(a); - word *buff = (word *) b; - int wrote, size, len = fixval(c); - if (immediatep(buff)) return IFALSE; - size = (hdrsize(*buff)-1)*W; - if (len > size) return IFALSE; - wrote = send(fd, ((byte *)buff)+W, len, 0); - if (wrote > 0) return F(wrote); - if (errno == EAGAIN || errno == EWOULDBLOCK) return F(0); - return IFALSE; } - case 16: { /* getenv */ - char *name = (char *)a; - if (!allocp(name)) return IFALSE; - return strp2owl((byte *)getenv(name + W)); } + case 8: { /* return system constants */ + static const word sysconst[] = { + S_IFMT, W, S_IFBLK, S_IFCHR, S_IFIFO, S_IFREG, S_IFDIR, S_IFLNK, + S_IFSOCK, E2BIG, EACCES, EADDRINUSE, EADDRNOTAVAIL, EAFNOSUPPORT, EAGAIN, EALREADY, + EBADF, EBADMSG, EBUSY, ECANCELED, ECHILD, ECONNABORTED, ECONNREFUSED, ECONNRESET, + EDEADLK, EDESTADDRREQ, EDOM, EDQUOT, EEXIST, EFAULT, EFBIG, EHOSTUNREACH, + EIDRM, EILSEQ, EINPROGRESS, EINTR, EINVAL, EIO, EISCONN, EISDIR, + ELOOP, EMFILE, EMLINK, EMSGSIZE, EMULTIHOP, ENAMETOOLONG, ENETDOWN, ENETRESET, + ENETUNREACH, ENFILE, ENOBUFS, ENODATA, ENODEV, ENOENT, ENOEXEC, ENOLCK, + ENOLINK, ENOMEM, ENOMSG, ENOPROTOOPT, ENOSPC, ENOSR, ENOSTR, ENOSYS, + ENOTCONN, ENOTDIR, ENOTEMPTY, ENOTRECOVERABLE, ENOTSOCK, ENOTSUP, ENOTTY, ENXIO, + EOPNOTSUPP, EOVERFLOW, EOWNERDEAD, EPERM, EPIPE, EPROTO, EPROTONOSUPPORT, EPROTOTYPE, + ERANGE, EROFS, ESPIPE, ESRCH, ESTALE, ETIME, ETIMEDOUT, ETXTBSY, + EWOULDBLOCK, EXDEV, SEEK_SET, SEEK_CUR, SEEK_END, O_EXEC, O_RDONLY, O_RDWR, + O_SEARCH, O_WRONLY, O_APPEND, O_CLOEXEC, O_CREAT, O_DIRECTORY, O_DSYNC, O_EXCL, + O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RSYNC, O_SYNC, O_TRUNC, O_TTY_INIT, O_ACCMODE, + FD_CLOEXEC, F_DUPFD, F_DUPFD_CLOEXEC, F_GETFD, F_SETFD, F_GETFL, F_SETFL, F_GETOWN, + F_SETOWN, F_GETLK, F_SETLK, F_SETLKW, F_RDLCK, F_UNLCK, F_WRLCK + }; + return onum(sysconst[immval(a) % (sizeof sysconst / W)], 0); } + case 9: /* return process variables */ + return onum( + a == F(0) ? errno : + a == F(1) ? (word)environ : + max_heap_mb, 0); + case 10: { /* receive-udp-packet sock → (ip-bvec . payload-bvec)| #false */ + struct sockaddr_in si_other; + socklen_t slen = sizeof(si_other); + word *bvec; + word *ipa; + int recvd; + recvd = recvfrom(immval(a), fp + 1, 65528, 0, (struct sockaddr *)&si_other, &slen); + if (recvd < 0) + return IFALSE; + bvec = mkbvec(recvd, TBVEC); + ipa = mkbvec(4, TBVEC); + bytecopy((byte *)&si_other.sin_addr, (byte *)ipa + W, 4); + return cons((word)ipa, (word)bvec); } + case 11: /* open-dir path → dirobjptr | #false */ + if (stringp(a)) { + DIR *dirp = opendir((const char *)a + W); + if (dirp != NULL) + return onum((intptr_t)dirp, 1); + } + return IFALSE; + case 12: { /* read-dir dirp → pointer */ + struct dirent *ent; + errno = 0; + ent = readdir((DIR *)(intptr_t)cnum(a)); + return onum(ent != NULL ? (word)&ent->d_name : 0, 0); } + case 13: /* close-dir dirp → bool */ + return BOOL(closedir((DIR *)(intptr_t)cnum(a)) == 0); + case 14: /* strerror errnum → pointer */ + return onum((word)strerror(immval(a)), 0); + case 15: /* fcntl port cmd arg → integer | #f */ + if (is_type(a, TPORT)) { + int res = fcntl(immval(a), cnum(b), (intptr_t)cnum(c)); + if (res != -1) + return onum(res, 1); + } + return IFALSE; + case 16: /* getenv key → pointer */ + return onum(stringp(a) ? (word)getenv((const char *)a + W) : 0, 0); case 17: { /* exec[v] path argl ret */ - char *path = ((char *) a) + W; + char *path = (char *)a + W; int nargs = llen((word *)b); - char **args = malloc((nargs+1) * sizeof(char *)); + char **args = realloc(NULL, (nargs + 1) * sizeof(char *)); char **argp = args; - if (args == NULL) + if (args == NULL) return IFALSE; - while(nargs--) { - *argp++ = ((char *) ((word *) b)[1]) + W; - b = ((word *) b)[2]; + while (nargs--) { + *argp++ = (char *)G(b, 1) + W; + b = G(b, 2); } *argp = NULL; - toggle_blocking(0,1); /* try to return stdio to blocking mode */ - toggle_blocking(1,1); /* warning, other file descriptors will stay in nonblocking mode */ - toggle_blocking(2,1); execv(path, args); /* may return -1 and set errno */ - toggle_blocking(0,0); /* exec failed, back to nonblocking io for owl */ - toggle_blocking(1,0); - toggle_blocking(2,0); + free(args); return IFALSE; } - case 18: { /* fork ret → #false=failed, fixnum=ok we're in parent process, #true=ok we're in child process */ + case 18: { /* fork → #f: failed, 0: we're in child process, integer: we're in parent process */ pid_t pid = fork(); - if (pid == -1) /* fork failed */ - return IFALSE; - if (pid == 0) /* we're in child, return true */ - return ITRUE; - if ((int)pid > FMAX) - exit(5); - return F(pid&FMAX); } + return pid != -1 ? onum(pid, 1) : IFALSE; } case 19: { /* wait _ */ - pid_t pid = (a == IFALSE) ? -1 : fixval(a); + pid_t pid = a != IFALSE ? cnum(a) : -1; int status; - word *r = (word *) b; - //pid = waitpid(pid, &status, WNOHANG|WUNTRACED|WCONTINUED); - pid = waitpid(pid, &status, WNOHANG|WUNTRACED); - if (pid == -1) + word *r = (word *)b; + pid = waitpid(pid, &status, WNOHANG|WUNTRACED); /* |WCONTINUED */ + if (pid == -1) return IFALSE; /* error */ if (pid == 0) return ITRUE; /* no changes, would block */ @@ -727,25 +769,31 @@ static word prim_sys(int op, word a, word b, word c) { r = (word *)IFALSE; } return (word)r; } - case 20: { /* chdir path res */ - char *path = ((char *)a) + W; - if (chdir(path) < 0) - return IFALSE; - return ITRUE; } - case 21: /* kill pid signal → fixnum */ - return (kill(fixval(a), fixval(b)) < 0) ? IFALSE : ITRUE; - case 22: /* unlink path → bool */ - return (unlink(((char *)a)+W) == 0) ? ITRUE : IFALSE; - case 23: /* rmdir path → bool */ - return (rmdir(((char *)a)+W) == 0) ? ITRUE : IFALSE; - case 24: /* rmdir path → bool */ - return (mkdir((((char *)a)+W), fixval(b)) == 0) ? ITRUE : IFALSE; - case 25: { - int whence = fixval(c); - off_t p = lseek(fixval(a), cnum(b), (whence == 0) ? SEEK_SET : ((whence == 1) ? SEEK_CUR : SEEK_END)); - return ((p == (off_t)-1) ? IFALSE : onum((int64_t) p)); } - case 26: { - if (a == ITRUE) { + case 20: /* chdir path → bool */ + return BOOL(stringp(a) && chdir((char *)a + W) == 0); + case 21: /* kill pid signal → bool */ + return BOOL(kill(cnum(a), immval(b)) == 0); + case 22: /* unlink path → bool */ + return BOOL(stringp(a) && unlink((char *)a + W) == 0); + case 23: /* rmdir path → bool */ + return BOOL(stringp(a) && rmdir((char *)a + W) == 0); + case 24: /* mknod path (type . mode) dev → bool */ + if (stringp(a) && pairp(b)) { + const char *path = (const char *)a + W; + const mode_t type = cnum(G(b, 1)), mode = immval(G(b, 2)); + if ((type == S_IFDIR ? mkdir(path, mode) : mknod(path, type | mode, cnum(c))) == 0) + return ITRUE; + } + return IFALSE; + case 25: /* lseek port offset whence → offset | #f */ + if (is_type(a, TPORT)) { + off_t o = lseek(immval(a), cnum(b), cnum(c)); + if (o != -1) + return onum(o, 1); + } + return IFALSE; + case 26: + if (a != IFALSE) { static struct termios old; tcgetattr(0, &old); old.c_iflag &= ~(IGNBRK | BRKINT | PARMRK | ISTRIP | INLCR | IGNCR | ICRNL | IXON); @@ -753,60 +801,136 @@ static word prim_sys(int op, word a, word b, word c) { old.c_lflag &= ~(ECHO | ECHONL | ICANON | ISIG | IEXTEN); old.c_cflag &= ~(CSIZE | PARENB); old.c_cflag |= CS8; - return (tcsetattr(0, TCSANOW, &old) == 0) ? ITRUE : IFALSE; + return BOOL(tcsetattr(0, TCSANOW, &old) == 0); } - return (tcsetattr(0, TCSANOW, &tsettings) == 0) ? ITRUE : IFALSE; } + return BOOL(tcsetattr(0, TCSANOW, &tsettings) == 0); case 27: { /* sendmsg sock (port . ipv4) bvec */ - int sock = fixval(a); + int sock = immval(a); int port; struct sockaddr_in peer; - byte* data = ((byte *) c) + W; - byte *ip; - word hdr = *((word *) c); - int nbytes = ((hdrsize(hdr)-1)*W) - ((hdr>>8)&7); - port = fixval(G(b, 1)); - ip = ((byte *) G(b, 2)) + W; + byte *ip, *data = (byte *)c + W; + size_t len = payl_len(header(c)); + port = immval(G(b, 1)); + ip = (byte *)G(b, 2) + W; peer.sin_family = AF_INET; peer.sin_port = htons(port); peer.sin_addr.s_addr = htonl((ip[0]<<24) | (ip[1]<<16) | (ip[2]<<8) | (ip[3])); - if (sendto(sock, data, nbytes, 0, (struct sockaddr *) &peer, sizeof(peer)) == -1) + return BOOL(sendto(sock, data, len, 0, (struct sockaddr *)&peer, sizeof(peer)) != -1); } + case 28: /* setenv */ + if (stringp(a) && (b == IFALSE || stringp(b))) { + const char *name = (const char *)a + W; + if ((b != IFALSE ? setenv(name, (const char *)b + W, 1) : unsetenv(name)) == 0) + return ITRUE; + } + return IFALSE; + case 29: + return prim_connect((word *) a, b, c); + case 30: /* dup2 old-port new-fd → new-port | #f */ + if (is_type(a, TPORT)) { + int fd = dup2(immval(a), immval(b)); + if (fd != -1) + return make_immediate(fd, TPORT); + } + return IFALSE; + case 31: { /* pipe → '(read-port . write-port) | #f */ + int fd[2]; + if (pipe(fd) != 0) return IFALSE; - return ITRUE; } - case 28: { /* setenv */ - char *name = (char *)a; - if (!allocp(name)) return IFALSE; - char *val = (char *)b; - if (!allocp(val)) return IFALSE; - return (setenv(name + W, val + W, 1) ? IFALSE : ITRUE); } + return cons(make_immediate(fd[0], TPORT), make_immediate(fd[1], TPORT)); } + case 32: /* rename src dst → bool */ + return BOOL(stringp(a) && stringp(b) && rename((char *)a + W, (char *)b + W) == 0); + case 33: /* link src dst → bool */ + return BOOL(stringp(a) && stringp(b) && link((char *)a + W, (char *)b + W) == 0); + case 34: /* symlink src dst → bool */ + return BOOL(stringp(a) && stringp(b) && symlink((char *)a + W, (char *)b + W) == 0); + case 35: /* readlink path → raw-sting | #false */ + if (stringp(a)) { + size_t len = memend - fp; + size_t max = len > MAXOBJ ? MAXPAYL + 1 : (len - 1) * W; + /* the last byte is temporarily used to check, if the string fits */ + len = readlink((const char *)a + W, (char *)fp + W, max); + if (len != (size_t)-1 && len != max) + return (word)mkbvec(len, TSTRING); + } + return IFALSE; + case 36: /* getcwd → raw-sting | #false */ + { + size_t len = memend - fp; + size_t max = len > MAXOBJ ? MAXPAYL + 1 : (len - 1) * W; + /* the last byte is temporarily used for the terminating '\0' */ + if (getcwd((char *)fp + W, max) != NULL) + return (word)mkbvec(lenn((byte *)fp + W, max - 1), TSTRING); + } + return IFALSE; + case 37: /* umask mask → mask */ + return F(umask(immval(a))); + case 38: /* stat fd|path follow → list */ + if (immediatep(a) || stringp(a)) { + struct stat st; + int flg = b != IFALSE ? 0 : AT_SYMLINK_NOFOLLOW; + if ((allocp(a) ? fstatat(AT_FDCWD, (char *)a + W, &st, flg) : fstat(immval(a), &st)) == 0) { + word lst = INULL; + lst = cons(onum(st.st_blocks, 1), lst); + lst = cons(onum(st.st_blksize, 1), lst); + lst = cons(onum(st.st_ctim.tv_sec * INT64_C(1000000000) + st.st_atim.tv_nsec, 1), lst); + lst = cons(onum(st.st_mtim.tv_sec * INT64_C(1000000000) + st.st_atim.tv_nsec, 1), lst); + lst = cons(onum(st.st_atim.tv_sec * INT64_C(1000000000) + st.st_atim.tv_nsec, 1), lst); + lst = cons(onum(st.st_size, 1), lst); + lst = cons(onum(st.st_rdev, 0), lst); + lst = cons(onum(st.st_gid, 0), lst); + lst = cons(onum(st.st_uid, 0), lst); + lst = cons(onum(st.st_nlink, 0), lst); + lst = cons(onum(st.st_mode, 0), lst); + lst = cons(onum(st.st_ino, 0), lst); + lst = cons(onum(st.st_dev, 1), lst); + return lst; + } + } + return INULL; + case 39: /* chmod fd|path mode follow → bool */ + if ((immediatep(a) || stringp(a)) && fixnump(b)) { + mode_t mod = immval(b); + int flg = c != IFALSE ? 0 : AT_SYMLINK_NOFOLLOW; + if ((allocp(a) ? fchmodat(AT_FDCWD, (char *)a + W, mod, flg) : fchmod(immval(a), mod)) == 0) + return ITRUE; + } + return IFALSE; + case 40: /* chown fd|path (uid . gid) follow → bool */ + if ((immediatep(a) || stringp(a)) && pairp(b)) { + uid_t uid = cnum(G(b, 1)); + gid_t gid = cnum(G(b, 2)); + int flg = c != IFALSE ? 0 : AT_SYMLINK_NOFOLLOW; + if ((allocp(a) ? fchownat(AT_FDCWD, (char *)a + W, uid, gid, flg) : fchown(immval(a), uid, gid)) == 0) + return ITRUE; + } + return IFALSE; + case 41: { /* peek mem nbytes → num */ + const word p = cnum(a); + return onum( + b == F(1) ? *(uint8_t *)p : + b == F(2) ? *(uint16_t *)p : + b == F(4) ? *(uint32_t *)p : + b == F(8) ? *(uint64_t *)p : + V(p), 0); + } default: return IFALSE; } } -static word prim_lraw(word wptr, int type, word revp) { - word *lst = (word *) wptr; - int nwords, len = 0, pads; +static word prim_lraw(word wptr, int type) { + word *lst = (word *)wptr; byte *pos; word *raw, *ob; - if (revp != IFALSE) { exit(1); } /* <- to be removed */ - ob = lst; - while (allocp(ob) && *ob == PAIRHDR) { + unsigned int len = 0; + for (ob = lst; pairp(ob); ob = (word *)ob[2]) len++; - ob = (word *) ob[2]; - } - if ((word) ob != INULL) return IFALSE; - if (len > FMAX) return IFALSE; - nwords = (len/W) + ((len % W) ? 2 : 1); - allocate(nwords, raw); - pads = (nwords-1)*W - len; /* padding byte count, usually stored to top 3 bits */ - *raw = make_raw_header(nwords, type, pads); - ob = lst; - pos = ((byte *) raw) + W; - while ((word) ob != INULL) { - *pos++ = fixval(ob[1])&255; - ob = (word *) ob[2]; - } - while(pads--) { *pos++ = 0; } /* clear the padding bytes */ + if ((word)ob != INULL || len > MAXPAYL) + return IFALSE; + raw = mkbvec(len, type); + pos = (byte *)raw + W; + for (ob = lst; (word)ob != INULL; ob = (word *)ob[2]) + *pos++ = immval(ob[1]) & 255; return (word)raw; } @@ -816,15 +940,15 @@ static word prim_mkff(word t, word l, word k, word v, word r) { ob[2] = v; if (l == IEMPTY) { if (r == IEMPTY) { - *ob = make_header(3, t); + *ob = make_header(3, t); fp += 3; } else { - *ob = make_header(4, t|FFRIGHT); + *ob = make_header(4, t | FFRIGHT); ob[3] = r; fp += 4; } - } else if (r == IEMPTY) { - *ob = make_header(4, t); + } else if (r == IEMPTY) { + *ob = make_header(4, t); ob[3] = l; fp += 4; } else { @@ -836,7 +960,7 @@ static word prim_mkff(word t, word l, word k, word v, word r) { return (word) ob; } -void do_poll(word a, word b, word c, word *r1, word *r2) { +void do_poll(word a, word b, word c, word *r1, word *r2) { fd_set rs, ws, es; word *cur; int nfds = 1; @@ -845,26 +969,26 @@ void do_poll(word a, word b, word c, word *r1, word *r2) { FD_ZERO(&rs); FD_ZERO(&ws); FD_ZERO(&es); cur = (word *)a; while((word)cur != INULL) { - int fd = fixval(((word *)cur[1])[1]); + int fd = immval(G(cur[1], 1)); FD_SET(fd, &rs); - FD_SET(fd, &es); - if (!(nfds > fd)) + FD_SET(fd, &es); + if (fd >= nfds) nfds = fd + 1; cur = (word *) cur[2]; } cur = (word *)b; while ((word)cur != INULL) { - int fd = fixval(((word *)cur[1])[1]); + int fd = immval(G(cur[1], 1)); FD_SET(fd, &ws); FD_SET(fd, &es); - if (!(nfds > fd)) + if (fd >= nfds) nfds = fd + 1; cur = (word *) cur[2]; } if (c == IFALSE) { res = select(nfds, &rs, &ws, &es, NULL); } else { - int ms = fixval(c); + int ms = immval(c); tv.tv_sec = ms/1000; tv.tv_usec = (ms%1000)*1000; res = select(nfds, &rs, &ws, &es, &tv); @@ -875,11 +999,11 @@ void do_poll(word a, word b, word c, word *r1, word *r2) { int fd; /* something active, wake the first thing */ for(fd=0;;fd++) { if (FD_ISSET(fd, &rs)) { - *r1 = make_immediate(fd, 12); *r2 = F(1); break; + *r1 = make_immediate(fd, TPORT); *r2 = F(1); break; } else if (FD_ISSET(fd, &ws)) { - *r1= make_immediate(fd, 12); *r2 = F(2); break; + *r1 = make_immediate(fd, TPORT); *r2 = F(2); break; } else if (FD_ISSET(fd, &es)) { - *r1 = make_immediate(fd, 12); *r2 = F(3); break; + *r1 = make_immediate(fd, TPORT); *r2 = F(3); break; } } } @@ -887,13 +1011,13 @@ void do_poll(word a, word b, word c, word *r1, word *r2) { word vm(word *ob, word *arg) { unsigned char *ip; - int bank = 0; - int ticker = TICKS; + unsigned int bank = 0; + unsigned int ticker = TICKS; unsigned short acc = 0; int op; word R[NR]; - word load_imms[] = {F(0), INULL, ITRUE, IFALSE}; /* for ldi and jv */ + word load_imms[] = {F(0), INULL, ITRUE, IFALSE}; /* for ldi and jv */ /* clear blank regs */ while(acc < NR) { R[acc++] = INULL; } @@ -906,15 +1030,15 @@ word vm(word *ob, word *arg) { if (allocp(ob)) { word hdr = *ob & 4095; /* cut size out, take just header info */ - if (hdr == make_header(0,TPROC)) { /* proc */ + if (hdr == make_header(0, TPROC)) { /* proc */ R[1] = (word) ob; ob = (word *) ob[1]; - } else if (hdr == make_header(0,TCLOS)) { /* clos */ + } else if (hdr == make_header(0, TCLOS)) { /* clos */ R[1] = (word) ob; ob = (word *) ob[1]; R[2] = (word) ob; ob = (word *) ob[1]; } else if (((hdr>>TPOS)&60) == TFF) { /* low bits have special meaning */ word *cont = (word *) R[3]; if (acc == 3) { - R[3] = prim_get(ob, R[4], R[5]); + R[3] = prim_get(ob, R[4], R[5]); } else if (acc == 2) { R[3] = prim_get(ob, R[4], (word) 0); if (!R[3]) { error(260, ob, R[4]); } @@ -924,19 +1048,19 @@ word vm(word *ob, word *arg) { ob = cont; acc = 1; goto apply; - } else if (((hdr >> TPOS) & 63) != TBYTECODE) { /* not even code, extend bits later */ + } else if (!is_type(hdr, TBYTECODE)) { /* not even code, extend bits later */ error(259, ob, INULL); } if (!ticker--) goto switch_thread; - ip = ((unsigned char *) ob) + W; + ip = (unsigned char *)ob + W; goto invoke; } else if ((word)ob == IEMPTY && acc > 1) { /* ff application: (False key def) -> def */ ob = (word *) R[3]; /* call cont */ - R[3] = (acc > 2) ? R[5] : IFALSE; /* default arg or false if none */ + R[3] = acc > 2 ? R[5] : IFALSE; /* default arg or false if none */ acc = 1; goto apply; } else if ((word)ob == IHALT) { - /* it's the final continuation */ + /* it's the final continuation */ ob = (word *) R[0]; if (allocp(ob)) { R[0] = IFALSE; @@ -966,7 +1090,7 @@ word vm(word *ob, word *arg) { } switch_thread: /* enter mcp if present */ - if (R[0] == IFALSE) { /* no mcp, ignore */ + if (R[0] == IFALSE) { /* no mcp, ignore */ ticker = TICKS; goto apply; } else { @@ -983,10 +1107,10 @@ word vm(word *ob, word *arg) { state[pos] = R[pos]; pos++; } - ob = (word *) R[0]; + ob = (word *) R[0]; R[0] = IFALSE; /* remove mcp cont */ /* R3 marks the syscall to perform */ - R[3] = breaked ? ((breaked & 8) ? F(14) : F(10)) : F(1); + R[3] = breaked ? (breaked & 8 ? F(14) : F(10)) : F(1); R[4] = (word) state; R[5] = F(breaked); R[6] = IFALSE; @@ -996,14 +1120,18 @@ word vm(word *ob, word *arg) { } invoke: /* nargs and regs ready, maybe gc and execute ob */ if (((word)fp) + 1024*64 >= ((word) memend)) { - int p = 0; - *fp = make_header(NR+2, 50); /* hdr r_0 .. r_(NR-1) ob */ - while(p < NR) { fp[p+1] = R[p]; p++; } + int p = 0; + *fp = make_header(NR + 2, 50); /* hdr r_0 .. r_(NR-1) ob */ + while (p < NR) { + fp[p + 1] = R[p]; + p++; + } fp[p+1] = (word) ob; fp = gc(1024*64, fp); ob = (word *) fp[p+1]; - while(--p >= 0) { R[p] = fp[p+1]; } - ip = ((unsigned char *) ob) + W; + while (--p >= 0) + R[p] = fp[p + 1]; + ip = (unsigned char *)ob + W; } op = *ip++; @@ -1015,45 +1143,48 @@ word vm(word *ob, word *arg) { op = *ip<<8 | ip[1]; goto super_dispatch; } - + op0: op = (*ip << 8) | ip[1]; goto super_dispatch; - op1: {word *ob = (word *)R[*ip]; R[ip[2]] = ob[ip[1]]; NEXT(3);} - op2: ob = (word*) R[*ip]; acc = ip[1]; goto apply; + op1: A2 = G(A0, ip[1]); NEXT(3); + op2: ob = (word *)A0; acc = ip[1]; goto apply; op3: OCLOSE(TCLOS); NEXT(0); op4: OCLOSE(TPROC); NEXT(0); op5: /* mov2 from1 to1 from2 to2 */ - R[ip[1]] = R[ip[0]]; - R[ip[3]] = R[ip[2]]; + A1 = A0; + A3 = A2; NEXT(4); op6: CLOSE1(TCLOS); NEXT(0); op7: CLOSE1(TPROC); NEXT(0); - op8: /* jlq a b o, extended jump */ - if(R[*ip] == A1) { ip += ip[2] + (ip[3] << 8); } - NEXT(4); - op9: R[ip[1]] = R[*ip]; NEXT(2); + op8: /* jlq a b o, extended jump */ + if (A0 == A1) + ip += ip[2] + (ip[3] << 8); + NEXT(4); + op9: A1 = A0; NEXT(2); op10: error(10, F(42), F(42)); - op11: { - do_poll(A0, A1, A2, &(A3), &(A4)); - NEXT(5); } + op11: + do_poll(A0, A1, A2, &A3, &A4); + NEXT(5); op12: /* jb n */ ip -= ip[0]; if (ticker) /* consume thread time */ ticker--; NEXT(0); op13: /* ldi{2bit what} [to] */ - R[*ip++] = load_imms[op>>6]; - NEXT(0); - op14: R[ip[1]] = F(*ip); NEXT(2); + A0 = load_imms[op >> 6]; + NEXT(1); + op14: A1 = F(*ip); NEXT(2); op15: { /* type-byte o r <- actually sixtet */ - word ob = R[*ip++]; - if (allocp(ob)) ob = V(ob); - R[*ip++] = F((ob>>TPOS)&63); - NEXT(0); } + word ob = A0; + if (allocp(ob)) + ob = V(ob); + A1 = F(imm_type(ob)); + NEXT(2); } op16: /* jv[which] a o1 a2*/ /* FIXME, convert this to jump-const comparing to make_immediate(,TCONST) */ - if(R[*ip] == load_imms[op>>6]) { ip += ip[1] + (ip[2] << 8); } - NEXT(3); - op17: { /* arity error */ + if (A0 == load_imms[op >> 6]) + ip += ip[1] + (ip[2] << 8); + NEXT(3); + op17: { /* arity error */ word *t; int p; allocate(acc+1, t); @@ -1063,21 +1194,21 @@ word vm(word *ob, word *arg) { } error(17, ob, t); } op18: /* goto-code p */ - ob = (word *) R[*ip]; /* needed in opof gc */ + ob = (word *)A0; /* needed in opof gc */ acc = ip[1]; - ip = ((unsigned char *) R[*ip]) + W; + ip = (unsigned char *)A0 + W; goto invoke; op19: { /* goto-proc p */ - word *this = (word *) R[*ip]; + word *this = (word *)A0; R[1] = (word) this; acc = ip[1]; ob = (word *) this[1]; - ip = ((unsigned char *) ob) + W; + ip = (unsigned char *)ob + W; goto invoke; } op20: { /* apply */ int reg, arity; word *lst; - if (op == 20) { /* normal apply: cont=r3, fn=r4, a0=r5, */ + if (op == 20) { /* normal apply: cont=r3, fn=r4, a0=r5 */ reg = 4; /* include cont */ arity = 1; ob = (word *) R[reg]; @@ -1088,7 +1219,7 @@ word vm(word *ob, word *arg) { arity++; } lst = (word *) R[reg+1]; - } else { /* _sans_cps apply: func=r3, a0=r4, */ + } else { /* _sans_cps apply: func=r3, a0=r4 */ reg = 3; /* include cont */ arity = 0; ob = (word *) R[reg]; @@ -1100,7 +1231,7 @@ word vm(word *ob, word *arg) { } lst = (word *) R[reg+1]; } - while(allocp(lst) && *lst == PAIRHDR) { /* unwind argument list */ + while(pairp(lst)) { /* unwind argument list */ /* FIXME: unwind only up to last register and add limited rewinding to arity check */ if (reg > 128) { /* dummy handling for now */ exit(3); @@ -1112,19 +1243,17 @@ word vm(word *ob, word *arg) { acc = arity; goto apply; } op21: { /* goto-clos p */ - word *this = (word *) R[*ip]; + word *this = (word *)A0; R[1] = (word) this; acc = ip[1]; this = (word *) this[1]; R[2] = (word) this; ob = (word *) this[1]; - ip = ((unsigned char *) ob) + W; + ip = (unsigned char *)ob + W; goto invoke; } - op22: { /* cast o t r */ - word *ob = (word *) R[*ip]; - word type = fixval(A1) & 63; - A2 = prim_cast(ob, type); - NEXT(3); } + op22: /* cast o t r */ + A2 = prim_cast((word *)A0, immval(A1)); + NEXT(3); op23: { /* mkt t s f1 .. fs r */ word t = *ip++; word s = *ip++ + 1; /* the argument is n-1 to allow making a 256-tuple with 255, and avoid 0-tuples */ @@ -1139,22 +1268,18 @@ word vm(word *ob, word *arg) { NEXT(s+1); } op24: /* ret val == implicit call r3 with 1 arg */ ob = (word *) R[3]; - R[3] = R[*ip]; + R[3] = A0; acc = 1; - goto apply; + goto apply; op25: { /* jmp-nargs(>=?) a hi lo */ int needed = *ip; if (acc == needed) { if (op & 64) /* add empty extra arg list */ R[acc + 3] = INULL; } else if ((op & 64) && acc > needed) { - word tail = INULL; /* todo: no call overflow handling yet */ + word tail = INULL; /* todo: no call overflow handling yet */ while (acc > needed) { - fp[0] = PAIRHDR; - fp[1] = R[acc + 2]; - fp[2] = tail; - tail = (word) fp; - fp += 3; + tail = cons(R[acc + 2], tail); acc--; } R[acc + 3] = tail; @@ -1163,8 +1288,8 @@ word vm(word *ob, word *arg) { } NEXT(3); } op26: { /* fxqr ah al b qh ql r, b != 0, int32 / int16 -> int32, as fixnums */ - uint64_t a = (((uint64_t) fixval(A0))<>FBITS); @@ -1174,33 +1299,32 @@ word vm(word *ob, word *arg) { op27: /* syscall cont op arg1 arg2 */ ob = (word *) R[0]; R[0] = IFALSE; - R[3] = A1; R[4] = R[*ip]; R[5] = A2; R[6] = A3; + R[3] = A1; + R[4] = A0; + R[5] = A2; + R[6] = A3; acc = 4; if (ticker > 10) bank = ticker; /* deposit remaining ticks for return to thread */ goto apply; op28: { /* sizeb obj to */ - word ob = R[*ip]; + word ob = A0; if (immediatep(ob)) { A1 = IFALSE; } else { - word hdr = V(ob); - A1 = (rawp(hdr)) ? F((hdrsize(hdr)-1)*W - ((hdr >> 8) & 7)) : IFALSE; + word hdr = header(ob); + A1 = rawp(hdr) ? F(payl_len(hdr)) : IFALSE; } NEXT(2); } op29: { /* ncons a b r */ - *fp = NUMHDR; - fp[1] = A0; - fp[2] = A1; - A2 = (word) fp; - fp += 3; + A2 = mkpair(NUMHDR, A0, A1); NEXT(3); } op30: { /* ncar a rd */ - word *ob = (word *) R[*ip]; + word *ob = (word *)A0; assert(allocp(ob), ob, 30); A1 = ob[1]; NEXT(2); } op31: { /* ncdr a r */ - word *ob = (word *) R[*ip]; + word *ob = (word *)A0; assert(allocp(ob), ob, 31); A1 = ob[2]; NEXT(2); } @@ -1214,55 +1338,56 @@ word vm(word *ob, word *arg) { NEXT(0); } op33: error(33, IFALSE, IFALSE); - op34: { /* connect -> fd | False, via an ipv4 tcp stream */ - /* fixme - this should not be a primitive */ - A2 = prim_connect((word *) A0, A1); /* fixme: remove and put to prim-sys*/ - NEXT(3); } + op34: /* jmp-nargs a hi li */ + if (acc != *ip) { + ip += (ip[1] << 8) | ip[2]; + } + NEXT(3); op35: { /* listuple type size lst to */ - word type = fixval(R[*ip]); - word size = fixval(A1); - word *lst = (word *) A2; + word type = immval(A0); + word size = immval(A1); + word *lst = (word *)A2; word *ob; allocate(size+1, ob); A3 = (word) ob; *ob++ = make_header(size+1, type); while(size--) { - assert((allocp(lst) && *lst == PAIRHDR), lst, 35); + assert(pairp(lst), lst, 35); *ob++ = lst[1]; lst = (word *) lst[2]; } NEXT(4); } op36: { /* size o r */ - word *ob = (word *) R[ip[0]]; - R[ip[1]] = (immediatep(ob)) ? IFALSE : F(hdrsize(*ob)-1); + word *ob = (word *)A0; + A1 = immediatep(ob) ? IFALSE : F(hdrsize(*ob) - 1); NEXT(2); } - op37: - error(256, F(37), IFALSE); + op37: /* lraw lst type r (FIXME: alloc amount testing compiler pass not in place yet) */ + A2 = prim_lraw(A0, immval(A1)); + NEXT(3); op38: { /* fx+ a b r o, types prechecked, signs ignored, assume fixnumbits+1 fits to machine word */ - word res = fixval(A0) + fixval(A1); - word low = res & FMAX; - A3 = (res & (1 << FBITS)) ? ITRUE : IFALSE; - A2 = F(low); + word res = immval(A0) + immval(A1); + A3 = BOOL(res & (1 << FBITS)); + A2 = F(res & FMAX); NEXT(4); } op39: { /* fx* a b l h */ - uint64_t res = ((uint64_t) ((uint64_t) fixval(R[*ip])) * ((uint64_t) fixval(A1))); - A2 = F(((word)(res&FMAX))); - A3 = F(((word)(res>>FBITS)&FMAX)); + uint64_t res = (uint64_t)immval(A0) * (uint64_t)immval(A1); + A2 = F(res & FMAX); + A3 = F((res >> FBITS) & FMAX); NEXT(4); } op40: { /* fx- a b r u, args prechecked, signs ignored */ - word r = (fixval(A0)|(1<> a b hi lo */ - uint64_t r = ((uint64_t) fixval(A0)) << (FBITS - fixval(A1)); + uint64_t r = (uint64_t)immval(A0) << (FBITS - immval(A1)); A2 = F(r>>FBITS); A3 = F(r&FMAX); NEXT(4); } op59: { /* fx<< a b hi lo */ - uint64_t res = (uint64_t) fixval(R[*ip]) << fixval(A1); + uint64_t res = (uint64_t)immval(A0) << immval(A1); A2 = F(res>>FBITS); A3 = F(res&FMAX); NEXT(4); } - op60: /* lraw lst type dir r (fixme, alloc amount testing compiler pass not in place yet!) */ - A3 = prim_lraw(A0, fixval(A1), A2); - NEXT(4); + op60: /* unused */ + error(256, F(60), IFALSE); op61: /* clock */ { /* fixme: sys */ struct timeval tp; word *ob; allocate(6, ob); /* space for 32-bit bignum - [NUM hi [NUM lo null]] */ - ob[0] = ob[3] = NUMHDR; + ob[0] = ob[3] = NUMHDR; A0 = (word) (ob + 3); - ob[2] = INULL; + ob[2] = INULL; ob[5] = (word) ob; gettimeofday(&tp, NULL); A1 = F(tp.tv_usec / 1000); @@ -1394,10 +1508,10 @@ word vm(word *ob, word *arg) { NEXT(2); } op62: /* set-ticker -> old ticker value */ /* fixme: sys */ A1 = F(ticker & FMAX); - ticker = fixval(A0); - NEXT(2); + ticker = immval(A0); + NEXT(2); op63: { /* sys-prim op arg1 arg2 arg3 r1 */ - A4 = prim_sys(fixval(A0), A1, A2, A3); + A4 = prim_sys(immval(A0), A1, A2, A3); NEXT(5); } super_dispatch: /* run macro instructions */ @@ -1416,39 +1530,7 @@ word vm(word *ob, word *arg) { acc = 4; goto apply; } - return 1; /* no mcp to handle error (fail in it?), so nonzero exit */ -} - -word *burn_args(int nargs, char **argv) { - int this; - word *oargs = (word *) INULL; - this = nargs-1; - while(this >= 0) { - byte *str = (byte *) argv[this]; - byte *pos = str; - int pads; - word *tmp; - int len = 0, size; - while(*pos++) len++; - if (len > FMAX) { - exit(1); - } - size = ((len % W) == 0) ? (len/W)+1 : (len/W) + 2; - pads = (size-1)*W - len; - tmp = fp; - fp += size; - *tmp = make_raw_header(size, 3, pads); - pos = ((byte *) tmp) + W; - while(*str) *pos++ = *str++; - *fp = PAIRHDR; - fp[1] = (word) tmp; - fp[2] = (word) oargs; - oargs = fp; - fp += 3; - this--; - } - fp = oargs + 3; - return oargs; + return 1; /* no mcp to handle error (fail in it?), so nonzero exit */ } /* Initial FASL image decoding */ @@ -1463,7 +1545,7 @@ word get_nat() { result = new + (i & 127); } while (i & 128); return result; -} +} word *get_field(word *ptrs, int pos) { if (0 == *hp) { @@ -1495,7 +1577,7 @@ word *get_obj(word *ptrs, int me) { byte *wp; type = *hp++ & 31; /* low 5 bits, the others are pads */ bytes = get_nat(); - size = ((bytes % W) == 0) ? (bytes/W)+1 : (bytes/W) + 2; + size = OBJWORDS(bytes); pads = (size-1)*W - bytes; *fp++ = make_raw_header(size, type, pads); wp = (byte *) fp; @@ -1512,7 +1594,7 @@ word *get_obj(word *ptrs, int me) { void get_obj_metrics(int *rwords, int *rnobjs) { int size; switch(*hp++) { - case 1: { + case 1: hp++; size = get_nat(); *rnobjs += 1; @@ -1522,17 +1604,16 @@ void get_obj_metrics(int *rwords, int *rnobjs) { hp += 2; get_nat(); } - break; } - case 2: { - int bytes; + break; + case 2: hp++; - bytes = get_nat(); - size = ((bytes % W) == 0) ? (bytes/W)+1 : (bytes/W) + 2; - hp += bytes; + size = get_nat(); *rnobjs += 1; - *rwords += size; - break; } - default: exit(42); + *rwords += OBJWORDS(size); + hp += size; + break; + default: + exit(42); } } @@ -1544,19 +1625,7 @@ void heap_metrics(int *rwords, int *rnobjs) { hp = hp_start; } -size_t count_cmdlinearg_words(int nargs, char **argv) { - size_t total = 0; - while(nargs--) { - size_t this = lenn((byte *) *argv, FMAX); - if (this == FMAX) - exit(3); - total += (this / W) + 3; - argv++; - } - return total; -} - -byte *read_heap(char *path) { +byte *read_heap(char *path) { struct stat st; int fd, pos = 0; if(stat(path, &st)) exit(1); @@ -1576,7 +1645,7 @@ byte *read_heap(char *path) { /* find a fasl image source to *hp or exit */ void find_heap(int *nargs, char ***argv, int *nobjs, int *nwords) { file_heap = NULL; - if ((word)heap == (word)NULL) { + if ((word)heap == 0) { /* if no preloaded heap, try to load it from first vm arg */ if (*nargs < 2) exit(1); file_heap = read_heap((*argv)[1]); @@ -1592,10 +1661,10 @@ void find_heap(int *nargs, char ***argv, int *nobjs, int *nwords) { } word *decode_fasl(int nobjs) { - word *ptrs = fp; + word *ptrs; word *entry; int pos = 0; - fp += nobjs+1; + allocate(nobjs + 1, ptrs); while(pos < nobjs) { if (fp >= memend) { /* bug */ exit(1); @@ -1603,65 +1672,42 @@ word *decode_fasl(int nobjs) { fp = get_obj(ptrs, pos); pos++; } - entry = (word *) ptrs[pos-1]; - ptrs[0] = make_raw_header(nobjs+1,0,0); + entry = (word *) ptrs[pos - 1]; + ptrs[0] = make_raw_header(nobjs + 1, 0, 0); return entry; } word *load_heap(int nobjs) { word *entry = decode_fasl(nobjs); - if (file_heap != NULL) free((void *) file_heap); + if (file_heap != NULL) + free(file_heap); return entry; } -void setup(int nargs, char **argv, int nwords, int nobjs) { +void setup(int nwords, int nobjs) { tcgetattr(0, &tsettings); state = IFALSE; set_signal_handler(); - toggle_blocking(0,0); /* change to nonblocking stdio */ - toggle_blocking(1,0); - toggle_blocking(2,0); - max_heap_mb = (W == 4) ? 4096 : 65535; - nwords += count_cmdlinearg_words(nargs, argv); + max_heap_mb = W == 4 ? 4096 : 65535; nwords += nobjs + INITCELLS; - memstart = genstart = fp = (word *) realloc(NULL, (nwords + MEMPAD)*W); - if (!memstart) exit(4); + memstart = genstart = fp = realloc(NULL, (nwords + MEMPAD) * W); + if (memstart == NULL) + exit(4); memend = memstart + nwords - MEMPAD; } -void setdown() { - tcsetattr(0, TCSANOW, &tsettings); -} - -/* library mode init */ -void init() { - int nobjs=0, nwords=0; - hp = (byte *) &heap; /* builtin heap */ - state = IFALSE; - heap_metrics(&nwords, &nobjs); - max_heap_mb = (W == 4) ? 4096 : 65535; - nwords += nobjs + INITCELLS; - memstart = genstart = fp = (word *) realloc(NULL, (nwords + MEMPAD)*W); - if (!memstart) exit(4); - memend = memstart + nwords - MEMPAD; - state = (word) load_heap(nobjs); -} - int main(int nargs, char **argv) { - word *prog, *args; + word *prog; int rval, nobjs=0, nwords=0; find_heap(&nargs, &argv, &nobjs, &nwords); - setup(nargs, argv, nwords, nobjs); - args = burn_args(nargs, argv); + setup(nwords, nobjs); prog = load_heap(nobjs); - rval = vm(prog, args); + rval = vm(prog, (word *)onum((word)argv, 0)); setdown(); - if(fixnump(rval)) { - int n = fixval(rval); - return (0 <= n && n < 128) ? n : 126; - } else { - return 127; + if (fixnump(rval)) { + int n = immval(rval); + if (!(n & ~127)) + return n; } + return 127; } - - diff --git a/doc/manual.md b/doc/manual.md new file mode 100644 index 00000000..3da530d0 --- /dev/null +++ b/doc/manual.md @@ -0,0 +1,236 @@ +--- +title: "Owl Lisp v0.2 manual" +author: Aki Helin +date: 19.2.2018 +geometry: "left=3cm,right=3cm,top=2cm,bottom=2cm" +output: pdf_document +--- + +Owl Lisp is a simple purely functional programming language. This +document describes the language, its implementation and available +libraries. The language is essentially R7RS Scheme, apart from having +only immmutable data structures and relying on multithreading for +some core operations. + +# History of Lisp + +Lisp (or LISP) is short for LISt Processor. It was initially a +mathematical formalism intended for reasoning about computations. Lisp +was invented by John McCarthy at MIT in 1958. The initial description of +the language contained a definition of the semantics of the language in +terms of itself. This evaluation function was soon implemented on a +computer, turning Lisp from theory to practice. + +Since then different dialects of Lisp have evolved into many different directions. +One of the main features connecting the dialects has been the syntax + - or to be more precise, lack of it. +Most data in Lisp can be displayed textually in a simple format. +Instead of having a syntax for the programming language and one for representing this data, + Lisp uses the same for both. +Lisp programs are just lists. + +Common Lisp is one of the major current dialects. +It is used by several commercial applications. +Scheme is another modern version of Lisp. +It attempts to define a small core of constructs + out of which many kinds of programming primitives can be built. + +Owl is essentially a small step from the multi-paradigm world of Scheme + into a purely functional one. +Scheme programs are usually mainly functional + with some mutations sprinkled sparingly where needed. + +## Why Another Lisp? + +These days compiler construction and parsing are usually taught towards +the end of computer science curriculum, if at all. This is probably +due to the complexity of modern programming languages and environments. +Parsers and compilers, the typical building blocks of programming language +implementations, seem like dark magic only a few select pupils and +devout lone programmers are fit to approach. + +This has not always been the case. In a few programming language families it +has been customary to start, not end, studies by building a small version +of the language you are studying. This approach favored +languages which had a small core of features, on top of which you could build the rest +of the system. Forth and Lisp are common examples of such languages. + +The goal of Owl Lisp has not at any point been to become han ultimate Lisp and +take over the world. Ïn fact, this has been an anti-goal. The goal has +been to remain simple while incrementally growing only features required +to enable building the kinds of programs it is actually used for. While +this is a somewhat circular definition, it has worked surprisingly well. +Owl is shaped by minimalism and practical applications, not by what seem +like cool and powerful language features. + + +## Owl vs Scheme + +Scheme is a modern lexically scoped multi-paradigm language. One of the +original goals was to also study the actor model of computation. The +actors were eventually removed, because in single threaded operation they +ended up being effectively equivalent with lambda-defined functions. + +Owl takes a step back towards the actor model by allowing concurrect +execution of functions and passing messages between them. The operation +is mainly modeled after Erlang. + +Another difference is in the multi-paradigm area. Owl does not try to +be able to support also imperative programming. All variable bindings +are made by lambdas, all bindings are permanent, and no data structure +can ever change. The core language is therefore closer to λ-calculus. + + +## Introduction + +Languages such as Latin and English are called natural languages. They +have developed and evolve organically without strict rules or meanings. +It would be impossible to pin down all rules how they operate. There are +also artificial languages which do operate according to fixed rules. +The rules specify what can be considered to be a valid expression in the +language, and usually also what can be done to it without altering +the meaning. Such languages are called *formal languages*. Programming +languages belong to the latter category. + +Lisp is a particular family of programming languages. A key feature of +programming languages is that you can write a program to compute anything. +Such programming languages are called *universal*. It is not difficult +to make a universal language - in fact it's quite hard not to! + +The definition of a programming language can be thought to consist of two parts, *syntax* and +*semantics*. Since we typically want to write programs as text, we need +some rules to define how sequences of letters are to be interpreted as +something in the programming language. Once we are in the world of the +proramming language, and not just reading a sequence of letters, we need +to attach some meaning and action to what we just read. This is the semantics +part. + +The Lisp family of programming languages has a peculiar feature not typically +seen in programming languages: it is homoiconic. This means, that the syntax +of the programs is the same as the syntax used to represent data elsewhere. +This makes it extremely easy to write programs which themselves modify or +create programs. + +Lisp programs can be developed either by typing the program into one or +more files and running, or by interactively working with a read-eval-print +loop (REPL). A Lisp REPL will repeatedly read one expression from the user, +evaluate expression and finally print out the textual representation of +the result. + + +## Simplified Core + + +## Common Data Types + +... + +## Macros + +... + +## Multithreading + +... + +## Modules + + +# Implementation + +... + +## Requirements + +You should have make and gcc or clang installed. + + +## Installation + +To install system-wide to /usr +``` + $ make + $ sudo make install +``` + +Alternatively you can try it out with +``` + $ make + $ cp bin/ol /somewhere/convenient + $ /somewhere/convenient/ol + You see a prompt + > +``` + + +## Files + + bin/ol - the owl interpreter/compiler + c/ovm.c - the virtual machine / shared owl lisp runtime + owl/*.scm - implementation of owl repl and compiler + bench/*.scm - some benchmarks + fasl/*.fasl - bytecode images for bin/vm used during boot + bin/vm - plain VM used during boot + c/ol.c - combined VM and REPL heap image + + +## Usage + +Owl can be used either interactively, or to interpret code from files, +or compile programs to fasl-images or c-files. The difference between +an owl program and a plain script is that the program should just have +a function of one argument as the last value, which will be called with +the command line argument list when the program is executed. + +In addition to being a regular interpreter, owl also tries to make it +easy to compile programs for different platforms. Owl programs can be +compiled with ol to C-files, which can be compiled to standalone binaries +without needing any owl-specific support files or libraries. The C files +also work on 32- and 64-bit systems, and compile as such at least on +Linux, OpenBSD, OSX and can be crosscompiled to Windows executables with +MinGW. + +For example, to build a hello world program: +``` + $ echo '(lambda (args) (print "Hello, world!"))' > hello.scm + $ ol -o hello.c hello.scm + $ gcc -o hello hello.c + $ ./hello + Hello, world! +``` + +Or simply: +``` + $ echo '(λ (args) (print "Hello, world!"))' \ + | ol -x c | gcc -x c -o hello - && ./hello +``` + +Parts of the compiled programs can be translated to C, instead of being +simply fasl-encoded, to increase speed. Using the --native flag compiles +most of the bytecode to C, and --usual-suspects compiles typically used +functions. To make programs run faster, one can use for example: + +``` + $ ol -O2 -o test.c test.scm && gcc -O2 -o test test.c +``` + +# Libraries + +Libraries are named by lists of symbols. For example `(owl lazy)` is +a library name. `ol` comes prelodaded with many libraries, some of which +are loaded by default to REPL. If you want to use exported definitions from a +builtin library `(owl lazy)`, you can do so by issuing `(import (owl lazy))`. + +Notice that `import` is not a function. It is one of the special forms used +by the REPL to handle management of visible definitions in your sessions. The +syntax is the same as in imports within a library. + +If you try to import a library which is not currently loaded, say `(my test)`, +Owl would try to look for library definition from the file "my/test.scm". If +it is available and contains definition of a libary called `(my test)`, it will +be loaded and added to your repl. + +You can get a listing of the currently loaded libraries with `,libraries` command. +Many of them are mainly needed for the implementation of the underlying system. +Some of the likely useful ones are documented below. + diff --git a/doc/ol.1 b/doc/ol.1 index be07bf1a..361c0d95 100644 --- a/doc/ol.1 +++ b/doc/ol.1 @@ -25,7 +25,7 @@ Show version of program. Evaluate the string, print it's value, and exit with 0 unless errors occurred. .TP .B \-t, \-\-test string -Evaluate the string and exit with 1 if the value is #false, 0 if it's true, or 127 if there is an error. +Evaluate the string and exit with 1 if the value is #false, 0 if it's true, or 126 if there is an error. .TP .B \-o, \-\-output output-file Compile the given file to fasl or C code, and save the result to the given output file. @@ -40,13 +40,6 @@ is normally deduced from the file suffix given in -o, and is thus not usually ne .B -O0, -O1, -O2 Write plain bytecode, compile some common functions to C or everything possible. These only make sense when compiling to C. .TP -.B \-S, \-\-seccomp -Enter seccomp sandbox mode at startup. This is an experimental Linux-only feature intended -to be used for evaluating untrusted code. -.TP -.B \-H, \-\-heap n -Make sure there are at least n megabytes of heap space available before entering SECCOMP sandbox. -.TP .B \-l, \-\-load path Resume execution of program state saved with \fIsuspend\fR. .SH EXAMPLES diff --git a/fasl/init.fasl b/fasl/init.fasl index 00bb468c..46a63112 100644 Binary files a/fasl/init.fasl and b/fasl/init.fasl differ diff --git a/libtest.scm b/libtest.scm new file mode 100644 index 00000000..698c50f6 --- /dev/null +++ b/libtest.scm @@ -0,0 +1,10 @@ + +(define (library-test state) + (λ (bvec) + (values + state + (library-test + (vec-fold + state bvec))))) + +(library-test 0) + diff --git a/owl/args.scm b/owl/args.scm index 82631278..a64808c2 100644 --- a/owl/args.scm +++ b/owl/args.scm @@ -1,10 +1,10 @@ ;;; ;;; COMMAND LINE ARGUMENT HANDLER -;;; +;;; (define-library (owl args) - (export + (export process-arguments ;; sexp → cl-rules format-rules ;; cl-rules → str print-rules ;; cl-rules → _ @@ -27,13 +27,13 @@ (scheme cxr)) (begin - ;; cl-rules is a ff of + ;; cl-rules is a ff of ;; 'short -> -x ;; 'long -> --xylitol ;; str (rule-ff ..) → #false | rule-ff (define (select-rule string rules) - (if (null? rules) + (if (null? rules) #false (let ((this (car rules))) (if (or (equal? string (getf this 'short)) @@ -41,8 +41,6 @@ this (select-rule string (cdr rules)))))) - (define (self x) x) - ;; "-foo" → ("-f" "-o" "-o") | #false (define (explode str) (if (m/^-[^-]{2,}/ str) @@ -60,7 +58,7 @@ (define (undefined? ff key) (eq? blank (get ff key blank))) - (define (defined? ff key) + (define (defined? ff key) (not (undefined? ff key))) ;; check that all rules which are marked mandatory have the corresponding id defined in dict @@ -71,8 +69,8 @@ (if (defined? dict (getf rule 'id)) ok? (begin - (write-bytes stderr - (foldr render '(10) + (write-bytes stderr + (foldr render '(10) (list "mandatory option not given: " (get rule 'long "(missing)")))) #false)) ok?)) @@ -80,11 +78,11 @@ ;; set set all default which are not set explicitly (define (fill-defaults dict rules) - (fold + (fold (λ (dict rule) (let ((id (getf rule 'id))) (if (and (undefined? dict id) (defined? rule 'default)) - (put dict id + (put dict id (let ((cookd ((getf rule 'cook) (getf rule 'default)))) (if (getf rule 'plural) (list cookd) cookd))) ; <- a single plural default value needs to be listed dict))) @@ -96,9 +94,9 @@ (if (lesser? s 1) #false (eq? 45 (refb str 0))))) - + (define (walk rules args dict others) - (cond + (cond ((null? args) (if (mandatory-args-given? dict rules) (tuple (fill-defaults dict rules) (reverse others)) @@ -117,13 +115,13 @@ (fail (list "'" (car args) "' requires an argument.")) (lets ((value (cook (cadr args))) - (ok? ((get rule 'pred (λ (x) x)) value))) + (ok? ((get rule 'pred self) value))) (if ok? - (walk rules + (walk rules ;; instert an implicit -- after terminal rules to stop (if (getf rule 'terminal) (cons "--" (cddr args)) (cddr args)) (put dict id - (if (getf rule 'plural) + (if (getf rule 'plural) ;; put values to a list if this is a multi argument (append (get dict id null) (list value)) value)) @@ -131,7 +129,7 @@ (fail (list "The argument '" (car args) "' did not accept '" (cadr args) "'."))))) ;; this doesn't have an argument, just count them - (walk rules (cdr args) + (walk rules (cdr args) (put dict id (+ 1 (get dict id 0))) others))))) ((explode (car args)) => @@ -187,12 +185,12 @@ (else (error "cl-rule: i do not get this: " lst)))))) - ; (name short long comment default (cook) (predicate) (mandatory?) (single?) (terminal?)) + ; (name short long comment default (cook) (predicate) (mandatory?) (single?) (terminal?)) (define (cl-rules lst) (map (λ (lst) (if (and (>= (length lst) 3) (symbol? (car lst))) - (cl-rule + (cl-rule (list->ff (zip cons '(id short long) lst)) (cdddr lst)) (error "cl-rules: funny option: " lst))) @@ -206,14 +204,14 @@ ;; rules → string (define (format-rules rules) (runes->string - (foldr - (λ (rule tl) - (foldr + (foldr + (λ (rule tl) + (foldr render tl - (list " " + (list " " (let ((short (getf rule 'short))) - (if short + (if short (string-append short " | ") " ")) (getf rule 'long) @@ -222,7 +220,7 @@ (string-append ", " (getf rule 'comment)) "") (if (getf rule 'default) - (foldr string-append "]" + (foldr string-append "]" (list " [" (getf rule 'default))) "") (if (getf rule 'mandatory) " (mandatory)" "") @@ -231,6 +229,6 @@ nl))) null rules))) - (define print-rules - (o display format-rules)))) - + (define print-rules + (B display format-rules)) +)) diff --git a/owl/assemble.scm b/owl/assemble.scm index 32b730df..676ffd8c 100644 --- a/owl/assemble.scm +++ b/owl/assemble.scm @@ -264,7 +264,7 @@ ;; make bytecode and intern it (to improve sharing, not mandatory) (define (bytes->bytecode bytes) - (interact 'intern (raw bytes type-bytecode #false))) + (interact 'intern (raw bytes type-bytecode))) ; code rtl object -> executable code ;; todo: exit via fail cont @@ -285,7 +285,7 @@ (error "too much bytecode: " len)) (bytes->bytecode (if fixed? - (ilist 25 arity + (ilist 34 arity (band 255 (>> len 8)) ;; hi jump (band 255 len) ;; low jump (append bytes diff --git a/owl/ast.scm b/owl/ast.scm index f62079d9..16c31e0c 100644 --- a/owl/ast.scm +++ b/owl/ast.scm @@ -24,7 +24,7 @@ (define (call? thing) (eq? (ref thing 1) 'call)) (define (var? thing) (eq? (ref thing 1) 'var)) - (define (value-of node) (ref node 2)) + (define value-of (C ref 2)) (define (mkval val) (tuple 'value val)) @@ -131,7 +131,7 @@ (then (lref exp 4)) (else (lref exp 5))) (tuple 'branch - (lref exp 1) ; type + (lref exp 1) ; type (translate a env fail) (translate b env fail) (translate then env fail) @@ -143,8 +143,8 @@ (translate (cadr exp) env fail) (translate (caddr exp) env fail)) (fail (list "Bad case-lambda node: " exp)))) - ((receive) ; (receive ) - (tuple 'receive + ((receive) ; (receive ) + (tuple 'receive (translate (lref exp 1) env fail) (translate (lref exp 2) env fail))) ;; FIXME pattern @@ -163,7 +163,7 @@ (cdr exp)))) ;; both now handled by apply-env ;((undefined) - ; (fail (list "i do not know this function" exp))) + ; (fail (list "i do not know this function" exp))) ; left here to handle primops temporarily ((defined value) (mkcall value @@ -214,6 +214,6 @@ (call/cc (lambda (drop) (tuple 'ok - (translate exp env - (lambda (reason) (drop (fail reason)))) - env)))))) + (translate exp env (B drop fail)) + env)))) +)) diff --git a/owl/base.scm b/owl/base.scm index da7a7a7d..ca755fc9 100644 --- a/owl/base.scm +++ b/owl/base.scm @@ -3,6 +3,7 @@ (define-library (owl base) (export + (exports (owl defmac)) (exports (owl list)) (exports (owl rlist)) (exports (owl list-extra)) @@ -10,13 +11,11 @@ (exports (owl io)) (exports (owl lazy)) (exports (owl string)) - (exports (scheme base)) (exports (owl symbol)) (exports (owl sort)) (exports (owl vector)) (exports (owl equal)) (exports (owl random)) - (exports (owl defmac)) (exports (owl render)) (exports (owl syscall)) (exports (owl bisect)) @@ -30,26 +29,28 @@ (exports (owl math)) (exports (owl tuple)) (exports (owl digest)) - (exports (scheme cxr)) - (exports (scheme time)) + halt + lets/cc + read + read-ll + suspend wait - call/cc - lets/cc) + (exports (scheme base)) + (exports (scheme cxr))) (import + (owl defmac) (owl list) (owl rlist) (owl list-extra) (owl tuple) (owl ff) - (owl primop) (owl io) (owl port) (owl time) (owl lazy) (owl math-extra) (owl string) - (scheme base) (owl symbol) (owl sort) (owl fasl) @@ -59,11 +60,22 @@ (owl equal) (owl random) (owl regex) - (owl defmac) (owl suffix) (owl render) (owl syscall) (owl math) (owl digest) + (only (owl dump) suspend) + (only (owl primop) halt lets/cc wait) + (only (owl sexp) read read-ll) + (scheme base) (scheme cxr) - (scheme time))) + + ;; just pull into the fasl + (owl codec) + (owl date) + (scheme case-lambda) + (scheme complex) + (scheme process-context) + (scheme time) + (scheme write))) diff --git a/owl/boolean.scm b/owl/boolean.scm index 3c5563e3..e43f5a60 100644 --- a/owl/boolean.scm +++ b/owl/boolean.scm @@ -1,14 +1,14 @@ (define-library (owl boolean) - (export boolean?) + (export + boolean?) (import (owl defmac)) (begin + (define (boolean? x) - (cond - ((eq? x #true) #true) - ((eq? x #false) #true) - (else #false))))) + (or (eq? x #true) (eq? x #false))) +)) diff --git a/owl/cgen.scm b/owl/cgen.scm index 9e1ce7bc..9b9392b5 100644 --- a/owl/cgen.scm +++ b/owl/cgen.scm @@ -56,7 +56,7 @@ ; -> list of bytes | #false (define (code->bytes code extras) (if (bytecode? code) - (let ((bytes (map (λ (p) (refb code p)) (iota 0 1 (sizeb code))))) + (let ((bytes (map (H refb code) (iota 0 1 (sizeb code))))) (if (eq? (car bytes) 0) ;; (0 ) == call extra instruction (lets ((opcode (+ (<< (cadr bytes) 8) (car (cddr bytes)))) @@ -118,7 +118,7 @@ (define (cify-sysprim bs regs fail) (lets ((op a1 a2 a3 ret bs (get5 (cdr bs)))) (values - (list "R["ret"]=prim_sys(fixval(R["op"]), R["a1"], R["a2"], R["a3"]);") + (list "R["ret"]=prim_sys(immval(R["op"]), R["a1"], R["a2"], R["a3"]);") bs (del regs ret)))) (define (cify-type bs regs fail) @@ -152,7 +152,7 @@ ;; lraw lst-reg type-reg flipp-reg to (define (cify-lraw bs regs fail) (lets ((lr tr fr to bs (get4 (cdr bs)))) - (values (list "R["to"]=prim_lraw(R["lr"],fixval(R["tr"]),R["fr"]);") bs + (values (list "R["to"]=prim_lraw(R["lr"],immval(R["tr"]));") bs (del regs to)))) ; <- lraw can fail ;; ref ob pos to @@ -168,7 +168,7 @@ (else (values ;; res is shifted down, so there is room for high bit - (list "{word res=fixval(R["a"])+fixval(R["b"]);R["o"]=BOOL(res&(1<>FBITS));}") + (list "{uint64_t res=(uint64_t)immval(R["a"])*(uint64_t)immval(R["b"]);R["l"]=F(res&FMAX);R["h"]=F(res>>FBITS);}") bs (put (put regs h 'fixnum) l 'fixnum)))) ; fx- a b r u? (define (cify-fxsub bs regs fail) (lets ((a b r u bs (get4 (cdr bs)))) (values - ;(list "{word a=fixval(R["a"]);word b=fixval(R["b"]);if(b>a){R["r"]=F((a|0x10000)-b);R["u"]=ITRUE;}else{R["r"]=F(a-b);R["u"]=IFALSE;}}") + ;(list "{word a=immval(R["a"]);word b=immval(R["b"]);if(b>a){R["r"]=F((a|0x10000)-b);R["u"]=ITRUE;}else{R["r"]=F(a-b);R["u"]=IFALSE;}}") ;(list "{word res=(R["a"]|0x10000000)-(R["b"]&0xffff000);R["r"]=res&0xffff002;;R["u"]=(res&0x10000000)?IFALSE:ITRUE;}") - (list "{word r=(fixval(R["a"])|(1<>FBITS);R["lo"]=F(res&FMAX);}") + (list "{uint64_t res=(uint64_t)immval(R["a"])<>FBITS);R["lo"]=F(res&FMAX);}") bs (put (put regs lo 'fixnum) hi 'fixnum)))) ; fx>> a b hi lo (define (cify-fxright bs regs fail) (lets ((a b hi lo bs (get4 (cdr bs)))) (values - (list "{uint64_t r=(uint64_t)fixval(R["a"])<<(FBITS-fixval(R["b"]));R["hi"]=F(r>>FBITS);R["lo"]=F(r&FMAX);}") + (list "{uint64_t r=(uint64_t)immval(R["a"])<<(FBITS-immval(R["b"]));R["hi"]=F(r>>FBITS);R["lo"]=F(r&FMAX);}") bs (put (put regs lo 'fixnum) hi 'fixnum)))) ; fxqr ah al b qh ql rem, for (ah<<16 | al) = (qh<<16 | ql)*b + rem (define (cify-fxqr bs regs fail) (lets ((ah al b qh ql rem bs (get6 (cdr bs)))) (values - (list "{uint64_t a=((uint64_t)fixval(R["ah"]))<>FBITS);R["ql"]=F(q&FMAX);R["rem"]=F(a-q*b);}") + (list "{uint64_t a=(uint64_t)immval(R["ah"])<>FBITS);R["ql"]=F(q&FMAX);R["rem"]=F(a-q*b);}") bs (put (put (put regs qh 'fixnum) ql 'fixnum) rem 'fixnum)))) ; fxqr ah al b qh ql rem, for (ah<<16 | al) = (qh<<16 | ql)*b + rem @@ -272,7 +272,7 @@ (define (cify-cast bs regs fail) (lets ((ob type to bs (get3 (cdr bs)))) (values - (list "R["to"]=prim_cast((word *)R["ob"],fixval(R["type"])&63);") bs + (list "R["to"]=prim_cast((word *)R["ob"],immval(R["type"])&63);") bs (del regs to)))) (define (cify-mkt bs regs fail) @@ -459,7 +459,7 @@ (values (list "ob=(word *)R[3];R[3]=R[" res "];acc=1;") ; the goto apply is automatic null regs)))))) ;; <- always end compiling (another branch may continue here) - (cons 25 ;; fixed jump-arity n hi8 lo8 + (cons 34 ;; fixed jump-arity n hi8 lo8 (λ (bs regs fail) (lets ((arity hi8 lo8 bs (get3 (cdr bs))) @@ -470,7 +470,7 @@ bs regs (drop bs jump-len) regs ) regs)))) - ;(cons (bor 25 64) ;; jump-variable-arity n + ;(cons 25 ;; jump-variable-arity n ; (λ (bs regs fail) ; (lets ; ((arity hi8 lo8 bs (get3 (cdr bs))) @@ -632,7 +632,7 @@ (emit-c then-bs then-regs fail (cons "}else{" (emit-c else-bs else-regs fail (cons "}" tail))))))))) - + (else ;; instruction compiled, handle the rest (append res (emit-c tl regs fail tail))))))) @@ -648,7 +648,7 @@ (foldr render null (emit-c ops empty (λ () (ret #false)) null))))))) #false)) - + )) ; (import (owl cgen)) ; (print (compile-to-c sys-prim *vm-special-ops*)) diff --git a/owl/checksum.scm b/owl/checksum.scm deleted file mode 100644 index 67028b6d..00000000 --- a/owl/checksum.scm +++ /dev/null @@ -1,180 +0,0 @@ -;;; -;;; A simple checksummer -;;; - -not currently in use - -(define-library (owl checksum) - (export - checksum ; ll -> nat, default checksum - adler-32 - fletcher-64 - make-checksummer) - - (import - (owl defmac) - (owl math) - (owl math-extra) - (owl list) - (owl string) - (owl vector) - (only (owl syscall) error) - (owl proof) - (owl lazy)) - - (begin - - ;;; Adler32 checksum - simple and fast to calculate - - (define adler-mod 65521) ; largest prime in 16 bits - - ;; fixme: fixnum add-mod with substract would be much better - (define (adler-32 ll) - (let loop ((ll ll) (a 1) (b 0)) - (cond - ((pair? ll) - (let ((a (rem (+ a (car ll)) adler-mod))) - (loop (cdr ll) - a (rem (+ a b) adler-mod)))) - ((null? ll) (+ (<< b 16) a)) - (else (loop (ll) a b))))) - - ;;; AdlerX checksum - get an Adler of any size - - ;; todo: add pseudoprime? to lib-math, ad optionally use largest-primeish here - (define (largest-prime-below n) - (cond - ((prime? n) n) - ((< n 2) 2) ; not exactly below.. - (else (largest-prime-below (- n 1))))) - - ;; bignum remainder is expensive, and rarely actually needed when numbers (usually 0-256) are below modulus - (define (add-mod a b m) - (let ((a (+ a b))) - (if (eq? (type a) type-fix+) - (rem a m) - (let loop ((a (+ a b))) - (if (< a m) a (loop (- a m))))))) - - ;; fixme: no bit amount guard in make-adler - - ;; recall that finding largest prime below n is not exactly O(1) - - (define (make-adler n) - (let ((modulus (largest-prime-below (- (<< 1 (>> n 1)) 1)))) - (define (walk lst a b) - (cond - ((null? lst) - (lets - ((abits (>> n 1)) - (bbits (- n abits))) - (bor (band a (- (<< 1 abits) 1)) - (<< (band b (- (<< 1 bbits) 1)) abits)))) - - ((pair? lst) - (let ((a (add-mod a (car lst) modulus))) - (walk (cdr lst) a - (add-mod b a modulus)))) - (else (walk (lst) a b)))) - (λ (lst) (walk lst 1 0)))) - - ;;; a quick check - - (let - ((data (string->list "Wikipedia")) ;; guess where the example checksum is from - (expected 300286872)) - (if (not (= expected (adler-32 data))) - (error "adler-32 is broken: " 'bad)) - (if (not (= expected ((make-adler 32) data))) - (error "make-adler is broken: " 'bad))) - - ;;; Fletcher64 (composite modulus, faster to compute but less accurate results) - - (define fletcher-bits #xffffffff) ; checksum will have twice this many bits - - (define (fletcher-64 ll) - (let loop ((ll ll) (a 716742388357) (b 4946315)) - (cond - ((pair? ll) - (lets - ((a (band (+ a (car ll)) fletcher-bits)) - (b (band (+ a b) fletcher-bits))) - (loop (cdr ll) a b))) - ((null? ll) (* a b)) ; shift would actually be better (larger target space) - (else (loop (ll) a b))))) - - - - ;;; Fletcher - - ; a simpler version of Adler, which could be faster in owl - - ; a = rolling sum of n (bitwise and 2^n-1) - ; b = rolling sum of as (ditto)a - ; finish = a (<< n) | b - - (define (make-fletcher total-bits) ; work in 2^(16*nd) - - (define bits (ceil (/ total-bits 2))) - - (define mask (- (expt 2 bits) 1)) - - (define (walk lst a b s) - (cond - ((null? lst) - (bor (band b mask) - (<< (band a mask) bits))) - ((eq? s bits) - (lets - ((a (band mask (+ a (car lst)))) - (b (band mask (+ a b)))) - (walk (cdr lst) a b 0))) - (else - (lets - ((a (+ a (car lst))) - (b (+ a b)) - (s _ (fx+ s 1))) - (walk (cdr lst) a b s))))) - - (λ (lst) (walk lst 0 0 #true))) - - ;;; - ;;; Default operations - ;;; - - ;; default generic checksum - - (define default-checksummer adler-32) - - (define (checksum x) - (cond - ((pair? x) (default-checksummer x)) - ((null? x) (default-checksummer x)) - ((string? x) (default-checksummer (str-iter x))) - ((vector? x) (default-checksummer (vec-iter x))) - (else - (error "checksum: what is " x)))) - - - ;; default checksum generator - - ; nbits -> ((byte ...) -> checksum), where 0 <= checksum <= 2^nbits - - (define default-checksummer - ;make-fletcher ; O(1) construction, many duplicates - make-adler ; slow construction for large n, pretty accurate - ) - - ;; n → (list|vector|string → checksum) - (define (make-checksummer n) - (let ((csum (default-checksummer n))) - (λ (data) - (csum - (cond - ((pair? data) data) - ((null? data) data) - ((string? data) (str-iter data)) - ((vector? data) (vec-iter data)) - (else (error "how do i compute a checksum for " data))))))))) - - diff --git a/owl/codec.scm b/owl/codec.scm index 7b7a3ecf..e39337c0 100644 --- a/owl/codec.scm +++ b/owl/codec.scm @@ -1,17 +1,32 @@ +;;; The codec library contains some simple content encoding transformations. +;;; +;;; ``` +;;; (hex-encode "slartibartfast") → "736c617274696261727466617374" +;;; (hex-decode "736c617274696261727466617374") → "slartibartfast" +;;; (hex-decode "7") → #false +;;; (hex-encode "λx.x") → "cebb782e78" +;;; (hex-decode "cebb782e78") → "λx.x" +;;; ``` + (define-library (owl codec) - (import - (owl base) - (owl proof)) + (import + (owl defmac) + (owl list) + (owl math) + (owl proof) + (owl string) + (owl syscall) + (owl vector)) - (export + (export hex-encode-list ;; (byte ...) → str hex-encode ;; str → str hex-decode ;; str → str | #false hex-decode-list) ;; str → (byte ...) | #false (begin - + (define hex-chars (vector #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\f)) @@ -19,7 +34,7 @@ (define (hex-encode-bytes lst) (foldr (λ (x tl) - (ilist + (ilist (vector-ref hex-chars (>> x 4)) (vector-ref hex-chars (band x 15)) tl)) @@ -45,7 +60,7 @@ #false) ((hex-char->bits b) => (lambda (b) - (lets + (lets ((a bs bs) (a (hex-char->bits a))) (if a @@ -53,17 +68,24 @@ #false)))) (else #false)))))) - (define (hex-encode-list lst) - (list->string - (hex-encode-bytes lst))) - + (define hex-encode-list + (B list->string hex-encode-bytes)) + (define (hex-encode str) - (hex-encode-list - (string->bytes str))) + (cond + ((string? str) + (hex-encode-list + (string->bytes str))) + ((pair? str) + (hex-encode-list str)) + ((null? str) + "") + (else + (error "hex-encode: " str)))) + + (define hex-decode-list + (B hex-decode-bytes string->bytes)) - (define (hex-decode-list str) - (hex-decode-bytes (string->bytes str))) - (define (hex-decode str) (maybe bytes->string (hex-decode-list str))) @@ -71,6 +93,5 @@ (example (hex-decode (hex-encode "")) = "" (hex-decode (hex-encode "foo")) = "foo" - (hex-decode (hex-encode "λä.ä")) = "λä.ä"))) - - + (hex-decode (hex-encode "λä.ä")) = "λä.ä") +)) diff --git a/owl/compile.scm b/owl/compile.scm index 48483ced..8bad1c95 100644 --- a/owl/compile.scm +++ b/owl/compile.scm @@ -4,9 +4,9 @@ (define-library (owl compile) - (export + (export compile - primops + primops prim-opcodes) (import @@ -81,9 +81,9 @@ ((eq? subtype (ref this 1)) (or (find-any (cdr regs) sym type subtype) - (let - ((sub - (index-of sym (ref this 2) 2))) + (let + ((sub + (index-of sym (ref this 2) 2))) ;; FIXME, 2 will not be correct for shared envs (if sub (cons (ref this 3) sub) @@ -233,7 +233,7 @@ (if (null? args) (error "rtl-primitive: no type for mkt" args) (begin - (rtl-primitive regs + (rtl-primitive regs (+ (<< op 8) (band (value-of (car args)) #xff)) formals (cdr args) cont))) (rtl-args regs args @@ -316,8 +316,8 @@ (lets ((call-prime (apply-saves saves free call)) (call-prime (rtl-add-targets call-prime)) - (call-prime - (remove + (call-prime + (remove (λ (move) (eq? (car move) (cdr move))) call-prime)) (call-prime (sort (λ (a b) (< (car a) (car b))) call-prime)) @@ -334,10 +334,9 @@ (λ (ret) (or (lfor #false (subsets call) - (λ (foo subset) + (λ (foo subset) (cond - ((rtl-try-saves subset free call rest) - => (λ (call) (ret call))) + ((rtl-try-saves subset free call rest) => ret) (else #false)))) ; has never happened in practice (error "failed to compile call: " call))))) @@ -402,7 +401,7 @@ ; (error "Bad operator: " rator)) #false ;; <- can't remember why we're not failing here. changed while adding variable arity? ))) - (else + (else ;(print "XXXXXXXXXXXXXXXXXXXXXXX non value call " rator) ;(print "ENV:") ;(for-each (λ (x) (print " - " x)) regs) @@ -414,7 +413,7 @@ (rtl-args regs (cons rator rands) (λ (regs all) (let ((free (rtl-safe-registers (length all) all))) - (rtl-jump (car all) (cdr all) free + (rtl-jump (car all) (cdr all) free (rtl-pick-call regs rator (length rands))))))) (define (value-pred pred) @@ -424,8 +423,8 @@ (else #false)))) (define null-value? (value-pred null?)) - (define false-value? (value-pred (λ (x) (eq? x #false)))) - (define zero-value? (value-pred (λ (x) (eq? x 0)))) + (define false-value? (value-pred (C eq? #f))) + (define zero-value? (value-pred zero?)) (define (simple-first a b cont) (cond @@ -442,9 +441,9 @@ ;; fixme: ??? O(n) search for opcode->primop. what the... (define (opcode->primop op) - (let + (let ((node - (some + (some (λ (x) (if (eq? (ref x 2) op) x #false)) primops))) (if node node (error "Unknown primop: " op)))) @@ -470,19 +469,19 @@ ;; todo: convert jump-if- rtl nodes to a single shared rtl node to avoid having to deal with them as separate instructions ((null-value? a) ; jump-if-null (optimization) (rtl-simple regs b (λ (regs bp) - (let + (let ((then (rtl-any regs then)) (else (rtl-any regs else))) (tuple 'jn bp then else))))) ((false-value? a) ; jump-if-false (rtl-simple regs b (λ (regs bp) - (let + (let ((then (rtl-any regs then)) (else (rtl-any regs else))) (tuple 'jf bp then else))))) ((zero-value? a) ; jump-if-false (rtl-simple regs b (λ (regs bp) - (let + (let ((then (rtl-any regs then)) (else (rtl-any regs else))) (tuple 'jz bp then else))))) @@ -498,16 +497,16 @@ ; FIXME check object size here (via meta) (let ((b (extract-value b))) (if (and (fixnum? b) (>= b 0) (< b 257)) - (rtl-simple regs a + (rtl-simple regs a (λ (regs ap) (tuple-case then ((lambda formals body) (bind (rtl-bind regs formals) (λ (selected then-regs) - (let + (let ((then-body (rtl-any then-regs body)) (else (rtl-any regs else))) - (tuple 'jab ap b + (tuple 'jab ap b (tuple 'lambda selected then-body) else))))) (else @@ -523,9 +522,9 @@ ((lambda formals body) (if (opcode-arity-ok? op (length (cdr rands))) (rtl-primitive regs op formals (cdr rands) - (λ (regs) (rtl-any regs body))) + (C rtl-any body)) ;; fixme: should be a way to show just parts of AST nodes, which may look odd - (error "Bad number of arguments for primitive: " + (error "Bad number of arguments for primitive: " (list 'op (primop-name op) 'got (length (cdr rands)) 'arguments)))) (else (error "bad primitive args: " rands))) @@ -572,18 +571,18 @@ ; code .. → code' ... (define (rtl-literals rtl-procedure lits) ;;; convert all uncompiled closures to procedures - (map (λ (lit) (rtl-literal rtl-procedure lit)) lits)) + (map (H rtl-literal rtl-procedure) lits)) (define (list->proc lst) (listuple type-proc (length lst) lst)) ;; rtl-procedure now passes the intended new form here - replace it later in the AST node also (define (rtl-plain-lambda rtl exp clos literals tail) - (tuple-case exp + (tuple-case exp ((lambda-var fixed? formals body) (lets ((exec - (assemble-code + (assemble-code (tuple 'code-var fixed? (length formals) (rtl-any (entry-regs clos literals formals) body)) @@ -592,7 +591,7 @@ exec ; # (list->proc (cons exec literals))))) ((lambda formals body) ;; to be deprecated - (rtl-plain-lambda rtl + (rtl-plain-lambda rtl (tuple 'lambda-var #true formals body) clos literals tail)) (else @@ -602,28 +601,28 @@ (define (bytecode->list thing) (cond ((bytecode? thing) - (map (λ (p) (refb thing p)) (iota 0 1 (sizeb thing)))) + (map (H refb thing) (iota 0 1 (sizeb thing)))) ((function? thing) ;; get the bytecode (bytecode->list (ref thing 1))) (else (error "bytecode->list: " thing)))) - + (define (rtl-case-lambda rtl exp clos literals) (tuple-case exp ((lambda-var fixed? formals body) (rtl-plain-lambda rtl exp clos literals null)) ((lambda formals body) ;; soon to be deprecated - (rtl-case-lambda rtl + (rtl-case-lambda rtl (tuple 'lambda-var #true formals body) clos literals)) ((case-lambda func else) (rtl-plain-lambda rtl func clos literals - (bytecode->list + (bytecode->list (rtl-case-lambda rtl else clos literals)))) (else (error "rtl-case-lambda: bad node " exp)))) - + ;; todo: separate closure nodes from lambdas now that the arity may vary ;; todo: control flow analysis time - if we can see what the arguments are here, the info could be used to make most continuation returns direct via known call opcodes, which could remove an important branch prediction killer ;;; proc = #(procedure-header l0 ... ln) @@ -639,7 +638,7 @@ (tuple 'lambda-var fixed? formals body) clos (rtl-literals rtl-procedure literals) null)) ((closure-case body clos literals) - (lets + (lets ((lits (rtl-literals rtl-procedure literals)) (body (rtl-case-lambda rtl-procedure body clos lits))) body)) @@ -659,5 +658,4 @@ ;; todo: exit via fail cont on errors (define (compile exp env) (ok (rtl-exp exp) env)) - )) diff --git a/owl/cps.scm b/owl/cps.scm index 871a3bbd..e38475d2 100644 --- a/owl/cps.scm +++ b/owl/cps.scm @@ -242,9 +242,9 @@ ((branch kind a b then else) (cps-branch cps-exp kind a b then else env cont free)) ((values vals) - (cps-values cps-exp vals env cont free)) + (cps-values cps-exp vals env cont free)) ((receive exp target) - (cps-receive cps-exp exp target env cont free)) + (cps-receive cps-exp exp target env cont free)) ((case-lambda fn else) (lets ((res free (cps-case-lambda cps-exp exp env cont free))) (values (mkcall cont (list res)) free))) @@ -263,13 +263,13 @@ (or (call/cc (lambda (fail) - (let ((cont-sym (gensym exp))) - ; a hack to be able to define code sans cps - ; a better solution would be ability to change the + (let ((cont-sym (gensym exp))) + ; a hack to be able to define code sans cps + ; a better solution would be ability to change the ; compiler chain interactively - (if (and + (if (and (call? exp) - (val-eq? (ref exp 2) '_sans_cps) + (val-eq? (ref exp 2) '_sans_cps) (= (length (ref exp 3)) 1)) (ok (mklambda (list cont-sym) @@ -282,4 +282,3 @@ env)))))) (fail "cps failed"))) )) - diff --git a/owl/date.scm b/owl/date.scm index 8a468daf..e5214c0b 100644 --- a/owl/date.scm +++ b/owl/date.scm @@ -1,3 +1,18 @@ +;;; This library attempts to implement date processing functions. Dates +;;; are typically represented as seconds or milliseconds since UNIX Epoch 1.1.1970. +;;; These are generally a good way to work with time, apart from assuming +;;; that an absolute time exists at all. Sometimes it is however necessary +;;; to convert time stamps to human readable form, which means splitting +;;; the time according to various more and less sensible rules. +;;; +;;; ``` +;;; (time) → current time in seconds since epoch +;;; (time-ms) → current time in milliseconds since epoch +;;; (date-str 0) → "00:00:00 1.1.1970 UTC+00:00" +;;; (date-str (time) 2.5) → "20:49:08 19.3.2018 UTC+02:30" +;;; (date 0) → 1 1 1970 0 0 0 ; as multiple values +;;; (leap-year? 2018) → #false +;;; ``` ;; todo: check how far before 1970 these hold ;; todo: --rfc-2822 @@ -6,8 +21,12 @@ (define-library (owl date) (import - (owl base) - (owl proof)) + (owl defmac) + (owl math) + (owl proof) + (owl render) + (owl time) + (owl syscall)) (export date @@ -50,9 +69,9 @@ #true)) #false))) - (define month-durations + (define month-durations (tuple 31 #false 31 30 31 30 31 31 30 31 30 31)) - + (define (days-in-month month year) (if (eq? month 2) (if (leap-year? year) 29 28) @@ -68,14 +87,14 @@ (values 1 (+ month 1) year))) (else (values (+ day 1) month year)))) - + ;; date is valid *and* date computations work for it (define (valid-date? d m y) (and (and (fixnum? m) (<= 1 m 12)) (and (integer? y) (> y 1200)) ;; check prior years also - (and (fixnum? d) (>= d 1) + (and (fixnum? d) (>= d 1) (<= d (days-in-month m y))))) ;;; @@ -84,7 +103,7 @@ (define (leap-years-before y) (cond - ((< y 5) + ((< y 5) (if (< y 1) (error "year must be >=1, but was " y) 1)) @@ -127,13 +146,13 @@ (- 4 d) (+ 4 (- 7 d)))) - (define (days-to-sunday d) - (- 7 d)) + (define days-to-sunday + (H - 7)) (define (maybe-swap-year y md week day) (cond ((< week 52) (values week day)) - ((> day 3) + ((> day 3) ;; thursday already contained in this week (values week day)) ((< (+ md (days-to-sunday day)) 32) @@ -169,18 +188,17 @@ (lets ((wn wd (week-info d m y))) (values d m y wd wn))) (values d m y (+ week-day 1) week-num)))) - + (example (next-date-with-week 31 12 1971 5 1) = (values 1 1 1972 6 1) (next-date-with-week 27 12 1970 7 52) = (values 28 12 1970 1 53)) - + ;;; ;;; UNIXish time ;;; - (define leap-years-since-epoch - (let ((before-epoch (leap-years-before 1970))) - (lambda (y) (- (leap-years-before y) before-epoch)))) + (define leap-years-since-epoch + (B (C - (leap-years-before 1970)) leap-years-before)) (define (seek-year s) (let loop ((s s) (y 1970)) @@ -205,27 +223,27 @@ (define date (case-lambda - (() (naive-date (time))) + (() (naive-date (time))) ((sec) (naive-date sec)))) (define (hours->secs h) (floor (* h 3600))) - + (define (date-str-tz s tz) (lets ((d m y H M S (naive-date (+ s tz))) (tz-sign (if (< tz 0) "-" "+")) (tz (abs tz)) (tz-mins _ (quotrem tz 60)) (tz-hours tz-mins (quotrem tz-mins 60))) - (str (zpad H) H ":" (zpad M) M ":" (zpad S) S + (str (zpad H) H ":" (zpad M) M ":" (zpad S) S " " d "." m "." y " UTC" tz-sign (zpad tz-hours) tz-hours ":" (zpad tz-mins) tz-mins))) - + (define (date-str s . tz) (if (null? tz) (date-str-tz s 0) (date-str-tz s (hours->secs (car tz))))) - + ; TZ=GMT date -d @1234567890 (example (date-str 0) = "00:00:00 1.1.1970 UTC+00:00" @@ -233,4 +251,3 @@ (date-str 1234567890 0) = "23:31:30 13.2.2009 UTC+00:00") )) - diff --git a/owl/defmac.scm b/owl/defmac.scm index a1f97a4a..01e3789b 100644 --- a/owl/defmac.scm +++ b/owl/defmac.scm @@ -1,26 +1,26 @@ - + (define-library (owl defmac) (export - λ syntax-error begin - quasiquote letrec let if + λ syntax-error begin + quasiquote letrec let if letrec* let*-values cond case define define* lets let* or and list - ilist tuple tuple-case + ilist tuple tuple-case call-with-values do define-library case-lambda define-values define-record-type _record-values - not o i self + not B C H I K self type-complex type-rational type-int+ type-int- type-record - immediate? allocated? raw? record? eof? + immediate? allocated? raw? record? -> ->> if-lets @@ -34,15 +34,12 @@ type-vector-leaf type-vector-raw type-ff-black-leaf - type-eof type-tuple type-symbol type-const type-rlist-spine type-rlist-node - type-port - type-socket - type-tcp-client + type-port type-string type-string-wide type-string-dispatch @@ -63,8 +60,8 @@ (begin - (define-syntax λ - (syntax-rules () + (define-syntax λ + (syntax-rules () ((λ . x) (lambda . x)))) (define-syntax syntax-error @@ -75,7 +72,7 @@ ;; expand case-lambda syntax to to (_case-lambda (_case-lambda ... (_case-lambda exp) . rest) + ((cond (clause => exp) . rest) (let ((fresh clause)) (if fresh (exp fresh) (cond . rest)))) - ((cond (clause exp . rest-exps) . rest) + ((cond (clause exp . rest-exps) . rest) (if clause (begin exp . rest-exps) (cond . rest))))) @@ -224,9 +221,9 @@ (define-syntax define* (syntax-rules (print list) ((define* (op . args) . body) - (define (op . args) + (define (op . args) (print " * " (list (quote op) . args)) - . body)) + . body)) ((define* name (lambda (arg ...) . body)) (define* (name arg ...) . body)))) @@ -238,11 +235,11 @@ ((lambda (var) (lets rest-bindings exp . rest-exps)) val)) ((lets ((var ... (op . args)) . rest-bindings) exp . rest-exps) (receive (op . args) - (lambda (var ...) + (lambda (var ...) (lets rest-bindings exp . rest-exps)))) ((lets ((var ... node) . rest-bindings) exp . rest-exps) (bind node - (lambda (var ...) + (lambda (var ...) (lets rest-bindings exp . rest-exps)))) ((lets (((name ...) <= value) . rest) . code) (bind value @@ -266,7 +263,7 @@ (λ (var ...) (let*-values rest . body)))) ((let*-values () . rest) (begin . rest)))) - + ; i hate special characters, especially in such common operations. ; lets (let sequence) is way prettier and a bit more descriptive @@ -313,8 +310,8 @@ ((quasiquote _work () (_sharp_vector . es)) (list->vector (quasiquote _work () es))) - ((quasiquote _work d (a . b)) - (cons (quasiquote _work d a) + ((quasiquote _work d (a . b)) + (cons (quasiquote _work d a) (quasiquote _work d b))) ((quasiquote _work d atom) (quote atom)) @@ -372,20 +369,20 @@ (receive (thunk) (lambda (arg ...) body))))) (define-syntax do - (syntax-rules (__init) - ((do __init () ((var init step) ...) (test then ...) command ...) - (let loop ((var init) ...) - (if test - (begin then ...) - (begin - command ... - (loop step ...))))) - ((do __init ((var init step) . rest) done . tail) - (do __init rest ((var init step) . done) . tail)) - ((do __init ((var init) . rest) done . tail) - (do __init rest ((var init var) . done) . tail)) - ((do (vari ...) (test exp ...) command ...) - (do __init (vari ...) () (test exp ...) command ...)))) + (syntax-rules (__init) + ((do __init () ((var init step) ...) (test then ...) command ...) + (let loop ((var init) ...) + (if test + (begin then ...) + (begin + command ... + (loop step ...))))) + ((do __init ((var init step) . rest) done . tail) + (do __init rest ((var init step) . done) . tail)) + ((do __init ((var init) . rest) done . tail) + (do __init rest ((var init var) . done) . tail)) + ((do (vari ...) (test exp ...) command ...) + (do __init (vari ...) () (test exp ...) command ...)))) (define-syntax define-library (syntax-rules (export import begin _define-library define-library) @@ -416,21 +413,19 @@ (define (not x) (if x #false #true)) - (define o (λ (f g) (λ (x) (f (g x))))) + ; (define call/cc ('_sans_cps (λ (k f) (f k (λ (r a) (k a)))))) - (define i (λ (x) x)) + (define (B f g) (λ (x) (f (g x)))) - (define eof? - (let ((eof (cast 4 13))) - (lambda (x) - (eq? x eof)))) + (define (C f y) (λ (x) (f x y))) - (define self i) + (define (H f x) (λ (y) (f x y))) - ; (define call/cc ('_sans_cps (λ (k f) (f k (λ (r a) (k a)))))) + (define (I x) x) + + (define (K x y) x) - (define (i x) x) - (define (k x y) x) + (define self I) ;;; @@ -448,14 +443,15 @@ ; object headers are further ; ; .----> immediate - ; [ssssssss ssssssss ????rppp tttttt10] - ; '---------------| '--||'-| '----| - ; | || | '-----> object type - ; | || '------------> number of padding (unused) bytes at end of object if raw (0-(wordsize-1)) - ; | |'---------------> rawness bit (raw objects have no decriptors in them) - ; | '----------------> your tags here! e.g. tag for closing file descriptors in gc + ; [ssssssss ssssssss ???trppp tttttt10] + ; '---------------| '-|||'-| '----| + ; | ||| | '-----> object type + ; | ||| '------------> number of padding (unused) bytes at end of object if raw (0-(wordsize-1)) + ; | ||'---------------> rawness bit (raw objects have no decriptors in them) + ; | |'----------------> teardown bit - something needs to be done if freed by gc + ; | '-----------------> your tags here! e.g. tag for closing file descriptors in gc ; '---------------------> object size in words - ; + ; ;; note - there are 6 type bits, but one is currently wasted in old header position ;; to the right of them, so all types must be <32 until they can be slid to right ;; position. @@ -473,7 +469,6 @@ (define type-ff-black-leaf 8) (define type-symbol 4) (define type-tuple 2) - (define type-symbol 4) (define type-rlist-node 14) (define type-rlist-spine 10) (define type-string 3) @@ -481,6 +476,8 @@ (define type-string-dispatch 21) (define type-thread-state 31) (define type-record 5) + (define type-int+ 40) + (define type-int- 41) ;; transitional trees or future ffs (define type-ff 24) @@ -488,21 +485,13 @@ (define type-ff-red 26) (define type-ff-red-r 27) - ; + type-ff-red, type-ff-right - - ; 8 - black ff leaf ;; IMMEDIATE (define type-fix+ 0) (define type-fix- 32) - (define type-int+ 40) - (define type-int- 41) (define type-rational 42) (define type-complex 43) ;; 3 free below - (define type-eof 20) ;; moved from 4, clashing with symbols (define type-const 13) ;; old type-null, moved from 1, clashing with pairs (define type-port 12) - (define type-socket 44) - (define type-tcp-client 62) ;; allocated/pointers allocated/rawdata immediate @@ -514,7 +503,7 @@ (define raw? sizeb) (define (record? x) (eq? type-record (type x))) - (define-syntax _record-values + (define-syntax _record-values (syntax-rules (emit find) ((_record-values emit tag mk pred () fields tail) (values tag mk pred . tail)) @@ -522,13 +511,13 @@ ;; next must cons accessor of field to tail, so need to lookup its position (_record-values find tag mk pred (x ...) fields tail field fields (2 3 4 5 6 7 8 9 10 11 12 13 14 15 16))) ((_record-values find tag mk pred left fields tail key (key . rest) (pos . poss)) - (_record-values emit tag mk pred left fields ((λ (x) (ref x pos)) . tail))) + (_record-values emit tag mk pred left fields ((C ref pos) . tail))) ((_record-values find tag mk pred left fields tail key (x . rest) (pos . poss)) (_record-values find tag mk pred left fields tail key rest poss)) ((_record-values find tag mk pred left fields tail key () (pos . poss)) - (syntax-error "Not found in record: " key)) + (syntax-error "Not found in record: " key)) ((_record-values find tag mk pred left fields tail key (x . rest) ()) - (syntax-error "Implementation restriction: add more offsets to define-record-type macro" tag)))) + (syntax-error "Implementation restriction: add more offsets to define-record-type macro" tag)))) (define-syntax define-record-type (syntax-rules (emit) @@ -536,10 +525,10 @@ (define-values (name constructor pred accessor ...) (let ((tag (quote name))) ; ← note, not unique after redefinition, but atm seems useful to get pattern matching - (_record-values emit - tag + (_record-values emit + tag (λ (fieldname ...) (mkt type-record tag fieldname ...)) - (λ (ob) (eq? tag (ref ob 1))) + (λ (ob) (eq? tag (ref ob 1))) ((field accessor) ...) (fieldname ...) ())))))) (define-syntax -> @@ -564,13 +553,13 @@ then) ((if-lets ((k ... val) . rest) then else) (lets ((k ... val)) - (if k - (if-lets rest then else) - else))) - ((if-lets bindings then) + (if k + (if-lets rest then else) + else))) + ((if-lets bindings then) (if-lets bindings then #false)))) (define (maybe op arg) (if arg (op arg) arg)) - + )) diff --git a/owl/digest.scm b/owl/digest.scm index 04ef0239..c9e2e5e0 100644 --- a/owl/digest.scm +++ b/owl/digest.scm @@ -1,6 +1,19 @@ +;;; The digest library provides functions for computing cryptographic signatures. +;;; Currently SHA1 and SHA256 digests and corresponding message authentication codes +;;; are supported. +;;; +;;; The hash functions also have `hasher-raw` and `hasher-bytes` -variants, which +;;; return the state words and raw signature bytes correspondingly. +;;; +;;; ``` +;;; (sha1 data) → hash-string +;;; (sha256 data) → hash-string +;;; (hmac-sha1 key message) → hash-string +;;; (hmac-sha256 key message) → hash-string +;;; ``` (define-library (owl digest) - + (export sha1 ;; str | vec | list | ll → str sha1-raw ;; ditto → integer list @@ -38,7 +51,7 @@ (c (band (>> n 16) 255)) (d (band (>> n 24) 255))) (values a b c d))) - + (define (sha1-finish-pad bits) (cons #x80 (let loop ((pos (band (+ bits 8) 511))) @@ -49,15 +62,15 @@ (list h g f e d c b a)) (cons 0 (loop (band (+ pos 8) 511))))))) - (define (word x) - (band x #xffffffff)) + (define word + (C band #xffffffff)) (define (rol x n) (word (bor (<< x n) (>> x (- 32 n))))) - + (define (ror x n) (word (bor @@ -84,7 +97,7 @@ (values (bor (bor d (<< c 8)) (bor (<< b 16) (<< a 24))) ll))) - + (define (grab-initial-words ll) (lets ((a ll (uncons ll #false))) (if a ;;something in stream @@ -107,8 +120,8 @@ (define (sha1-step a b c d e f k w) (values (word (+ (rol a 5) f e k w)) a (word (rol b 30)) c d)) - (define (bnot w) - (bxor w #xffffffff)) + (define bnot + (C bxor #xffffffff)) (define (sha1-chunk h0 h1 h2 h3 h4 ws) (let loop ((i 0) (a h0) (b h1) (c h2) (d h3) (e h4) (ws (reverse ws))) @@ -164,8 +177,8 @@ (append (cdr (string->list (number->string (+ #x100 b) 16))) tl)) null bs))) - (define sha1-format-result - (o hash-bytes->string ws->bytes)) + (define sha1-format-result + (B hash-bytes->string ws->bytes)) ;; i-3 i-8 i-14 i-16 (define (sha1-extend-initial-words lst) @@ -202,10 +215,10 @@ (else thing)))) (define sha1-bytes - (o ws->bytes sha1-raw)) + (B ws->bytes sha1-raw)) - (define sha1 - (o sha1-format-result sha1-raw)) + (define sha1 + (B sha1-format-result sha1-raw)) (define (list-xor a b) (cond @@ -226,7 +239,7 @@ (else ;; may be a lazy list or list x))) - + (define (make-hmac hasher blocksize) (lambda (key msg) (lets @@ -242,10 +255,11 @@ (hasher (append (list-xor o-pad key) (hasher (append (list-xor i-pad key) msg))))))) - + (define hmac-sha1-bytes (make-hmac sha1-bytes sha1-blocksize)) + ;; (hmac-sha1 key message) → "result", compute SHA1-based message authentication code (define (hmac-sha1 k m) (hash-bytes->string (hmac-sha1-bytes k m))) @@ -302,7 +316,7 @@ (let loop ((lst lst) (n 16)) (if (eq? n 64) lst - (lets ;; + (lets ((p2 l (pick lst 2)) ;; i-2 (p7 l (pick l 5)) ;; i-7 (p15 l (pick l 8)) ;; i-15 @@ -311,10 +325,10 @@ (s1 (bxor (bxor (ror p2 17) (ror p2 19)) (>> p2 10))) (new (word (+ (+ p16 s0) (+ p7 s1))))) (loop (cons new lst) (+ n 1)))))) - + (define (sha256-chunks ll) - (let loop + (let loop ((ll (sha256-pad ll)) (h0 #x6a09e667) (h1 #xbb67ae85) @@ -333,7 +347,7 @@ (loop ll h0 h1 h2 h3 h4 h5 h6 h7)) (list h0 h1 h2 h3 h4 h5 h6 h7))))) - + (define (sha256-raw thing) (sha256-chunks (cond @@ -342,10 +356,10 @@ (else thing)))) (define sha256-bytes - (o ws->bytes sha256-raw)) + (B ws->bytes sha256-raw)) (define sha256 - (o sha1-format-result sha256-raw)) + (B sha1-format-result sha256-raw)) (define hmac-sha256-bytes (make-hmac sha256-bytes sha256-blocksize)) diff --git a/owl/dump.scm b/owl/dump.scm index 8c8b36c5..b2bfc28b 100644 --- a/owl/dump.scm +++ b/owl/dump.scm @@ -5,16 +5,18 @@ (define-library (owl dump) - (export + (export make-compiler ; ((make-compiler extra-insts) entry path opts native) dump-fasl - load-fasl) + load-fasl + suspend) - (import + (import (owl defmac) (owl fasl) (owl list) (owl sort) + (owl syscall) (owl ff) (owl symbol) (owl vector) @@ -27,6 +29,7 @@ (owl render) (owl lazy) (owl cgen) + (only (owl sys) mem-strings) (only (owl syscall) error mail exit-owl) (only (owl env) signal-halt signal-tag) (only (owl unicode) utf8-decode) @@ -34,9 +37,9 @@ (only (owl queue) qnull)) (begin - ;;; + ;;; ;;; Symbols must be properly interned in a repl. - ;;; + ;;; (define (symbols-of node) @@ -97,7 +100,7 @@ #false (high-point? str pos))) #true)) - + ;; utf-8 decode if necessary (avoids some constant overhead, which is useful if there are 2 quadriollion args) (define (maybe-utf8-decode str) (let ((n (sizeb str))) ;; <- command line args are raw blocks so primitive lenb is ok @@ -151,8 +154,8 @@ #false))) (define (dump-fasl obj path) - (dump-data (fasl-encode-stream obj (lambda (x) x)) path)) - + (dump-data (fasl-encode-stream obj self) path)) + ;; fixme: sould be (load-fasl ) (define (load-fasl path fval) (let ((port (open-input-file path))) @@ -169,13 +172,12 @@ (λ (tl func info) (lets ((opcode new-func c-code info)) ;; render code if there (shared users do not have it) - (if c-code + (if c-code ;; all of these end to an implicit goto apply - (ilist " case " opcode ":" c-code "break; /* " func " */ - " tl) + (ilist " case " opcode ":" c-code "break;\n" tl) tl))) null nops)))) - + ; nodes = ((func . #(opcode warpper src)) ...) @@ -197,8 +199,8 @@ "report this as an issue if this happens for a real program.")) ((compile-to-c (car obs) extras) => (λ (src) - (lets - ((wrapper (raw (list 0 (>> code 8) (band code 255)) type-bytecode #false))) + (lets + ((wrapper (raw (list 0 (>> code 8) (band code 255)) type-bytecode))) (loop (+ code 1) (cdr obs) (cons (cons (car obs) (tuple code wrapper src)) out))))) (else @@ -212,7 +214,7 @@ (define (show-func val) (cons 'bytecode - (map (λ (p) (refb val p)) (iota 0 1 (sizeb val))))) + (map (H refb val) (iota 0 1 (sizeb val))))) ; native-ops → (obj → obj') ;; fixme: rewrite... @@ -220,12 +222,10 @@ (λ (obj) (cond ;; if chosen to be a macro instruction in the new vm, replace with new bytecode calling it - ((get native-ops obj #false) => - (λ (vals) - ; write a reference to the wrapper function instead of the original bytecode - (ref vals 2))) - ;; if this is a macro instruction in the current system, convert back to vanilla bytecode, or the - ;; target machine won't understand this + ;; write a reference to the wrapper function instead of the original bytecode + ((get native-ops obj #false) => (C ref 2)) + ;; if this is a macro instruction in the current system, convert back + ;; to vanilla bytecode, or the target machine won't understand this ((extended-opcode obj) => (λ (opcode) ;(print " * mapping superinstruction back to to bytecode: " opcode) @@ -248,10 +248,10 @@ (clone-code original extras) (error "bug: no original code found for superinstruction " opcode))))) (else - (let ((bytes (map (λ (p) (refb bc p)) (iota 0 1 (sizeb bc))))) + (let ((bytes (map (H refb bc) (iota 0 1 (sizeb bc))))) (if (eq? (cadr bytes) 0) (error "bug: vm speciazation instruction probably referencing code from current vm: " bytes)) - (raw bytes type-bytecode #false))))) ; <- reallocate it + (raw bytes type-bytecode))))) ; <- reallocate it (define (original-sources native-ops extras) (ff-fold @@ -328,14 +328,25 @@ (cook-format (s/^.*\.([a-z]+)$/\1/ path)) #false))) + (define owl-ohai-resume "Welcome back.") + + ; path -> 'loaded | 'saved + (define (suspend path) + (let ((maybe-world (syscall 16 #true #true))) + (if (eq? maybe-world 'resumed) + owl-ohai-resume + (begin + (dump-fasl maybe-world path) + 'saved)))) + + (define with-args + (C B mem-strings)) ; obj → (ff of #[bytecode] → #(native-opcode native-using-bytecode c-fragment)) ; dump entry object to path, or stdout if path is "-" (define (make-compiler extras) (λ (entry path opts native . custom-runtime) ; <- this is the usual compile-owl - (if (null? custom-runtime) - (print-to stderr "custom runtime not provided")) (lets ((path (get opts 'output "-")) ; <- path argument deprecated (format @@ -348,23 +359,16 @@ (if (get opts 'want-threads #false) (with-threading entry) entry)) ; <- continue adding this next - + (entry ;; pass symbols to entry if requested (repls need this) (if (get opts 'want-symbols #false) (entry (symbols-of entry)) entry)) - + (entry ;; pass code vectors to entry if requested (repls need this) (if (get opts 'want-codes #false) (entry (codes-of entry)) entry)) - - ;; fixme: allow a compiler arg to convert this point fully to native to get also the thread scheduler compiled - ;(extra-native ;; choose 10% of most frequently linked code unless compiling a fasl image - ; (cond - ; ((eq? format 'fasl) null) ; fasl -> no natives - ; ((eq? entry native) null) ; everything native anyway - ; (else (most-linked-code entry 10)))) ; pick most linked 10% (testing) (native-ops ;; choose which bytecode vectors to add as extended vm instructions (choose-native-ops (if (get opts 'native #false) entry native) extras)) @@ -380,17 +384,20 @@ entry (with-decoded-args entry))) + (entry ;; pull command line args to owl from **argv + (with-args entry)) + (native-cook ;; make a function to possibly rewrite bytecode during save (usually to native code wrappers) (make-native-cook native-ops extras)) - + (bytes ;; encode the resulting object for saving in some form (fasl-encode-cooked entry native-cook)) - + (runtime (if (and (pair? custom-runtime) (car custom-runtime)) (car custom-runtime) rts-source)) - + (port ;; where to save the result (if (equal? path "-") stdout @@ -407,10 +414,10 @@ (write-bytes port bytes) (close-port port) #true) - ((eq? format 'c) + ((eq? format 'c) (write-bytes port ;; output fasl-encoded heap as an array (append - (string->bytes "unsigned char heap[] = {") + (string->bytes "static const unsigned char heap[] = {") (render-byte-array bytes 24))) ;; dump also a fasl if requested (write-bytes port (string->bytes "};\n ")) @@ -420,10 +427,7 @@ (str-replace runtime "/* AUTOGENERATED INSTRUCTIONS */" (render-native-ops native-ops)))) - + ;; done, now just gcc -O2 -o foo (close-port port)))))) - )) - - diff --git a/owl/env.scm b/owl/env.scm index b028ba18..05be215a 100644 --- a/owl/env.scm +++ b/owl/env.scm @@ -1,13 +1,13 @@ (define-library (owl env) - (export - lookup env-bind + (export + lookup env-bind empty-env apply-env env-fold verbose-vm-error prim-opcodes opcode->wrapper primop-of primitive? poll-tag name-tag link-tag buffer-tag signal-tag signal-halt thread-quantum meta-tag current-library-key - env-set-macro *tabula-rasa* env-del + env-set-macro *tabula-rasa* env-del env-get ;; env key default → val | default env-del ;; env key → env' env-set ;; env-set env key val → env' @@ -46,8 +46,8 @@ (define name-tag '*owl-names*) ; key for reverse function/object → name mapping (define current-library-key '*owl-source*) ; toplevel value storing what is being loaded atm - (define (signal-halt threads state controller) - (print-to stderr "stopping on signal") + (define (signal-halt threads state controller) + (print-to stderr "stopping on signal") (halt 42)) ;; exit owl with a specific return value (define thread-quantum 10000) @@ -71,7 +71,7 @@ (define (env-set env key val) (put env key - (tuple 'defined + (tuple 'defined (tuple 'value val)))) (define (env-set-macro env key transformer) @@ -83,8 +83,8 @@ ((invoke module name arg ...) ((env-get module (quote name) (lambda (arg ...) - (error "invoke: failed to invoke " - (cons (quote name) + (error "invoke: failed to invoke " + (cons (quote name) (list arg ...))))) arg ...)))) @@ -126,12 +126,12 @@ ((bound) exp) ((defined defn) (tuple-case defn - ((value val) + ((value val) (value-exp val)) (else is funny (fail (list "funny defined value: " funny))))) ((undefined) - (fail (list "What is" + (fail (list "What is" (bytes->string (foldr render '() (list "'" exp "'?")))))) (else is bad (fail (list "The symbol" exp "has a funny value: '" bad "'"))))) @@ -191,17 +191,12 @@ ; after macros have been expanded (define (apply-env exp env) - (call/cc + (call/cc (lambda (ret) (ok env - ((walker env - (lambda (reason) - (ret (fail reason)))) - exp))))) - - (define env-fold ff-fold) + ((walker env (B ret fail)) exp))))) - (define env-del del) + (define env-fold ff-fold) (define (tuple->list t) (let loop ((pos 1)) @@ -242,7 +237,7 @@ ;; ff of wrapper-fn → opcode (define prim-opcodes - (fold + (fold (λ (ff node) (put ff (ref node 5) (ref node 2))) empty primops)) @@ -257,7 +252,7 @@ ;; later check type, get first opcode and compare to primop wrapper (define (primop-of val) (cond - ((get prim-opcodes val #false) => (lambda (op) op)) + ((get prim-opcodes val #false) => self) ;((equal? val mkt) 23) ((eq? val '__mkt__) 23) ;; temp hack to work around changing bytecode ;((equal? val bind) 32) @@ -294,5 +289,4 @@ (ff-fold (λ (words key value) (cons key words)) null env)) (define primitive? primop-of) - )) diff --git a/owl/eof.scm b/owl/eof.scm new file mode 100644 index 00000000..6135054a --- /dev/null +++ b/owl/eof.scm @@ -0,0 +1,21 @@ +(define-library (owl eof) + + (export + eof-object + eof-object?) + + (import + (owl defmac)) + + (begin + + (define *eof-object* + (cast 4 13)) + + (define (eof-object) + *eof-object*) + + (define eof-object? + (C eq? *eof-object*)) + +)) diff --git a/owl/eval.scm b/owl/eval.scm index 286ff1e9..cfc34889 100644 --- a/owl/eval.scm +++ b/owl/eval.scm @@ -1,3 +1,13 @@ +;;; This library exports some read-eval-print-loop functions, such as evaluate. +;;; It is typically called through eval. The `*toplevel*` variable is updated +;;; after each definition, so it can be used to evaluate a term in the corresponding +;;; environment. +;;; +;;; ``` +;;; (eval (list '+ 1 2) *toplevel*) → 3 +;;; (eval '(/ 1 0) *toplevel*) → #false +;;; ``` + ;; todo: use a failure continuation or make the failure handling otherwise more systematic ;; todo: should (?) be factored to eval, repl and library handling ;; todo: add lib-http and allow including remote resources @@ -5,51 +15,24 @@ (define-library (owl eval) - (export - repl-file - repl-port - repl-string - repl-trampoline - repl - exported-eval ; fixme, here only temporarily - print-repl-error - bind-toplevel - library-import ; env exps fail-cont → env' | (fail-cont ) + (export evaluate - *owl-core*) + exported-eval) - (import + (import (owl defmac) - (owl list) - (owl primop) - (owl compile) - (owl closure) - (owl cps) - (owl alpha) - (owl ff) - (owl sort) - (owl fixedpoint) - (owl ast) (owl env) - (owl syscall) - (owl time) ;; for testing metadata - (owl symbol) - ;(owl terminal) - (owl io) - (owl math) - (owl list-extra) - (owl render) - (owl string) - (owl sexp) - (owl parse) - (owl function) - (owl equal) - (scheme base) - (owl lazy) + (owl ast) + (owl fixedpoint) + (owl alpha) + (owl cps) + (owl closure) + (owl compile) + (owl list) (owl macro) - (owl intern) - (only (owl regex) string->regex) - (scheme cxr)) + (only (owl primop) call/cc) + (only (owl syscall) error) + (owl thread)) (begin @@ -57,53 +40,19 @@ (define (ok exp env) (tuple 'ok exp env)) (define (fail reason) (tuple 'fail reason)) - (define (name->func name) - (some - (λ (x) (if (eq? (ref x 1) name) (ref x 5) #false)) - primops)) - - (define (debug env . msg) - (if (env-get env '*debug* #false) - (print* msg))) - - ;; library (just the value of) containing only special forms, primops and - (define *owl-core* - (fold - (λ (env thing) - (env-set env thing (name->func thing))) - (env-set-macro - *tabula-rasa* ;; from (owl env), env with only special form tags, no primops - 'define-syntax - (make-transformer - '(define-syntax syntax-rules add quote) - '( - ((define-syntax keyword - (syntax-rules literals (pattern template) ...)) - () - (quote syntax-operation add #false - (keyword literals (pattern ...) - (template ...))))))) - ;; note that these could now come straight from primops - '(cons car cdr eq? type type-old size cast fetch ref sys-prim refb - pick mk mkr sys fxbor fxbxor fread _fopen fclose fsend lraw - raw _connect _sopen accept mkt bind set lesser? call-native - mkred mkblack ff-bind ff-toggle ffcar ffcdr red? listuple - fxband fx+ fxqr fx* fx- fx<< fx>> ncons ncar ncdr raw-mode - iomux clock time sizeb getev type-byte))) - (define (execute exp env) (receive (exp) (lambda vals (ok (cond - ((null? vals) "no vals") + ((null? vals) "nothing") ((null? (cdr vals)) (car vals)) (else (cons 'values vals))) env)))) ; (op exp env) -> #(ok exp' env') | #(fail info) (define compiler-passes - (list + (list ;; macros have already been expanded apply-env ;; apply previous definitions sexp->ast ;; safe sane tupled structure @@ -114,10 +63,8 @@ compile ;; translate and flatten to bytecode execute)) ;; call the resulting code - ; run the code in its own thread - (define (evaluate-as exp env task) - ; run the compiler chain in a new task - (fork-linked task + (define (try-evaluate exp env fail-val) + (try (λ () (call/cc (λ (exit) @@ -125,770 +72,25 @@ (λ (state next) (if (ok? state) (begin - (debug env " * " (ref state 2)) (next (ref state 2) (ref state 3))) (exit state))) (ok exp env) - compiler-passes))))) - ; grab the result - (tuple-case (ref (accept-mail (λ (env) (eq? (ref env 1) task))) 2) - ((finished result not used) - result) ; <- is already ok/fail - ((crashed opcode a b) - ;; note! ob != called function for closures and procs, so the name is lost - (fail (verbose-vm-error env opcode a b))) - ((error cont reason info) - ; note, these could easily be made resumable by storing cont - (fail (list reason info))) - ((breaked) - (fail (list "breaked"))) - (else is foo - (fail (list "Funny result for compiler " foo))))) - - (define (evaluate exp env) - (evaluate-as exp env 'repl-eval)) - - ;; toplevel variable to which loaded libraries are added - - (define (? x) #true) - - (define library-key '*libraries*) ;; list of loaded libraries - (define features-key '*features*) ;; list of implementation feature symbols - (define includes-key '*include-dirs*) ;; paths where to try to load includes from - - (define definition? - (let ((pat (list '_define symbol? ?))) - (λ (exp) (match pat exp)))) - - (define multi-definition? - (let ((pat (list '_define list? ?))) - (λ (exp) (match pat exp)))) - - ;; toplevel variable which holds currently loaded (r7rs-style) libraries - (define libraries-var '*libs*) - - (define error-port stderr) - - (define (print-repl-error lst) - (define (format-error lst ind) - (cond - ((and (pair? lst) (null? (cdr lst)) (list? (car lst))) - (cons 10 - (let ((ind (+ ind 2))) - (append (map (λ (x) 32) (iota 0 1 ind)) - (format-error (car lst) ind))))) - ((pair? lst) - (render (car lst) - (cons 32 - (format-error (cdr lst) ind)))) - ((null? lst) '(10)) - (else (render lst '(10))))) - (write-bytes error-port - (format-error lst 0))) - - ; -> (ok value env), (error reason env) - - (define repl-op? - (let ((pattern (list 'unquote symbol?))) - (λ (exp) (match pattern exp)))) - - (define (mark-loaded env path) - (let ((loaded (env-get env '*loaded* null))) - (if (mem string-eq? loaded path) - env - (env-set env '*loaded* - (cons path loaded))))) - - ;; values used by the repl to signal they should be printed as such, not rendered as a value - (define repl-message-tag "foo") - (define (repl-message foo) (cons repl-message-tag foo)) - (define (repl-message? foo) (and (pair? foo) (eq? repl-message-tag (car foo)))) - - (define (maybe-show-metadata env val) - (lets - ((meta (env-get env meta-tag empty)) - (info (getf meta val))) - (if info - (begin - (display ";; ") - (if (list? info) - (for-each (λ (x) (display x) (display " ")) info) - info) - (display "\n"))))) - - ;; render the value if *interactive*, and print as such (or not at all) if it is a repl-message - ;; if interactive mode and output fails, the error is fatal - (define (prompt env val) - (let ((prompt (env-get env '*interactive* #false))) - (if prompt - (if (repl-message? val) - (begin - (if (cdr val) - (print (cdr val))) - (if (not (display "> ")) - (halt 127))) - (begin - (maybe-show-metadata env val) - ((writer-to (env-get env name-tag empty)) - stdout val) - (if (not (display "\n> ")) - (halt 127))))))) - - (define syntax-error-mark (list 'syntax-error)) - - ;; fixme: the input data stream is iirc raw bytes, as is parser error position, but that one is unicode-aware - - ; lst -> n, being the number of things before next 10 or end of list - (define (next-newline-distance lst) - (let loop ((lst lst) (pos 0)) - (cond - ((null? lst) (values pos lst)) - ((eq? (car lst) 10) (values (+ pos 1) (cdr lst))) - (else (loop (cdr lst) (+ pos 1)))))) - - (define (find-line data error-pos) - ;(print " - find-line") - (let loop ((data data) (pos 0)) - ;(print* (list "data " data " pos " pos " error-pos " error-pos)) - (lets ((next datap (next-newline-distance data))) - (cond - ((<= error-pos next) - (runes->string (take data (- next 1)))) ; take this line - ((null? data) - "(end of input)") - (else - (loop datap next)))))) - - (define (syntax-fail pos info lst) - (list syntax-error-mark info - (list ">>> " (find-line lst pos) " <<<"))) - - (define (syntax-error? x) (and (pair? x) (eq? syntax-error-mark (car x)))) - - (define (repl-fail env reason) (tuple 'error reason env)) - (define (repl-ok env value) (tuple 'ok value env)) - - ;; just be quiet - (define repl-load-prompt - (λ (val result?) null)) - - ;; load and save path to *loaded* - - (define (repl-load repl path in env) - (lets - ((exps ;; find the file to read - (or - (file->exp-stream path "" sexp-parser syntax-fail) - (file->exp-stream - (string-append (env-get env '*owl* "NA") path) - "" sexp-parser syntax-fail)))) - (if exps - (begin - ;(if (env-get env '*interactive* #false) - ; (print " + " path)) - (lets - ((current-prompt (env-get env '*interactive* #false)) ; <- switch prompt during loading - (load-env - (if prompt - (env-set env '*interactive* #false) ;; <- switch prompt during load (if enabled) - env)) - (outcome (repl load-env exps))) - (tuple-case outcome - ((ok val env) - (ok val (env-set env '*interactive* current-prompt))) - ((error reason partial-env) - ; fixme, check that the fd is closed! - (repl-fail env (list "Could not load" path "because" reason)))))) - (repl-fail env - (list "Could not find any of" - (list path (string-append (env-get env '*owl* "") path)) - "for loading."))))) - - ;; regex-fn | string | symbol → regex-fn | #false - (define (thing->rex thing) - (cond - ((function? thing) thing) - ((string? thing) - (string->regex - (foldr string-append "" (list "m/" thing "/")))) - ((symbol? thing) - (thing->rex (symbol->string thing))) - (else #false))) - - (define repl-ops-help "Commands: - ,help - show this - ,words - list all current definitions - ,expand - expand macros in the expression - ,find [regex|sym] - list all defined words matching regex or m// - ,load string - (re)load a file - ,libraries - show all currently loaded libraries - ,quit - exit owl") - - (define (repl-op repl op in env) - (case op - ((help) - (prompt env (repl-message repl-ops-help)) - (repl env in)) - ((load) - (lets ((op in (uncons in #false))) - (cond - ((string? op) - (tuple-case (repl-load repl op in env) - ((ok exp env) - (prompt env (repl-message (string-append ";; Loaded " op))) - (repl env in)) - ((error reason envp) - (prompt env (repl-message (string-append ";; Failed to load " op))) - ;; drop out of loading (recursively) files, or hit repl trampoline on toplevel - (repl-fail env reason)))) - (else - (repl-fail env (list "expected ,load \"dir/foo.scm\", got " op)))))) - ((forget-all-but) - (lets ((op in (uncons in #false))) - (if (and (list? op) (all symbol? op)) - (let ((nan (tuple 'defined (tuple 'value 'undefined)))) - (repl - (env-keep env - (λ (name) - (if (or (primop-of name) (has? op name)) - name - #false))) - in)) - (repl-fail env (list "bad word list: " op))))) - ((words w) - (prompt env - (repl-message - (bytes->string - (foldr - (λ (x tl) (render x (cons #\space tl))) - null - (cons "Words: " - (sort stringstring - (env-keys env)))))))) - (repl env in)) - ((find) - (lets - ((thing in (uncons in #false)) - (rex (thing->rex thing))) - (cond - ((function? rex) - (define (seek env) - (keep (λ (sym) (rex (symbol->string sym))) (env-keys env))) - (print "current toplevel: " - (apply str (interleave ", " (seek env)))) - (for-each - (λ (lib) - (let ((matches (seek (cdr lib)))) - (if (not (null? matches)) - (print - (str " " (car lib) ": " (apply str (interleave ", " matches))))))) - (env-get env '*libraries* null)) - (prompt env (repl-message #false))) - (else - (prompt env "I would have preferred a regex or a symbol."))) - (repl env in))) - ((libraries libs) - (print "Currently defined libraries:") - (for-each print (map car (env-get env library-key null))) - (prompt env (repl-message #false)) - (repl env in)) - ((expand) - (lets ((exp in (uncons in #false))) - (tuple-case (macro-expand exp env) - ((ok exp env) - (print exp)) - ((fail reason) - (print ";; Macro expansion failed: " reason))) - (prompt env (repl-message #false)) - (repl env in))) - ((quit) - ; this goes to repl-trampoline - (tuple 'ok 'quitter env)) - (else - (prompt env - (repl-message - (str ";; unknown repl op: " op ". use ,help for help."))) - (repl env in)))) - - ;; → (name ...) | #false - (define (exported-names env lib-name) - (let ((libp (assoc lib-name (env-get env library-key null)))) - (if libp - (env-fold (λ (out name value) (cons name out)) null (cdr libp)) - #false))) - - ;; todo: this uses direct environment access - move to lib-env or handle here? - ;; = - ;; | (rename ) - ;; | (exports - (λ (value) - (loop (cdr names) unbound (env-put-raw module (car names) value)))) - ((and ;; swap name for (rename ) - (match `(rename ,symbol? ,symbol?) (car names)) - (env-get-raw env (cadar names) #false)) => - (λ (value) - (loop (cdr names) unbound (env-put-raw module (caddar names) value)))) - ((match `(exports ,list?) (car names)) - (let ((exported (exported-names env (cadr (car names))))) - (if exported - (loop (append exported (cdr names)) unbound module) - (fail (list "Didn't find " (cadar names) " for exporting."))))) - (else - (loop (cdr names) (cons (car names) unbound) module))))) - - ; fixme, use pattern matching... - - (define (symbol-list? l) (and (list? l) (all symbol? l))) - - (define export? - (let ((pat `(export . ,symbol-list?))) - (λ (exp) (match pat exp)))) - - (define (_ x) #true) - - (define import? ; toplevel import using the new library system - (let - ((patternp `(import . ,(λ (x) #true)))) - (λ (exp) (match patternp exp)))) + compiler-passes)))) + fail-val)) - (define (library-definition? x) - (and (pair? x) (list? x) (eq? (car x) '_define-library))) - - ;; a simple eval + (define (evaluate exp env) + (try-evaluate exp env + (tuple 'fail "compiler bug"))) (define (exported-eval exp env) (tuple-case (macro-expand exp env) ((ok exp env) - (tuple-case (evaluate-as exp env (list 'evaluating)) - ((ok value env) + (tuple-case (try-evaluate exp env (tuple 'fail "compiler bug")) + ((ok value env) value) ((fail reason) #false))) ((fail reason) #false))) - (define (bind-toplevel env) - (env-set env '*toplevel* - (env-del env '*toplevel))) - - ;; list starting with val? - (define (headed? val exp) - (and (pair? exp) (eq? val (car exp)) (list? exp))) - - ;; (import ...) - ;; = - ;; | (only ...) - ;; | (except ...) - ;; | (prefix ) - ;; | (rename ( ) ..) - - ;; (a ...) - (define (symbols? exp) - (and (list? exp) (all symbol? exp))) - - ;; ((a b) ...) - (define (pairs? exp) - (and (list? exp) - (all (λ (x) (and (list? x) (= (length x) 2))) exp))) - - ;; → 'ok env | 'needed name | 'circular name, non-ok exists via fail - (define (import-set->library iset libs fail) - (cond - ((assoc iset libs) => - (λ (pair) - (if (eq? (cdr pair) 'loading) ;; trying to reload something - (fail 'circular iset) - (values 'ok (cdr pair))))) - ((match `(only ,? . ,symbols?) iset) - (lets ((ok lib (import-set->library (cadr iset) libs fail))) - (values 'ok - (env-keep lib (λ (var) (if (has? (cddr iset) var) var #false)))))) - ((match `(except ,? . ,symbols?) iset) - (lets ((ok is (import-set->library (cadr iset) libs fail))) - (values 'ok - (env-keep is (λ (var) (if (has? (cddr iset) var) #false var)))))) - ((match `(rename ,? . ,pairs?) iset) - (lets ((ok lib (import-set->library (cadr iset) libs fail))) - (values 'ok - (env-keep lib - (λ (var) - (let ((val (assq var (cddr iset)))) - (if val (cdr val) #false))))))) - ((match `(prefix ,? ,symbol?) iset) - (lets - ((ok lib (import-set->library (cadr iset) libs fail)) - (prefix (symbol->string (caddr iset)))) - (values 'ok - (env-keep lib - (λ (var) - (string->symbol - (string-append prefix (symbol->string var)))))))) - (else - (fail 'needed iset)))) - - ;; (foo bar baz) → "/foo/bar/baz.scm" - (define (library-name->path iset) - (bytes->string - (cons #\/ - (foldr - (λ (thing tl) - (append - (string->list (symbol->string thing)) - (if (null? tl) - (string->list ".scm") - (cons #\/ tl)))) - null iset)))) - - ;; try to find and parse contents of and wrap to (begin ...) or call fail - (define (repl-include env path fail) - (lets - ((include-dirs (env-get env includes-key null)) - (conv (λ (dir) (list->string (append (string->list dir) (cons #\/ (string->list path)))))) - (paths (map conv include-dirs)) - (contentss (map file->list paths)) - (data (first (λ (x) x) contentss #false))) - (if data - (let ((exps (list->sexps data "library fail" path))) - (if exps ;; all of the file parsed to a list of sexps - (cons 'begin exps) - (fail (list "Failed to parse contents of " path)))) - (fail (list "Couldn't find " path "from any of" include-dirs))))) - - ;; nonempty list of symbols or integers - (define (valid-library-name? x) - (and (list? x) (pair? x) (all (λ (x) (or (integer? x) (symbol? x))) x))) - - ;; try to load a library based on it's name and current include prefixes if - ;; it is required by something being loaded and we don't have it yet - ;; → 'ok x env | 'error x reason | 'not-found x _ - (define (try-autoload env repl iset) - (if (valid-library-name? iset) ;; (foo bar baz) → try to load "./foo/bar/baz.scm" - (let - ((exps - (call/cc - (λ (ret) - (repl-include env - (library-name->path iset) (λ (why) (ret #false))))))) - (if exps - (tuple-case (repl env (cdr exps)) ; drop begin - ((ok value env) - ;; we now have the library if it was defined in the file - (values 'ok env)) - ((error reason env) - ;; no way to distinquish errors in the library from missing library atm - (values 'error reason))) - (values 'not-found (library-name->path iset)))) - (values 'error (list "Bad library name:" iset)))) - - (define (any->string obj) - (list->string (render obj null))) - - (define (library-import env exps fail repl) - (fold - (λ (env iset) - (lets ((status lib (call/cc (λ (ret) (import-set->library iset (env-get env library-key null) ret))))) - (cond - ((eq? status 'needed) - (lets ((status env (try-autoload env repl lib))) - (cond - ((eq? status 'ok) - (library-import env exps fail repl)) - ((eq? status 'error) - (fail (list "Failed to load" lib "because" env))) - (else - (fail (list "I didn't have or find library" (any->string lib))))))) - ((eq? status 'ok) - (env-fold env-put-raw env lib)) ;; <- TODO env op, should be in (owl env) - ((eq? status 'circular) - (fail (list "Circular dependency causing reload of" (bytes->string (render lib null))))) - (else - (fail (list "BUG: bad library load status: " status)))))) - env exps)) - - ;; temporary toplevel import doing what library-import does within libraries - (define (toplevel-library-import env exps repl) - (lets/cc ret - ((fail (λ (x) (ret (cons "Import failed because" x))))) - (library-import env exps fail repl))) - - (define (match-feature req feats libs fail) - (cond - ((memv req feats) #true) ;; a supported implementation feature - ((symbol? req) #false) - ((assv req libs) #true) ;; an available (loaded) library - ((and (headed? 'not req) (= (length req) 2)) - (not (match-feature (cadr req) feats libs fail))) - ((headed? 'and req) - (all (λ (req) (match-feature req feats libs fail)) (cdr req))) - ((headed? 'or req) - (some (λ (req) (match-feature req feats libs fail)) (cdr req))) - (else - (fail "Weird feature requirement: " req)))) - - (define (choose-branch bs env fail) - (cond - ((null? bs) null) ;; nothing matches, no else - ((match `(else . ,list?) (car bs)) (cdar bs)) - ((pair? (car bs)) - (if (match-feature - (caar bs) - (env-get env features-key null) - (env-get env library-key null) - fail) - (cdar bs) - (choose-branch (cdr bs) env fail))) - (else - (fail (list "Funny cond-expand node: " bs))))) - - - (define (repl-library exp env repl fail) - (cond - ((null? exp) (fail "no export?")) - ((headed? 'import (car exp)) - (repl-library (cdr exp) - (library-import env (cdar exp) fail repl) - repl fail)) - ((headed? 'begin (car exp)) - ;; run basic repl on it - (tuple-case (repl env (cdar exp)) - ((ok value env) - ;; continue on to other defines or export - (repl-library (cdr exp) env repl fail)) - ((error reason env) - (fail reason)))) - ((headed? 'export (car exp)) - ;; build the export out of current env - (ok (build-export (cdar exp) env fail) env)) - ((headed? 'include (car exp)) - (repl-library - (foldr - (λ (path exp) (cons (repl-include env path fail) exp)) - (cdr exp) (cdar exp)) - env repl fail)) - ((headed? 'cond-expand (car exp)) - (repl-library - (append (choose-branch (cdar exp) env fail) (cdr exp)) - env repl fail)) - (else - (fail (list "unknown library term: " (car exp)))))) - - ;; variables which are added to *owl-core* when evaluating libraries - (define library-exports - (list - library-key ;; loaded libraries - includes-key ;; where to load libraries from - features-key)) ;; implementation features - - ;; update *owl-names* (used by renderer of repl prompt) if the defined value is a function - (define (maybe-name-function env name value) - (if (function? value) - (lets - ((names (env-get env name-tag empty)) - (old (getf env value)) - (env - (if old - env - (env-set env name-tag - (put names value name))))) - (if (eq? (type value) 16) - env - ;; if this is a proc or closure name also the internal parts - (maybe-name-function env name (ref value 1)))) - env)) - - ;; update *owl-meta* to have some data about this - (define (maybe-save-metadata env name value) - (env-set env meta-tag - (put (env-get env meta-tag empty) value - `(defined in ,(env-get env current-library-key 'repl))))) - - (define (eval-repl exp env repl) - (debug env "Evaling " exp) - (tuple-case (macro-expand exp env) - ((ok exp env) - (debug env " * expanded to " exp) - (cond - ((import? exp) ;; <- new library import, temporary version - (lets - ((envp (toplevel-library-import env (cdr exp) repl))) - (if (pair? envp) ;; the error message - (fail envp) - (ok - (repl-message - (list->string - (foldr render null - (cons ";; Imported " (cdr exp))))) - envp)))) - ((definition? exp) - (tuple-case (evaluate (caddr exp) env) - ((ok value env2) - (lets - ((env (env-set env (cadr exp) value)) - (env (maybe-name-function env (cadr exp) value)) - ;(env (maybe-save-metadata env (cadr exp) value)) - ) - (ok - (repl-message - (bytes->string (render ";; Defined " (render (cadr exp) null)))) - (bind-toplevel env)))) - ((fail reason) - (fail - (list "Definition of" (cadr exp) "failed because" reason))))) - ((multi-definition? exp) - (tuple-case (evaluate (caddr exp) env) - ((ok value env2) - (let ((names (cadr exp))) - (if (and (list? value) - (= (length value) (length names))) - (ok (repl-message ";; All defined") - (fold - (λ (env pair) - (env-set env (car pair) (cdr pair))) - env - (zip cons names value))) - (fail - (list "Didn't get expected values for definition of " names))))) - ((fail reason) - (fail - (list "Definition of" (cadr exp) "failed because" reason))))) - ((export? exp) - (lets ((module (build-export (cdr exp) env (λ (x) x)))) ; <- to be removed soon, dummy fail cont - (ok module env))) - ((library-definition? exp) - ;; evaluate libraries in a blank *owl-core* env (only primops, specials and define-syntax) - ;; include just loaded *libraries* and *include-paths* from the current one to share them - (lets/cc ret - ((exps (map cadr (cdr exp))) ;; drop the quotes - (name exps (uncons exps #false)) - (libs (env-get env library-key null)) - ;; mark the current library as being loaded for circular dependency detection - (env (env-set env library-key (cons (cons name 'loading) libs))) - (fail - (λ (reason) - (ret (fail (list "Library" name "failed:" reason))))) - (lib-env - (fold - (λ (lib-env key) (env-set lib-env key (env-get env key null))) - *owl-core* library-exports)) - (lib-env (env-set lib-env current-library-key name))) - (tuple-case (repl-library exps lib-env repl fail) ;; anything else must be incuded explicitly - ((ok library lib-env) - ;; get new function names and metadata from lib-env (later to be handled differently) - (lets - ((names (env-get lib-env name-tag empty)) - (env (env-set env name-tag (ff-union (env-get env name-tag empty) names (λ (old new) new)))) - (meta (env-get lib-env meta-tag empty)) - (env (env-set env meta-tag (ff-union (env-get env meta-tag empty) meta (λ (old new) new))))) - (ok - (repl-message - (list->string - (foldr render null - (list ";; Library " name " added" )))) - (env-set env library-key - (cons (cons name library) - (keep ;; drop the loading tag for this library - (λ (x) (not (equal? (car x) name))) - (env-get lib-env library-key null))))))) ; <- lib-env may also have just loaded dependency libs - ((error reason not-env) - (fail - (list "Library" name "failed to load because" reason)))))) - (else - (evaluate exp env)))) - ((fail reason) - (tuple 'fail - (list "Macro expansion of" exp "failed: " reason))))) - - ; (repl env in) -> #(ok value env) | #(error reason env) - - (define (repl env in) - (let loop ((env env) (in in) (last 'blank)) - (cond - ((null? in) - (repl-ok env last)) - ((pair? in) - (lets ((this in (uncons in #false))) - (cond - ((eof? this) - (repl-ok env last)) - ((syntax-error? this) - (repl-fail env (cons "This makes no sense: " (cdr this)))) - ((repl-op? this) - (repl-op repl (cadr this) in env)) - (else - (tuple-case (eval-repl this env repl) - ((ok result env) - (prompt env result) - (loop env in result)) - ((fail reason) - (repl-fail env reason))))))) - (else - (loop env (in) last))))) - - - ;; run the repl on a fresh input stream, report errors and catch exit - - (define (stdin-sexp-stream env bounced?) - (λ () (fd->exp-stream stdin "> " sexp-parser syntax-fail bounced?))) - - (define (repl-trampoline repl env) - (let boing ((repl repl) (env env) (bounced? #false)) - (lets - ((stdin (stdin-sexp-stream env bounced?)) - (stdin - (if bounced? - (begin ;; we may need to reprint a prompt here - (if (env-get env '*interactive* #false) - (display "> ")) ;; reprint prompt - stdin) - stdin)) - (env (bind-toplevel env))) - (tuple-case (repl env stdin) - ((ok val env) - ;; the end - (if (env-get env '*interactive* #false) - (print "bye bye _o/~")) - (halt 0)) - ((error reason env) - ; better luck next time - (cond - ((list? reason) - (print-repl-error reason) - (boing repl env #true)) - (else - (print reason) - (boing repl env #true)))) - (else is foo - (print "Repl is rambling: " foo) - (boing repl env #true)))))) - - (define (repl-port env fd) - (repl env - (if (eq? fd stdin) - (λ () (fd->exp-stream stdin "> " sexp-parser syntax-fail #false)) - (fd->exp-stream fd "> " sexp-parser syntax-fail #false)))) - - (define (repl-file env path) - (let ((fd (if (equal? path "-") stdin (open-input-file path)))) - (if fd - (repl-port env fd) - (tuple 'error "cannot open file" env)))) - - (define (repl-string env str) - (lets ((exps (try-parse (get-kleene+ sexp-parser) (str-iter str) #false syntax-fail #false))) - ;; list of sexps - (if exps - (repl env exps) - (tuple 'error "not parseable" env)))))) +)) diff --git a/owl/fasl.scm b/owl/fasl.scm index 4e722e10..0a7f2201 100644 --- a/owl/fasl.scm +++ b/owl/fasl.scm @@ -1,23 +1,35 @@ +;;; This library implements serialization of objects to byte +;;; lists, and parsing of the byte lists to corresponding +;;; objects. The format is used internally for storing memory +;;; images to disk. Files with .fasl suffix used in booting +;;; up Owl are just fasl-encoded functions. ;;; -;;; Object serialization and reconstruction -;;; +;;; ``` +;;; (fasl-encode 42) → '(0 0 42) +;;; (fasl-encode 42) → '(0 0 42) +;;; (fasl-encode 1/4+i) → '(1 42 2 0 0 1 0 0 4 1 43 2 1 0 0 1 0) +;;; (fasl-encode (lambda (x) x)) → '(2 16 7 34 2 0 2 24 4 17 0) +;;; (fasl-decode '(0 0 0 0) 'bad) → 'bad +;;; ((fasl-decode (fasl-encode prime?) 'bad) 13337) → #true +;;; (eq? 'foo (fasl-decode (fasl-encode 'foo) #false)) → #true +;;; ``` ; protocol -; = 0 -- immediate object -; = 1 ... -- allocated -; = 2 ... -- allocated, raw data +; = 0 -- immediate object +; = 1 ... -- allocated +; = 2 ... -- allocated, raw data ; now used ; 00 - imm ; 01 - alloc ; 10 - alloc raw ; 11 - free -> use as tag for allocs where the type fits 6 bits (not in use atm) -; -; = 0 -- immediate -; = -- pointer to nth last object (see hack warning below) +; +; = 0 -- immediate +; = -- pointer to nth last object (see hack warning below) (define-library (owl fasl) - (export + (export fasl-encode ; ; obj -> (byte ... 0) fasl-encode-cooked ; obj cook -> (byte ... 0), with (cook alloc-obj) -> alloc-obj' fasl-encode-stream ; obj cook -> (bvec ...) stream @@ -41,7 +53,6 @@ (only (owl syscall) error) (owl proof) (owl list) - (owl intern) (owl rlist)) (begin @@ -77,7 +88,6 @@ (define type-byte-of type) ;(type-byte-of val) - ;(fxband (>> (type-old val) 3) 255) (define (enc-immediate val tail) (cons 0 @@ -93,17 +103,17 @@ (let ((seen (put seen obj 1))) (if (raw? obj) seen - (fold partial-object-closure seen + (fold partial-object-closure seen (tuple->list obj))))))) (define (sub-objects root pred) (ff->list (partial-object-closure empty root))) - (define (object-closure obj) - (partial-object-closure empty obj)) + (define object-closure + (H partial-object-closure empty)) - (define (objects-below obj) + (define (objects-below obj) (ff-fold (λ (out obj _) (cons obj out)) null (object-closure obj))) @@ -155,8 +165,8 @@ ((t (type-byte-of val)) (s (size val))) ; options for optimization - ; t and s fit in 6 bits -> pack (seems to be only about 1/20 compression) - ; t fits in 6 bits -> (+ (<< t 2) 3) (ditto) + ; t and s fit in 6 bits -> pack (seems to be only about 1/20 compression) + ; t fits in 6 bits -> (+ (<< t 2) 3) (ditto) (ilist 1 t (send-number s (render-fields out (tuple->list val) pos clos)))))))) @@ -165,7 +175,7 @@ ;; produce tail-first eagerly ;(define (encoder-output clos cook) - ; (ff-foldr (encode-allocated clos cook) fasl-finale clos)) + ; (ff-foldr (encode-allocated clos cook) fasl-finale clos)) (define (encoder-output clos cook) (let ((enc (encode-allocated clos cook))) @@ -177,7 +187,6 @@ (enc (lambda () (loop (cdr kvs))) (car kv) (cdr kv)))) (else (loop (kvs))))))) - ; root cook-fn -> byte-stream (define (encoder obj cook) (encoder-output @@ -199,14 +208,14 @@ ; dump the data as such (define (fasl-encode obj) - (force-ll (encode obj (λ (x) x)))) + (force-ll (encode obj self))) (define chunk-size 32767) (define (chunk-stream bs n buff) (cond ((eq? n chunk-size) - (cons + (cons (list->byte-vector (reverse buff)) (chunk-stream bs 0 null))) ((null? bs) @@ -222,7 +231,7 @@ (define (fasl-encode-stream obj cook) (chunk-stream (encode obj cook) 0 null)) - ;;; + ;;; ;;; Decoder ;;; @@ -237,9 +246,9 @@ (if (eq? 0 (fxband b 128)) ; leaf case (values ll (bor (<< top 7) b)) (get-nat ll fail (bor (<< top 7) (band b low7)))))) - + (define (decode-immediate ll fail) - (lets + (lets ((ll type (grab ll fail)) (ll val (get-nat ll fail 0))) (values ll (cast val type)))) @@ -291,7 +300,7 @@ (cond ((symbol? obj) ;; symbols must be (re)interned. they are only valid up to equalit within the fasl. - (decoder ll + (decoder ll (rcons (string->symbol (symbol->string obj)) got) @@ -311,7 +320,7 @@ (ll size (get-nat ll fail 0)) (foo (if (> size 65535) (fail "bad raw object size"))) (ll rbytes (get-bytes ll size fail null)) - (obj (raw (reverse rbytes) type #false))) + (obj (raw (reverse rbytes) type))) (decoder ll (rcons obj got) fail))) ((eq? kind 0) ;; fasl stream end marker ;; object done @@ -322,7 +331,7 @@ (ll size (get-nat ll fail 0)) (foo (if (> size 65535) (fail "bad raw object size"))) (ll rbytes (get-bytes ll size fail null)) - (obj (raw (reverse rbytes) type #false))) + (obj (raw (reverse rbytes) type))) (decoder ll (rcons obj got) fail))) (else (fail (list "unknown object tag: " kind)))))) @@ -332,12 +341,12 @@ (define (decode-or ll err) ; -> ll obj | null (err why) (call/cc ; setjmp2000 (λ (ret) - (lets ((fail (λ (why) (ret null (err why))))) + (lets ((fail (B (H ret null) err))) (cond ((null? ll) (fail enodata)) ((pair? ll) ; a leading 0 is special and means the stream has no allocated objects, just one immediate one - (if (eq? 0 (car ll)) + (if (eq? (car ll) 0) (decode-immediate (cdr ll) fail) (decoder ll null fail))) (else (decode-or (ll) err))))))) @@ -345,7 +354,7 @@ ;; decode a full (possibly lazy) list of data, and succeed only if it exactly matches a fasl-encoded object (define failed "fail") ;; a unique object - + ;; ll fail → val | fail (define (decode ll fail-val) (lets ((ll ob (decode-or ll (λ (why) failed)))) diff --git a/owl/ff.scm b/owl/ff.scm index 0a336650..badc3bf1 100644 --- a/owl/ff.scm +++ b/owl/ff.scm @@ -1,6 +1,82 @@ +;;; A typical way to make data structures for holding key-value in +;;; Lisp systems is to make an association list. An association list +;;; is a list of pairs, where the car holds the key, and cdr holds the +;;; value. While easy to define and use, they have the downside of slowing +;;; down linearly as the size of the association list grows. ;;; -;;; Finite functions (or red-black key-value maps) +;;; Owl has finite functions, or ffs, which behave like association +;;; lists, but they slow down only logarithmically as they get more keys. +;;; They are internally represented as red-black trees. ;;; +;;; `#empty` or `@()` can be used to refer to an empty finite function. +;;; `put` adds or rewrites the value of a key, `get` fetches the value +;;; or returns the third argument if the key is not found. `del` removes +;;; a key from a ff. +;;; +;;; ``` +;;; > (define f (put (put #empty 'foo 100) 'bar 42)) +;;; > f +;;; @(foo 100 bar 42) +;;; > (ff? f) +;;; #true +;;; > (get f 'foo #f) +;;; 100 +;;; > (get f 'x #f) +;;; #f +;;; > (get (del f 'foo) 'foo #f) +;;; #f +;;; ``` +;;; A finite function maps keys to values. As the name implies, a ff +;;; can also be called to do just that. If one argument is given and it +;;; is defined, the value is returned. In case of an undefined value, either +;;; an error is signaled or the second default argument is returned, if +;;; it is specified. +;;; +;;; ``` +;;; > (f 'foo) +;;; 100 +;;; > (f 'x 'not-there) +;;; 'not-there +;;; > (map f '(foo bar)) +;;; '(100 42) +;;; ``` +;;; +;;; Many list functions have corresponding functions for ffs, where +;;; usually a function receiving the list element just receives two +;;; arguments, being a particular key and value pair. The name of the +;;; function is typically prefixed with ff-. +;;; +;;; ``` +;;; (get @(a 1) 'a #f) → 1 +;;; +;;; (get @(a 1) 'x #f) → #f +;;; +;;; (put @(a 1 b 2) 'c 3) → @(a 1 b 2 c 3) +;;; +;;; (del @(a 1 b 2) 'a) → @(b 2) +;;; +;;; (fupd ff key value) → ff', like put, but for an existing key +;;; +;;; (keys @(foo 1 bar 2)) → '(foo bar) +;;; +;;; (ff-union @(a 100 b 200) @(b 2 c 3) +) → @(a 100 b 202 c 3) +;;; +;;; (ff-diff @(a 1 b 2 c 3) @(a 10 b 20)) → @(c 3) +;;; +;;; (ff-fold (λ (o k v) (cons (cons k v) o)) null @(foo 1 bar 2) → +;;; '((bar . 2) (foo . 1)) +;;; +;;; (ff-foldr (λ (o k v) (cons (cons k v) o)) null @(foo 1 bar 2) → +;;; '((foo . 1) (bar . 2)) +;;; (ff-map @(a 1 b 2 c 3) (λ (k v) (square v))) → @(a 1 b 4 c 9) +;;; +;;; (ff-iter ff) → a lazy list of key-value pairs +;;; +;;; (list->ff '((a . 1) (b . 2))) → @(a 1 b 2) +;;; +;;; (ff->list @(a 1 b 2)) → '((a . 1) (b . 2)) +;;; +;;; ``` ;; fixme: ff unit tests went missing at some point. add with lib-compare vs naive alists. ;; fixme: ffc[ad]r are no longer needed as primitives @@ -33,7 +109,7 @@ ff-ok? empty empty? - + getf ; (getf ff key) == (get ff key #false) ) @@ -53,7 +129,7 @@ (define empty #empty) - (define (empty? x) (eq? x empty)) + (define empty? (C eq? empty)) ;; shadowed below (define (black l k v r) @@ -88,7 +164,7 @@ (define-syntax red? (syntax-rules () ((red? node) (eq? redness (fxband (type node) redness))))) ;; false for black nodes and #empty - + ;; does a (non-empty) red or black node of size 3 have a right child? 2 never does and 4 always has (define-syntax right? (syntax-rules () @@ -131,7 +207,7 @@ (and (red? ff) (or (red? l) (red? r))) (red-red-violation? l) (red-red-violation? r))))) - + ;; fixnum addition, math not defined yte (define (f+ a b) (lets ((c _ (fx+ a b))) c)) @@ -246,7 +322,7 @@ (else (black left key val right)))) (black left key val right))) - + (define (putn node key val) (if (eq? node #empty) (red #empty key val #empty) @@ -273,13 +349,13 @@ def (with-ff (node left key _ right) (ff-max right key)))) - + (define (ff-min node def) (if (eq? node #empty) def (with-ff (node left key _ right) (ff-min left key)))) - + ;; bytecoded get '(define (get ff key def) (if (eq? ff #empty) @@ -378,7 +454,7 @@ (ff-fold op state r)) (op state k v)))) state)) - + ;; iterate key-value pairs in order (define (ff-iterate tree tl) (if (nonempty? tree) @@ -397,8 +473,8 @@ (λ () (ff-iterrate l tl))))) tl)) - (define (ff-iter tree) (ff-iterate tree null)) - (define (ff-iterr tree) (ff-iterrate tree null)) + (define ff-iter (C ff-iterate null)) + (define ff-iterr (C ff-iterrate null)) ;; note: ff-map will switch argument order in the generic equivalent ;; fixme, also much faster if types are used directly @@ -536,7 +612,7 @@ (if (red? ff) (color-black ff) ff))) - + ;;; ;;; FIXME bad hacks diff --git a/owl/fixedpoint.scm b/owl/fixedpoint.scm index dff5e754..8c1a0b6a 100644 --- a/owl/fixedpoint.scm +++ b/owl/fixedpoint.scm @@ -21,7 +21,7 @@ ; return the least score by pred (define (least pred lst) (if (null? lst) - #false + #false (cdr (fold (λ (lead x) @@ -59,7 +59,7 @@ ((value val) found) ((values vals) (walk-list vals bound found)) - ((receive op fn) + ((receive op fn) (walk op bound (walk fn bound found))) ((branch kind a b then else) @@ -74,8 +74,8 @@ (eq? (ref exp 1) 'lambda)) (define (set-deps node deps) (set node 3 deps)) - (define (deps-of node) (ref node 3)) - (define (name-of node) (ref node 1)) + (define deps-of (C ref 3)) + (define name-of (C ref 1)) ; pick a set of bindings for binding (define (pick-binding deps env) @@ -86,7 +86,7 @@ (or ; things which have no dependences (maybe 'trivial - (keep (lambda (node) (null? (deps-of node))) deps)) + (keep (B null? deps-of) deps)) ; things which only depend on themselvs (simply recursive) (maybe 'simple @@ -106,7 +106,7 @@ (let ((node (least - (lambda (node) (length (deps-of node))) + (B length deps-of) (keep (lambda (node) (lambda? (value-of node) env)) deps)))) (if node (let ((partition (deps-of node))) @@ -114,7 +114,7 @@ (lambda (node) (has? partition (name-of node))) deps)) null))) - + (error "unable to resolve dependencies for mutual recursion. remaining bindings are " deps))) ;;; remove nodes and associated deps @@ -159,7 +159,7 @@ (tuple 'branch kind (walk a) (walk b) (walk then) (walk else))) ((receive op fn) (tuple 'receive (walk op) (walk fn))) - ((values vals) + ((values vals) (tuple 'values (map walk vals))) ((value val) exp) ((var sym) @@ -182,22 +182,19 @@ (tuple-case (lookup env sym) ((recursive formals deps) (if (not (= (length formals) (length rands))) - (error + (error "Wrong number of arguments: " (list 'call exp 'expects formals))) - (let ((sub-env (env-bind env formals))) - (mkcall rator - (append - (map - (lambda (arg) (carry-bindings arg sub-env)) - rands) - (map mkvar deps))))) + (mkcall rator + (append + (map (C carry-bindings (env-bind env formals)) rands) + (map mkvar deps)))) (else (mkcall (carry-bindings rator env) - (map(lambda (exp) (carry-bindings exp env)) rands))))) + (map (C carry-bindings env) rands))))) (else (mkcall (carry-bindings rator env) - (map (lambda (exp) (carry-bindings exp env)) rands))))) + (map (C carry-bindings env) rands))))) ((lambda formals body) (mklambda formals (carry-bindings body @@ -217,9 +214,9 @@ ((var sym) (tuple-case (lookup env sym) ((recursive formals deps) - (let - ((lexp - (mklambda formals + (let + ((lexp + (mklambda formals (mkcall exp (map mkvar (append formals deps)))))) ; (print "carry-bindings: made local closure " lexp) lexp)) @@ -227,7 +224,7 @@ ((value val) exp) ((values vals) (tuple 'values - (map (lambda (exp) (carry-bindings exp env)) vals))) + (map (C carry-bindings env) vals))) (else (error "carry-bindings: strage expression: " exp)))) @@ -263,14 +260,14 @@ ; bind all things from deps using possibly several nested head lambda calls (define (generate-bindings deps body env) - (define (second x) (ref x 2)) - (define (first x) (ref x 1)) + (define second (C ref 2)) + (define first (C ref 1)) (if (null? deps) body (tuple-case (pick-binding deps env) ; no dependecies, so bind with ((lambda (a ...) X) A ...) - ((trivial nodes) + ((trivial nodes) (make-bindings (map first nodes) (map second nodes) (generate-bindings (remove-deps (map first nodes) deps) @@ -283,9 +280,9 @@ (fold (lambda (env node) (let ((formals (ref (value-of node) 2))) - (env-put-raw env - (name-of node) - (tuple 'recursive formals + (env-put-raw env + (name-of node) + (tuple 'recursive formals (list (name-of node)))))) env nodes))) ; bind all names to extended functions (think (let ((fakt (lambda (fakt x fakt) ...) ...)))) @@ -293,7 +290,7 @@ (map first nodes) (handle-recursion nodes env-rec) ; then in the body bind them to (let ((fakt (lambda (x) (fakt x fakt))) ...) ...) - (let + (let ((body (generate-bindings (remove-deps (map first nodes) deps) @@ -314,7 +311,7 @@ (fold (lambda (body node) (lets ((name val deps node)) - (carry-simple-recursion body name + (carry-simple-recursion body name (append (ref val 2) deps)))) ; add self to args body nodes) )))) @@ -328,16 +325,16 @@ (lambda (node) (if (null? (diff (deps-of node) partition)) (set-deps node partition) - (error - "mutual recursion bug, partitions differ: " + (error + "mutual recursion bug, partitions differ: " (list 'picked partition 'found node)))) nodes)) (env-rec (fold (lambda (env node) (let ((formals (ref (value-of node) 2))) - (env-put-raw env - (name-of node) + (env-put-raw env + (name-of node) (tuple 'recursive formals partition)))) env nodes))) (make-bindings @@ -357,7 +354,7 @@ (define (dependency-closure deps) - (define (third x) (ref x 3)) + (define third (C ref 3)) (define (grow current deps) (lets ((related @@ -394,7 +391,7 @@ (define (unletrec exp env) (define (unletrec-list exps) - (map (lambda (exp) (unletrec exp env)) exps)) + (map (C unletrec env) exps)) (tuple-case exp ((var value) exp) ((call rator rands) @@ -410,7 +407,7 @@ ((rlambda names values body) (lets ((env (env-bind env names)) - (handle (lambda (exp) (unletrec exp env)))) + (handle (C unletrec env))) (compile-rlambda names (map handle values) (handle body) env))) ((receive op fn) (tuple 'receive (unletrec op env) (unletrec fn env))) @@ -426,7 +423,7 @@ (else (unletrec else env))) (tuple 'branch kind a b then else))) ((case-lambda func else) - (tuple 'case-lambda + (tuple 'case-lambda (unletrec func env) (unletrec else env))) (else @@ -436,5 +433,4 @@ (define (fix-points exp env) (let ((result (unletrec exp env))) (tuple 'ok result env))) - - )) +)) diff --git a/owl/function.scm b/owl/function.scm index bcd260a9..919f6c1d 100644 --- a/owl/function.scm +++ b/owl/function.scm @@ -1,7 +1,10 @@ (define-library (owl function) - (export function? procedure? bytecode?) + (export + bytecode? + function? + procedure?) (import (owl defmac) @@ -10,7 +13,7 @@ (begin - (define (bytecode? x) + (define (bytecode? x) (eq? type-bytecode (type x))) ;; raw bytecode vector, 1-level (proc) or 2-level (clos) function @@ -18,13 +21,10 @@ (or (bytecode? x) (eq? (type x) type-proc) - (eq? (type x) type-clos) - ;(eq? #b010 (fxband (type-old x) #b11111010)) - )) + (eq? (type x) type-clos))) ;; something executable? being a function or a finite function (define (procedure? obj) (or (function? obj) - (ff? obj))))) - - + (ff? obj))) +)) diff --git a/owl/gensym.scm b/owl/gensym.scm index 15f18efe..28c76047 100644 --- a/owl/gensym.scm +++ b/owl/gensym.scm @@ -1,7 +1,23 @@ +;;; It is sometimes useful to get symbols, which do not occur elsewhere. +;;; This is typically needed in the compiler, but it may also be needed +;;; elsewhere. Gensyms in Owl are just regular symbols, which do not +;;; occur in a given expression. This requires walking through the whole +;;; expression. To avoid having to walk the original expression in many +;;; cases when gensyms are needed, they work in a way that ensures that +;;; the gensym of the gensym of an expression also does not occur in the +;;; original expression. +;;; +;;; ``` +;;; (gensym '(lambda (x) x)) → g1 +;;; (gensym 'g1) → g2 +;;; (gensym 'g100000) → 'g100001 +;;; ``` (define-library (owl gensym) - (export gensym fresh) + (export + fresh + gensym) (import (owl defmac) @@ -11,20 +27,16 @@ (owl list) (owl tuple) (owl render) - (owl intern) (owl math)) (begin - ; now in lib-intern - ;(define (string->symbol str) (interact 'intern str)) - ;(define (symbol->string x) (ref x 1)) ; return the gensym id of exp (number) or #false (define (count-gensym-id str pos end n) (if (= pos end) n - (let ((this (refb str pos))) + (let ((this (refb str pos))) (cond ((and (< 47 this) (< this 58)) (count-gensym-id str (+ pos 1) end (+ (* n 10) (- this 48)))) @@ -40,7 +52,7 @@ #false)) (define (max-gensym-id exp max) - (cond + (cond ((pair? exp) (if (eq? (car exp) 'quote) max @@ -63,7 +75,7 @@ (max-gensym-id formals max))) ((call rator rands) (max-ast-id rator - (fold + (fold (lambda (max exp) (max-ast-id exp max)) max rands))) ((value val) max) @@ -76,14 +88,14 @@ ((values vals) (fold (lambda (max exp) (max-ast-id exp max)) max vals)) ((case-lambda fn else) - (max-ast-id fn + (max-ast-id fn (max-ast-id else max))) (else (error "gensym: max-ast-id: what is this: " exp)))) (define (gensym exp) - (lets + (lets ((id (+ 1 (if (tuple? exp) (max-ast-id exp 0) (max-gensym-id exp 0)))) (digits (cons 103 (render id null)))) (string->symbol (runes->string digits)))) @@ -94,5 +106,4 @@ ;(gensym 1) ;(gensym '(1 2 3)) ;(gensym '(g1 (g2 g9999) . g10000000000000)) - )) - +)) diff --git a/owl/intern.scm b/owl/intern.scm index 87e69ce1..f9453d72 100644 --- a/owl/intern.scm +++ b/owl/intern.scm @@ -10,13 +10,11 @@ (define-library (owl intern) (export bytes->symbol - string->symbol - symbol->string initialize-interner string->uninterned-symbol string->interned-symbol ;; tree string → tree' symbol put-symbol ;; tree sym → tree' - empty-symbol-tree + empty-symbol-tree intern-symbols start-dummy-interner start-symbol-interner @@ -29,7 +27,6 @@ (owl list) (owl math) (owl function) - (only (owl primop) apply) (owl ff) (owl tuple) (owl symbol)) @@ -51,7 +48,7 @@ ((pair? s1) (cond ((pair? s2) - (lets + (lets ((a as s1) (b bs s2)) (cond @@ -61,7 +58,7 @@ ((null? s2) 1) (else (walk s1 (s2))))) (else (walk (s1) s2)))) - + (define (compare s1 s2) (walk (str-iter s1) (str-iter s2))) @@ -70,12 +67,9 @@ (define (string->uninterned-symbol str) (mkt type-symbol str)) - (define (symbol->string ob) - (ref ob 1)) - ; lookup node str sym -> node' sym' - (define (maybe-lookup-symbol node str) + (define (maybe-lookup-symbol node str) (if node (lets ((this (symbol->string (ref node 2))) @@ -99,13 +93,13 @@ ((eq? res 0) (set node 2 sym)) (res - (set node 1 + (set node 1 (put-symbol (ref node 1) sym))) (else (set node 3 (put-symbol (ref node 3) sym))))) (tuple #false sym #false))) - + ;; note, only leaf strings for now (define (string->interned-symbol root str) (let ((old (maybe-lookup-symbol root str))) @@ -114,9 +108,6 @@ (let ((new (string->uninterned-symbol str))) (values (put-symbol root new) new))))) - (define (string->symbol str) - (interact 'intern str)) - ;;; ;;; BYTECODE INTERNING ;;; @@ -139,7 +130,7 @@ (lets ((as (sizeb a)) (bs (sizeb b))) - (cond + (cond ((eq? as bs) (compare-bytes a b 0 as)) ((lesser? as bs) is-less) (else is-greater)))) @@ -149,7 +140,7 @@ ;; codes bcode value → codes' (define (insert-code codes bcode value) (if codes - (lets + (lets ((l k v r codes) (res (compare-code k bcode))) (cond @@ -164,7 +155,7 @@ ;; codes bcode → bcode' | #false (define (lookup-code codes bcode) (if codes - (lets + (lets ((l k v r codes) (res (compare-code k bcode))) (cond @@ -185,8 +176,8 @@ ; them, and then make the intial threads with an up-to-date interner (define (bytes->symbol bytes) - (string->symbol - (runes->string + (string->symbol + (runes->string (reverse bytes)))) (define (intern-symbols sexp) @@ -222,7 +213,7 @@ (interner root codes))) ((bytecode? msg) ;; find an old equal bytecode sequence, extended wrapper, or add a new code fragment ;(debug "interner: interning bytecode") - (lets + (lets ((codes code (intern-code codes msg))) (mail sender code) (interner root codes))) ;; name after first finding @@ -249,7 +240,7 @@ (lets ((env (wait-mail)) (sender msg env)) (cond - ((bytecode? msg) + ((bytecode? msg) (mail sender msg) (dummy-interner)) ((tuple? msg) @@ -263,18 +254,18 @@ (error "bad interner request: " msg))))) (define (start-dummy-interner) - (fork-server 'intern dummy-interner)) + (thunk->thread 'intern dummy-interner)) ;; make a thunk to be forked as the thread ;; (sym ...) ((bcode . value) ...) → thunk (define (initialize-interner symbol-list codes) - (let + (let ((sym-root (fold put-symbol empty-symbol-tree symbol-list)) (code-root (fold (λ (codes pair) (insert-code codes (car pair) (cdr pair))) #false codes))) (λ () (interner sym-root code-root)))) (define (start-symbol-interner initial-symbols) - (fork-server 'intern + (thunk->thread 'intern (initialize-interner initial-symbols null))) )) diff --git a/owl/io.scm b/owl/io.scm index 4b7f56f4..0f956fb6 100644 --- a/owl/io.scm +++ b/owl/io.scm @@ -4,7 +4,7 @@ (define-library (owl io) - (export + (export ;; thread-oriented non-blocking io open-output-file ;; path → fd | #false open-input-file ;; path → fd | #false @@ -17,7 +17,6 @@ port->fd ;; port → fixnum fd->port ;; fixnum → port port? ;; _ → bool - flush-port ;; fd → _ close-port ;; fd → _ start-base-threads ;; start stdio and sleeper threads wait-write ;; fd → ? (no failure handling yet) @@ -28,21 +27,26 @@ tcp-client ;; port → ip tcp-fd | #f #f tcp-clients ;; port → ((ip . fd) ... . X), X = null → ok, #false → error tcp-send ;; ip port (bvec ...) → (ok|write-error|connect-error) n-bytes-written - + + ;; datagram-oriented IO + udp-packets ;; port → null | ((ip . bvec) ...) + udp-client-socket ;; temp + wait-udp-packet ;; port → (ip . bvec), blocks + check-udp-packet ;; port → #false | (ip . bvec), does not block + send-udp-packet ;; sock ip port bvec → bool + file->vector ;; vector io, may be moved elsewhere later file->list ;; list io, may be moved elsewhere later file->byte-stream ;; path → #false | (byte ...) vector->file write-vector ;; vec port port->meta-byte-stream ;; fd → (byte|'io-error|'block ...) | thunk - port->byte-stream ;; fd → (byte ...) | thunk + port->byte-stream ;; fd → (byte ...) | thunk + port->tail-byte-stream ;; fd → (byte ...) | thunk byte-stream->port ;; bs fd → bool port->block-stream ;; fd → (bvec ...) block-stream->port ;; (bvec ...) fd → bool - ;; temporary exports - fclose ;; fd → _ - stdin stdout stderr display-to ;; port val → bool print-to ;; port val → bool @@ -50,31 +54,33 @@ print print* print*-to ;; port val → bool - write + write writer-to ;; names → (port val → bool + io) write-to ;; port val → bool write-bytes ;; port byte-list → bool write-byte-vector ;; port byte-vector → bool get-block ;; fd n → bvec | eof | #false - write-really ;; + write-really try-get-block ;; fd n block? → bvec | eof | #false=error | #true=block - lines ;; fd → null | ll of string, read error is just null, each [\r]\n removed + byte-stream->lines ;; (byte ...) → null | ll of string, read error is just null, each [\r]\n removed + lines ;; fd → null | ll of string, read error is just null, each [\r]\n removed system-print system-println system-stderr fasl-save ;; obj path → done? fasl-load ;; path default → done? - + start-muxer ;; new io muxer sleep ;; sleep ms -> sleep at least for ms ) (import (owl defmac) + (owl eof) (owl syscall) (owl queue) (owl string) (owl list-extra) - (owl sys) + (prefix (owl sys) sys-) (owl ff) (owl equal) (owl vector) @@ -93,35 +99,21 @@ (begin ;; standard io ports - (define stdin (fd->port 0)) - (define stdout (fd->port 1)) - (define stderr (fd->port 2)) - - ;; use type 12 for fds - - (define (fclose fd) - (sys-prim 2 fd #false #false)) - - (define (fopen path mode) - (cond - ((c-string path) => - (λ (raw) (sys-prim 1 raw mode #false))) - (else #false))) + (define stdin sys-stdin) + (define stdout sys-stdout) + (define stderr sys-stderr) ;;; Writing ;; #[0 1 .. n .. m] n → #[n .. m] (define (bvec-tail bvec n) - (raw (map (lambda (p) (refb bvec p)) (iota n 1 (sizeb bvec))) type-vector-raw #false)) + (raw (map (H refb bvec) (iota n 1 (sizeb bvec))) type-vector-raw)) (define (try-write-block fd bvec len) - (cond - ;; one does not simply write() on all platforms - ((tcp? fd) (sys-prim 15 fd bvec len)) - ((port? fd) (sys-prim 0 fd bvec len)) - (else - ;(sys-prim 0 fd bvec len) - #false))) + ;; stdio ports are in blocking mode, so poll always + (if (sys-stdio? fd) + (interact 'iomux (tuple 'write fd))) + (sys-write fd bvec len)) ;; bvec port → bool (define (write-really bvec fd) @@ -134,7 +126,6 @@ ((eq? wrote end) #true) ;; ok, wrote the whole chunk ((eq? wrote 0) ;; 0 = EWOULDBLOCK (interact 'iomux (tuple 'write fd)) - ;(interact sid 2) (loop)) (wrote ;; partial write (write-really (bvec-tail bvec wrote) fd)) @@ -143,42 +134,36 @@ ;; how many bytes (max) to add to output buffer before flushing it to the fd (define output-buffer-size 4096) - (define mode/read #b0000) - (define mode/write #b0001) - (define mode/truncate #b0010) - (define mode/append #b0100) - (define mode/create #b1000) - - (define read-mode mode/read) - (define output-mode (foldr bor 0 (list mode/write mode/truncate mode/create))) - (define append-mode (foldr bor 0 (list mode/write mode/create mode/append))) + (define read-mode + sys-O_RDONLY) + (define (output-mode) + (bor (bor (sys-O_WRONLY) (sys-O_CREAT)) (sys-O_TRUNC))) + (define (append-mode) + (bor (bor (sys-O_WRONLY) (sys-O_CREAT)) (sys-O_APPEND))) - (define (open-input-file path) - (let ((fd (fopen path read-mode))) - (if fd (fd->port fd) fd))) + (define (open-input-file path) + (sys-open path (read-mode) 0)) (define (open-output-file path) - (let ((fd (fopen path output-mode))) ;; temporarily also applies others - (if fd (fd->port fd) fd))) + (sys-open path (output-mode) #o600)) ;; temporarily also applies others (define (open-append-file path) - (let ((fd (fopen path append-mode))) - (if fd - (let ((port (fd->port fd))) - (seek-end port) - port) - #false))) + (let ((port (sys-open path (append-mode) #o600))) + (and port (begin (sys-seek-end port) port)))) ;;; Reading - (define input-block-size + (define input-block-size *vec-leaf-size*) ;; changing from 256 breaks vector leaf things (define stream-block-size #x8000) (define (try-get-block fd block-size block?) - (let ((res (sys-prim 5 fd block-size 0))) + ;; stdio ports are in blocking mode, so poll always + (if (sys-stdio? fd) + (interact 'iomux (tuple 'read fd))) + (let ((res (sys-read fd block-size))) (if (eq? res #true) ;; would block (if block? (begin @@ -191,7 +176,7 @@ ;; get a block of size up to block size (define (get-block fd block-size) (try-get-block fd block-size #true)) - + (define (maybe-get-block fd block-size) (try-get-block fd block-size #false)) @@ -206,7 +191,7 @@ (define (get-whole-block fd block-size) (let ((this (get-block fd block-size))) (cond - ((eof? this) (values #true this)) + ((eof-object? this) (values #true this)) ((not this) (values #false this)) (else (let ((n (sizeb this))) @@ -214,9 +199,9 @@ (values #false this) (lets ((eof-seen? tail (get-whole-block fd (- block-size n)))) (cond - ((eof? tail) (values #true this)) + ((eof-object? tail) (values #true this)) ((not tail) (values #false this)) ;; next read will also fail, return last ok data - (else + (else ;; unnecessarily many conversions if there are many partial ;; reads, but block size is tiny in file->vector making this ;; irrelevant @@ -231,7 +216,7 @@ (let ((res (sys-prim 4 fd #false #false))) (if res ; did get connection (lets ((ip fd res)) - (mail thread fd) + (mail thread (sys-port->non-blocking fd)) #true) (begin ;(interact sid 5) ;; delay rounds @@ -240,21 +225,42 @@ (define socket-type-tcp 0) (define socket-type-udp 1) - + (define (open-tcp-socket port) - (let ((sock (sys-prim 3 port socket-type-tcp #false))) - (if sock - (fd->port sock) - #false))) + (sys-port->non-blocking (sys-prim 3 port socket-type-tcp #false))) (define (open-udp-socket port) - (let ((sock (sys-prim 3 port socket-type-udp #false))) - (if sock - (fd->port sock) - #false))) - + (sys-port->non-blocking (sys-prim 3 port socket-type-udp #false))) + + ;; port → (ip . bvec) | #false, nonblocking + (define (check-udp-packet port) + (sys-prim 10 port #f #f)) + + (define (send-udp-packet sock ip port payload) + (sys-prim 27 sock (cons port ip) payload)) + + ;; port → (ip . bvec), blocks thread + (define (wait-udp-packet port) + (let ((res (check-udp-packet port))) + (or res + (begin + ;(interact sid socket-read-delay) + (interact 'iomux (tuple 'read port)) + (wait-udp-packet port))))) + + ;; port → null | ((ip . bvec) ...) + (define (udp-packets port) + (let ((sock (open-udp-socket port))) + (if sock + (λ () + (let loop ((sock sock)) + (pair + (wait-udp-packet sock) + (loop sock)))) + null))) + (define open-socket open-tcp-socket) - + ;;; TCP connections (define (open-connection ip port) @@ -262,21 +268,15 @@ ((not (eq? (type port) type-fix+)) #false) ((and (eq? (type ip) type-vector-raw) (eq? 4 (sizeb ip))) ;; silly old formats - (let ((fd (_connect ip port))) - (if fd - (fd->port fd) - #false))) - (else + (sys-port->non-blocking (sys-prim 29 ip port socket-type-tcp))) + (else ;; note: could try to autoconvert formats to be a bit more user friendly #false))) - ;; deprecated - (define (flush-port fd) - ;(mail fd 'flush) - 42) + (define (udp-client-socket) + (sys-prim 29 #f #f socket-type-udp)) - (define (close-port fd) - (fclose fd)) + (define close-port sys-close) ;;; @@ -307,15 +307,15 @@ (define (closing-blocks->port ll fd) (lets ((r n (blocks->port ll fd))) - (fclose fd) + (close-port fd) (values r n))) ;; sock → #f #f | ip client (define (tcp-client sock) (let ((res (sys-prim 4 sock #false #false))) - (if res + (if res (lets ((ip fd res)) - (values ip (fd->port fd))) + (values ip (sys-port->non-blocking fd))) (begin ;(interact sid socket-read-delay) (interact 'iomux (tuple 'read sock)) @@ -337,7 +337,7 @@ ;; ip port (bvec ...) → #true n-written | #false error-sym (define (tcp-send ip port ll) - (let ((fd (_connect ip port))) + (let ((fd (sys-prim 29 ip port socket-type-tcp))) (if fd (lets ((ll n (closing-blocks->port ll fd))) (if (null? ll) @@ -354,11 +354,11 @@ (define (printer lst len out fd) (cond ((eq? len output-buffer-size) - (and - (write-really (raw (reverse out) type-vector-raw #false) fd) + (and + (write-really (raw (reverse out) type-vector-raw) fd) (printer lst 0 null fd))) ((null? lst) - (write-really (raw (reverse out) type-vector-raw #false) fd)) + (write-really (raw (reverse out) type-vector-raw) fd)) (else ;; avoid dependency on generic math in IO (lets ((len _ (fx+ len 1))) @@ -378,22 +378,23 @@ (λ (to obj) (printer (serialize obj '()) 0 null to)))) - (define write-to - (writer-to + (define write-to + (writer-to (put #empty map "map"))) (define (display-to to obj) (printer (render obj '()) 0 null to)) - (define (display x) - (display-to stdout x)) + (define display + (H display-to stdout)) - (define print + (define print (case-lambda ((obj) (print-to stdout obj)) (xs (printer (foldr render '(#\newline) xs) 0 null stdout)))) - (define (write obj) (write-to stdout obj)) + (define write + (H write-to stdout)) (define (print*-to to lst) (printer (foldr render '(10) lst) 0 null to)) @@ -402,13 +403,13 @@ (printer (foldr render '(10) lst) 0 null stdout)) (define-syntax output - (syntax-rules () + (syntax-rules () ((output . stuff) (print* (list stuff))))) ;; fixme: system-X do not belong here (define (system-print str) - (sys-prim 0 1 str (sizeb str))) + (sys-write stdout str #f)) (define (system-println str) (system-print str) @@ -416,9 +417,9 @@ ")) (define (system-stderr str) ; <- str is a raw or pre-rendered string - (sys-prim 0 2 str (sizeb str))) + (sys-write stderr str #f)) - ;;; + ;;; ;;; Files <-> vectors ;;; @@ -427,14 +428,14 @@ (lets ((eof-seen? val (get-whole-block port input-block-size))) (cond (eof-seen? - (let ((buff (if (eof? val) buff (cons val buff)))) + (let ((buff (if (eof-object? val) buff (cons val buff)))) (merge-chunks (reverse buff) (fold + 0 (map sizeb buff))))) ((not val) #false) (else - (read-blocks port + (read-blocks port (cons val buff)))))) (define (explode-block block tail) @@ -449,7 +450,7 @@ (define (read-blocks->list port buff) (let ((block (get-block port 4096))) (cond - ((eof? block) + ((eof-object? block) (foldr explode-block null (reverse buff))) ((not block) ;; read error @@ -476,16 +477,6 @@ (begin ;(print "file->vector: cannot open " path) #false)))) - - (define (file->list path) ; path -> vec | #false - (let ((port (maybe-open-file path))) - (if port - (let ((data (read-blocks->list port null))) - (maybe-close-port port) - data) - (begin - ;(print "file->vector: cannot open " path) - #false)))) (define (file->list path) ; path -> vec | #false (let ((port (maybe-open-file path))) @@ -517,8 +508,8 @@ outcome) #false))) - (define (wait-write fd) - (interact fd 'wait)) + (define wait-write + (C interact 'wait)) (define (stream-chunk buff pos tail) (if (eq? pos 0) @@ -527,25 +518,42 @@ (stream-chunk buff next (cons (refb buff pos) tail))))) - (define (port->block-stream fd) + (define (sleep ms) + (interact 'iomux (tuple 'alarm ms))) + + (define (block-stream fd tail?) (λ () - (let ((block (get-block fd stream-block-size))) - (cond - ((eof? block) - (close-port fd) - null) - ((not block) - null) - (else - (cons block - (port->block-stream fd))))))) + (let ((block (get-block fd stream-block-size))) + (cond + ((eof-object? block) + (if tail? + (begin + ;; read does not block at eof, so wait explicitly + (sleep 1000) + (block-stream fd #true)) + (begin + (close-port fd) + null))) + ((not block) + null) + (else + (cons block + (block-stream fd tail?))))))) + + ;; stream blocks close at eof + (define port->block-stream + (C block-stream #true)) + + ;; stream blocks, wait for more at eof + (define port->tail-block-stream + (C block-stream #false)) ;; include metadata symbols (define (port->meta-block-stream fd) (let loop ((block? #false)) (let ((block (try-get-block fd stream-block-size block?))) (cond - ((eof? block) + ((eof-object? block) (close-port fd) null) ((not block) @@ -560,7 +568,13 @@ (ledit (λ (block ll) (stream-chunk block (- (sizeb block) 1) ll)) - (port->block-stream fd))) + (block-stream fd #f))) + + (define (port->tail-byte-stream fd) + (ledit + (λ (block ll) + (stream-chunk block (- (sizeb block) 1) ll)) + (block-stream fd #t))) (define (port->meta-byte-stream fd) (ledit @@ -597,9 +611,8 @@ (else (loop (bs) n out))))) - (define (lines fd) - (let loop ((ll (utf8-decoder (port->byte-stream fd) (λ (self line ll) null))) - (out null)) + (define (byte-stream->lines ll) + (let loop ((ll ll) (out null)) (cond ((pair? ll) (lets ((byte ll ll)) @@ -619,7 +632,13 @@ (list->string (reverse out))))) (else (λ () - (loop (ll) out)))))) + (loop (ll) out)))))) + + (define (lines fd) + (byte-stream->lines + (utf8-decoder + (port->byte-stream fd) + (λ (self line ll) null)))) (define (file->byte-stream path) (let ((fd (open-input-file path))) @@ -627,14 +646,14 @@ (port->byte-stream fd) #false))) - (define (fasl-save obj path) - (vector->file + (define (fasl-save obj path) + (vector->file (list->vector (fasl-encode obj)) path)) (define (fasl-load path fail-val) (let ((bs (file->byte-stream path))) - (if bs + (if bs (fasl-decode bs fail-val) fail-val))) @@ -642,7 +661,7 @@ (define (delelt lst x) ;; lst x → lst' | #false if not there (let loop ((lst lst) (out null)) - (if (null? lst) + (if (null? lst) out (lets ((a lst lst)) (if (eq? a x) @@ -686,13 +705,13 @@ (print-to stderr " - found it")) (eq? port fd))) alarms)) - + ;; alarm-mail = #(sender #(read-timeout fd ms)) - + (define (wakeup rs ws alarms fd reason) (cond ((eq? reason 1) ;; data ready to be read - (lets + (lets ((rs x (grabelt rs fd)) (fd envelope x) (from message envelope)) @@ -702,7 +721,7 @@ (values rs ws alarms)) ((read-timeout fd timeout) (mail from message) - (values rs ws + (values rs ws (remove-alarm alarms envelope))) (else (print-to stderr "wakeup: unknown wakeup " message) @@ -722,13 +741,13 @@ (remove-alarm-by-fd alarms fd)))))) (define (push-alarm alarms time id) - (if (null? alarms) + (if (null? alarms) (list (cons time id)) (let ((a (car alarms))) (if (< (car a) time) (cons a (push-alarm (cdr alarms) time id)) (cons (cons time id) alarms))))) - + ;; including time currently causes a circular dependency - resolve later (define (time-ms) (lets ((ss ms (clock))) @@ -761,8 +780,8 @@ (waked x (_poll2 rs ws timeout))) (cond (waked - (lets ((rs ws alarms (wakeup rs ws alarms waked x))) - (muxer rs ws alarms))) + (lets ((rs ws alarms (wakeup rs ws alarms waked x))) + (muxer rs ws alarms))) (x 3) (else (set-ticker 0) @@ -775,7 +794,7 @@ (lets ((rs ws alarms (muxer-add rs ws alarms envelope))) (muxer rs ws alarms)) (lets - ((timeout + ((timeout (if (single-thread?) (min *max-fixnum* (- (caar alarms) now)) 0)) (waked x (_poll2 rs ws timeout))) (cond @@ -783,7 +802,7 @@ (lets ((rs ws alarms (wakeup rs ws alarms waked x))) (muxer rs ws alarms))) (x 2) - (else + (else (set-ticker 0) (muxer rs ws alarms)))))) ;; the bell tolls @@ -804,13 +823,11 @@ (print-to stderr "not sure how to alarm " message) (mail id 'alarm) (muxer rs ws (cdr alarms))))))))) - - (define (start-muxer . id) - (fork-server (if (null? id) 'iomux (car id)) - (λ () (muxer null null null)))) - (define (sleep ms) - (interact 'iomux (tuple 'alarm ms))) + (define (start-muxer . id) + (thread + (if (null? id) 'iomux (car id)) + (muxer null null null))) ;; start normally mandatory threads (apart form meta which will be removed later) (define (start-base-threads) @@ -820,10 +837,8 @@ (define (file-size path) (let ((port (open-input-file path))) (if port - (let ((end (seek-end port))) + (let ((end (sys-seek-end port))) (close-port port) end) port))) - )) - diff --git a/owl/lazy.scm b/owl/lazy.scm index 281d6a41..12b4b91a 100644 --- a/owl/lazy.scm +++ b/owl/lazy.scm @@ -1,13 +1,27 @@ -;;; -;;; Lazy lists (poor man's streams) -;;; +;;; Lazy lists (or streams) are like lists, but they are computed only as far as needed. +;;; You can for example define a lazy list of all integers below a million, and then +;;; proceed to run computations on them, without worrying whether you have enough memory +;;; to hold a million numbers. Lazy lists are for example useful in computations, where +;;; you know how something is constructed, but don't yet know how many of them will be +;;; needed, or know that you only need them one at a time and don't want to waste memory. +;;; +;;; A lazy list is either null, a pair of a value and rest of the lazy list, or a +;;; function of zero arguments (a thunk) which when called will return the rest of the +;;; lazy list. Therefore, since normal lists are a subset of lazy lists, all lazy list +;;; functions can also take normal lists as arguments. +;;; +;;; `Scheme warning`: recall that Owl does not have mutable data structures, so lazy +;;; lists do not cache their results. +;;; +;;; ``` +;;; (pair head exp) → ll, lazy equivalent of (cons head exp), but exp is not evaluated yet +;;; (force-ll ll) → list, turn a lazy list into a regular one +;;; ``` -;; in owl a lazy list some nodes of which may be thunks that evaluate to lists or lazy lists - (define-library (owl lazy) - (export + (export lfold lfoldr lmap lappend ; main usage patterns lfor liota liter lnums lzip ltake lsplit llast llen @@ -20,18 +34,20 @@ lunfold delay force avg + lnull? + lpair? ; ll → (head . ll-tail) | #false ) (import - (owl math) (owl defmac) (owl list) (owl list-extra) + (owl math) (owl proof) (only (owl syscall) error)) (begin - + ;; convert an application to a thunk (define-syntax delay (syntax-rules () @@ -63,7 +79,7 @@ (if (null? tl) (car l) (llast tl)))) ((null? l) (error "llast: empty list: " l)) (else (llast (l))))) - + ;; l → hd l' | error (define (uncons l d) (cond @@ -71,15 +87,15 @@ ((null? l) (values d l)) (else (uncons (l) d)))) - (define (lfold op state lst) + (define (lfold op state lst) (cond - ((pair? lst) + ((pair? lst) (lfold op (op state (car lst)) (cdr lst))) ((null? lst) state) (else (lfold op state (lst))))) ; only swaps argument order, useful for making folds out of iterators - (define (lfoldr op state lst) + (define (lfoldr op state lst) (cond ((pair? lst) (lfoldr op (op (car lst) state) (cdr lst))) ((null? lst) state) @@ -97,9 +113,9 @@ ((pair? l) (cons (fn (car l)) (lmap fn (cdr l)))) - ((null? l) + ((null? l) null) - (else + (else (λ () (lmap fn (l)))))) ;; preserves laziness @@ -108,11 +124,11 @@ ((pair? a) (cons (car a) (lappend (cdr a) b))) ((null? a) b) - (else + (else (λ () (lappend (a) b))))) (define (lunfold op st end?) - (if (end? st) + (if (end? st) null (lets ((this st (op st))) (pair this @@ -133,7 +149,7 @@ (d _ (fx+ c 1))) (ilist a b c (lambda () (lnums-fix d)))) (lnums-other a))) - + (define (lnums n) (case (type n) (type-fix+ (lnums-fix n)) @@ -171,7 +187,7 @@ (define (liota pos step end) (if (eq? step 1) - (if (eq? (type pos) type-fix+) + (if (eq? (type pos) type-fix+) (if (eq? (type end) type-fix+) (liota-fix pos end) ; positive fixnum range interval (liota-walk-one pos end)) ; increment iota @@ -185,7 +201,7 @@ (λ () (ledit op (cdr l))))) ((null? l) l) - (else + (else (lambda () (ledit op (l)))))) @@ -210,7 +226,7 @@ (error "llref: out of list: " p) val))) - (define (ltake l n) + (define (ltake l n) (cond ((eq? n 0) null) ((null? l) l) @@ -220,10 +236,10 @@ (else (λ () (ltake (l) n))))) - (define (lsplit l n) + (define (lsplit l n) (let loop ((l l) (o null) (n n)) (cond - ((eq? n 0) + ((eq? n 0) (values (reverse o) l)) ((pair? l) (loop (cdr l) (cons (car l) o) (- n 1))) @@ -232,10 +248,10 @@ (else (loop (l) o n))))) - (example + (example (lsplit '(1 2 3 4) 2) = (values '(1 2) '(3 4))) - - (define (lkeep p l) + + (define (lkeep p l) (cond ((null? l) l) ((pair? l) @@ -247,11 +263,11 @@ (λ () (lkeep p (l)))))) (define (lremove p l) - (lkeep (λ (x) (not (p x))) l)) + (lkeep (B not p) l)) ;; zip, preserves laziness of first argument (define (lzip op a b) - (cond + (cond ((null? a) null) ((null? b) null) ((pair? a) @@ -259,7 +275,7 @@ (pair (op (car a) (car b)) (lzip op (cdr a) (cdr b))) (lzip op a (b)))) - (else + (else (λ () (lzip op (a) b))))) ; lst -> stream of (lst' ...) @@ -271,9 +287,9 @@ (let loop ((a l) (b null)) (if (null? a) (rest) - (lperm-take (append b (cdr a)) (cons (car a) out) + (lperm-take (append b (cdr a)) (cons (car a) out) (lambda () (loop (cdr a) (cons (car a) b)))))))) - + (define (lperms l) (if (null? l) '(()) @@ -311,14 +327,14 @@ (let loop ((n 1)) (if (= n end) null - (lpick l null n + (lpick l null n (lambda () (loop (+ n 1)))))))))) (define subsets subs) ; (lfold (lambda (n s) (print s) (+ n 1)) 0 (subsets (iota 0 1 5))) - + ; (lfold (lambda (n s) (print s) (+ n 1)) 0 (permutations (iota 0 1 5))) (define (force-ll it) @@ -343,6 +359,12 @@ (define (lcdr ll) (if (pair? ll) (cdr ll) (lcdr (ll)))) -)) - + (define (lpair? ll) + (cond + ((null? ll) #false) + ((pair? ll) ll) + (else (lpair? (ll))))) + (define (lnull? ll) + (eq? #false (lpair? ll))) +)) diff --git a/owl/list-extra.scm b/owl/list-extra.scm index e95b3a94..e4160e6f 100644 --- a/owl/list-extra.scm +++ b/owl/list-extra.scm @@ -1,6 +1,6 @@ (define-library (owl list-extra) - (export + (export lref lset ldel length led ledn lins take drop iota @@ -11,14 +11,14 @@ ) (import + (owl defmac) (owl math) (owl list) (owl proof) - (owl defmac) (owl syscall)) (begin - + (define (lref lst pos) (cond ((null? lst) (error "lref: out of list" pos)) @@ -34,7 +34,7 @@ (else (cons (car lst) (lset (cdr lst) (- pos 1) val))))) - + (define (ldel lst pos) (cond ((null? lst) (error "list-del: out of list, left " pos)) @@ -58,7 +58,7 @@ (else (lets ((hd tl lst)) (cons hd (led tl (- pos 1) op)))))) - + ;; insert value to list at given position (define (lins lst pos val) (cond @@ -68,14 +68,14 @@ (lets ((hd tl lst)) (cons hd (lins tl (- pos 1) val)))))) - (example + (example (lref '(a b c) 1) = 'b (lset '(a b c) 1 'x) = '(a x c) (ldel '(a b c) 1) = '(a c) - (led '(1 2 3) 1 (λ (x) (* x 10))) = '(1 20 3) - (ledn '(1 2 3) 1 (λ (lst) (cons 'x lst))) = '(1 x 2 3) + (led '(1 2 3) 1 (C * 10)) = '(1 20 3) + (ledn '(1 2 3) 1 (H cons 'x)) = '(1 x 2 3) (lins '(a b c) 1 'x) = '(a x b c)) - + (define (length lst) (fold (λ (n v) (+ n 1)) 0 lst)) @@ -99,7 +99,7 @@ (take '(a) 100) = '(a) (drop '(a b c) 2) = '(c) (drop '(a) 100) = '()) - + (define (iota-up p s e) (if (< p e) (cons p (iota-up (+ p s) s e)) @@ -116,15 +116,15 @@ (if (< to from) null (iota-up from step to))) ((< step 0) (if (> to from) null (iota-down from step to))) - ((= from to) + ((= from to) null) - (else + (else (error "bad iota: " (list 'iota from step to))))) (example (iota 0 1 5) = '(0 1 2 3 4) (iota 10 -2 0) = '(10 8 6 4 2)) - + (define (list-tail lst n) (if (eq? n 0) lst @@ -136,14 +136,14 @@ out (loop (- n 1) (cons thing out))))) - (define (split l n) + (define (split l n) (let loop ((l l) (o null) (n n)) (cond ((null? l) (values (reverse o) l)) ((eq? n 0) (values (reverse o) l)) - (else + (else (loop (cdr l) (cons (car l) o) (- n 1)))))) (example diff --git a/owl/list.scm b/owl/list.scm index eea16e00..62cfc8f5 100644 --- a/owl/list.scm +++ b/owl/list.scm @@ -1,14 +1,14 @@ (define-library (owl list) - (export + (export null pair? null? caar cadr cdar cddr - list? + list? zip fold foldr map for-each has? getq last drop-while mem fold-map foldr-map - append reverse keep remove + append reverse keep remove all some smap unfold take-while ;; pred, lst -> as, bs @@ -18,7 +18,7 @@ edit ;; op lst → lst' interleave ╯°□°╯ - + diff union intersect) (import @@ -38,7 +38,7 @@ (define (pair? x) (eq? type-pair (type x))) ;; any -> bool - (define (null? x) (eq? x null)) + (define null? (C eq? null)) (define-syntax withcc (syntax-rules () @@ -46,13 +46,13 @@ (call/cc (λ (name) proc))))) ;; '((a . b) . c) -> a - (define (caar x) (car (car x))) + (define caar (B car car)) ;; '(a . (b . c)) -> b - (define (cadr x) (car (cdr x))) + (define cadr (B car cdr)) ;; '((a . b) . c) -> b - (define (cdar x) (cdr (car x))) + (define cdar (B cdr car)) ;; '(a . (b . c)) -> c - (define (cddr x) (cdr (cdr x))) + (define cddr (B cdr cdr)) ;; any -> bool, check if a thing is a linked list, O(n) (define (list? l) @@ -69,19 +69,19 @@ (else (let ((hd (op (car a) (car b)))) (cons hd (zip op (cdr a) (cdr b))))))) - + ;; op state lst -> state', walk over a list from left and compute a value - - (define (fold op state lst) - (if (null? lst) - state - (fold op + + (define (fold op state lst) + (if (null? lst) + state + (fold op (op state (car lst)) (cdr lst)))) - (example + (example (zip cons '(1 2 3) '(a b c d)) = '((1 . a) (2 . b) (3 . c))) - + (define (unfold op st end?) (if (end? st) null @@ -102,21 +102,21 @@ st (op (car lst) (foldr op st (cdr lst))))) - + (example (foldr cons null '(a b c)) = '(a b c)) ;; fn lst -> lst', run a function to all elements of a list (define (map fn lst) (if (null? lst) null - (lets + (lets ((hd tl lst) (hd (fn hd))) ;; compute head first (cons hd (map fn tl))))) (example (map not '(#false #false #true)) = '(#true #true #false)) - + ;; fn lst -> _, run a function to all elements of a list for side effects (define (for-each op lst) (if (null? lst) @@ -138,20 +138,20 @@ ((null? lst) #false) ((eq? k (car (car lst))) (car lst)) (else (getq (cdr lst) k)))) - - (example + + (example (getq '((a . 1) (b . 2)) 'a) = '(a . 1) (getq '((a . 1) (b . 2)) 'c) = #false) - + ;; last list default -> last-elem | default, get the last value of a list (define (last l def) - (fold (λ (a b) b) def l)) + (fold (λ (a b) b) def l)) (example (last '(1 2 3) 'a) = 3 (last '() 'a) = 'a) - + ;; mem compare lst elem -> bool, check if lst contains elem comparing with compare (define (mem cmp lst elem) (cond @@ -163,7 +163,7 @@ (if (null? a) b (cons (car a) (app (cdr a) b app)))) - + (define (appl l appl) (if (null? (cdr l)) (car l) @@ -172,7 +172,7 @@ ;; append list ... -> list', join lists ;; (append '(1) '() '(2 3)) = '(1 2 3) (define append - (case-lambda + (case-lambda ((a b) (app a b app)) ((a b . cs) (app a (app b (appl cs appl) app) app)) ((a) a) @@ -181,7 +181,7 @@ (example (append '(1 2 3) '(a b c)) = '(1 2 3 a b c)) - + ; todo: update to work like ledit (define (edit op l) (if (null? l) @@ -199,11 +199,11 @@ (rev-loop (cdr a) (cons (car a) b)))) ;; lst -> lst', reverse a list - (define (reverse l) (rev-loop l null)) + (define reverse (C rev-loop null)) - (example + (example (reverse '(1 2 3)) = '(3 2 1)) - + ;; misc (define (drop-while pred lst) @@ -224,7 +224,7 @@ (foldr (λ (x tl) (if (pred x) (cons x tl) tl)) null lst)) (define (remove pred lst) - (keep (o not pred) lst)) + (keep (B not pred) lst)) (let ((l '(1 2 () 3 () 4))) (example @@ -235,7 +235,7 @@ (withcc ret (fold (λ (ok x) (if (pred x) ok (ret #false))) #true lst))) - (define (some pred lst) + (define (some pred lst) (withcc ret (fold (λ (_ x) (let ((v (pred x))) (if v (ret v) #false))) #false lst))) @@ -243,7 +243,7 @@ (example (some null? l) = #true (all null? l) = #false)) - + ; map carrying one state variable down like fold (define (smap op st lst) (if (null? lst) @@ -262,7 +262,7 @@ (example (first null? '(1 2 3) 42) = 42 (first null? '(1 ()) 42) = ()) - + (define (fold-map o s l) (let loop ((s s) (l l) (r null)) (if (null? l) @@ -311,7 +311,7 @@ (union abc def) = '(a b c d e f) (intersect abc cd) = '(c) (diff abc cd) = (diff abc (intersect abc cd)))) - + (define (interleave mid lst) (if (null? lst) null @@ -319,7 +319,7 @@ (if (null? as) (list a) (ilist a mid (loop (car as) (cdr as))))))) - + ;; lst → a b, a ++ b == lst, length a = length b | length b + 1 (define (halve lst) (let walk ((t lst) (h lst) (out null)) @@ -330,14 +330,14 @@ (values (reverse (cons (car t) out)) (cdr t)) (walk (cdr t) (cdr h) (cons (car t) out))))))) (lets ((l '(a b c d e f))) - (example + (example l = (lets ((head tail (halve l))) (append head tail)))) - + (example (interleave 'x '(a b c)) = '(a x b x c) (interleave 'x '()) = () (halve '(a b c d)) = (values '(a b) '(c d)) (halve '(a b c d e)) = (values '(a b c) '(d e))) - (define ╯°□°╯ reverse) + (define ╯°□°╯ reverse) )) diff --git a/owl/macro.scm b/owl/macro.scm index d0efab3d..f4157a82 100644 --- a/owl/macro.scm +++ b/owl/macro.scm @@ -1,7 +1,7 @@ ; already loaded when booting. (define-library (owl macro) - + ; remove make-transformer when it is no longer referred (export macro-expand match make-transformer) @@ -38,8 +38,7 @@ (cons exp found)) (else found))) - (lambda (exp) - (walk exp null))) + (C walk null)) ;;; @@ -170,7 +169,7 @@ ;; single matches can be used along with ellipsis matches. (define (repetition-length dict) - (let loop ((opts (sort < (map (o length cdr) dict))) (best 0)) + (let loop ((opts (sort < (map (B length cdr) dict))) (best 0)) (cond ((null? opts) ;; 0 if ellipsis with empty match, or 1 due to ellipsis of lenght 1 or just normal valid bindings @@ -181,7 +180,7 @@ (else ;; repetition of length 0 or n>1 (car opts))))) - + ;; pop all bindings of length > 1 (define (pop-ellipsis dict) (map @@ -199,8 +198,7 @@ ((pair? form) (if (and (pair? (cdr form)) (eq? (cadr form) '...)) (lets - ((syms (symbols-of (car form))) - (dict (keep (λ (node) (has? syms (car node))) dictionary)) + ((dict (keep (B (H has? (symbols-of (car form))) car) dictionary)) (len (repetition-length dict))) (let rep-loop ((dict dict) (n len)) (if (= n 0) @@ -219,12 +217,8 @@ ; exp env free -> status exp' free' (define toplevel-macro-definition? - (let - ((pattern - `(quote syntax-operation add #false (,symbol? ,list? ,list? ,list?)))) - ;; -> keyword literals patterns templates - (lambda (exp) - (match pattern exp)))) + ;; -> keyword literals patterns templates + (H match `(quote syntax-operation add #false (,symbol? ,list? ,list? ,list?)))) ; fold w/ 2 state variables (define (fold2 op s1 s2 lst) @@ -402,11 +396,8 @@ (define (macro-expand exp env) (lets/cc exit - ((abort (lambda (why) (exit (fail why)))) + ((abort (B exit fail)) (free (gensym exp)) (exp free (expand exp env free abort))) (post-macro-expand exp env abort))) - - )) - diff --git a/owl/math-extra.scm b/owl/math-extra.scm index 20001a6e..d281a0ee 100644 --- a/owl/math-extra.scm +++ b/owl/math-extra.scm @@ -22,14 +22,14 @@ ) (import + (owl defmac) (owl math) (owl iff) (owl list) (owl list-extra) (owl sort) (owl primop) - (only (owl syscall) por por*) - (owl defmac) + (only (owl syscall)) (owl ff) (only (owl syscall) error)) @@ -367,7 +367,7 @@ (define (factor n) (if (> n 1) - (por + (or ;; prime check is relatively fast (for deterministic range) so try it first (if (prime? n) (list (cons n 1)) diff --git a/owl/math.scm b/owl/math.scm index 598a173d..5111d9ae 100644 --- a/owl/math.scm +++ b/owl/math.scm @@ -16,12 +16,12 @@ (define-library (owl math) - (export + (export number? fixnum? integer? - + - * = / - << < <= = >= > >> + + - * = / + << < <= = >= > >> band bor bxor - div ediv rem mod quotrem mod divmod + div ediv rem mod quotrem mod divmod add nat-succ sub mul big-bad-args negate even? odd? gcd gcdl lcm @@ -52,6 +52,9 @@ (begin + (define zero? + (C eq? 0)) + ;; check how many fixnum bits the vm supports with fx<< ;; idea is to allow the vm to be compiled with different ranges, initially fixed to 24 (define *max-fixnum* @@ -85,11 +88,9 @@ (define *first-bignum* (ncons 0 *big-one*)) - (define (zero? x) (eq? x 0)) - - (define (fixnum? x) + (define (fixnum? x) (let ((t (type x))) - (or + (or (eq? t type-fix+) ;(eq? t type-fix-) ;; <- FIXME - breaks build, someone isn't expecting negative fixnums ))) @@ -98,8 +99,8 @@ (define (inexact? n) #false) ;; signaling an error would also make sense for these, but as compat ;; functions returning the argument as suggested in filed bug - (define (exact->inexact n) n) - (define (inexact->exact n) n) + (define exact->inexact self) + (define inexact->exact self) ;; deprecated primop ;(define-syntax fxdivmod @@ -108,7 +109,7 @@ ; (lets ((q1 q2 r (fxqr 0 a b))) ; (values q2 r))))) - (define-syntax define-traced + (define-syntax define-traced (syntax-rules () ((define-traced (name arg ...) . whatever) (define (name arg ...) @@ -122,7 +123,7 @@ (ncdr num) (ncons (ncar num) to)))) - (define-syntax nrev + (define-syntax nrev (syntax-rules () ((nrev num) (nrev-walk num null)))) @@ -184,7 +185,7 @@ (case (type b) (type-int+ (big-less a b #false)) (else #false))) - (type-int- + (type-int- (case (type b) (type-int- (if (big-less a b #false) #false #true)) @@ -224,10 +225,10 @@ (else #false))) (type-complex (if (eq? (type b) type-complex) - (and (= (ref a 1) (ref b 1)) + (and (= (ref a 1) (ref b 1)) (= (ref a 2) (ref b 2))) #false)) - (else + (else (big-bad-args '= a b)))) ; later just, is major type X @@ -265,8 +266,8 @@ (else (error "Bad number: " a)))) (else (error 'negative? a)))) - (define positive? - (o not negative?)) + (define positive? + (B not negative?)) ;; RnRS compat (define real? number?) @@ -308,7 +309,7 @@ (loop (ncdr n) (nat-succ i))))))) (define (add-number-big a big) - (lets + (lets ((b bs big) (new overflow? (fx+ a b))) (if overflow? @@ -336,8 +337,8 @@ (ncons r (add-big (ncdr a) (ncdr b) o))))))) - (define-syntax add-small->positive - (syntax-rules () + (define-syntax add-small->positive + (syntax-rules () ((add-small->positive a b) (lets ((r overflow? (fx+ a b))) (if overflow? (ncons r *big-one*) r))))) @@ -374,7 +375,7 @@ (if (eq? tail null) (if leading? r #false) (ncons r tail)))) - (else + (else (ncons r (ncdr a)))))) ; a - B = a + -B = -(-a + B) = -(B - a) @@ -425,7 +426,7 @@ (define (sub-big a b) (cond - ((big-less a b #false) + ((big-less a b #false) (let ((neg (sub-digits b a #false #true))) (cond ((eq? neg 0) neg) @@ -444,7 +445,7 @@ ; for changing the (default positive) sign of unsigned operations - (define-syntax negative + (define-syntax negative (syntax-rules (imm cast if fix+) ((negative (op . args)) (let ((foo (op . args))) @@ -453,14 +454,14 @@ (if (eq? (type x) type-fix+) (cast x type-fix-) (cast x type-int-))))) - + (define-syntax rational (syntax-rules () ((rational a b) (mkt type-rational a b)))) - - (define (negate num) + + (define (negate num) (case (type num) - (type-fix+ + (type-fix+ (if (eq? num 0) 0 (cast num type-fix-))) ;; a -> -a @@ -478,10 +479,10 @@ ;;; - ;;; Addition and substraction generics + ;;; Addition and subtraction generics ;;; - (define (add a b) + (define (addi a b) (case (type a) (type-fix+ ; a signed fixnum (case (type b) @@ -511,7 +512,7 @@ (type-int+ (sub-big b a)) ;; -A + +B == +B + -A -> as above (type-int- (cast (add-big a b #false) type-int-)) ;; -A + -B == -(A + B) (else (big-bad-args 'add a b)))) - (else + (else (big-bad-args 'add a b)))) ; substraction is just just opencoded (+ a (negate b)) @@ -547,10 +548,9 @@ (type-int+ (cast (add-big a b #false) type-int-)) ;; -A - +B -> as -A + -B (type-int- (sub-big b a)) ;; -A - -B -> as -A + +B (else (big-bad-args '- a b)))) - (else + (else (big-bad-args '- a b)))) - ;;; @@ -578,12 +578,12 @@ (tail (ncons this tail)) ((eq? this 0) (if first? 0 #false)) - (else - (if first? this + (else + (if first? this (ncons this null))))))))) (define (shift-right a n) - (if (eq? a null) + (if (eq? a null) 0 (lets ((hi lo (fx>> (ncar a) n))) (shift-right-walk hi (ncdr a) n #true)))) @@ -603,7 +603,7 @@ (case (type b) (type-fix+ (lets ((_ wor bits (fxqr 0 b *fixnum-bits*))) - (if (eq? wor 0) + (if (eq? wor 0) (case (type a) (type-fix+ (receive (fx>> a bits) (lambda (hi lo) hi))) (type-fix- (receive (fx>> a bits) (lambda (hi lo) (if (eq? hi 0) 0 (negate hi))))) @@ -614,8 +614,8 @@ (type-fix+ 0) (type-fix- 0) (type-int+ (shift-right (drop-digits a wor) bits)) - (type-int- - (negative + (type-int- + (negative (shift-right (drop-digits a wor) bits))) (else (big-bad-args '>> a b)))))) (type-int+ @@ -659,21 +659,21 @@ lo (extend-digits (ncons lo null) words)) (if (eq? words 0) - (ncons lo (ncons hi null)) - (extend-digits - (ncons lo (ncons hi null)) + (ncons lo (ncons hi null)) + (extend-digits + (ncons lo (ncons hi null)) words))))) (type-fix- (lets ((hi lo (fx<< a bits))) (if (eq? hi 0) (if (eq? words 0) (cast lo type-fix-) - (cast - (extend-digits (ncons lo null) words) + (cast + (extend-digits (ncons lo null) words) type-int-)) - (cast - (extend-digits - (ncons lo (ncons hi null)) words) + (cast + (extend-digits + (ncons lo (ncons hi null)) words) type-int-)))) (type-int+ (extend-digits (shift-left a bits 0) words)) @@ -688,7 +688,7 @@ ;; could allow negative shift left to mean a shift right, but that is ;; probably more likely an accident than desired behavior, so failing here (big-bad-args '<< a b)))) - + (define (big-band a b) (cond ((eq? a null) 0) @@ -734,7 +734,7 @@ (let ((r (big-bxor-digits a b))) (cond ;; maybe demote to fixnum - ((null? r) 0) + ((null? r) 0) ((null? (ncdr r)) (ncar r)) (else r)))) @@ -766,7 +766,7 @@ (type-fix+ (case (type b) (type-fix+ (fxbor a b)) - (type-int+ + (type-int+ (ncons (fxbor a (ncar b)) (ncdr b))) (else @@ -788,7 +788,7 @@ (type-fix+ (case (type b) (type-fix+ (fxbxor a b)) - (type-int+ + (type-int+ (ncons (fxbxor a (ncar b)) (ncdr b))) (else (big-bad-args 'bxor a b)))) @@ -848,7 +848,7 @@ (if (eq? hi 0) lo (ncons lo (ncons hi null))))))) - + ;;; ;;; Big multiplication @@ -865,13 +865,13 @@ ; a + (b << ex*16) (define (add-ext a b ex) (cond - ((eq? ex 0) (if (null? a) (bigen b) (add a b))) + ((eq? ex 0) (if (null? a) (bigen b) (addi a b))) ((null? a) (ncons 0 (add-ext null b (subi ex 1)))) ((eq? (type a) type-fix+) (add-ext (ncons a null) b ex)) ((eq? (type ex) type-fix+) - (lets + (lets ((ex u (fx- ex 1)) (d ds a)) (ncons d (add-ext ds b ex)))) @@ -886,10 +886,11 @@ (define (mul-simple a b) (if (null? a) null - (lets ((digit (ncar a)) + (lets + ((digit (ncar a)) (head (ncons 0 (mul-simple (ncdr a) b))) (this (mult-num-big digit b 0))) - (add head this)))) + (addi head this)))) ; downgrade to fixnum if length 1 (define (fix n) @@ -897,7 +898,7 @@ ; drop leading zeros, reverse digits and downgrade to fixnum if possible (define (fixr n) - (if (null? n) + (if (null? n) 0 (lets ((d ds n)) (cond @@ -915,8 +916,8 @@ (s? (splice-nums (ncdr ah) (ncdr bh) at bt rat rbt #false l)) (else - (lets - ((a at at) + (lets + ((a at at) (b bt bt) (l over (fx+ l 1))) ; fixme, no bignum len (splice-nums (ncdr ah) (ncdr bh) @@ -933,7 +934,7 @@ ;; O(n) or O(1) leaf cases ((eq? (type a) type-fix+) (if (eq? (type b) type-fix+) (mult-fixnums a b) (mult-num-big a b 0))) ((eq? (type b) type-fix+) (mult-num-big b a 0)) - ((null? (ncdr a)) + ((null? (ncdr a)) (if (null? (ncdr b)) (mult-fixnums (ncar a) (ncar b)) (mult-num-big (ncar a) b 0))) @@ -945,17 +946,17 @@ ; 3O(n) ((ah at bh bt atl (splice-nums a b a b null null #true 0))) - (if (lesser? atl 30) + (if (lesser? atl 30) (mul-simple a b) (lets ; 3F(O(n/2)) + 2O(n/2) ((z2 (kara ah bh)) (z0 (kara at bt)) - (z1a - (lets ((a (add ah at)) (b (add bh bt))) + (z1a + (lets ((a (addi ah at)) (b (addi bh bt))) (kara a b))) ; 2O(n) - (z1 (subi z1a (add z2 z0))) + (z1 (subi z1a (addi z2 z0))) ; two more below (x (if (eq? z1 0) z0 (add-ext z0 z1 atl)))) (if (eq? z2 0) @@ -966,7 +967,7 @@ (define mult-big kara) (define (muli a b) - (cond + (cond ; are these actually useful? ((eq? a 0) 0) ;((eq? a 1) b) @@ -995,7 +996,7 @@ (type-int+ (mult-big a b)) ; +A * +B -> +C (type-int- (cast (mult-big a b) type-int-)) ; +A * -B -> -C (else (big-bad-args 'mul a b)))) - (type-int- + (type-int- (case (type b) (type-fix+ (cast (mult-num-big b a 0) type-int-)) ; -A * +b -> -C (type-fix- (mult-num-big b a 0)) ; -A * -b -> +C @@ -1023,7 +1024,7 @@ ((eq? (type b) type-rational) ; a < b/b' <=> ab' < b (int< (muli a (ncdr b)) (ncar b))) - (else + (else (int< a b)))) (define (denominator n) @@ -1031,11 +1032,6 @@ (ncdr n) ;; always positive 1)) - (define (numerator n) - (if (eq? (type n) type-rational) - (ncar n) ;; has the sign if negative - 1)) - (define (<= a b) (or (< a b) (= a b))) @@ -1052,8 +1048,6 @@ ;;; DIVISION ;;; - - ; walk down a and compute each digit of quotient using the top 2 digits of a (define (qr-bs-loop a1 as b out) (if (null? as) @@ -1077,7 +1071,7 @@ ; (let ((tl (ncdr a))) ; (fxqr (ncar tl) (ncar a) b))) (else - (lets + (lets ((ra (nrev a)) (a as ra)) (qr-bs-loop a as b null))))) @@ -1095,7 +1089,7 @@ ((eq? n 0) 0) ((eq? a b) (subi n 1)) ((lesser? b a) n) - (else + (else (lets ((b over (fx>> b 1))) (shift-local-down a b (subi n 1)))))) @@ -1104,14 +1098,14 @@ (cond ((eq? a b) (subi n 1)) ((lesser? a b) (subi n 1)) - (else + (else (lets ((over b (fx<< b 1))) (if (eq? over 0) (shift-local-up a b (nat-succ n)) (subi n 1)))))) (define (div-shift a b n) - (if (eq? (type a) type-fix+) + (if (eq? (type a) type-fix+) 0 (let ((na (ncdr a)) (nb (ncdr b))) (cond @@ -1122,7 +1116,7 @@ (if (eq? n 0) 0 (shift-local-down (ncar a) *pre-max-fixnum* (subi n 1))) - (let ((aa (ncar a)) (bb (add b-lead 1))) + (let ((aa (ncar a)) (bb (addi b-lead 1))) ; increment b to ensure b'000.. > b.... (cond ((lesser? aa bb) @@ -1132,16 +1126,16 @@ ; divisor is larger 0)) ((null? nb) - (div-shift (ncdr a) b (add n *fixnum-bits*))) + (div-shift (ncdr a) b (addi n *fixnum-bits*))) (else (div-shift (ncdr a) (ncdr b) n)))))) - + (define (nat-quotrem-finish a b out) (let ((next (subi a b))) (if (negative? next) (values out a) (nat-quotrem-finish next b (nat-succ out))))) - + (define (nat-quotrem a b) (let loop ((a a) (out 0)) (let ((s (div-shift a b 0))) @@ -1152,7 +1146,7 @@ (nat-quotrem-finish a b out)) (else (let ((this (<< b s))) - (loop (subi a this) (add out (<< 1 s))))))))) + (loop (subi a this) (addi out (<< 1 s))))))))) (define (div-big->negative a b) (lets ((q r (nat-quotrem a b))) @@ -1164,7 +1158,7 @@ - ;;; + ;;; ;;; REMAINDER ;;; @@ -1203,10 +1197,10 @@ (dr (let ((d (subi d 1))) ; int- (of was -*max-fixnum*), fix- or fix+ (if (negative? d) - (values (ncons (add d *first-bignum*) tl) #true) ; borrow + (values (ncons (addi d *first-bignum*) tl) #true) ; borrow (values (ncons d tl) #false)))) ((eq? (type d) type-fix-) ; borrow - (values (ncons (add d *first-bignum*) tl) #true)) + (values (ncons (addi d *first-bignum*) tl) #true)) (else (values (ncons d tl) #false))))))) @@ -1218,7 +1212,7 @@ (define (rev-sub a b) ; bignum format a' | #false (lets ((val fail? (rsub a b))) - (if fail? + (if fail? #false (drop-zeros val)))) @@ -1228,7 +1222,7 @@ (if (null? n) (values null 0) (lets - ((x tl n) + ((x tl n) (lo hi (fx* x d)) (tl carry (rmul (ncdr n) d)) (lo over (fx+ lo carry))) @@ -1246,7 +1240,7 @@ (if (eq? carry 0) tl (ncons carry tl)))))) - + (define (rrem a b) ; both should be scaled to get a good head for b (cond ((null? a) a) @@ -1258,14 +1252,13 @@ (bp (rmul-digit b f)) (ap (rev-sub a bp))) (if ap (rrem ap b) a))) - ((rev-sub a b) => - (lambda (ap) (rrem ap b))) + ((rev-sub a b) => (C rrem b)) (else (lets ((h o (fx+ (ncar b) 1)) (f r (qr-big-small (ncons (ncar (ncdr a)) (ncons (ncar a) null)) h)) ; FIXME, use fxqr instead ) - (if (eq? (type f) type-fix+) + (if (eq? (type f) type-fix+) (lets ((bp (rmul-digit b f)) (ap (rev-sub a bp)) @@ -1334,11 +1327,11 @@ ((eq? a 0) (div-finish out)) ((eq? (band a bit) 0) ; O(1) (if (eq? bp last-bit) - (lets + (lets ((a (ncdr a)) (a (if (null? (ncdr a)) (ncar a) a))) (divex 1 0 a b (ncons 0 out))) - (lets + (lets ((_ bit (fx<< bit 1)) (bp _ (fx+ bp 1))) (divex bit bp a b out)))) @@ -1352,7 +1345,7 @@ (define (nat-divide-exact a b) (if (eq? (band b 1) 0) - (if (eq? (band a 1) 0) + (if (eq? (band a 1) 0) ;; drop a powers of two from both and get 1 bit to bottom of b (nat-divide-exact (>> a 1) (>> b 1)) #false) ;; not divisible @@ -1376,7 +1369,7 @@ ;; fixme, add ^ - + ;;; alternative division (define (div-big-exact a b) (ediv (subi a (nat-rem a b)) b)) @@ -1429,7 +1422,7 @@ (type-fix- (lets ((q r (qr-big-small a b))) q)) ; -A / -b -> +c | +C (type-int+ (div-big->negative (negate a) b)) ; -A / +B -> 0 | -c | -C (type-int- (div-big (negate a) (negate b))) ; -A / -B -> 0 | +c | +C - (else (big-bad-args 'div a b)))) + (else (big-bad-args 'div a b)))) (else (big-bad-args 'div a b))))) (define-syntax fx% @@ -1443,7 +1436,7 @@ (case (type b) (type-fix+ (fx% a b)) (type-fix- (fx% a b)) - (type-int+ a) + (type-int+ a) (type-int- a) (else (big-bad-args 'mod a b)))) (type-fix- @@ -1462,11 +1455,11 @@ (else (big-bad-args 'mod a b)))) (type-int- (case (type b) - (type-fix+ - (receive (qr-big-small a b) + (type-fix+ + (receive (qr-big-small a b) (lambda (q r) (negate r)))) - (type-fix- - (receive (qr-big-small a b) + (type-fix- + (receive (qr-big-small a b) (lambda (q r) (negate r)))) (type-int+ (negate (nat-rem (negate a) b))) (type-int- (negate (nat-rem (negate a) (negate b)))) @@ -1492,7 +1485,7 @@ (if (eq? b 0) (big-bad-args 'quotrem a b) (case (type a) - (type-fix+ + (type-fix+ (case (type b) (type-fix+ (receive (fxqr 0 a b) (lambda (_ q r) (values q r)))) (type-int+ (values 0 a)) @@ -1504,26 +1497,26 @@ (type-fix+ (receive (qr-big-small a b) (lambda (q r) (values q r)))) (type-int+ (nat-quotrem a b)) (type-fix- (receive (qr-big-small a b) (lambda (q r) (values (negate q) r)))) - (type-int- (receive (nat-quotrem a (negate b)) + (type-int- (receive (nat-quotrem a (negate b)) (lambda (q r) (values (negate q) r)))) (else (big-bad-args 'quotrem a b)))) - (type-fix- + (type-fix- (case (type b) - (type-fix+ + (type-fix+ (receive (fxqr 0 a b) (lambda (_ q r) (values (negate q) (negate r))))) (type-fix- (receive (fxqr 0 a b) (lambda (_ q r) (values q (negate r))))) (type-int+ (values 0 a)) (type-int- (values 0 a)) - (else (big-bad-args 'quotrem a b)))) + (else (big-bad-args 'quotrem a b)))) (type-int- (case (type b) (type-fix+ (lets ((q r (qr-big-small a b))) (values (negate q) (negate r)))) (type-fix- (receive (qr-big-small a b) (lambda (q r) (values q (negate r))))) - (type-int+ (receive (nat-quotrem (negate a) b) + (type-int+ (receive (nat-quotrem (negate a) b) (lambda (q r) (values (negate q) (negate r))))) - (type-int- (receive (nat-quotrem (negate a) (negate b)) + (type-int- (receive (nat-quotrem (negate a) (negate b)) (lambda (q r) (values q (negate r))))) (else (big-bad-args 'quotrem a b)))) (else @@ -1547,7 +1540,7 @@ ; O(1), shift focus bit (define (gcd-drop n) - (let ((s (car n))) + (let ((s (car n))) (cond ((eq? s #x800000) (let ((n (cdr n))) @@ -1558,17 +1551,17 @@ (if (null? (ncdr tl)) (cons 1 (ncar tl)) (cons 1 tl)))))) - (else + (else (lets ((hi lo (fx<< s 1))) (cons lo (cdr n))))))) ;; FIXME - consider carrying these instead ;; FIXME depends on fixnum size - (define gcd-shifts - (list->ff + (define gcd-shifts + (list->ff (map (lambda (x) (cons (<< 1 x) x)) '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)))) - + (define (lazy-gcd a b n) (let ((av (cdr a)) (bv (cdr b))) (cond @@ -1576,7 +1569,7 @@ ((eq? bv 0) (<< av n)) ((eq? (band av (car a)) 0) ; a even (if (eq? (band bv (car b)) 0) ; a and b even - (lazy-gcd (gcd-drop a) (gcd-drop b) (add n 1)) + (lazy-gcd (gcd-drop a) (gcd-drop b) (addi n 1)) (lazy-gcd (gcd-drop a) b n))) ((eq? (band bv (car b)) 0) ; a is odd, u is even (lazy-gcd a (gcd-drop b) n)) @@ -1605,7 +1598,7 @@ ((eq? (type b) type-fix+) (gcd-euclid a b)) ((eq? a b) a) (else (nat-gcd a b)))) - + (define (gcdl ls) (fold gcd (car ls) (cdr ls))) @@ -1645,17 +1638,17 @@ (cond ((eq? (type b) type-fix-) (divide (negate a) (negate b))) ((eq? (type b) type-int-) (divide (negate a) (negate b))) - ((divide-simple a b) => (lambda (x) x)) - (else + ((divide-simple a b) => self) + (else (let ((f (gcd a b))) (cond - ((eq? f 1) + ((eq? f 1) (if (eq? b 1) a (rational a b))) ((= f b) (divide-exact a f)) - (else + (else (rational (divide-exact a f) (divide-exact b f)))))))) @@ -1671,7 +1664,7 @@ ;; rational case: a/b + c, gcd(a,b) = 1 => gcd(a+bc, b) = 1 -> no need to renormalize (define (add a b) (case (type a) - (type-fix+ + (type-fix+ (case (type b) (type-fix+ (add-small->positive a b)) (type-int+ (add-number-big a b)) @@ -1707,16 +1700,16 @@ (type-rational (lets ((x z b)) (rational (add (muli a z) x) z))) (type-complex (lets ((x y b)) (complex (add a x) y))) (else (big-bad-args '+ a b)))) - (type-rational + (type-rational (case (type b) (type-rational ; a'/a" + b'/b" = a'b" + b'a" / a"b" (let ((ad (ncdr a)) (bd (ncdr b))) - (if (eq? ad bd) + (if (eq? ad bd) ; a/x + b/x = (a+b)/x, x within fixnum range (divide (add (ncar a) (ncar b)) ad) - (let ((an (ncar a)) (bn (ncar b))) - (divide + (let ((an (ncar a)) (bn (ncar b))) + (divide (add (muli an bd) (muli bn ad)) (muli ad bd)))))) (type-complex @@ -1728,7 +1721,7 @@ (type-complex (if (eq? (type b) type-complex) ;; A+ai + B+bi = A+B + (a+b)i - (lets + (lets ((ar ai a) (br bi b) (r (add ar br)) @@ -1737,7 +1730,7 @@ (lets ((ar ai a)) (complex (add ar b) ai)))) - (else + (else (big-bad-args '+ a b)))) (define (sub a b) @@ -1780,14 +1773,14 @@ (else (big-bad-args '- a b)))) (type-rational (case (type b) - (type-rational + (type-rational ; a'/a" - b'/b" = a'b" - b'a" / a"b" (let ((ad (ncdr a)) (bd (ncdr b))) - (if (eq? ad bd) + (if (eq? ad bd) ; a/x - b/x = (a-b)/x, x within fixnum range (divide (subi (ncar a) (ncar b)) ad) - (let ((an (ncar a)) (bn (ncar b))) - (divide + (let ((an (ncar a)) (bn (ncar b))) + (divide (subi (muli an bd) (muli bn ad)) (muli ad bd)))))) (type-complex @@ -1797,8 +1790,8 @@ (rational (subi (ncar a) (muli b (ncdr a))) (ncdr a))))) (type-complex (if (eq? (type b) type-complex) - (lets - ((ar ai a) + (lets + ((ar ai a) (br bi b) (r (sub ar br)) (i (sub ai bi))) @@ -1828,7 +1821,7 @@ (type-fix- (negative (mult-fixnums a b))) ; +a * -b (type-int- (negative (mult-num-big a b 0))) ; +a * -b (type-rational (divide (mul a (ncar b)) (ncdr b))) - (type-complex + (type-complex (lets ((br bi b) (r (mul a br)) (i (mul a bi))) (if (eq? i 0) r (complex r i)))) (else (big-bad-args 'mul a b)))) @@ -1839,7 +1832,7 @@ (type-fix- (mult-fixnums a b)) ; -a * -b -> +c | +C (type-int- (mult-num-big a b 0)) ; -a * -B -> +C (type-rational (divide (mul a (ncar b)) (ncdr b))) - (type-complex + (type-complex (lets ((br bi b) (r (mul a br)) (i (mul a bi))) (if (eq? i 0) r (complex r i)))) (else (big-bad-args 'mul a b)))) @@ -1850,33 +1843,33 @@ (type-fix- (cast (mult-num-big b a 0) type-int-)) ; +A * -b -> -C (type-int- (cast (mult-big a b) type-int-)) ; +A * -B -> -C (type-rational (divide (mul a (ncar b)) (ncdr b))) - (type-complex + (type-complex (lets ((br bi b) (r (mul a br)) (i (mul a bi))) (if (eq? i 0) r (complex r i)))) (else (big-bad-args 'mul a b)))) - (type-int- + (type-int- (case (type b) (type-fix+ (cast (mult-num-big b a 0) type-int-)) ; -A * +b -> -C (type-int+ (cast (mult-big a b) type-int-)) ; -A * +B -> -C (type-fix- (mult-num-big b a 0)) ; -A * -b -> +C (type-int- (mult-big a b)) ; -A * -B -> +C (type-rational (divide (mul a (ncar b)) (ncdr b))) - (type-complex + (type-complex (lets ((br bi b) (r (mul a br)) (i (mul a bi))) (if (eq? i 0) r (complex r i)))) (else (big-bad-args 'mul a b)))) (type-rational (case (type b) - (type-rational + (type-rational (divide (mul (ncar a) (ncar b)) (mul (ncdr a) (ncdr b)))) - (type-complex + (type-complex (lets ((br bi b) (r (mul a br)) (i (mul a bi))) (if (eq? i 0) r (complex r i)))) - (else + (else (divide (mul (ncar a) b) (ncdr a))))) - (type-complex + (type-complex (if (eq? (type b) type-complex) - (lets + (lets ((ar ai a) (br bi b) (r (sub (mul ar br) (mul ai bi))) @@ -1887,22 +1880,22 @@ (r (mul ar b)) (i (mul ai b))) (if (eq? i 0) r (complex r i))))) - (else + (else (big-bad-args '* a b)))))) ;; todo: division lacks short circuits (define (/ a b) - (cond + (cond ((eq? b 0) (error "division by zero " (list '/ a b))) ((eq? (type a) type-complex) (if (eq? (type b) type-complex) - (lets - ((ar ai a) + (lets + ((ar ai a) (br bi b) (x (add (mul br br) (mul bi bi))) (r (/ (add (mul ar br) (mul ai bi)) x)) - (i (/ (sub (mul ai br) (mul ar bi)) x))) + (i (/ (sub (mul ai br) (mul ar bi)) x))) (if (eq? i 0) r (complex r i))) (lets ((ar ai a) @@ -1911,7 +1904,7 @@ (i (/ (mul ai b) x))) (if (eq? i 0) r (complex r i))))) ((eq? (type b) type-complex) - (lets + (lets ((br bi b) (x (add (mul br br) (mul bi bi))) (re (/ (mul a br) x)) @@ -1921,14 +1914,14 @@ (if (eq? (type b) type-rational) ; a'/a" / b'/b" = a'b" / a"b' (divide - (mul (ncar a) (ncdr b)) + (mul (ncar a) (ncdr b)) (mul (ncdr a) (ncar b))) ; a'/a" / b = a'/ba" (divide (ncar a) (mul (ncdr a) b)))) ((eq? (type b) type-rational) ; a / b'/b" = ab"/n (divide (mul a (ncdr b)) (ncar b))) - (else + (else (divide a b)))) @@ -1952,7 +1945,7 @@ (negate (nat-succ (div (abs a) b))) (div a b))) n)) - + (define (ceiling n) (if (eq? (type n) type-rational) (lets ((a b n)) @@ -2070,19 +2063,19 @@ ;(import-old lib-test) ;(test ; (lmap (λ (i) (lets ((rst n (rand i 10000000000000000000))) n)) (lnums 1)) - ; (λ (n) (log-naive 3 n)) - ; (λ (n) (log 3 n))) + ; (H log-naive 3) + ; (H log 3)) ;(import-old lib-test) ;(test ; (lmap (λ (i) (lets ((rst n (rand i #x20000))) n)) (lnums 1)) - ; (λ (n) (log 2 n)) - ; (λ (n) (log2 n))) + ; (H log 2) + ; log2) ; note: it is safe to use div, which is faster for bignums, because by definition ; the product is divisble by the gcd. also, gcd 0 0 is not safe, but since (lcm ; a a) == a, handlin this special case and and a small optimization overlap nicely. - (define (lcm a b) + (define (lcm a b) (if (eq? a b) a (div (abs (mul a b)) (gcd a b)))) @@ -2096,7 +2089,7 @@ (add digit (if (< digit 10) 48 87))) (define (render-digits num tl base) - (fold (λ (a b) (cons b a)) tl + (fold (λ (a b) (cons b a)) tl (unfold (λ (n) (lets ((q r (quotrem n base))) (values (char-of r) q))) num zero?))) ;; move to math.scm @@ -2111,7 +2104,7 @@ ((eq? (type num) type-complex) ;; todo: imaginary number rendering looks silly, written in a hurry (lets ((real imag num)) - (render-number real + (render-number real (cond ((eq? imag 1) (ilist #\+ #\i tl)) ((eq? imag -1) (ilist #\- #\i tl)) @@ -2161,15 +2154,15 @@ ;; - → sub (define - - (case-lambda + (case-lambda ((a b) (sub a b)) ((a) (sub 0 a)) - ((a b . xs) + ((a b . xs) (sub a (add b (fold add 0 xs)))))) - + ;; * → mul (define * - (case-lambda + (case-lambda ((a b) (mul a b)) ((a b . xs) (mul a (mul b (fold mul 1 xs)))) ((a) a) @@ -2187,7 +2180,7 @@ (define (each op x xs) (cond ((null? xs) #true) - ((op x (car xs)) + ((op x (car xs)) (each op (car xs) (cdr xs))) (else #false))) @@ -2217,5 +2210,4 @@ (define max (vararg-fold max #false)) (define gcd (vararg-fold gcd 0)) (define lcm (vararg-fold lcm 1)) - )) diff --git a/owl/ol.scm b/owl/ol.scm index c269e5f7..560bb8dc 100644 --- a/owl/ol.scm +++ b/owl/ol.scm @@ -2,241 +2,99 @@ ;;; ol.scm: an Owl read-eval-print loop. ;;; -#| Copyright (c) 2012-2017 Aki Helin +#| Copyright (c) 2012-2018 Aki Helin | - | Permission is hereby granted, free of charge, to any person obtaining a + | Permission is hereby granted, free of charge, to any person obtaining a | copy of this software and associated documentation files (the "Software"), | to deal in the Software without restriction, including without limitation | the rights to use, copy, modify, merge, publish, distribute, sublicense, | and/or sell copies of the Software, and to permit persons to whom the | Software is furnished to do so, subject to the following conditions - | - | The above copyright notice and this permission notice shall be included + | + | The above copyright notice and this permission notice shall be included | in all copies or substantial portions of the Software. - | + | | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL + | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER | DEALINGS IN THE SOFTWARE. |# -;; check that (owl defmac) is indeed from last generation - (define build-start (time-ms)) -; (import (owl defmac)) - (mail 'intern (tuple 'flush)) ;; ask intern to forget all symbols it knows ; forget all other libraries to have them be reloaded and rebuilt (define *libraries* - (keep + (keep (λ (lib) (equal? (car lib) '(owl core))) - *libraries*)) + *libraries*)) (import (owl defmac)) ;; reload default macros needed for defining libraries etc ;; forget everhything except these and core values (later list also them explicitly) -,forget-all-but (*vm-special-ops* *libraries* *codes* wait *args* stdin stdout stderr set-ticker run build-start) +,forget-all-but (quote *vm-special-ops* *libraries* build-start) -;;; -;;; Time for a new REPL -;;; - -;; this should later be just a sequence of imports followed by a fasl dump +;; -------------------------------------------------------------------------------- (import (owl core)) ;; get special forms, primops and define-syntax (import (owl defmac)) ;; get define, define-library, import, ... from the just loaded (owl defmac) (define *interactive* #false) ;; be verbose -(define *include-dirs* (list ".")) ;; now we can (import ) and have them be autoloaded to current repl +(define *include-dirs* '(".")) ;; now we can (import ) and have them be autoloaded to current repl (define *owl-names* #empty) -(import (owl syscall)) -(import (owl primop)) - -;; shared parameters, librarize later or remove if possible - -(define *owl-version* "0.1.14") -(define max-object-size #xffff) - -(define owl-ohai "You see a prompt.") -(define owl-ohai-resume "Welcome back.") - -(import (owl boolean)) -(import (owl list)) -(import (owl ff)) -(import (only (owl iff))) -(import (owl math)) -(import (owl list-extra)) -(import (owl sort)) -(import (owl lazy)) -(import (only (owl unicode) encode-point)) -(import (owl string)) -(import (owl vector)) -(import (owl symbol)) -(import (owl tuple)) -(import (owl function)) -(import (owl equal)) -(import (owl render)) -(import (owl intern)) -(import (owl io)) -(import (owl parse)) -(import (owl regex)) -(import (owl sexp)) -(import (only (owl math-extra))) -(import (only (owl rlist))) -(import (only (owl queue))) - -;; extremely old data structure being used between compler steps. -;; replace later. -(define (ok? x) (eq? (ref x 1) 'ok)) -(define (ok exp env) (tuple 'ok exp env)) -(define (fail reason) (tuple 'fail reason)) - -(import (owl env)) -(import (owl gensym)) -(import (owl bisect)) -(import (owl macro)) -(import (owl ast)) -(import (owl fixedpoint)) -(import (owl cps)) -(import (owl alpha)) -(import (owl thread)) -(import (owl assemble)) -(import (owl closure)) -(import (owl compile)) -(import (owl suffix)) -(import (owl time)) -(import (owl random)) -(import (owl args)) -(import (owl cgen)) -(import (only (owl dump) make-compiler dump-fasl load-fasl)) - -(define compiler ; <- to compile things out of the currently running repl using the freshly loaded compiler - (make-compiler *vm-special-ops*)) - -; path -> 'loaded | 'saved -(define (suspend path) - (let ((maybe-world (syscall 16 #true #true))) - (if (eq? maybe-world 'resumed) - owl-ohai-resume - (begin - (dump-fasl maybe-world path) - 'saved)))) - -;(import (owl checksum)) -(import (owl sys)) -(import (owl char)) - -;; implementation features, used by cond-expand -(define *features* - (cons - (string->symbol (string-append "owl-lisp-" *owl-version*)) - '(owl-lisp r7rs exact-closed ratios exact-complex full-unicode immutable))) - ;; ^ - ;; '-- to be a fairly large subset of at least, so adding this - -(import (owl eval)) -(import (owl digest)) -(import (owl base)) -(import (owl date)) -(import (owl codec)) - -(import (scheme cxr)) -(import (scheme base)) -(import (scheme case-lambda)) -(import (scheme write)) - - -;(define *libraries* -; (cons -; (cons '(owl core) *owl-core*) -; (keep (λ (x) (not (equal? (car x) '(owl core)))) *libraries*))) +(define *owl-version* "0.1.15") + +(import + (owl intern) + (owl env) + (owl ast) + (owl thread) + (owl args) + (only (owl dump) make-compiler load-fasl) + (owl eval) + (owl repl) + (owl base) + (owl variable)) (define-syntax share-bindings (syntax-rules (defined) ((share-bindings) null) ((share-bindings this . rest) (cons - (cons 'this - (tuple 'defined (mkval this))) + (cons 'this (tuple 'defined (mkval this))) (share-bindings . rest))))) -;; todo: share the modules instead later -(define shared-misc +;; implementation features, used by cond-expand +(define *features* + (cons + (string->symbol (string-append "owl-lisp-" *owl-version*)) + '(owl-lisp r7rs exact-closed ratios exact-complex full-unicode immutable))) + +(define shared-bindings (share-bindings - run syscall error - pair? boolean? fixnum? eof? symbol? - tuple? string? function? procedure? equal? eqv? bytecode? - not - null? null - o - time - time-ms - halt - apply - call/cc - call-with-current-continuation - display print-to print print* - render - system-println - sleep - list->tuple - exit-thread - number->string - fork - fork-named - fork-linked - fork-server - fork-linked-server - exit-owl - single-thread? - set-ticker - kill - catch-thread - release-thread - suspend - mail interact - string->number - wait - wait-mail accept-mail check-mail return-mails - set-signal-action - byte-vector? - string->symbol - close-port flush-port - set-memory-limit - gensym - get-word-size - get-memory-limit - string->sexp - read read-ll *features* *include-dirs* *libraries* ;; all currently loaded libraries )) - -(define shared-bindings shared-misc) - (define initial-environment-sans-macros - (fold + (fold (λ (env pair) (env-put-raw env (car pair) (cdr pair))) *owl-core* shared-bindings)) - + (define initial-environment (bind-toplevel (library-import initial-environment-sans-macros '((owl base)) - (λ (reason) (error "bootstrap import error: " reason)) + (H error "bootstrap import error: ") (λ (env exp) (error "bootstrap import requires repl: " exp))))) -;; todo: after there are a few more compiler options than one, start using -On mapped to predefined --compiler-flags foo=bar:baz=quux - (define (path->string path) (let ((data (file->vector path))) (if data @@ -252,11 +110,11 @@ (test "-t" "--test" has-arg comment "evaluate given expression exit with 0 unless the result is #false") (quiet "-q" "--quiet" comment "be quiet (default in non-interactive mode)") (run "-r" "--run" has-arg comment "run the last value of the given foo.scm with given arguments" terminal) - (load "-l" "--load" has-arg comment "resume execution of a saved program state saved with suspend") - (output "-o" "--output" has-arg comment "where to put compiler output (default auto)") + (load "-l" "--load" has-arg comment "resume execution of a saved program state saved with suspend") + (output "-o" "--output" has-arg comment "where to put compiler output (default auto)") (output-format "-x" "--output-format" has-arg comment "output format when compiling (default auto)") (optimize "-O" "--optimize" cook ,string->number comment "optimization level in C-compilation (0-2)") - (custom-runtime "-R" "--runtime" + (custom-runtime "-R" "--runtime" cook ,path->string comment "use a custom runtime in C compilation") ;(interactive "-i" "--interactive" comment "use builtin interactive line editor") @@ -280,68 +138,40 @@ (tuple-case outcome ((ok val env) ;; be silent when all is ok - ;; exit with 127 and have error message go to stderr when the run crashes - (try (λ () (val args)) 127)) + ;; exit with 126 and have error message go to stderr when the run crashes + (try (λ () (val args)) 126)) ((error reason env) (print-repl-error (list "ol: cannot run" path "because there was an error during loading:" reason)) 2)) 1)) -(define about-owl +(define about-owl "Owl Lisp -- a functional scheme -Copyright (c) 2016 Aki Helin +Copyright (c) Aki Helin Check out https://github.com/aoh/owl-lisp for more information.") -(define-library (owl usuals) - - (export usual-suspects) - ; make sure the same bindings are visible that will be at the toplevel - - (import - (owl defmac) - (owl suffix) - (owl math) - (owl random) - (owl bisect) - (owl thread) - (owl list) - (owl list-extra) - (owl syscall) - (owl vector) - (owl sort) - (owl equal) - (owl ff) - (owl lazy) - (owl sexp)) - - (begin - ; commonly needed functions - (define usual-suspects - (list - put get del ff-fold fupd - - + * / - div gcd ediv - << < <= = >= > >> - equal? has? mem - band bor bxor - sort - ; suffix-array bisect - fold foldr map reverse length zip append unfold - lref lset iota - ;vec-ref vec-len vec-fold vec-foldr - ;print - mail interact - take keep remove - thread-controller - ;sexp-parser - uncons lfold lmap - rand seed->rands - )))) - -(import (owl usuals)) - +(define usual-suspects + (list + put get del ff-fold fupd + - + * / + div gcd ediv + << < <= = >= > >> + equal? has? mem + band bor bxor + sort + ; suffix-array bisect + fold foldr map reverse length zip append unfold + lref lset iota + ;vec-ref vec-len vec-fold vec-foldr + ;print + mail interact + take keep remove + thread-controller + uncons lfold lmap + rand seed->rands + )) ;; handles $ ol -c stuff (define (repl-compile compiler env path opts) @@ -353,10 +183,10 @@ Check out https://github.com/aoh/owl-lisp for more information.") ((ok val env) (if (function? val) (begin - (compiler val + (compiler val ;; output path (cond - ((get opts 'output #false) => (λ (given) given)) ; requested with -o + ((get opts 'output #false) => self) ; requested with -o ((equal? path "-") path) ; stdin → stdout (else (c-source-name path))) ;; inverse option on command line, add here if set @@ -387,35 +217,37 @@ Check out https://github.com/aoh/owl-lisp for more information.") (define (try-load-state path args) (let ((val (load-fasl path #false))) (if (function? val) - (try (λ () (val (cons path args))) 127) + (try (λ () (val (cons path args))) 126) (begin (print "failed to load dump from " path) 1)))) - + ;; -> vm exit with 0 on success, n>0 on error (define (try-repl-string env str) (tuple-case (repl-string env str) ((ok val env) (exit-owl - (if (print val) 0 127))) + (if (print val) 0 126))) ((error reason partial-env) - (print-repl-error + (print-repl-error (list "An error occurred while evaluating:" str reason)) (exit-owl 1)) (else (exit-owl 2)))) -;; exit with 0 if value is non-false, 1 if it's false, 127 if error +;; exit with 0 if value is non-false, 1 if it's false, 126 if error (define (try-test-string env str) (tuple-case (repl-string env str) ((ok val env) (exit-owl (if val 0 1))) ((error reason partial-env) - (print-repl-error + (print-repl-error (list "An error occurred while evaluating:" str reason)) - (exit-owl 127)) + (exit-owl 126)) (else - (exit-owl 127)))) + (exit-owl 126)))) + +(define owl-ohai "You see a prompt.") ;; say hi if interactive mode and fail if cannot do so (the rest are done using ;; repl-prompt. this should too, actually) @@ -425,7 +257,7 @@ Check out https://github.com/aoh/owl-lisp for more information.") (and (print owl-ohai) (display "> ")) - (halt 127)))) + (halt 126)))) ;; todo: this should probly be wrapped in a separate try to catch them all ; ... → program rval going to exit-owl @@ -433,7 +265,7 @@ Check out https://github.com/aoh/owl-lisp for more information.") (or (process-arguments (cdr vm-args) command-line-rules error-usage-text (λ (dict others) - (lets + (lets ((env ;; be quiet automatically if any of these are set (if (fold (λ (is this) (or is (get dict this #false))) #false '(quiet test evaluate run output output-format)) (env-set env '*interactive* #false) @@ -451,11 +283,10 @@ Check out https://github.com/aoh/owl-lisp for more information.") (print "Owl Lisp " *owl-version*) 0) ((getf dict 'about) (print about-owl) 0) - ((getf dict 'load) => - (λ (path) (try-load-state path others))) + ((getf dict 'load) => (C try-load-state others)) ((or (getf dict 'output) (getf dict 'output-format)) (if (< (length others) 2) ;; can take just one file or stdin - (repl-compile compiler env + (repl-compile compiler env (if (null? others) "-" (car others)) dict) (begin (print "compile just one file for now please: " others) @@ -463,15 +294,11 @@ Check out https://github.com/aoh/owl-lisp for more information.") ((getf dict 'run) => (λ (path) (owl-run (try (λ () (repl-file env path)) #false) (cons "ol" others) path))) - ((getf dict 'evaluate) => - (λ (str) - (try-repl-string env str))) ;; fixme, no error reporting - ((getf dict 'test) => - (λ (str) - (try-test-string env str))) + ((getf dict 'evaluate) => (H try-repl-string env)) ;; FIXME: no error reporting + ((getf dict 'test) => (H try-test-string env)) ((null? others) (greeting env) - (repl-trampoline repl + (repl-trampoline repl (-> env ;(env-set '*line-editor* (getf dict 'interactive)) ))) @@ -480,32 +307,23 @@ Check out https://github.com/aoh/owl-lisp for more information.") (define input (foldr (λ (path tail) (ilist ',load path tail)) null others)) (tuple-case (repl (env-set env '*interactive* #false) input) - ((ok val env) + ((ok val env) 0) ((error reason partial-env) (print-repl-error reason) 1))))))) 2)) - - -; *owl* points to owl root directory -; initally read from binary path (argv [0] ) - (define (directory-of path) (runes->string (reverse - (drop-while - (lambda (x) (not (eq? x 47))) + (drop-while + (B not (C eq? #\/)) (reverse - (string->bytes path)))))) - - + (string->runes path)))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Dump a new repl image -;;; +(define compiler ; <- to compile things out of the currently running repl using the freshly loaded compiler + (make-compiler *vm-special-ops*)) (define (heap-entry symbol-list) (λ (codes) ;; all my codes are belong to codes @@ -521,22 +339,25 @@ Check out https://github.com/aoh/owl-lisp for more information.") (start-thread-controller (list (tuple 'init - (λ () - (fork-server 'repl - (λ () + (λ () + (thread 'repl + (let ((state (make-variable '*state* #empty))) ;; get basic io running (start-base-threads) + ;; store initial state values + (state 'call (λ (st) (put st 'command-line-arguments vm-args))) + ;; repl needs symbol etc interning, which is handled by this thread - (fork-server 'intern interner-thunk) + (thunk->thread 'intern interner-thunk) ;; set a signal handler which stop evaluation instead of owl ;; if a repl eval thread is running (set-signal-action repl-signal-handler) - (exit-owl + (exit-owl (repl-start vm-args repl compiler - (fold + (fold (λ (env defn) (env-set env (car defn) (cdr defn))) initial-environment @@ -550,20 +371,11 @@ Check out https://github.com/aoh/owl-lisp for more information.") (cons 'eval exported-eval) (cons 'render render) ;; can be removed when all rendering is done via libraries (cons '*vm-special-ops* vm-special-ops) + (cons '*state* state) ;(cons '*codes* (vm-special-ops->codes vm-special-ops)) ))))))))) null))))))) -;; todo: dumping with fasl option should only dump the fasl and only fasl - - -;;; -;;; Dump the new repl -;;; - -;; note, one one could use the compiler of the currently running system, but using -;; the rebuilt one here to make changes possible in 1 instead of 2 build cycles. -;; (this may be changed later) (define command-line-rules (cl-rules @@ -578,10 +390,6 @@ Check out https://github.com/aoh/owl-lisp for more information.") ((equal? str "all") all) (else (print "Bad native selection: " str)))) -;;; -;;; Step 3 - profit -;;; - (print "Code loaded at " (- (time-ms) build-start) "ms.") (λ (args) @@ -598,9 +406,8 @@ Check out https://github.com/aoh/owl-lisp for more information.") (want-symbols . #true) (want-codes . #true) (want-native-ops . #true))) - (choose-natives + (choose-natives (get opts 'specialize "none") heap-entry)) (print "Output written at " (- (time-ms) build-start) "ms.") 0))))) - diff --git a/owl/parse.scm b/owl/parse.scm index c147ebea..fdd85583 100644 --- a/owl/parse.scm +++ b/owl/parse.scm @@ -6,394 +6,292 @@ (export let-parses - get-byte - get-imm - get-epsilon - assert - get-byte-if - get-rune - get-rune-if - get-one-of - get-word - get-word-ci ; placeholder - get-either - get-any-of - get-kleene* - get-kleene+ - get-greedy* - get-greedy+ - get-greedy-repeat - try-parse ; parser x ll x path|#false x errmsg|#false x fail-val - peek + byte + imm + seq + epsilon ε + byte-if + rune + either + one-of + star + plus + greedy-star + greedy-plus + byte-between + parse-head + backtrack + try-parse + word + + ;; old compat names + get-imm get-byte get-kleene+ get-kleene* get-epsilon get-byte-between get-either + get-byte-if get-rune get-rune-if get-greedy* get-greedy+ get-word + + ;; old ones fd->exp-stream file->exp-stream - null-stream?) + silent-syntax-fail + ) (import (owl defmac) + (owl function) (owl lazy) - (owl math) (owl list) (owl string) - (owl list-extra) + (owl math) (owl unicode) (owl io) - (owl vector) - (owl render) - (only (owl primop) wait) (owl syscall)) (begin - ; (parser ll ok fail pos) - ; -> (ok ll' fail' val pos) - ; -> (fail fail-pos fail-msg') - (define (null-stream? ll) - (cond - ((null? ll) #true) - ((pair? ll) #false) - (else (null-stream? (ll))))) + + ; (parser l r ok) → (ok l' r' val) | (backtrack l r why) + ; ... → l|#f r result|error + + (define (backtrack l r reason) + (if (null? l) + (values #f r reason) + (let ((hd (car l))) + (if (eq? (type hd) type-fix+) + (backtrack (cdr l) (cons hd r) reason) + (hd (cdr l) r reason))))) (define eof-error "end of input") - (define (get-byte ll ok fail pos) + (define (byte l r ok) (cond - ((null? ll) (fail pos eof-error)) ; will always be the largest value - ((pair? ll) (ok (cdr ll) fail (car ll) (+ pos 1))) - (else (get-byte (ll) ok fail pos)))) - - ; read nothing, succeed with val - (define (get-epsilon val) - (λ (ll ok fail pos) - (ok ll fail val pos))) - - ;; todo: in addition to assert would be useful to have compute (returns the value) and check - (define (assert pred val) ; fixme: should have a error message to throw when no luck - (λ (ll ok fail pos) - (let ((res (pred val))) - (if res - (ok ll fail val pos) - (fail pos "parser assert blocked"))))) + ((null? r) (backtrack l r eof-error)) + ((pair? r) (ok (cons (car r) l) (cdr r) (car r))) + (else (byte l (r) ok)))) + + (define (imm x) + (λ (l r ok) + (cond + ((null? r) + (backtrack l r eof-error)) + ((pair? r) + (if (eq? (car r) x) + (ok (cons (car r) l) (cdr r) x) + (backtrack l r 'bad-byte))) + (else + ((imm x) l (r) ok))))) + + (define (ε val) + (λ (l r ok) + (ok l r val))) + + (define epsilon ε) + + (define (either a b) + (λ (l r ok) + (a (cons (λ (l r why) (b l r ok)) l) r ok))) + + (define (seq a b) + (λ (l r ok) + (a l r + (λ (l r av) + (b l r + (λ (l r bv) + (ok l r (cons av bv)))))))) + + (define (star-vals a vals) + (λ (l r ok) + (a + (cons + (λ (l r why) (ok l r (reverse vals))) l) + r + (λ (l r val) + ((star-vals a (cons val vals)) l r ok))))) + + (define star + (C star-vals null)) + + (define (drop l x) + (if (eq? (car l) x) + (cdr l) + (cons (car l) (drop (cdr l) x)))) + + (define (greedy-star-vals a vals) + (λ (l r ok) + (let ((bt (λ (l r why) (ok l r (reverse vals))))) + (a + (cons bt l) + r + (λ (l r val) + ((greedy-star-vals a (cons val vals)) + (drop l bt) r ok)))))) (define-syntax let-parses (syntax-rules (verify eval) - ((let-parses 42 sc ft lst pos ((val (eval term)) . r) body) + ((let-parses 42 l r ok ((val (eval term)) . rest) body) (let ((val term)) - (let-parses 42 sc ft lst pos r body))) - ((let-parses 42 sc ft lst pos ((val parser) . r) body) - (parser lst - (λ (lst ft val pos) - (let-parses 42 sc ft lst pos r body)) - ft pos)) - ((let-parses 42 sc ft lst pos () body) (sc lst ft body pos)) - ((let-parses 42 sc ft lst pos ((verify term msg) . r) body) + (let-parses 42 l r ok rest body))) + ((let-parses 42 l r ok ((val parser) . rest) body) + (parser l r + (λ (l r val) + (let-parses 42 l r ok rest body)))) + ((let-parses 42 l r ok () body) + (ok l r body)) + ((let-parses 42 l r ok ((verify term msg) . rest) body) (if term - (let-parses 42 sc ft lst pos r body) - (ft pos msg))) + (let-parses 42 l r ok rest body) + (backtrack l r msg))) ((let-parses ((a . b) ...) body) - (λ (ll ok fail pos) - (let-parses 42 ok fail ll pos ((a . b) ...) body))))) + (λ (l r ok) + (let-parses 42 l r ok ((a . b) ...) body))))) - ;; testing a slower one to check assertions - (define (get-byte-if pred) - (let-parses - ((b get-byte) - (verify (pred b) "bad byte") - ;(_ (assert pred b)) - ) - b)) + (define greedy-star + (C greedy-star-vals null)) - (define peek-mark "loltron") - (define (peek-val? x) (if (pair? x) (eq? (car x) peek-mark) #false)) - - ; make sure the next thing is *not* accepted by parser (unfortunate name, change later) - (define (peek parser) ; fixme, add error message - (λ (lst ok fail pos) - (parser lst - (λ (lst fail val pos) - ; we do *not* want a match - (fail lst "peek matched")) - (λ (fpos fmsg) - ; ok not to match - (ok lst fail 'peeked pos)) - pos))) - - (define (get-imm n) + (define (greedy-plus a) (let-parses - ((a get-byte) - (verify (eq? a n) '(expected n))) - a)) + ((first a) + (rest (greedy-star a))) + (cons first rest))) + + (define (word s val) + (let ((bytes (string->bytes s))) + (λ (l r ok) + (let loop ((l l) (r r) (left bytes)) + (cond + ((null? left) + (ok l r val)) + ((null? r) + (backtrack l r eof-error)) + ((pair? r) + (if (eq? (car r) (car left)) + (loop (cons (car r) l) (cdr r) (cdr left)) + (backtrack l r "bad byte"))) + (else + (loop l (r) left))))))) + + + (define-syntax one-of + (syntax-rules () + ((one-of a) a) + ((one-of a b) (either a b)) + ((one-of a b . c) (either a (one-of b . c))))) - (define (get-one-of bytes) - (get-byte-if (λ (x) (has? bytes x)))) - - (define (get-word str val) - (let ((bytes (string->bytes str))) - (λ (lst ok fail pos) - (let loop ((bytes bytes) (lst lst) (fail fail) (pos pos)) - (if (null? bytes) - (ok lst fail val pos) - (get-byte lst - (λ (lst fail byte pos) - (if (eq? byte (car bytes)) - (loop (cdr bytes) lst fail pos) - (fail pos (list "expected next '" (runes->string bytes) "'")))) - fail pos)))))) - - ;; fixme: not correct yet - (define (get-word-ci str val) - (let ((bytes (string->bytes str))) - (λ (lst ok fail pos) - (let loop ((bytes bytes) (lst lst) (fail fail) (pos pos)) - (if (null? bytes) - (ok lst fail val pos) - (get-byte lst - (λ (lst fail byte pos) - (if (char-ci=? byte (car bytes)) - (loop (cdr bytes) lst fail pos) - (fail pos (list "expected next '" (runes->string bytes) "'")))) - fail pos)))))) - - (define (get-either a b) - (λ (lst ok fail pos) - (a lst ok - (λ (fa fai) - (b lst ok (λ (fb fbi) (if (< fa fb) (fail fb fbi) (fail fa fai))) pos)) - pos))) - - (define (get-kleene* par) - (get-either - (let-parses - ((hd par) (tl (get-kleene* par))) - (cons hd tl)) - (get-epsilon null))) - - ; get all of successful parses of parser not allowing backtracking - ; intention being that "aaaaa" has quite a few combinations of (kleene+ a), - ; and when describing something like lexical structure, which is usually - ; handled by a pass greedily matching regular expressions, this may cause - ; unexpected exponential slowdowns on parse errors when using simple - ; parsing combinators like these in lib-parse. - - (define (get-greedy parser zero-ok?) - (λ (lst ok fail pos) - (let loop ((lst lst) (rvals null) (pos pos)) - (parser lst - (λ (lst fail val pos) - (loop lst (cons val rvals) pos)) - (λ (fpos freason) - (if (or zero-ok? (pair? rvals)) - (ok lst fail (reverse rvals) pos) ; pass the original failure cont - (fail fpos freason))) ; could fail differently when zero and requested at least one - pos)))) - - (define (get-greedy* parser) (get-greedy parser #true)) - (define (get-greedy+ parser) (get-greedy parser #false)) - - (define (get-greedy-repeat n parser) - (λ (lst ok fail pos) - (let loop ((lst lst) (rvals null) (pos pos) (n n)) - (if (eq? n 0) - (ok lst fail (reverse rvals) pos) - (parser lst - (λ (lst fail val pos) - (loop lst (cons val rvals) pos (- n 1))) - fail pos))))) - - (define (get-kleene+ what) + (define (plus parser) (let-parses - ((hd what) - (tl (get-kleene* what))) - (cons hd tl))) + ((a parser) + (as (star parser))) + (cons a as))) - (define-syntax get-any-of - (syntax-rules () - ((get-any-of a) a) - ((get-any-of a b) (get-either a b)) - ((get-any-of a . bs) - (get-either a (get-any-of . bs))))) - - (define (get-between below above) - (get-byte-if - (λ (x) - (and (lesser? below x) (lesser? x above))))) + (define (byte-if pred) + (let-parses + ((a byte) + (verify (pred a) "checked")) + a)) ; #b10xxxxxx - (define get-extension-byte + (define extension-byte (let-parses - ((b get-byte) + ((b byte) (verify (eq? #b10000000 (fxband b #b11000000)) "Bad extension byte")) b)) - ;; fixme: could also support the longer proposed ones - ;; fixme: get-rune == get-utf-8 - (define get-rune - (get-any-of - (get-byte-if (λ (x) (lesser? x 128))) + (define (byte-between lo hi) + (byte-if + (λ (x) + (and (lesser? lo x) + (lesser? x hi))))) + + (define rune + (one-of + (byte-if (C lesser? 128)) (let-parses - ((a (get-between 127 224)) + ((a (byte-between 127 224)) (verify (not (eq? a #b11000000)) "blank leading 2-byte char") ;; would be non-minimal - (b get-extension-byte)) + (b extension-byte)) (two-byte-point a b)) (let-parses - ((a (get-between 223 240)) + ((a (byte-between 223 240)) (verify (not (eq? a #b11100000)) "blank leading 3-byte char") ;; would be non-minimal - (b get-extension-byte) (c get-extension-byte)) + (b extension-byte) (c extension-byte)) (three-byte-point a b c)) (let-parses - ((a (get-between 239 280)) + ((a (byte-between 239 280)) (verify (not (eq? a #b11110000)) "blank leading 4-byte char") ;; would be non-minimal - (b get-extension-byte) (c get-extension-byte) (d get-extension-byte)) + (b extension-byte) (c extension-byte) (d extension-byte)) (four-byte-point a b c d)))) - (define (get-rune-if pred) + (define (rune-if pred) (let-parses - ((rune get-rune) - (rune (assert pred rune))) - rune)) - - - ;;; - ;;; Port data streaming and parsing - ;;; - - ; this is fairly distinct from the rest of lib-parse, because it mainly deals with - ; IO operation sequencing. - - ; notice that this difficulty comes from owl not havign side-effects on data structures - ; even in the VM level, ruling out lazy lists and and manually mutated streams, which - ; are usually used in functional parsers. - - (define (stdio-port? port) - (has? (list stdin stdout stderr) port)) - - ; rchunks fd block? -> rchunks' end? - ;; bug: maybe-get-input should now use in-process mail queuing using return-mails syscall at the end if necessary - (define (maybe-get-input rchunks fd block? prompt) - (let ((chunk (try-get-block fd 4096 #false))) - ;; handle received input - (cond - ((not chunk) ;; read error in port - (values rchunks #true)) - ((eq? chunk #true) ;; would block - (if block? - (interact 'iomux (tuple 'read fd))) - ;(take-nap) ;; interact with sleeper thread to let cpu sleep - (values rchunks #false)) - ((eof? chunk) ;; normal end if input, no need to call me again - (values rchunks #true)) - (else - (maybe-get-input (cons chunk rchunks) fd #false prompt))))) - - (define (push-chunks data rchunks) - (if (null? rchunks) - data - (append data - (foldr append null - (map vec->list (reverse rchunks)))))) - - ;; todo: fd->exp-stream could easily keep track of file name and line number to show also those in syntax error messages - - ; -> lazy list of parser results, possibly ending to ... (fail ) - - (define (fd->exp-stream fd prompt parse fail re-entry?) - (let loop ((old-data null) (block? #true) (finished? #false)) ; old-data not successfullt parseable (apart from epsilon) - (lets - ((rchunks end? - (if finished? - (values null #true) - (maybe-get-input null fd (or (null? old-data) block?) - (if (null? old-data) prompt "| ")))) - (data (push-chunks old-data rchunks))) - (if (null? data) - (if end? null (loop data #true #false)) - (parse data - (λ (data-tail backtrack val pos) - (pair val - (if (and finished? (null? data-tail)) - null - (loop data-tail (null? data-tail) end?)))) - (λ (pos info) - (cond - (end? - ; parse failed and out of data -> must be a parse error, like unterminated string - (list (fail pos info data))) - ((= pos (length data)) - ; parse error at eof and not all read -> get more data - (loop data #true end?)) - (else - (list (fail pos info data))))) - 0))))) - - - ; (parser ll ok fail pos) - ; -> (ok ll' fail' val pos) - ; -> (fail fail-pos fail-msg') - - (define (file->exp-stream path prompt parse fail) + ((val rune) + (verify (pred val) "bad rune")) + val)) + + (define (parser-succ l r v) + (values l r v)) + + (define (parse-head parser ll def) + (lets ((l r val (parser null ll parser-succ))) + (if l (cons val r) def))) + + ;; computes rest of parser stream + (define (silent-syntax-fail val) + (λ (cont ll msg) val)) + + ; (parser l r ok) → (ok l' r' val) | (backtrack l r why) + ; ... → l|#f r result|error + ;; prompt removed from here - it belongs elsewhere + (define (fd->exp-stream fd parser fail) + (λ () + (let loop ((ll (port->byte-stream fd))) + (lets + ((lp r val + (parser null ll parser-succ))) + (cond + (lp ;; something parsed successfully + (pair val (loop r))) + ((null? r) ;; end of input + ;; typically there is whitespace, so this does not happen + null) + ((function? fail) + ;null + (fail loop r val) + ) + (else + ;; error handling being converted + ;(print-to stderr "fd->exp-stream: syntax error") + null)))))) + + (define (file->exp-stream path parser fail) + ;(print "file->exp-stream: trying to open " path) (let ((fd (open-input-file path))) + ;(print "file->exp-stream: got fd " fd) (if fd - (fd->exp-stream fd prompt parse fail #false) + (fd->exp-stream fd parser fail) #false))) - (define (print-syntax-error reason bytes posn) - (print-to stderr reason) - (write-bytes stderr '(32 32 32)) ; indent by 3 spaces - (write-bytes stderr (cons 96 (append (force-ll bytes) '(39 10)))) - (write-bytes stderr (map (λ (x) 32) (iota 0 1 (+ posn 4)))) ; move to right position - (write-bytes stderr '(94 10))) - - ; find the row where the error occurs - ; keep the row number stored so it can be shown in output - (define (print-row-syntax-error path reason bytes err-posn) - (let row-loop ((row 1) (bytes bytes) (pos 0) (rthis null)) + (define get-imm imm) + (define get-byte byte) + (define get-byte-if byte-if) + (define get-rune rune) + (define get-rune-if rune-if) + (define get-kleene+ plus) + (define get-kleene* star) + (define get-greedy+ greedy-plus) + (define get-greedy* greedy-star) + (define get-epsilon ε) + (define get-byte-between byte-between) + (define get-either either) + (define get-word word) + + (define (try-parse parser data maybe-path maybe-error-msg fail-fn) + (lets ((l r val (parser null data parser-succ))) (cond - ((null? bytes) - (for-each (λ (x) (display-to stderr x)) (list path ":" row " ")) - (print-syntax-error reason (reverse rthis) (- pos err-posn))) - ((not (pair? bytes)) ; force - (row-loop row (bytes) pos rthis)) - ((= (car bytes) 10) - (if (> err-posn pos) - (row-loop (+ row 1) (cdr bytes) (+ pos 1) null) - (begin - (for-each display (list path ":" row " ")) - (print-syntax-error reason (reverse rthis) (- (length rthis) (+ 1 (- pos err-posn))))))) + ((not l) + (if fail-fn + (fail-fn 0 null) + #false)) + ((lpair? r) => + (λ (r) + (backtrack l r "trailing garbage"))) (else - (row-loop row (cdr bytes) (+ pos 1) (cons (car bytes) rthis)))))) - - (define (has-newline? ll) - (cond - ((null? ll) #false) - ((not (pair? ll)) (has-newline? (ll))) - ((eq? (car ll) 10) #true) - (else (has-newline? (cdr ll))))) - - ; can be unforced - (define (null-ll? ll) - (cond - ((null? ll) #true) - ((pair? ll) #false) - (else (null-ll? (ll))))) - - ; try to parse all of data with given parser, or return fail-val - ; printing a nice error message if maybe-error-msg is given - - (define (try-parse parser data maybe-path maybe-error-msg fail-val) - (parser data - (λ (data fail val pos) - (if (null-ll? data) - ; all successfully parsed - val - ; something unparsed. backtrack. - (fail pos "out of data"))) - (λ (pos reason) - ; print error if maybe-error-msg is given - (if maybe-error-msg - (if (or maybe-path (has-newline? data)) - (print-row-syntax-error - (or maybe-path "input") - maybe-error-msg data pos) - (print-syntax-error maybe-error-msg data (- pos 1)))) ; is the one from preceding newlines? - fail-val) - 0)))) - + ;; full match + val)))) +)) diff --git a/owl/port.scm b/owl/port.scm index 6f323700..f0f7cafb 100644 --- a/owl/port.scm +++ b/owl/port.scm @@ -1,13 +1,7 @@ (define-library (owl port) - (export + (export port? - socket? - tcp? - fd->port - fd->socket - fd->tcp - port->fd) ;; port | socket | tcp → fd (import @@ -15,14 +9,8 @@ (begin - (define (port? x) (eq? (type x) type-port)) - (define (socket? x) (eq? (type x) type-socket)) - (define (tcp? x) (eq? (type x) type-tcp-client)) - - (define (fd->port fd) (cast fd type-port)) - (define (fd->socket fd) (cast fd type-socket)) - (define (fd->tcp fd) (cast fd type-tcp-client)) - - (define (port->fd port) (cast port type-fix+)) + (define (port? x) (eq? (type x) type-port)) + (define fd->port (C cast type-port)) + (define port->fd (C cast type-fix+)) )) diff --git a/owl/ppm.scm_ b/owl/ppm.scm_ deleted file mode 100644 index 564d52e5..00000000 --- a/owl/ppm.scm_ +++ /dev/null @@ -1,167 +0,0 @@ -;;; -;;; Support for reading PPM images (initial quick hack) -;;; - -(define-module lib-ppm - (export - read-ppm ; path → #(rgb888-pixel-list width height) | #false - ) - - ; drop anything up to and including the next newine (if any) - (define (pop-comment bs) - (cond - ((null? bs) bs) - ((pair? bs) - (if (eq? (car bs) 10) - (cdr bs) - (pop-comment (cdr bs)))) - (else (pop-comment (bs))))) - - (define whitespace-chars (list 9 10 32)) - - ; bs -> bs' after possibly dropping a single whitespace - (define (pop-whitespace bs) - (cond - ((null? bs) bs) - ((pair? bs) - (cond - ((has? whitespace-chars (car bs)) - (cdr bs)) - ((eq? (car bs) 35) ; # .... \n - (pop-comment bs)) - (else bs))) - (else (pop-whitespace (bs))))) - - (define (pop-whitespaces bs) - (let ((bsp (pop-whitespace bs))) - (if (eq? bs bsp) - bsp - (pop-whitespaces bsp)))) - - ; bs + predicate -> bs' + kleene*-matched-bytes - (define (get-bytes bs pred) - (if (pair? bs) - (if (pred (car bs)) - (lets - ((this (car bs)) - (bs tl (get-bytes (cdr bs) pred))) - (values bs (cons this tl))) - (values bs null)) - (get-bytes (bs) pred))) - - (define (decimal-char-byte? b) - (and (>= b 48) (<= b 57))) - - (define (bytes->natural bs) - (fold (λ (h d) (+ (* h 10) d)) 0 - (map (λ (b) (- b 48)) bs))) - - ; bs -> bs' + n|0 - (define (get-decimal bs) - (lets - ((bs (pop-whitespaces bs)) - (bs these (get-bytes bs decimal-char-byte?))) - (values bs (bytes->natural these)))) - - (define (magic-byte? b) - (or (decimal-char-byte? b) (eq? b 80))) - - ; P6 - ; blanks, tabs, crs, lfs etc - ; -- ascii decimal - ; -- ascii decimal - ; -- ascii 1-65535 (if more than 255, read 2 bytes of pixels) - ; - ; width*height times 3/6-byte triplets representing red, green and blue intensities - - ; bs -> bs val|#false - (define (get-byte bs) - (cond - ((null? bs) - (print "ppm: out of data") - (values bs #false)) - ((pair? bs) - (values (cdr bs) (car bs))) - (else (get-byte (bs))))) - - (define (make-pixel-reader get) - (λ (bs) - (lets - ((bs r (get bs)) - (bs g (get bs)) - (bs b (get bs))) - (if b - ;; fixme: assumed 8-bit here - (values bs - (bor (bor (<< r 16) (<< g 8)) b)) - (values bs #false))))) - - ;; fixme: rgb8 color bounding missing (very simple but ENOTIME, just pass the multiplier to both readers, 1 for 255) - (define (get-rgb8 maxval) - (if (= maxval 255) - get-byte - (error "ppm: rgb8 cannot yet handle maxval " maxval))) - - ;; fixme: rgb16 missing (and simple) - (define (get-rgb16 maxval) - (error "ppm: rgb16" "i'm not implemented")) - - (define (get-pixels bs get n) - (let loop ((bs bs) (n n) (out null)) - (if (= n 0) - (reverse out) - (lets ((bs this (get bs))) - (if this - (loop bs (- n 1) (cons this out)) - #false))))) - - ; note, this will somewhat misleadingly report bad parses as having values 0 - (define (parse-ppm-p6 bs) - (lets - ((bs width (get-decimal bs)) - (bs height (get-decimal bs)) - (bs maxval (get-decimal bs)) - (bs (pop-whitespace bs))) - (cond - ((or (< width 1) (< height 1) (> width 65536) (> height 65536)) - (print "refusing to load image of proportions " (cons width height)) - #false) - ((= maxval 0) - (print "ppm: maximum color cannot be 0") - #false) - ((> maxval 65535) - (print "ppm: too many colours: " maxval) - #false) - (else - (lets - ((get-color (if (< maxval 256) (get-rgb8 maxval) (get-rgb16 maxval))) - (get-pixel (make-pixel-reader get-color)) - (data (get-pixels bs get-pixel (* width height)))) - (if data - (tuple data width height) - #false)))))) - - (define (parse-ppm bs) - (lets ((bs magic (get-bytes bs magic-byte?))) - (cond - ((equal? magic '(80 54)) - (parse-ppm-p6 bs)) - ;; fixme: only supports P6 atm - (else - (print "bad magic in file: " magic) - #false)))) - - (define (read-ppm path) - (let ((port (open-input-file path))) - (if port - (lets ((stuff (parse-ppm (port->byte-stream port)))) - (close-port port) - stuff) - (begin - (print "failed to open " path) - #false)))) - -) - -;(import-old lib-ppm) -;(read-ppm "/tmp/black.ppm") diff --git a/owl/primop.scm b/owl/primop.scm index e3d08b66..dde8abc3 100644 --- a/owl/primop.scm +++ b/owl/primop.scm @@ -4,16 +4,16 @@ ;; todo: convert arity checks 17 -> 25 (define-library (owl primop) - (export + (export primops primop-name ;; primop → symbol | primop multiple-return-variable-primops variable-input-arity? special-bind-primop? ;; primop wrapper functions - run + run set-ticker - clock + clock sys-prim bind ff-bind @@ -21,16 +21,16 @@ halt wait ;; extra ops - set-memory-limit get-word-size get-memory-limit start-seccomp + set-memory-limit get-word-size get-memory-limit eq? apply apply-cont ;; apply post- and pre-cps - call/cc call-with-current-continuation + call/cc call-with-current-continuation lets/cc - + _poll2 ;; vm interface - vm bytes->bytecode bytecode-function + vm bytes->bytecode ) (import @@ -38,9 +38,12 @@ (begin - (define eq? - (cast #(25 3 0 6 54 4 5 6 24 6 17) - (type (lambda (x) x)))) + (define bytes->bytecode + (C raw type-bytecode)) + + (define eq? + (bytes->bytecode + '(25 3 0 6 54 4 5 6 24 6 17))) (define (app a b) (if (eq? a '()) @@ -48,29 +51,21 @@ (cons (car a) (app (cdr a) b)))) ;; l -> fixnum | #false if too long - (define (fx-length l) + (define (len l) (let loop ((l l) (n 0)) (if (eq? l '()) n (lets ((n o (fx+ n 1))) (if o #false (loop (cdr l) n)))))) - (define (len lst) - (let loop ((lst lst) (n 0)) - (if (eq? lst '()) - n - (lets ((n _ (fx+ n 1))) - (loop (cdr lst) n))))) - (define (func lst) (lets ((arity (car lst)) (lst (cdr lst)) (len (len lst))) - (raw + (bytes->bytecode (cons 25 (cons arity (cons 0 (cons len - (app lst (list 17)))))) ;; fail if arity mismatch - type-bytecode #false))) + (app lst (list 17))))))))) ;; fail if arity mismatch ;; changing any of the below 3 primops is tricky. they have to be recognized by the primop-of of ;; the repl which builds the one in which the new ones will be used, so any change usually takes @@ -102,8 +97,7 @@ (define clock (func '(1 9 3 5 61 3 4 2 5 2))) (define sys (func '(4 27 4 5 6 7 24 7))) (define sizeb (func '(2 28 4 5 24 5))) - (define raw (func '(4 60 4 5 6 7 24 7))) - (define _connect (func '(3 34 4 5 6 24 6))) + (define raw (func '(3 37 4 5 6 24 6))) (define _poll2 (func '(4 9 3 11 11 4 5 6 3 4 2 11 2))) (define fxband (func '(3 55 4 5 6 24 6))) (define fxbor (func '(3 56 4 5 6 24 6))) @@ -121,7 +115,7 @@ (if (eq? n 0) n (lets ((n _ (fx- n 1))) - (set-ticker 0) + (set-ticker 0) ;; allow other threads to run (wait n)))) ;; from cps @@ -132,15 +126,14 @@ (define multiple-return-variable-primops '(49 11 26 38 39 40 58 59 37 61)) - (define (variable-input-arity? op) (eq? op 23)) ;; mkt + (define variable-input-arity? (C eq? 23)) ;; mkt (define primops-1 (list ;;; input arity includes a continuation (tuple 'sys 27 4 1 sys) (tuple 'sizeb 28 1 1 sizeb) ;; raw-obj -> numbe of bytes (fixnum) - (tuple 'raw 60 3 1 raw) ;; make raw object, and *add padding byte count to type variant* - (tuple '_connect 34 2 1 _connect) ;; (connect host port) -> #false | socket-fd + (tuple 'raw 37 2 1 raw) ;; make raw object, and *add padding byte count to type variant* (tuple 'cons 51 2 1 cons) (tuple 'car 52 1 1 car) (tuple 'cdr 53 1 1 cdr) @@ -169,9 +162,9 @@ (define fx- (func '(4 40 4 5 6 7 24 7))) (define fx>> (func '(4 58 4 5 6 7 24 7))) (define fx<< (func '(4 59 4 5 6 7 24 7))) - - (define apply (raw '(20) type-bytecode #false)) ;; <- no arity, just call 20 - (define apply-cont (raw (list (fxbor 20 64)) type-bytecode #false)) + + (define apply (bytes->bytecode '(20))) ;; <- no arity, just call 20 + (define apply-cont (bytes->bytecode (list (fxbor 20 64)))) (define primops-2 (list @@ -196,21 +189,19 @@ (tuple 'set-ticker 62 1 1 set-ticker) (tuple 'sys-prim 63 4 1 sys-prim))) - ;; no append yet (define primops - (let loop ((in primops-1) (out primops-2)) - (if (null? in) - out - (loop (cdr in) (cons (car in) out))))) + (app primops-1 + primops-2)) ;; special things exposed by the vm - (define (set-memory-limit n) (sys-prim 7 n n n)) - (define (get-word-size) (sys-prim 8 #false #false #false)) - (define (get-memory-limit) (sys-prim 9 #false #false #false)) - (define (start-seccomp) (sys-prim 10 #false #false #false)) ; not enabled by defa + (define (set-memory-limit n) (sys-prim 7 n #f #f)) + (define (get-word-size) (sys-prim 8 1 #f #f)) + (define (get-memory-limit) (sys-prim 9 #f #f #f)) + + ;; todo: add get-heap-metrics ;; stop the vm *immediately* without flushing input or anything else with return value n - (define (halt n) (sys-prim 6 n n n)) + (define (halt n) (sys-prim 6 n #f #f)) (define call/cc ('_sans_cps @@ -237,7 +228,7 @@ ((eq? op 32) 'bind) ((eq? op 50) 'run) (else #false))) - + (define (primop-name pop) (let ((pop (fxband pop 63))) ; ignore top bits which sometimes have further data (or (instruction-name pop) @@ -249,39 +240,12 @@ (else (loop (cdr primops)))))))) - ;; TODO: these → (owl vm), and convert assble to use it - ;; make bytecode and intern it (to improve sharing, not mandatory) - (define (bytes->bytecode bytes) - (raw bytes type-bytecode #false)) - - (define (app a b) - (if (eq? a '()) - b - (cons (car a) - (app (cdr a) b)))) - - ;; construct the arity check, just return #false on errors, since we don't have any IO or error throwing yet - (define (bytecode-function fixed? arity bytes) - (let ((l (fx-length bytes))) - (if l - (lets - ((hi lo (fx>> (fx-length bytes) 8))) - (if (eq? hi (fxband hi 255)) - (bytes->bytecode - (ilist ;; arity check - (if fixed? 25 89) - arity hi lo - ;; given bytecode - (app bytes (list 17)))) - #false)) - #false))) - ;; silly runtime exception, error not defined yet here (define (check-equal a b) (if (eq? a b) 'ok (car 'assert-fail))) - + ;; exit by returning to r3 (define (vm . bytes) ((bytes->bytecode bytes))) @@ -289,7 +253,7 @@ '(check-equal 42 ;; load 42: (vm 14 42 4 ;; r4 = fixnum(42) 24 4)) ;; return r4 = call r3 with it - + '(check-equal 0 ;; count down to zero: ((bytes->bytecode ;; r4 arg '(14 0 5 ;; r5 = 0 diff --git a/owl/queue.scm b/owl/queue.scm index 801b16ac..6124dbf7 100644 --- a/owl/queue.scm +++ b/owl/queue.scm @@ -56,7 +56,7 @@ (define (qcons a cl) (lets ((hd rtl cl)) (cons (cons a hd) rtl))) - + ; cons to tail (define (qsnoc a cl) (lets ((hd rtl cl)) @@ -114,7 +114,7 @@ (values (car rtl) (cons hd (cdr rtl)))))) (values (car rtl) (cons hd (cdr rtl)))))) - (define (list->queue lst) (cons lst null)) + (define list->queue (C cons null)) (define (queue->list cl) (lets ((hd rtl cl)) diff --git a/owl/random.scm b/owl/random.scm index 94e796cb..149c7a60 100644 --- a/owl/random.scm +++ b/owl/random.scm @@ -1,16 +1,40 @@ +;;; Randomness is an interesting thing to work with in a purely +;;; functional setting. Owl builds randomness around streams of +;;; typically deterministically generated 24-bit fixnums. These +;;; are usually called rands in the code. ;;; -;;; a pseudorandom number generator +;;; A function involving randomness typically receives a rand +;;; stream, and also returns it after possibly consuming some +;;; rands. Behavior like this would be easy to hide using macros +;;; or monadic code, but Owl generally strives to be explicit and +;;; simple, so the rand streams are handled just like any other +;;; value. ;;; +;;; ``` +;;; > (define rs (seed->rands 9)) +;;; > (rand rs 10000) +;;; '(values # 3942) ;; the new rand stream and 3942 +;;; > (lets ((rs a (rand rs 10000))) a) +;;; 3942 +;;; > (lets ((rs elem (rand-elem rs '(a b c d e f g)))) elem) +;;; 'c +;;; > (lets ((rs sub (rand-subset rs '(a b c d e f g)))) sub) +;;; '(b e f) +;;; > (lets ((rs perm (random-permutation rs '(a b c d e f g)))) perm) +;;; '(g e c b d a f) +;;; > (lets ((rs ns (random-numbers rs 100 10))) ns) +;;; '(95 39 69 99 2 98 56 85 77 39) +;;; ``` ;; todo: alternative distributions ;; note - we use mainly primop math here, so this may look a bit odd (define-library (owl random) - (export + (export ;; prngs lcg-rands ;; seed (int32) → rands - + ;; stream construction seed->rands ;; seed → ll of (digit ...) ;; only the default one, later also merseinne twister, blum blum shub etc alternatives rands->bits ;; (digit ...) → (0|1 ...) @@ -31,11 +55,11 @@ shuffle ;; rs x lst -> rs' lst' random-permutation ;; rs x lst -> rs' lst' random-subset ;; rs x lst -> rs' lst' <- lst, same order, each element has 50% chance to be included - rand-elem ;; rs x thing -> rs' x element (for some data types) rand-occurs? ;; rs → rs' T|F ) (import + (owl defmac) (owl math) (owl lazy) (owl list) @@ -47,8 +71,7 @@ (owl io) (owl syscall) (owl sort) - (owl time) - (owl defmac)) + (owl time)) (begin @@ -93,7 +116,7 @@ (nrev-iter ds (ncons d to))))) (define (nrev-fix ds) - (if (null? ds) + (if (null? ds) 0 (lets ((d ds ds)) (cond @@ -107,16 +130,16 @@ (define word32 #xffffffff) (define (xorshift-128 x y z w) - (lets + (lets ((t (bxor x (band word32 (<< x 11)))) (x y) (y z) (z w) (w (bxor w (bxor (>> w 19) (bxor t (>> t 8)))))) (if (eq? (type w) type-fix+) - (cons w (cons 0 + (cons w (cons 0 (λ () (xorshift-128 x y z w)))) - (cons (ncar w) (cons (ncar (ncdr w)) + (cons (ncar w) (cons (ncar (ncdr w)) (λ () (xorshift-128 x y z w))))))) (define xors (xorshift-128 123456789 362436069 521288629 88675123)) @@ -171,33 +194,33 @@ (if (eq? 0 (fxband x n)) 0 1)) (define (rands->bits rs) - (lets + (lets ((d rs (uncons rs 0)) (tl (λ () (rands->bits rs)))) (let loop ((p #b1000000000000000)) - (if (eq? p 0) + (if (eq? p 0) tl (cons (bit d p) (loop (>> p 1))))))) ;; assumes 24-bit fixnums (define (rands->bytes rs) - (lets + (lets ((digit rs (uncons rs 0)) (lo (fxband digit #xff)) (digit _ (fx>> digit 8)) (mid (fxband digit #xff)) (hi _ (fx>> digit 8))) - (ilist lo mid hi + (ilist lo mid hi (λ () (rands->bytes rs))))) ;; passed dieharder tests surprisingly well (define seed->rands adhoc-seed->rands) - (define seed->bits - (o rands->bits seed->rands)) - + (define seed->bits + (B rands->bits seed->rands)) + (define seed->bytes - (o rands->bytes seed->rands)) + (B rands->bytes seed->rands)) ;; note, a custom uncons could also promote random seeds to streams, but probably better to force ;; being explicit about the choice of prng and require all functions to receive just digit streams. @@ -211,7 +234,7 @@ (define (rand-big rs n) (if (null? n) (values rs null #true) - (lets + (lets ((rs head eq (rand-big rs (ncdr n))) (this rs (uncons rs 0))) (if eq @@ -243,7 +266,7 @@ (lets ((d rs (uncons rs rs))) (values rs d)) (rand-fixnum rs (+ n 1)))) - + (define (rand-bignum rs n) (let loop ((rs rs) (left n) (out null) (lower? #false)) (lets ((digit left left)) @@ -270,7 +293,7 @@ (else (error "bad rand limit: " max))))) ;; a quick skew check. definite doom if delta percent > 0, but please do dieharder later. - '(let + '(let ((lim #b11111111111111111111111111)) ;((lim #b10000000000000000000000000)) ;((lim #b1000000000000000000000000)) @@ -281,7 +304,7 @@ (if (eq? 0 (band 1023 n)) (let ((avg (div sum (max n 1)))) (print - (list "at " n " sum " sum " avg " avg " delta percent " + (list "at " n " sum " sum " avg " avg " delta percent " (let ((perc (div (* 100 (abs (- (>> lim 1) avg))) (>> lim 1)))) perc))))) (lets ((rs val (rand rs lim))) @@ -311,7 +334,7 @@ (cond ((null? lst) out) ((eq? this (band bits this)) - (select-members lst (- bits this) this + (select-members lst (- bits this) this (cons (car lst) out))) ((eq? this #x8000) ; highest fixnum bit (select-members (cdr lst) (ncdr bits) 1 out)) @@ -350,19 +373,19 @@ ((null? ll) (values rs (return-selection res))) ((pair? ll) - (lets + (lets ((rs x (rand rs p)) (res (if (< x n) (rset res x (car ll)) res))) (reservoir-sampler rs (cdr ll) n (+ p 1) res))) - (else + (else (reservoir-sampler rs (ll) n p res)))) ;; populate initial n elements to reservoir and start sampler if full (define (reservoir-init rs ll n p res) (cond - ((null? ll) + ((null? ll) (values rs (return-selection res))) - ((= n p) + ((= n p) (reservoir-sampler rs ll n (+ n 1) res)) ((pair? ll) (reservoir-init rs (cdr ll) n (+ p 1) (rcons (car ll) res))) (else (reservoir-init rs (ll) n p res)))) @@ -393,7 +416,7 @@ (values rs n)))) (define (rand-range rs lo hi) - (if (< lo hi) + (if (< lo hi) ;; fixme: is this indeed ok? (lets ((rs o (rand rs (- hi lo)))) (values rs (+ o lo))) @@ -423,8 +446,7 @@ (if (null? pairs) (values rs tail) (lets - ((this (caar pairs)) - (these pairs (take-while (λ (x) (eq? (car x) this)) pairs))) + ((these pairs (take-while (B (C eq? (caar pairs)) car) pairs))) (if (null? (cdr these)) ; leaf case, just one (shuffle-merge rs pairs (cons (cdar these) tail) rec) (lets ((rs tail (shuffle-merge rs pairs tail rec))) @@ -432,7 +454,7 @@ (define (shuffler rs lst tail) (if (null? lst) - (values rs tail) + (values rs tail) (lets ((rs opts (fold2 shuffle-label rs null lst)) (opts (sort carless opts))) @@ -456,14 +478,14 @@ (define (random-bvec rs n) (let loop ((rs rs) (out null) (n n)) (if (eq? n 0) - (values rs (raw out type-vector-raw #true)) ; reverses to keep order - (lets + (values rs (raw (reverse out) type-vector-raw)) ; reverses to keep order + (lets ((d rs (uncons rs 0)) - (n _ (fx- n 1))) + (n _ (fx- n 1))) (loop rs (cons (fxband d 255) out) n))))) (define (random-data-file rs path) - (let + (let ((port (open-output-file path)) (block (* 1024 32)) ; write in 32kb blocks (megs (* 1024 500))) ; ~1GB is enough for dieharder and smallcrush, 500 might be enough for crush? @@ -505,7 +527,7 @@ ;;; (define (prng-speed str) - (let + (let ((start (time-ms)) (ndigits (* 1024 64))) ; make 1mb (let loop ((str str) (n ndigits)) @@ -522,7 +544,7 @@ '(begin (begin (display " * blank ") - (prng-speed (liter (λ (x) x) 42))) + (prng-speed (liter self 42))) (begin (display " * default ") (prng-speed (seed->rands 42))) @@ -560,4 +582,3 @@ ; ((byte rs (uncons rs 0)) ; (n _ (fx+ n 1))) ; (loop rs (cons byte out) n)))))) - diff --git a/owl/regex.scm b/owl/regex.scm index fab3c1a3..6dff4d17 100644 --- a/owl/regex.scm +++ b/owl/regex.scm @@ -10,23 +10,10 @@ ;;; spec: http://pubs.opengroup.org/onlinepubs/007908799/xbd/re.html ;;; syntax ref of portable scheme regexps (Dorai Sitaram): http://evalwhen.com/pregexp/index-Z-H-3.html#node_sec_3 -;; todo: c/regex/ : str → head|F tail, c/regex/g : str → (part ...) -;; todo: it would be nice to be able to call an arbitrary function on the matched area easily (for example to be used in radamsa) -;; fixme: some variable and function names are now misleading -;; todo: later return an ast instead of the function from parser to allow some postprocessing -;; todo: add regexp flags (as implicit cloisters? (starting with case [i]nsensitive)) as postprocessing steps for the ast -;; todo: merge runs of known letters to a node using match-list like for submatches -;; todo: merge mergeable repetitions of equal asts -;; todo: lookbehind is missing -;; todo: add state to parsing to capture flags, greediness etc -;; todo: s///r = repeat at the match position while match -;; todo: s///R = repeat from beginning while match -;; todo: check handling of non-fixnum code points in the regex string itself (likely fails but no time to test atm) - - (define-library (owl regex) (export get-sexp-regex + get-replace-regex string->regex string->replace-regex string->complete-match-regex @@ -49,9 +36,9 @@ (begin - ;;; + ;;; ;;; Matching functions - ;;; + ;;; ;; the regexp is represented by a function which does stream matching @@ -70,7 +57,7 @@ (define (dot ls buff ms cont) (cond ((null? ls) #false) - ((pair? ls) + ((pair? ls) (cont (cdr ls) (cons (car ls) buff) ms)) (else (dot (ls) buff ms cont)))) @@ -83,12 +70,12 @@ (if (eq? (car ls) cp) (cont (cdr ls) (cons cp buff) ms) #false)) - (else + (else (accept (ls) buff ms cont)))) (if (eq? (type cp) type-fix+) accept (error "match string cannot yet contain a " cp))) - + (define (pred fn) ;; match match a specific (fixnum) code point (define (accept ls buff ms cont) (cond @@ -97,10 +84,10 @@ (if (fn (car ls)) (cont (cdr ls) (cons (car ls) buff) ms) #false)) - (else + (else (accept (ls) buff ms cont)))) accept) - + ;; [ab..n], store set in a ff (range 0-65535) (define (accept-ff ff) (λ (ls buff ms cont) @@ -141,8 +128,8 @@ (define (make-ff cs) (call/cc (λ (ret) - (fold - (λ (ff n) + (fold + (λ (ff n) (if (eq? (type n) type-fix+) (put ff n #true) (ret #false))) ;; code point outside of fixnum range @@ -153,24 +140,23 @@ (cond ((null? cs) ;; should not come out of parser (error "empty char class: " cs)) - (complement? + (complement? ;; always use an iff for now in [^...] (reject-iff - (fold + (fold (λ (iff val) (iput iff val #true)) #empty cs))) ((null? (cdr cs)) (imm (car cs))) - ((make-ff cs) => - (λ (ff) (accept-ff ff))) - (else - (accept-iff - (fold + ((make-ff cs) => accept-ff) + (else + (accept-iff + (fold (λ (iff val) (iput iff val #true)) #empty cs))))) ;; | - (define (rex-or ra rb) + (define (rex-or ra rb) (λ (ls buff ms cont) (or (ra ls buff ms cont) (rb ls buff ms cont)))) @@ -178,7 +164,7 @@ ;; (define (rex-and ra rb) (λ (ls buff ms cont) - (ra ls buff ms + (ra ls buff ms (λ (ls buff ms) (rb ls buff ms cont))))) @@ -203,22 +189,22 @@ (define (plus rx) (rex-and rx (star rx))) ;; ? - (define (quest rx) (rex-or rx epsilon)) + (define quest (C rex-or epsilon)) ;;; non-greedy (altruistic?) quantifiers (define (alt-star rx) (define (collect ls buff ms cont) (or (cont ls buff ms) - (rx ls buff ms + (rx ls buff ms (λ (ls buff ms) (collect ls buff ms cont))))) collect) - + ;; +? (define (alt-plus rx) (rex-and rx (alt-star rx))) ;; ?? - (define (alt-quest rx) (rex-or epsilon rx)) + (define alt-quest (H rex-or epsilon)) ;;; repetitions @@ -247,7 +233,7 @@ (define (maybe ls buff ms n) (if (eq? n 0) (cont ls buff ms) - (or + (or (rx ls buff ms (λ (ls buff ms) (maybe ls buff ms (- n 1)))) (cont ls buff ms)))) (maybe ls buff ms n))))) @@ -278,7 +264,7 @@ (cond ((null? head) out) ((eq? head old) out) - (else + (else (add-range (cdr head) old (cons (car head) out))))) ;; find node = (id . start-pos) in ms, and update the cdr to hold the range between buff and the start-pos @@ -308,7 +294,7 @@ (λ (ls buff ms cont) (rex ls buff ms (λ (lsp buffp msp) (cont ls buff ms))))) ;; there she blows - + (define (lookahead-not rex) (λ (ls buff ms cont) (if (rex ls buff ms (λ (a b c) #true)) @@ -328,7 +314,7 @@ ((rex try rev ms (λ (ls buff ms) (null? ls))) (cont ls buff ms)) ((null? rev) #false) - (else + (else (lets ((char rev rev)) (loop rev (cons char try)))))))) @@ -341,7 +327,7 @@ #false) ((null? rev) (cont ls buff ms)) - (else + (else (lets ((char rev rev)) (loop rev (cons char try)))))))) @@ -372,7 +358,7 @@ (values #false #false))))) (else (match-list (ls) val buff)))) - + (define (matched n) (λ (ls buff ms cont) (let ((val (ranges-ref (reverse ms) n))) @@ -385,11 +371,11 @@ ;;; Running the regexen ;;; - (define start-node + (define start-node (cons 0 null)) ;; ranges = ((nth-range . start-node) ...) - (define blank-ranges + (define blank-ranges (list start-node)) @@ -403,7 +389,7 @@ (define (rex-match-prefix? rex ll) (rex ll null blank-ranges (λ (ls buff ms) #true))) - + ;; rex ll → #false | #(ls buff ms), for replacing (define (rex-match-prefix rex ll) (rex ll null blank-ranges @@ -412,7 +398,7 @@ ;; rex str → bool (if matches anywhere) (define (rex-match-anywhere? rex ll) (cond - ((null? ll) + ((null? ll) (rex-match-prefix? rex ll)) ((pair? ll) (if (rex-match-prefix? rex ll) @@ -435,7 +421,7 @@ (rex-match-prefix? rex (iter target))) (λ (target) (rex-match-anywhere? rex (iter target))))) - + ;; another half-sensible but at the moment useful thing would be (m// iterable) -> #false | (head . tail) (define (make-copy-matcher rex start?) (if start? @@ -449,7 +435,7 @@ (if (null? out) null (list (runes->string (reverse out))))) - + (define (force node) (cond ((pair? node) node) ((null? node) node) @@ -490,19 +476,17 @@ (define (rex-matches rex thing) (let loop ((ll (iter thing)) (out null)) - (print (list 'loop ll out)) (cond ((null? ll) (reverse out)) ((pair? ll) (let ((res (rex-match-prefix rex ll))) - (print 'res res) (if res (lets ((ls buff ms res)) (loop ls (cons (runes->string (reverse buff)) out))) (loop (cdr ll) out)))) (else (loop (ll) out))))) - + ;;; ;;; Replacing ;;; @@ -545,7 +529,7 @@ (let ((match (rex-match-prefix rex ll))) (cond (match - (lets + (lets ((ls buff ms match) (ms (update-node ms start-node buff))) ;; save whole match to \0 (cond @@ -565,7 +549,7 @@ (loop (ll)))))) (define (make-replacer rex rep all? start?) - (λ (target) + (λ (target) (cond ((string? target) (runes->string (rex-replace (str-iter target) rex rep start? all?))) @@ -575,22 +559,20 @@ (define (rex-full-match ll rex) (let ((match (rex-match-prefix rex ll))) (if match - (lets + (lets ((ls buff ms match)) ;; check end of stream (lets ((a ls (uncons ls #false))) - (if a - #false - ms))) + (if a #false ms))) #false))) (define (make-full-match rex) - (λ (target) + (λ (target) (cond ((string? target) (let ((res (rex-full-match (str-iter target) rex))) (if res - (map (o runes->string cdr) + (map (B runes->string cdr) (cdr (reverse res))) #false))) (else @@ -606,12 +588,12 @@ (define get-dot ;; . (let-parses ((foo (get-imm 46))) dot)) - + (define get-fini ;; $ (let-parses ((foo (get-imm 36))) fini)) ;; maybe get a ? - (define get-altp + (define get-altp (get-either (get-imm 63) (get-epsilon #false))) ;; todo: / or ?, and carry along in get-regex @@ -619,30 +601,28 @@ (get-imm #\/)) ;; → (rex → rex') - (define get-star - (let-parses + (define get-star + (let-parses ((skip (get-imm 42)) (altp get-altp)) (if altp alt-star star))) - + ;; a+ = aa* - (define get-plus - (let-parses + (define get-plus + (let-parses ((skip (get-imm 43)) (altp get-altp)) (if altp alt-plus plus))) - + ;; a? = a{0,1} = (a|"") - (define get-quest - (let-parses + (define get-quest + (let-parses ((skip (get-imm 63)) (altp get-altp)) (if altp alt-quest quest))) - (define (i x) x) - (define special-chars '(40 41 124 46 47)) ;; kinda ugly. the parser should check for these first - + (define (imm-val imm val) (let-parses ((d (get-imm imm))) val)) @@ -651,24 +631,24 @@ (define big-alpha? (λ (b) (and (lesser? 64 b) (lesser? b 91)))) ;; A-Z (define alnum? (λ (b) (or (alpha? b) (big-alpha? b) (digit? b)))) (define word? (λ (b) (or (eq? b 95) (alnum? b)))) - (define space? (λ (b) (has? '(32 9 13 10 11 12) b))) + (define space? (H has? '(32 9 13 10 11 12))) ;; shared automata parts corresponding to predefined character classes - (define accept-digit (pred digit?)) + (define accept-digit (pred digit?)) (define accept-dot (imm 46)) - (define accept-nondigit (pred (λ (b) (not (digit? b))))) + (define accept-nondigit (pred (B not digit?))) (define accept-alnum (pred alnum?)) (define accept-word (pred word?)) - (define accept-nonword (pred (λ (b) (not (word? b))))) + (define accept-nonword (pred (B not word?))) (define accept-space (pred space?)) - (define accept-nonspace (pred (λ (b) (not (space? b))))) - + (define accept-nonspace (pred (B not space?))) + ;; \ (define get-quoted-char (let-parses ((skip (get-imm 92)) ; \ (val - (get-any-of + (one-of (imm-val #\d accept-digit) ;; \d = [0-9] (imm-val #\D accept-nondigit) ;; \D = [^0-9] (imm-val #\. accept-dot) ;; \. = . @@ -691,14 +671,14 @@ ;; strings are already sequences of unicode code points, so no need to decode here ;; accept any non-special char - (define get-plain-char - (let-parses + (define get-plain-char + (let-parses ((val get-byte) ;; really get-code-point since the input is already decoded (verify (not (has? special-chars val)) "bad special char")) (imm val))) - + (define (quoted-imm val) - (let-parses + (let-parses ((quote (get-imm 92)) (val (get-imm val))) val)) @@ -744,18 +724,18 @@ (verify (char->hex b) #false)) (char->hex b))) - (define get-8bit + (define get-8bit (let-parses ((hi get-hex) (lo get-hex)) (bor (<< hi 4) lo))) - - (define get-16bit + + (define get-16bit (let-parses ((hi get-8bit) (lo get-8bit)) (bor (<< hi 8) lo))) - - (define get-32bit + + (define get-32bit (let-parses ((hi get-16bit) (lo get-16bit)) (bor (<< hi 16) lo))) ;; todo: what is the quotation used for 32-bit \xhhhhhhhh? (define parse-quoted-char-body - (get-any-of + (one-of ;; the usual quotations (imm-val 97 7) ;; \a = 7 (imm-val 98 8) ;; \b = 8 @@ -781,7 +761,7 @@ ;; a quoted character or anything other than ] (define parse-char-class-char (get-either - parse-quoted-char + parse-quoted-char (let-parses ((char get-byte) (verify (not (eq? char 93)) #false)) @@ -805,7 +785,7 @@ (get-either (get-imm 94) ;; hack, returned 94 on match is also true (get-epsilon #false))) - + (define get-char-class (let-parses ((open (get-imm 91)) @@ -819,24 +799,24 @@ (define (make-repeater n m) (cond ((eq? m 'inf) - (λ (rx) (at-least n rx))) + (H at-least n)) ((= n m) - (if (eq? n 0) + (if (eq? n 0) epsilon - (λ (rx) (exactly n rx)))) + (H exactly n))) ((< n m) ;; <= enforced when parsing but ok to double-check as this is only done once - (if (eq? n 0) - (λ (rx) (at-most m rx)) + (if (eq? n 0) + (H at-most m) (λ (rx) (rex-and (exactly n rx) (at-most (- m n) rx))))) (else (error "make-repeater: bad range: " (list n 'to m))))) - (define get-range + (define get-range (let-parses ((skip (get-imm 123)) ; <{>...} - (start + (start (get-either get-number (get-epsilon 0))) ; <{[n]>...} - (end + (end (get-either (let-parses ((skip (get-imm 44)) ; <{[n],> @@ -851,7 +831,7 @@ (define (get-catn get-regex) (let-parses ((regex ;; parse a single regexp thing - (get-any-of + (one-of get-dot get-fini ;; todo: merge the parenthetical ones later @@ -898,22 +878,22 @@ (close (get-imm 41))) (chunk rex)) get-char-class - get-reference + get-reference get-quoted-char get-plain-char)) (repetition - (get-any-of + (one-of get-star get-plus get-quest get-range - (get-epsilon i))) - (tail - (get-any-of + (get-epsilon self))) + (tail + (one-of (let-parses ;; join tail of exp with implicit catenation ((tl (get-catn get-regex))) - (λ (head) (rex-and head tl))) - (get-epsilon i)))) ;; nothing + (C rex-and tl)) + (get-epsilon self)))) ;; nothing (tail (repetition regex)))) ;; get a sequence of regexps with zero or more | in between and merge them @@ -922,9 +902,9 @@ ((hd (get-catn get-regex)) (tl (get-kleene* (let-parses ((skip (get-imm 124)) (rex (get-catn get-regex))) rex)))) (fold rex-or hd tl))) - + (define get-matcher-regex - (let-parses + (let-parses ((skip (get-imm #\m)) ;; [m]atch (skip (get-imm 47)) ;; opening / (start? (get-either (get-imm 94) (get-epsilon #false))) ;; maybe get leading ^ (special) @@ -938,7 +918,7 @@ (make-matcher (rex-and rex fini) #true))) (define get-copy-matcher-regex - (let-parses + (let-parses ((skip (get-imm #\g)) ;; [g]rab (skip (get-imm 47)) ;; opening / (start? (get-either (get-imm 94) (get-epsilon #false))) ;; maybe get leading ^ (special) @@ -947,7 +927,7 @@ (make-copy-matcher rex start?))) (define get-cutter-regex - (let-parses + (let-parses ((skip (get-imm 99)) ;; [c]ut (skip (get-imm 47)) ;; opening / (start? (get-either (get-imm 94) (get-epsilon #false))) ;; maybe get leading ^ (special) @@ -956,7 +936,7 @@ ) (make-cutter rex start?))) - (define get-replace-char + (define get-replace-char (get-either (let-parses ;; quoted ((skip (get-imm 92)) ;; \\ @@ -968,8 +948,8 @@ char))) (define get-maybe-g - (get-either - (get-imm 103) + (get-either + (get-imm 103) (get-epsilon #false))) (define get-replace-regex @@ -993,7 +973,7 @@ (make-full-match rex))) (define get-sexp-regex - (get-any-of + (one-of get-replace-regex get-matcher-regex get-cutter-regex @@ -1004,7 +984,7 @@ ;; str -> rex|#false, for conversion of strings to complete matchers (define (string->complete-match-regex str) (try-parse get-body-regex (str-iter str) #false #false #false)) - + ;; str → rex|#false, same as is used in owl parser (define (string->extended-regexp str) (try-parse get-sexp-regex (str-iter str) #false #false #false)) diff --git a/owl/register.scm b/owl/register.scm index ebd5dec4..2dcd9411 100644 --- a/owl/register.scm +++ b/owl/register.scm @@ -9,8 +9,8 @@ (define-library (owl register) - (export - allocate-registers + (export + allocate-registers n-registers) (import @@ -28,7 +28,7 @@ (begin ;; fixme: temp register limit (define highest-register 95) ;; atm lower than NR in ovm.c - (define n-registers (+ highest-register 1)) + (define n-registers (+ highest-register 1)) ; reg-touch U r -> mark as live -> make sure it has a value ; (must be in some register) @@ -47,7 +47,7 @@ ; return a list of registers from uses (where the value has been moved to), or ; some list of low registers if this one is outside the available ones (define (use-list uses reg) - (let ((opts (keep (λ (x) (< x highest-register)) (get uses reg null)))) + (let ((opts (keep (C < highest-register) (get uses reg null)))) (cond ((< reg highest-register) opts) @@ -93,7 +93,7 @@ (tuple 'move a b (rtl-rename more op target fail))))))) ((prim opcode args to more) (if (fixnum? to) - (if (bad? to target op) + (if (bad? to target op) (fail) (tuple 'prim opcode (map op args) @@ -102,7 +102,7 @@ (fail) (tuple 'prim opcode (map op args) to (rtl-rename more op target fail))))) ((clos-proc lp off env to more) - (if (bad? to target op) + (if (bad? to target op) (fail) (tuple 'clos-proc (op lp) off (map op env) to (rtl-rename more op target fail)))) ((clos-code lp off env to more) @@ -146,10 +146,10 @@ (let ((new (car news))) (if (or (eq? old new) (get uses new #false)) (retarget-first code old (cdr news) uses cont) - (let ((new-code + (let ((new-code (call/cc (λ (drop) - (rtl-rename code + (rtl-rename code (λ (reg) (if (eq? reg old) new reg)) new (lambda () (drop #false))))))) @@ -158,7 +158,7 @@ (retarget-first code old (cdr news) uses cont))))))) (define (rtl-retard-jump proc op a b then else) - (lets + (lets ((then then-uses (proc then)) (else else-uses (proc else)) (uses (merge-usages then-uses else-uses)) @@ -203,7 +203,7 @@ ((> b highest-register) (error "out of registers in move: " b)) (else - (lets + (lets ((more uses (rtl-retard more)) (uses (del uses b)) (targets (use-list uses a))) @@ -214,9 +214,9 @@ (values (tuple 'move a b more) (put uses a (cons b targets)))))))) ((prim op args to more) - (lets + (lets ((more uses (rtl-retard more)) - (pass + (pass (λ () (values (tuple 'prim op args to more) (fold reg-touch (del uses to) args))))) @@ -250,7 +250,7 @@ (pass))))) ((ld val to cont) - (lets + (lets ((cont uses (rtl-retard cont)) (good (use-list uses to)) (good (if (> to highest-register) (append good (iota 0 1 highest-register)) good)) @@ -261,19 +261,19 @@ (pass) (rtl-retard (tuple 'ld val to-new cont-new))))))) - ((clos-proc lpos offset env to more) + ((clos-proc lpos offset env to more) (rtl-retard-closure rtl-retard code)) - ((clos-code lpos offset env to more) + ((clos-code lpos offset env to more) (rtl-retard-closure rtl-retard code)) ((refi from offset to more) - (lets + (lets ((more uses (rtl-retard more)) (uses (reg-touch uses from)) (good (use-list uses to)) - (uses (del uses to)) - (pass + (uses (del uses to)) + (pass (λ () (values (tuple 'refi from offset to more) (reg-touch uses from))))) (retarget-first more to good uses @@ -306,5 +306,4 @@ (define (allocate-registers rtl) (lets ((rtl usages (rtl-retard rtl))) rtl)) - - )) +)) diff --git a/owl/render.scm b/owl/render.scm index 9311a59e..df8ee268 100644 --- a/owl/render.scm +++ b/owl/render.scm @@ -5,11 +5,11 @@ (import (owl defmac) + (owl eof) (owl string) (owl list) (owl list-extra) (owl boolean) - (owl symbol) (owl ff) (owl tuple) (owl function) @@ -18,12 +18,12 @@ (owl lazy) (owl math) (owl port) - ;(only (owl fasl) sub-objects) + (only (owl symbol) render-symbol symbol?) (only (owl vector) byte-vector? vector? vector->list) (only (owl math) render-number number?) (only (owl string) render-string string?)) - - (export + + (export make-serializer ;; names → ((obj tl) → (byte ... . tl)) ;serialize ;; obj tl → (byte ... . tl), eager, always shared ;serialize-lazy ;; obj tl share? → (byte ... . tl), lazy, optional sharing @@ -57,16 +57,16 @@ (cond ((null? obj) tl) ((pair? obj) - (cons #\space + (cons #\space (render (car obj) (loop (cdr obj) tl)))) (else (ilist #\space #\. #\space (render obj tl)))))))) ((boolean? obj) (append (string->list (if obj "#true" "#false")) tl)) - + ((symbol? obj) - (render (symbol->string obj) tl)) + (render-symbol obj tl)) ;; these are a subclass of vectors in owl ;((byte-vector? obj) @@ -91,7 +91,7 @@ (λ (tl pos) (cons 32 (render (ref obj pos) tl))) (cons #\] tl) (iota (size obj) -1 1))))) - + ((record? obj) (ilist #\# #\{ (render (ref obj 1) ;; type tag object @@ -108,18 +108,15 @@ ((ff? obj) (cons #\@ (render (ff-foldr (λ (st k v) (cons k (cons v st))) null obj) tl))) - + ((tuple? obj) (ilist #\# #\[ (render (tuple->list obj) (cons #\] tl)))) - ;; port = socket | tcp | fd - ((socket? obj) (ilist #\# #\[ #\s #\o #\c #\k #\e #\t #\space (render (port->fd obj) (cons #\] tl)))) - ((tcp? obj) (ilist #\# #\[ #\t #\c #\p #\space (render (port->fd obj) (cons #\] tl)))) ((port? obj) (ilist #\# #\[ #\f #\d #\space (render (port->fd obj) (cons #\] tl)))) - ((eof? obj) (ilist #\# #\e #\o #\f tl)) + ((eof-object? obj) (ilist #\# #\e #\o #\f tl)) ((eq? obj #empty) (ilist #\# #\e #\m #\p #\t #\y tl)) - (else + (else (append (string->list "#") tl)))) ;; What This Format? render) @@ -139,10 +136,10 @@ (cond ((getf sh obj) => - (λ (id) + (λ (id) (if (< id 0) ;; already written, just refer (ilist #\# (render (abs id) (pair #\# (k sh)))) - (ilist #\# + (ilist #\# (render id (ilist #\# #\= (ser (del sh obj) obj @@ -157,7 +154,7 @@ (render-number obj (delay (k sh)) 10)) ((string? obj) - (cons #\" + (cons #\" (render-quoted-string obj ;; <- all eager now (pair #\" (k sh))))) @@ -176,33 +173,33 @@ (if (< id 0) (pair 41 (k sh)) (pair #\= - (ser (del sh obj) obj + (ser (del sh obj) obj (λ (sh) (pair 41 - (k - (put sh obj + (k + (put sh obj (- 0 id))))))))))))) - ((pair? obj) + ((pair? obj) ;; render car, then cdr (ser sh (car obj) (λ (sh) - (delay + (delay (if (null? (cdr obj)) (loop sh (cdr obj)) (cons #\space (loop sh (cdr obj)))))))) - (else + (else ;; improper list - (ilist #\. #\space + (ilist #\. #\space (ser sh obj (λ (sh) (pair 41 (k sh)))))))))) ((boolean? obj) - (append - (string->list (if obj "#true" "#false")) + (append + (string->list (if obj "#true" "#false")) (delay (k sh)))) - + ((symbol? obj) - (render (symbol->string obj) (delay (k sh)))) + (render-symbol obj (delay (k sh)))) ((vector? obj) (cons #\# @@ -240,32 +237,29 @@ (ser sh (tuple->list obj) (λ (sh) (pair #\] (k sh)))))) - ((socket? obj) (render obj (λ () (k sh)))) - ((tcp? obj) (render obj (λ () (k sh)))) ((port? obj) (render obj (λ () (k sh)))) - ((eof? obj) (render obj (λ () (k sh)))) + ((eof-object? obj) (render obj (λ () (k sh)))) ((eq? obj #empty) (render obj (λ () (k sh)))) - (else + (else (append (string->list "#") (delay (k sh)))))) ser) (define (self-quoting? val) - (or + (or (immediate? val) - (number? val) (string? val) (function? val) - (tcp? val) (socket? val) (rlist? val) + (number? val) (string? val) (function? val) (ff? val))) ;; could drop val earlier to possibly gc it while rendering (define (maybe-quote val lst) - (if (self-quoting? val) + (if (self-quoting? val) lst (cons #\' lst))) ;; a value worth checking for sharing in datum labeler (define (shareable? x) - (not (or (function? x) (symbol? x) (port? x) (tcp? x) (socket? x)))) + (not (or (function? x) (symbol? x) (port? x)))) (define (partial-object-closure seen obj) (cond @@ -287,14 +281,14 @@ (define (label-shared-objects val) (lets ((refs (sub-objects val shareable?)) - (shares - (fold + (shares + (fold (λ (shared p) (lets ((ob refs p)) (cond - ((eq? refs 1) shared) - ((shareable? ob) (cons ob shared)) - (else shared)))) + ((eq? refs 1) shared) + ((shareable? ob) (cons ob shared)) + (else shared)))) null refs))) (let loop ((out empty) (shares shares) (n 1)) (if (null? shares) @@ -305,7 +299,7 @@ (let ((ser (make-ser names))) (λ (val tl share?) (maybe-quote val - (ser + (ser (if share? ;; O(n), allow skipping (label-shared-objects val) empty) @@ -314,7 +308,7 @@ (define (make-serializer names) (let ((serialize-lazy (make-lazy-serializer names))) (λ (val tl) - (force-ll + (force-ll (serialize-lazy val tl #true))))) (define (str . args) diff --git a/owl/repl.scm b/owl/repl.scm new file mode 100644 index 00000000..fe72316f --- /dev/null +++ b/owl/repl.scm @@ -0,0 +1,796 @@ + +(define-library (owl repl) + + (export + repl-file + repl-port + repl-string + repl-trampoline + repl + print-repl-error + bind-toplevel + library-import ; env exps fail-cont → env' | (fail-cont ) + *owl-core*) + + (import + (owl defmac) + (owl list) + (owl eval) + (owl primop) + (owl ff) + (owl sort) + (owl env) + ;(owl terminal) + (owl io) + (owl list-extra) + (owl render) + (owl string) + (owl sexp) + (owl parse) + (owl function) + (scheme base) + (owl lazy) + (owl macro) + (only (owl regex) string->regex) + (scheme cxr)) + + (begin + + (define (ok? x) (eq? (ref x 1) 'ok)) + (define (ok exp env) (tuple 'ok exp env)) + (define (fail reason) (tuple 'fail reason)) + + (define (name->func name) + (some + (λ (x) (if (eq? (ref x 1) name) (ref x 5) #false)) + primops)) + + (define (debug env . msg) + (if (env-get env '*debug* #false) + (print* msg))) + + ;; library (just the value of) containing only special forms, primops and + (define *owl-core* + (fold + (λ (env thing) + (env-set env thing (name->func thing))) + (env-set-macro + *tabula-rasa* ;; from (owl env), env with only special form tags, no primops + 'define-syntax + (make-transformer + '(define-syntax syntax-rules add quote) + '( + ((define-syntax keyword + (syntax-rules literals (pattern template) ...)) + () + (quote syntax-operation add #false + (keyword literals (pattern ...) + (template ...))))))) + ;; note that these could now come straight from primops + '(cons car cdr eq? type size cast ref sys-prim refb sys fxbor fxbxor + raw mkt bind set lesser? mkred mkblack ff-bind listuple fxband fx+ + fxqr fx* fx- fx<< fx>> ncons ncar ncdr clock sizeb type-byte))) + + ;; toplevel variable to which loaded libraries are added + + (define (? x) #true) + + (define library-key '*libraries*) ;; list of loaded libraries + (define features-key '*features*) ;; list of implementation feature symbols + (define includes-key '*include-dirs*) ;; paths where to try to load includes from + + (define definition? + (H match (list '_define symbol? ?))) + + (define multi-definition? + (H match (list '_define list? ?))) + + ;; toplevel variable which holds currently loaded (r7rs-style) libraries + (define libraries-var '*libs*) + + (define error-port stderr) + + (define (print-repl-error lst) + (define (format-error lst ind) + (cond + ((and (pair? lst) (null? (cdr lst)) (list? (car lst))) + (cons 10 + (let ((ind (+ ind 2))) + (append (map (λ (x) 32) (iota 0 1 ind)) + (format-error (car lst) ind))))) + ((pair? lst) + (render (car lst) + (cons 32 + (format-error (cdr lst) ind)))) + ((null? lst) '(10)) + (else (render lst '(10))))) + (write-bytes error-port + (format-error lst 0))) + + ; -> (ok value env), (error reason env) + + (define repl-op? + (H match (list 'unquote symbol?))) + + (define (mark-loaded env path) + (let ((loaded (env-get env '*loaded* null))) + (if (mem string-eq? loaded path) + env + (env-set env '*loaded* + (cons path loaded))))) + + ;; values used by the repl to signal they should be printed as such, not rendered as a value + (define repl-message-tag "foo") + (define repl-message (H cons repl-message-tag)) + (define (repl-message? foo) (and (pair? foo) (eq? repl-message-tag (car foo)))) + + (define (maybe-show-metadata env val) + (lets + ((meta (env-get env meta-tag empty)) + (info (getf meta val))) + (if info + (begin + (display ";; ") + (if (list? info) + (for-each (λ (x) (display x) (display " ")) info) + info) + (display "\n"))))) + + ;; render the value if *interactive*, and print as such (or not at all) if it is a repl-message + ;; if interactive mode and output fails, the error is fatal + (define (prompt env val) + (let ((prompt (env-get env '*interactive* #false))) + (if prompt + (if (repl-message? val) + (begin + (if (cdr val) + (print (cdr val))) + (if (not (display "> ")) + (halt 125))) + (begin + (maybe-show-metadata env val) + ((writer-to (env-get env name-tag empty)) + stdout val) + (if (not (display "\n> ")) + (halt 125))))))) + + (define syntax-error-mark (list 'syntax-error)) + + ;; fixme: the input data stream is iirc raw bytes, as is parser error position, but that one is unicode-aware + + ; lst -> n, being the number of things before next 10 or end of list + (define (next-newline-distance lst) + (let loop ((lst lst) (pos 0)) + (cond + ((null? lst) (values pos lst)) + ((eq? (car lst) 10) (values (+ pos 1) (cdr lst))) + (else (loop (cdr lst) (+ pos 1)))))) + + (define (find-line data error-pos) + (let loop ((data data) (pos 0)) + (lets ((next datap (next-newline-distance data))) + (cond + ((<= error-pos next) + (runes->string (take data (- next 1)))) ; take this line + ((null? data) + "(end of input)") + (else + (loop datap next)))))) + + (define (syntax-fail pos info lst) + (list syntax-error-mark info + (list ">>> " (find-line lst pos) " <<<"))) + + (define (syntax-error? x) (and (pair? x) (eq? syntax-error-mark (car x)))) + + (define (repl-fail env reason) (tuple 'error reason env)) + (define (repl-ok env value) (tuple 'ok value env)) + + ;; just be quiet + (define repl-load-prompt + (λ (val result?) null)) + + ;; load and save path to *loaded* + + (define (repl-load repl path in env) + (lets + ((exps ;; find the file to read + (or + (file->exp-stream path sexp-parser (silent-syntax-fail null)) + (file->exp-stream + (string-append (env-get env '*owl* "NA") path) + sexp-parser + (silent-syntax-fail null))))) + (if exps + (begin + (lets + ((current-prompt (env-get env '*interactive* #false)) ; <- switch prompt during loading + (load-env + (if prompt + (env-set env '*interactive* #false) ;; <- switch prompt during load (if enabled) + env)) + (outcome (repl load-env exps))) + (tuple-case outcome + ((ok val env) + (ok val (env-set env '*interactive* current-prompt))) + ((error reason partial-env) + ; fixme, check that the fd is closed! + (repl-fail env (list "Could not load" path "because" reason)))))) + (repl-fail env + (list "Could not find any of" + (list path (string-append (env-get env '*owl* "") path)) + "for loading."))))) + + ;; regex-fn | string | symbol → regex-fn | #false + (define (thing->rex thing) + (cond + ((function? thing) thing) + ((string? thing) + (string->regex + (foldr string-append "" (list "m/" thing "/")))) + ((symbol? thing) + (thing->rex (symbol->string thing))) + (else #false))) + + (define repl-ops-help "Commands: + ,help - show this + ,words - list all current definitions + ,expand - expand macros in the expression + ,find [regex|sym] - list all defined words matching regex or m// + ,load string - (re)load a file + ,libraries - show all currently loaded libraries + ,quit - exit owl") + + (define (repl-op repl op in env) + (case op + ((help) + (prompt env (repl-message repl-ops-help)) + (repl env in)) + ((load) + (lets ((op in (uncons in #false))) + (cond + ((string? op) + (tuple-case (repl-load repl op in env) + ((ok exp env) + (prompt env (repl-message (string-append ";; Loaded " op))) + (repl env in)) + ((error reason envp) + (prompt env (repl-message (string-append ";; Failed to load " op))) + ;; drop out of loading (recursively) files, or hit repl trampoline on toplevel + (repl-fail env reason)))) + (else + (repl-fail env (list "expected ,load \"dir/foo.scm\", got " op)))))) + ((forget-all-but) + (lets ((op in (uncons in #false))) + (if (and (list? op) (all symbol? op)) + (let ((nan (tuple 'defined (tuple 'value 'undefined)))) + (repl + (env-keep env + (λ (name) + (if (or (primop-of name) (has? op name)) + name + #false))) + in)) + (repl-fail env (list "bad word list: " op))))) + ((words w) + (prompt env + (repl-message + (bytes->string + (foldr + (λ (x tl) (render x (cons #\space tl))) + null + (cons "Words: " + (sort stringstring + (env-keys env)))))))) + (repl env in)) + ((find) + (lets + ((thing in (uncons in #false)) + (rex (thing->rex thing))) + (cond + ((function? rex) + (define (seek env) + (keep (B rex symbol->string) (env-keys env))) + (print "current toplevel: " + (apply str (interleave ", " (seek env)))) + (for-each + (λ (lib) + (let ((matches (seek (cdr lib)))) + (if (not (null? matches)) + (print + (str " " (car lib) ": " (apply str (interleave ", " matches))))))) + (env-get env '*libraries* null)) + (prompt env (repl-message #false))) + (else + (prompt env "I would have preferred a regex or a symbol."))) + (repl env in))) + ((libraries libs) + (print "Currently defined libraries:") + (for-each print (map car (env-get env library-key null))) + (prompt env (repl-message #false)) + (repl env in)) + ((expand) + (lets ((exp in (uncons in #false))) + (tuple-case (macro-expand exp env) + ((ok exp env) + (print exp)) + ((fail reason) + (print ";; Macro expansion failed: " reason))) + (prompt env (repl-message #false)) + (repl env in))) + ((quit) + ; this goes to repl-trampoline + (tuple 'ok 'quitter env)) + (else + (prompt env + (repl-message + (str ";; unknown repl op: " op ". use ,help for help."))) + (repl env in)))) + + ;; → (name ...) | #false + (define (exported-names env lib-name) + (let ((libp (assoc lib-name (env-get env library-key null)))) + (if libp + (env-fold (λ (out name value) (cons name out)) null (cdr libp)) + #false))) + + ;; todo: this uses direct environment access - move to lib-env or handle here? + ;; = + ;; | (rename ) + ;; | (exports + (λ (value) + (loop (cdr names) unbound (env-put-raw module (car names) value)))) + ((and ;; swap name for (rename ) + (match `(rename ,symbol? ,symbol?) (car names)) + (env-get-raw env (cadar names) #false)) => + (λ (value) + (loop (cdr names) unbound (env-put-raw module (caddar names) value)))) + ((match `(exports ,list?) (car names)) + (let ((exported (exported-names env (cadr (car names))))) + (if exported + (loop (append exported (cdr names)) unbound module) + (fail (list "Didn't find " (cadar names) " for exporting."))))) + (else + (loop (cdr names) (cons (car names) unbound) module))))) + + ; fixme, use pattern matching... + + (define (symbol-list? l) (and (list? l) (all symbol? l))) + + (define export? + (H match `(export . ,symbol-list?))) + + (define (_ x) #true) + + (define import? ; toplevel import using the new library system + (H match `(import . ,(λ (x) #true)))) + + (define (library-definition? x) + (and (pair? x) (list? x) (eq? (car x) '_define-library))) + + (define (bind-toplevel env) + (env-set env '*toplevel* + (env-del env '*toplevel))) + + ;; list starting with val? + (define (headed? val exp) + (and (pair? exp) (eq? val (car exp)) (list? exp))) + + ;; (import ...) + ;; = + ;; | (only ...) + ;; | (except ...) + ;; | (prefix ) + ;; | (rename ( ) ..) + + ;; (a ...) + (define (symbols? exp) + (and (list? exp) (all symbol? exp))) + + ;; ((a b) ...) + (define (pairs? exp) + (and (list? exp) + (all (λ (x) (and (list? x) (= (length x) 2))) exp))) + + ;; → 'ok env | 'needed name | 'circular name, non-ok exists via fail + (define (import-set->library iset libs fail) + (cond + ((assoc iset libs) => + (λ (pair) + (if (eq? (cdr pair) 'loading) ;; trying to reload something + (fail 'circular iset) + (values 'ok (cdr pair))))) + ((match `(only ,? . ,symbols?) iset) + (lets ((ok lib (import-set->library (cadr iset) libs fail))) + (values 'ok + (env-keep lib (λ (var) (if (has? (cddr iset) var) var #false)))))) + ((match `(except ,? . ,symbols?) iset) + (lets ((ok is (import-set->library (cadr iset) libs fail))) + (values 'ok + (env-keep is (λ (var) (if (has? (cddr iset) var) #false var)))))) + ((match `(rename ,? . ,pairs?) iset) + (lets ((ok lib (import-set->library (cadr iset) libs fail))) + (values 'ok + (env-keep lib + (λ (var) + (let ((val (assq var (cddr iset)))) + (if val (cdr val) #false))))))) + ((match `(prefix ,? ,symbol?) iset) + (lets + ((ok lib (import-set->library (cadr iset) libs fail)) + (prefix (symbol->string (caddr iset)))) + (values 'ok + (env-keep lib + (λ (var) + (string->symbol + (string-append prefix (symbol->string var)))))))) + (else + (fail 'needed iset)))) + + ;; (foo bar baz) → "/foo/bar/baz.scm" + (define (library-name->path iset) + (bytes->string + (cons #\/ + (foldr + (λ (thing tl) + (append + (string->list (symbol->string thing)) + (if (null? tl) + (string->list ".scm") + (cons #\/ tl)))) + null iset)))) + + ;; try to find and parse contents of and wrap to (begin ...) or call fail + (define (repl-include env path fail) + (lets + ((include-dirs (env-get env includes-key null)) + (conv (λ (dir) (list->string (append (string->list dir) (cons #\/ (string->list path)))))) + (paths (map conv include-dirs)) + (contentss (map file->list paths)) + (data (first self contentss #false))) + (if data + (let ((exps (list->sexps data "library fail" path))) + (if exps ;; all of the file parsed to a list of sexps + (cons 'begin exps) + (fail (list "Failed to parse contents of " path)))) + (fail (list "Couldn't find " path "from any of" include-dirs))))) + + ;; nonempty list of symbols or integers + (define (valid-library-name? x) + (and (list? x) (pair? x) (all (λ (x) (or (integer? x) (symbol? x))) x))) + + ;; try to load a library based on it's name and current include prefixes if + ;; it is required by something being loaded and we don't have it yet + ;; → 'ok x env | 'error x reason | 'not-found x _ + (define (try-autoload env repl iset) + (if (valid-library-name? iset) ;; (foo bar baz) → try to load "./foo/bar/baz.scm" + (let + ((exps + (call/cc + (λ (ret) + (repl-include env + (library-name->path iset) (λ (why) (ret #false))))))) + (if exps + (tuple-case (repl env (cdr exps)) ; drop begin + ((ok value env) + ;; we now have the library if it was defined in the file + (values 'ok env)) + ((error reason env) + ;; no way to distinquish errors in the library from missing library atm + (values 'error reason))) + (values 'not-found (library-name->path iset)))) + (values 'error (list "Bad library name:" iset)))) + + (define (any->string obj) + (list->string (render obj null))) + + (define (library-import env exps fail repl) + (fold + (λ (env iset) + (lets ((status lib (call/cc (λ (ret) (import-set->library iset (env-get env library-key null) ret))))) + (cond + ((eq? status 'needed) + (lets ((status env (try-autoload env repl lib))) + (cond + ((eq? status 'ok) + (library-import env exps fail repl)) + ((eq? status 'error) + (fail (list "Failed to load" lib "because" env))) + (else + (fail (list "I didn't have or find library" (any->string lib))))))) + ((eq? status 'ok) + (env-fold env-put-raw env lib)) ;; <- TODO env op, should be in (owl env) + ((eq? status 'circular) + (fail (list "Circular dependency causing reload of" (bytes->string (render lib null))))) + (else + (fail (list "BUG: bad library load status: " status)))))) + env exps)) + + ;; temporary toplevel import doing what library-import does within libraries + (define (toplevel-library-import env exps repl) + (lets/cc ret + ((fail (λ (x) (ret (cons "Import failed because" x))))) + (library-import env exps fail repl))) + + (define (match-feature req feats libs fail) + (cond + ((memv req feats) #true) ;; a supported implementation feature + ((symbol? req) #false) + ((assv req libs) #true) ;; an available (loaded) library + ((and (headed? 'not req) (= (length req) 2)) + (not (match-feature (cadr req) feats libs fail))) + ((headed? 'and req) + (all (λ (req) (match-feature req feats libs fail)) (cdr req))) + ((headed? 'or req) + (some (λ (req) (match-feature req feats libs fail)) (cdr req))) + (else + (fail "Weird feature requirement: " req)))) + + (define (choose-branch bs env fail) + (cond + ((null? bs) null) ;; nothing matches, no else + ((match `(else . ,list?) (car bs)) (cdar bs)) + ((pair? (car bs)) + (if (match-feature + (caar bs) + (env-get env features-key null) + (env-get env library-key null) + fail) + (cdar bs) + (choose-branch (cdr bs) env fail))) + (else + (fail (list "Funny cond-expand node: " bs))))) + + + (define (repl-library exp env repl fail) + (cond + ((null? exp) (fail "no export?")) + ((headed? 'import (car exp)) + (repl-library (cdr exp) + (library-import env (cdar exp) fail repl) + repl fail)) + ((headed? 'begin (car exp)) + ;; run basic repl on it + (tuple-case (repl env (cdar exp)) + ((ok value env) + ;; continue on to other defines or export + (repl-library (cdr exp) env repl fail)) + ((error reason env) + (fail reason)))) + ((headed? 'export (car exp)) + ;; build the export out of current env + (ok (build-export (cdar exp) env fail) env)) + ((headed? 'include (car exp)) + (repl-library + (foldr + (λ (path exp) (cons (repl-include env path fail) exp)) + (cdr exp) (cdar exp)) + env repl fail)) + ((headed? 'cond-expand (car exp)) + (repl-library + (append (choose-branch (cdar exp) env fail) (cdr exp)) + env repl fail)) + (else + (fail (list "unknown library term: " (car exp)))))) + + ;; variables which are added to *owl-core* when evaluating libraries + (define library-exports + (list + library-key ;; loaded libraries + includes-key ;; where to load libraries from + features-key)) ;; implementation features + + ;; update *owl-names* (used by renderer of repl prompt) if the defined value is a function + (define (maybe-name-function env name value) + (if (function? value) + (lets + ((names (env-get env name-tag empty)) + (old (getf env value)) + (env + (if old + env + (env-set env name-tag + (put names value name))))) + (if (eq? (type value) 16) + env + ;; if this is a proc or closure name also the internal parts + (maybe-name-function env name (ref value 1)))) + env)) + + ;; update *owl-meta* to have some data about this + (define (maybe-save-metadata env name value) + (env-set env meta-tag + (put (env-get env meta-tag empty) value + `(defined in ,(env-get env current-library-key 'repl))))) + + (define (eval-repl exp env repl) + (debug env "Evaling " exp) + (tuple-case (macro-expand exp env) + ((ok exp env) + (debug env " * expanded to " exp) + (cond + ((import? exp) ;; <- new library import, temporary version + (lets + ((envp (toplevel-library-import env (cdr exp) repl))) + (if (pair? envp) ;; the error message + (fail envp) + (ok + (repl-message + (list->string + (foldr render null + (cons ";; Imported " (cdr exp))))) + envp)))) + ((definition? exp) + (tuple-case (evaluate (caddr exp) env) + ((ok value env2) + (lets + ((env (env-set env (cadr exp) value)) + (env (maybe-name-function env (cadr exp) value)) + ;(env (maybe-save-metadata env (cadr exp) value)) + ) + (ok + (repl-message + (bytes->string (render ";; Defined " (render (cadr exp) null)))) + (bind-toplevel env)))) + ((fail reason) + (fail + (list "Definition of" (cadr exp) "failed because" reason))))) + ((multi-definition? exp) + (tuple-case (evaluate (caddr exp) env) + ((ok value env2) + (let ((names (cadr exp))) + (if (and (list? value) + (= (length value) (length names))) + (ok (repl-message ";; All defined") + (fold + (λ (env pair) + (env-set env (car pair) (cdr pair))) + env + (zip cons names value))) + (fail + (list "Didn't get expected values for definition of " names))))) + ((fail reason) + (fail + (list "Definition of" (cadr exp) "failed because" reason))))) + ((export? exp) + (lets ((module (build-export (cdr exp) env self))) ; <- to be removed soon, dummy fail cont + (ok module env))) + ((library-definition? exp) + ;; evaluate libraries in a blank *owl-core* env (only primops, specials and define-syntax) + ;; include just loaded *libraries* and *include-paths* from the current one to share them + (lets/cc ret + ((exps (map cadr (cdr exp))) ;; drop the quotes + (name exps (uncons exps #false)) + (libs (env-get env library-key null)) + ;; mark the current library as being loaded for circular dependency detection + (env (env-set env library-key (cons (cons name 'loading) libs))) + (fail + (λ (reason) + (ret (fail (list "Library" name "failed:" reason))))) + (lib-env + (fold + (λ (lib-env key) (env-set lib-env key (env-get env key null))) + *owl-core* library-exports)) + (lib-env (env-set lib-env current-library-key name))) + (tuple-case (repl-library exps lib-env repl fail) ;; anything else must be incuded explicitly + ((ok library lib-env) + ;; get new function names and metadata from lib-env (later to be handled differently) + (lets + ((names (env-get lib-env name-tag empty)) + (env (env-set env name-tag (ff-union (env-get env name-tag empty) names (λ (old new) new)))) + (meta (env-get lib-env meta-tag empty)) + (env (env-set env meta-tag (ff-union (env-get env meta-tag empty) meta (λ (old new) new))))) + (ok + (repl-message + (list->string + (foldr render null + (list ";; Library " name " added" )))) + (env-set env library-key + (cons (cons name library) + (keep ;; drop the loading tag for this library + (λ (x) (not (equal? (car x) name))) + (env-get lib-env library-key null))))))) ; <- lib-env may also have just loaded dependency libs + ((error reason not-env) + (fail + (list "Library" name "failed to load because" reason)))))) + (else + (evaluate exp env)))) + ((fail reason) + (tuple 'fail + (list "Macro expansion of" exp "failed: " reason))))) + + ; (repl env in) -> #(ok value env) | #(error reason env) + + (define (repl env in) + (let loop ((env env) (in in) (last 'blank)) + (cond + ((null? in) + (repl-ok env last)) + ((pair? in) + (lets ((this in (uncons in #false))) + (cond + ((eof-object? this) + (repl-ok env last)) + ((syntax-error? this) + (repl-fail env (cons "This makes no sense: " (cdr this)))) + ((repl-op? this) + (repl-op repl (cadr this) in env)) + (else + (tuple-case (eval-repl this env repl) + ((ok result env) + (prompt env result) + (loop env in result)) + ((fail reason) + (repl-fail env reason))))))) + (else + ;; prompt here + (loop env (in) last))))) + + + ;; run the repl on a fresh input stream, report errors and catch exit + + (define (stdin-sexp-stream env bounced?) + (λ () (fd->exp-stream stdin sexp-parser (silent-syntax-fail null)))) + + (define (repl-trampoline repl env) + (let boing ((repl repl) (env env) (bounced? #false)) + (lets + ((stdin (stdin-sexp-stream env bounced?)) + (stdin + (if bounced? + (begin ;; we may need to reprint a prompt here + (if (env-get env '*interactive* #false) + (display "> ")) ;; reprint prompt + stdin) + stdin)) + (env (bind-toplevel env))) + (tuple-case (repl env stdin) + ((ok val env) + ;; the end + (if (env-get env '*interactive* #false) + (print "bye bye _o/~")) + (halt 0)) + ((error reason env) + ; better luck next time + (cond + ((list? reason) + (print-repl-error reason) + (boing repl env #true)) + (else + (print reason) + (boing repl env #true)))) + (else is foo + (print "Repl is rambling: " foo) + (boing repl env #true)))))) + + (define (repl-port env fd) + (repl env + (if (eq? fd stdin) + (λ () (fd->exp-stream stdin sexp-parser (silent-syntax-fail null))) + (fd->exp-stream fd sexp-parser (silent-syntax-fail null))))) + + (define (repl-file env path) + (let ((fd (if (equal? path "-") stdin (open-input-file path)))) + (if fd + (repl-port env fd) + (tuple 'error "cannot open file" env)))) + + (define (repl-string env str) + (lets ((exps (try-parse (get-kleene+ sexp-parser) (str-iter str) #false syntax-fail #false))) + (if exps + (repl env exps) + (tuple 'error "not parseable" env)))) +)) diff --git a/owl/rlist.scm b/owl/rlist.scm index 72a0ed8e..ac25fd24 100644 --- a/owl/rlist.scm +++ b/owl/rlist.scm @@ -169,7 +169,7 @@ (riter-tree t (lambda () (riterator tl tail)))))) - (define (riter rl) (riterator rl null)) + (define riter (C riterator null)) ;; riterr (backwards) @@ -189,7 +189,7 @@ (lambda () (riterr-tree t tail)))))) - (define (riterr rl) (riteratorr rl null)) + (define riterr (C riteratorr null)) ;; rfold (== (lfold op st (riter rl))) @@ -224,7 +224,7 @@ st (lets ((w t tl rl)) (rfoldr-tree op (rfoldr op st tl) t)))) - + ;; conversions (define (list->rlist l) ; naive O(n log n) @@ -295,11 +295,11 @@ (define-syntax same (syntax-rules () ((same a r) (mkt 14 a r)))) - + (define-syntax less (syntax-rules () ((less a r) (mkt 46 a r)))) - + (define-syntax node ;; in-tree node (syntax-rules () ((node a b) (mkt 78 a b)))) @@ -329,9 +329,9 @@ (same a r)))) ; O(1) - (define (rcar r) - (ref r 1)) - + (define rcar + (C ref 1)) + (define (ref-small-tree r p n) (if (eq? n 0) r @@ -425,7 +425,7 @@ ;; O(n log n) (define (list->rlist lst) (foldr rcons null lst)) - + ;; O(n) (define (rlist->list rl) (rfoldr cons null rl)) diff --git a/owl/sexp.scm b/owl/sexp.scm index 1a6a4308..f5739f36 100644 --- a/owl/sexp.scm +++ b/owl/sexp.scm @@ -1,20 +1,21 @@ -;; todo: remove implicit UTF-8 conversion from parser and move to a separate pass (define-library (owl sexp) - - (export - sexp-parser + + (export + sexp-parser read-exps-from list->number - get-sexps ;; greedy* get-sexp + get-sexps ;; greedy* get-sexp + get-padded-sexps ;; whitespace at either end string->sexp vector->sexps list->sexps read read-ll) (import - (owl parse) (owl defmac) + (owl eof) + (owl parse) (owl math) (owl string) (owl list) @@ -38,44 +39,44 @@ (define special-symbol-chars (string->bytes "+-=<>!*%?_/~&$^:")) ;; owl uses @ for finite function syntax - (define (symbol-lead-char? n) - (or + (define (symbol-lead-char? n) + (or (between? #\a n #\z) (between? #\A n #\Z) (has? special-symbol-chars n) (> n 127))) ;; allow high code points in symbols - (define (symbol-char? n) - (or (symbol-lead-char? n) - (eq? n #\.) - (or - (between? #\0 n #\9) - (> n 127)))) ;; allow high code points in symbols + (define (symbol-char? n) + (or + (symbol-lead-char? n) + (eq? n #\.) + (or (between? #\0 n #\9) (> n 127)))) ;; allow high code points in symbols - (define get-symbol + (define get-symbol (get-either - (let-parses + (let-parses ((head (get-rune-if symbol-lead-char?)) (tail (get-greedy* (get-rune-if symbol-char?))) - (next (peek get-byte)) - (foo (assert (lambda (b) (not (symbol-char? b))) next))) ; avoid useless backtracking + ;(next (peek get-byte)) + ;(foo (assert (B not symbol-char?) next)) + ) (string->uninterned-symbol (runes->string (cons head tail)))) (let-parses ((skip (get-imm #\|)) - (chars - (get-greedy* - (get-either - (let-parses ((skip (get-imm #\\)) (rune get-rune)) rune) - (get-rune-if (λ (x) (not (eq? x #\|))))))) + (chars + (get-greedy* + (get-either + (let-parses ((skip (get-imm #\\)) (rune get-rune)) rune) + (get-rune-if (B not (C eq? #\|)))))) (skip (get-imm #\|))) (string->uninterned-symbol (runes->string chars))))) - (define (digit-char? x) + (define (digit-char? x) (or (between? 48 x 57) (between? 65 x 70) (between? 97 x 102))) - (define digit-values + (define digit-values (list->ff (foldr append null (list @@ -101,8 +102,8 @@ 0 digits)) (define get-sign - (get-any-of (get-imm 43) (get-imm 45) (get-epsilon 43))) - + (one-of (get-imm 43) (get-imm 45) (get-epsilon 43))) + (define bases (list->ff (list @@ -112,8 +113,8 @@ (cons #\x 16)))) ; fixme, # and cooked later - (define get-base - (get-any-of + (define get-base + (one-of (let-parses ((skip (get-imm #\#)) (char (get-byte-if (λ (x) (getf bases x))))) @@ -142,9 +143,7 @@ (define get-signer (let-parses ((char get-sign)) - (if (eq? char 43) - (λ (x) x) - (λ (x) (- 0 x))))) + (if (eq? char 43) self (H - 0)))) ;; separate parser with explicitly given base for string->number @@ -199,10 +198,10 @@ (if (eq? imag 0) real (complex real imag)))) - + (define get-rest-of-line (let-parses - ((chars (get-greedy* (get-byte-if (lambda (x) (not (eq? x 10)))))) + ((chars (get-greedy* (get-byte-if (B not (C eq? 10))))) (skip (get-imm 10))) ;; <- note that this won't match if line ends to eof chars)) @@ -213,7 +212,7 @@ (bang (get-imm 33)) (line get-rest-of-line)) (list 'quote (list 'hashbang (list->string line))))) - + ;; skip everything up to |# (define (get-block-comment) (get-either @@ -227,9 +226,9 @@ skip))) (define get-a-whitespace - (get-any-of + (one-of ;get-hashbang ;; actually probably better to make it a symbol as above - (get-byte-if (lambda (x) (has? '(9 10 32 13) x))) + (get-byte-if (H has? '(9 10 32 13))) (let-parses ((skip (get-imm #\;)) (skip get-rest-of-line)) @@ -272,10 +271,10 @@ (#\" . #x0022) (#\\ . #x005c)))) - (define get-quoted-string-char + (define get-quoted-string-char (let-parses ((skip (get-imm #\\)) - (char + (char (get-either (let-parses ((char (get-byte-if (λ (byte) (getf quoted-values byte))))) @@ -294,7 +293,7 @@ (get-kleene* (get-either get-quoted-string-char - (get-rune-if (lambda (x) (not (has? '(#\" #\\) x))))))) + (get-rune-if (B not (H has? '(#\" #\\))))))) (skip (get-imm #\"))) (runes->string chars))) @@ -303,15 +302,15 @@ (define (get-quoted parser) (let-parses - ((type + ((type (get-either (let-parses ((_ (get-imm 44)) (_ (get-imm 64))) 'splice) ; ,@ (get-byte-if (λ (x) (get quotations x #false))))) (value parser)) (list (get quotations type #false) value))) - + (define get-named-char - (get-any-of + (one-of (get-word "null" 0) (get-word "alarm" 7) (get-word "backspace" 8) @@ -332,12 +331,12 @@ ;; most of these are to go via type definitions later (define get-funny-word - (get-any-of + (one-of (get-word "..." '...) (let-parses ((skip (get-imm #\#)) (val - (get-any-of + (one-of (get-word "true" #true) ;; get the longer ones first if present (get-word "false" #false) (get-word "empty" #empty) @@ -365,24 +364,24 @@ (define (valid-ff-node? val) (and (pair? val) (or - (symbol? val) + (symbol? val) (immediate? val)))) (define (valid-ff-key? val) - (or (symbol? val) (immediate? val))) + (or (symbol? val) (immediate? val))) (define (ff-able? lst) - (cond - ((null? lst) - #true) - ((valid-ff-key? (car lst)) - (let ((lst (cdr lst))) - (if (null? lst) - #false - (ff-able? (cdr lst))))) - (else - (print-to stderr "Invalid ff key: " (car lst)) - #false))) + (cond + ((null? lst) + #true) + ((valid-ff-key? (car lst)) + (let ((lst (cdr lst))) + (if (null? lst) + #false + (ff-able? (cdr lst))))) + (else + (print-to stderr "Invalid ff key: " (car lst)) + #false))) (define (lst->ff lst) (let loop ((lst lst) (ff #empty)) @@ -391,20 +390,20 @@ (lets ((k lst lst) (v lst lst)) (loop lst (put ff k v)))))) - + (define (get-ff get-any) (let-parses ((skip (get-imm #\@)) - (fields + (fields (get-list-of get-any)) - (foo (assert ff-able? fields))) + (verify (ff-able? fields) '(bad ff))) (lst->ff (intern-symbols fields)))) (define (get-sexp) (let-parses ((skip maybe-whitespace) (val - (get-any-of + (one-of ;get-hashbang get-number ;; more than a simple integer get-sexp-regex ;; must be before symbols, which also may start with / @@ -415,7 +414,7 @@ (get-vector-of (get-sexp)) ;; #(...) -> vector or #((a . b) (c . d)) (get-ff (get-sexp)) ;; #(...) -> vector or #((a . b) (c . d)) (get-quoted (get-sexp)) - (get-byte-if eof?) + (get-byte-if eof-object?) get-quoted-char))) val)) @@ -423,26 +422,33 @@ (define (ok exp env) (tuple 'ok exp env)) (define (fail reason) (tuple 'fail reason)) - (define sexp-parser + (define sexp-parser (let-parses - ((sexp (get-sexp)) - (foo maybe-whitespace)) + ((foo maybe-whitespace) + (sexp (get-sexp))) ;; do not read trailing whitespace to avoid blocking when parsing a stream (intern-symbols sexp))) (define get-sexps (get-greedy* sexp-parser)) + ;; whitespace at either end + (define get-padded-sexps + (let-parses + ((data get-sexps) + (ws maybe-whitespace)) + data)) + ;; fixme: new error message info ignored, and this is used for loading causing the associated issue (define (read-exps-from data done fail) (lets/cc ret ;; <- not needed if fail is already a cont - ((data - (utf8-decoder data - (λ (self line data) + ((data + (utf8-decoder data + (λ (self line data) (ret (fail (list "Bad UTF-8 data on line " line ": " (ltake line 10)))))))) (sexp-parser data (λ (data drop val pos) (cond - ((eof? val) (reverse done)) + ((eof-object? val) (reverse done)) ((null? data) (reverse (cons val done))) ;; only for non-files (else (read-exps-from data (cons val done) fail)))) (λ (pos reason) @@ -464,24 +470,24 @@ (define (vector->sexps vec fail errmsg) ; try-parse parser data maybe-path maybe-error-msg fail-val (let ((lst (vector->list vec))) - (try-parse get-sexps lst #false errmsg #false))) + (try-parse get-padded-sexps lst #false errmsg #false))) (define (list->sexps lst fail errmsg) ; try-parse parser data maybe-path maybe-error-msg fail-val - (try-parse get-sexps lst #false errmsg #false)) - + (try-parse get-padded-sexps lst #false errmsg #false)) + (define (read-port port) - (fd->exp-stream port #false sexp-parser #false #false)) - + (fd->exp-stream port sexp-parser (silent-syntax-fail (list #false)))) + (define read-ll (case-lambda (() (read-port stdin)) - ((thing) + ((thing) (cond ((port? thing) (read-port thing)) ((string? thing) - (try-parse get-sexps (str-iter thing) #false #false #false)) + (try-parse get-padded-sexps (str-iter thing) #false #false #false)) (else (error "read needs a port or a string, but got " thing)))))) @@ -491,5 +497,4 @@ (ll (lcar ll)) ((null? rest) (error "read: bad data in " thing)) (else (car rest))))) - )) diff --git a/owl/sort.scm b/owl/sort.scm index bf7df3ee..bf141798 100644 --- a/owl/sort.scm +++ b/owl/sort.scm @@ -5,7 +5,7 @@ (export sort isort quicksort mergesort) - (import + (import (owl defmac) (owl math) (owl syscall) @@ -17,12 +17,12 @@ ;;; quicksort, never use this, worst case O(n^2) on sorted data ;;; - (define (quicksort op lst) + (define (quicksort op lst) (let loop ((x lst)) - (if (null? x) null - (let ((this (car x))) + (if (null? x) null + (let ((this (car x))) (let diffx ((x (cdr x)) (left null) (right null)) - (cond + (cond ((null? x) (let ((left (loop left))) (append left (cons this (loop right))))) @@ -59,7 +59,7 @@ (else (cons (car a) (merge op (cdr a) b))))) (define (merger op l) - (if (null? l) + (if (null? l) null (let ((a (car l)) (l (cdr l))) (if (null? l) @@ -67,7 +67,7 @@ (let ((b (car l)) (l (cdr l))) (cons (merge op a b) (merger op l))))))) - ; as an optimization to (map (lambda (x) (list x)) l), chunk the list + ; as an optimization to (map list l), chunk the list ; initially to lists using insertion sort steps (define chunk-size 10) @@ -89,7 +89,7 @@ (merge-pairs op (merger op l)))) (define (mergesort op l) - (if (null? l) + (if (null? l) null (let ((l (chunker op l null 0))) (if (null? (cdr l)) diff --git a/owl/string.scm b/owl/string.scm index 87165a58..87792810 100644 --- a/owl/string.scm +++ b/owl/string.scm @@ -50,13 +50,13 @@ char-ci=? ; cp cp → bool (temp) ) - (import + (import + (owl defmac) (owl iff) (only (owl syscall) error) (owl unicode) (owl list) (owl list-extra) - (owl defmac) (owl lazy) (owl math)) @@ -81,7 +81,7 @@ ;;; enumerate code points forwards (define (str-iter-leaf str tl pos end) - (if (eq? pos end) + (if (eq? pos end) tl (pair (refb str pos) (lets ((pos u (fx+ pos 1))) @@ -101,7 +101,7 @@ (if (eq? len 0) tl (str-iter-leaf str tl 0 len)))) - (type-string-wide + (type-string-wide (str-iter-wide-leaf str tl 1)) (type-string-dispatch (let loop ((pos 2)) @@ -112,7 +112,7 @@ (else (error "str-iter: not a string: " str)))) - (define (str-iter str) (str-iter-any str null)) + (define str-iter (C str-iter-any null)) ;;; iterate backwards @@ -149,7 +149,7 @@ (else (error "str-iterr: not a string: " str)))) - (define (str-iterr str) (str-iterr-any str null)) + (define str-iterr (C str-iterr-any null)) ;; string folds @@ -160,12 +160,8 @@ (define (hexencode cp tl) (ilist #\\ #\x - (append (render-number cp null 16) + (append (render-number cp null 16) (cons #\; tl)))) - - ;; move these elsewhere - ;(define (number->string n base) - ; (list->string (render-number n null base))) (define (maybe-hexencode char tl) (cond @@ -173,9 +169,9 @@ (hexencode char tl)) ((eq? char 128) (hexencode char tl)) - (else + (else #false))) - + ;; quote just ":s for now (define (encode-quoted-point p tl) (cond @@ -189,8 +185,7 @@ (ilist #\\ #\r tl)) ((eq? p #\tab) (ilist #\\ #\t tl)) - ((maybe-hexencode p tl) => - (lambda (tl) tl)) + ((maybe-hexencode p tl) => self) (else (encode-point p tl)))) @@ -198,7 +193,7 @@ (define (string->bytes str) (str-foldr encode-point null str)) (define (render-string str tl) (str-foldr encode-point tl str)) (define (string->runes str) (str-foldr cons null str)) - (define (render-quoted-string str tl) + (define (render-quoted-string str tl) (str-foldr encode-quoted-point tl str)) @@ -232,7 +227,7 @@ (define (make-chunk rcps len ascii?) (if ascii? - (let ((str (raw (reverse rcps) type-string #false))) + (let ((str (raw (reverse rcps) type-string))) (if str str (error "Failed to make string: " rcps))) @@ -242,7 +237,7 @@ (define (stringify runes out n ascii? chu) (cond ((null? runes) - (finish-string + (finish-string (reverse (cons (make-chunk out n ascii?) chu)))) ; make 4Kb chunks by default ((eq? n 4096) @@ -251,23 +246,23 @@ ((pair? runes) (cond ((and ascii? (< 128 (car runes)) (> n 256)) - ; allow smaller leaf chunks + ; allow smaller leaf chunks (stringify runes null 0 #true (cons (make-chunk out n ascii?) chu))) ((valid-code-point? (car runes)) (let ((rune (car runes))) - (stringify (cdr runes) (cons rune out) (+ n 1) + (stringify (cdr runes) (cons rune out) (+ n 1) (and ascii? (< rune 128)) chu))) (else #false))) (else (stringify (runes) out n ascii? chu)))) ;; (codepoint ..) → string | #false - (define (runes->string lst) + (define (runes->string lst) (stringify lst null 0 #true null)) - (define bytes->string - (o runes->string utf8-decode)) + (define bytes->string + (B runes->string utf8-decode)) ;;; temps @@ -275,14 +270,14 @@ ; figure out how to handle balancing. 234-trees with occasional rebalance? (define (str-app a b) (bytes->string - (render-string a + (render-string a (render-string b null)))) (define (string-eq-walk a b) (cond ((pair? a) (cond - ((pair? b) + ((pair? b) (if (= (car a) (car b)) (string-eq-walk (cdr a) (cdr b)) #false)) @@ -292,7 +287,7 @@ (if (and (pair? b) (= (car b) (car a))) (string-eq-walk (cdr a) (cdr b)) #false))))) - ((null? a) + ((null? a) (cond ((pair? b) #false) ((null? b) #true) @@ -305,7 +300,9 @@ (string-eq-walk (str-iter a) (str-iter b)) #false))) - (define string-append str-app) + (define (string-append . str) + (fold str-app "" str)) + (define string->list string->runes) (define list->string runes->string) @@ -315,19 +312,19 @@ (list->string (list . things))))) (define (c-string str) ; -> bvec | #false - (if (eq? (type str) type-string) + (raw + (str-foldr ;; do not re-encode raw strings. these are normally ASCII strings ;; which would not need encoding anyway, but explicitly bypass it ;; to allow these strings to contain *invalid string data*. This ;; allows bad non UTF-8 strings coming for example from command ;; line arguments (like paths having invalid encoding) to be used ;; for opening files. - (raw (str-foldr cons '(0) str) type-string #false) - (let ((bs (str-foldr encode-point '(0) str))) - ; check that the UTF-8 encoded version fits one raw chunk (64KB) - (if (<= (length bs) #xffff) - (raw bs type-string #false) - #false)))) + (if (eq? (type str) type-string) + cons + encode-point) + '(0) str) + type-string)) (define null-terminate c-string) @@ -359,7 +356,7 @@ (else (walk (cons (car in) rout) (cdr in))))) (walk null lst)) - + (define (str-replace str pat val) (runes->string (replace-all @@ -371,13 +368,10 @@ (runes->string (lmap op (str-iter str)))) - (define (str-rev str) - (runes->string - (str-iterr str))) - - (define (i x) x) + (define str-rev + (B runes->string str-iterr)) - (define string-copy i) + (define string-copy self) ;; going as per R5RS (define (substring str start end) @@ -388,14 +382,14 @@ (error "substring: negative start: " start)) ((< end start) (error "substring: bad interval " (cons start end))) - (else + (else (list->string (ltake (ldrop (str-iter str) start) (- end start)))))) ;; lexicographic comparison with end of string < lowest code point ;; 1 = sa smaller, 2 = equal, 3 = sb smaller (define (str-compare cook sa sb) (let loop ((la (cook (str-iter sa))) (lb (cook (str-iter sb)))) - (lets + (lets ((a la (uncons la #false)) (b lb (uncons lb #false))) (cond @@ -407,10 +401,10 @@ ;; iff of codepoint → codepoint | (codepoint ...), the first being equal to (codepoint) (define char-fold-iff - (fold - (λ (iff node) - (if (= (length node) 2) - (iput iff (car node) (cadr node)) + (fold + (λ (iff node) + (if (= (length node) 2) + (iput iff (car node) (cadr node)) (iput iff (car node) (cdr node)))) #empty char-folds)) @@ -426,7 +420,7 @@ (llref (str-iter str) p)) (define (upcase ll) - (lets + (lets ((cp ll (uncons ll #false))) (if cp (let ((cp (iget char-fold-iff cp cp))) @@ -439,7 +433,7 @@ ;; fixme: incomplete, added because needed for ascii range elsewhere (define (char-ci=? a b) - (or (eq? a b) + (or (eq? a b) (= (iget char-fold-iff a a) (iget char-fold-iff b b)))) @@ -447,10 +441,10 @@ (define string=? string-eq?) (define (string-ci=? a b) (eq? 2 (str-compare upcase a b))) - (define (string? a b) (eq? 3 (str-compare i a b))) - (define (string>=? a b) (not (eq? 1 (str-compare i a b)))) + (define (string? a b) (eq? (str-compare self a b) 3)) + (define (string>=? a b) (not (eq? (str-compare self a b) 1))) (define (string-ci=? a b) (not (eq? 1 (str-compare upcase a b)))) (define (str-iter-bytes str) - (ledit + (ledit (lambda (codepoint tl) (if (lesser? codepoint #x80) (cons codepoint tl) (encode-point codepoint tl))) (str-iter str))) - - (define (make-string n char) - (list->string (repeat char n))))) + (define (make-string n char) + (list->string (repeat char n))) +)) diff --git a/owl/symbol.scm b/owl/symbol.scm index b1294bc5..0ee897a0 100644 --- a/owl/symbol.scm +++ b/owl/symbol.scm @@ -2,26 +2,41 @@ ;;; Symbols ;;; - (define-library (owl symbol) - (export symbol? symbol->string) + (export + string->symbol + symbol? + symbol=? + symbol->string + render-symbol) (import (owl defmac) + (only (owl list) all) (owl string) - (only (owl syscall) error)) + (only (owl syscall) error interact)) (begin - (define (symbol? x) (eq? (type x) type-symbol)) - - (define (symbol->string x) - (if (eq? (type x) type-symbol) - (let ((str (ref x 1))) - (cond - ((string=? str "") - "||") ;; make empty symbols less invisible - ((m/ / str) ;; fixme: doesn't quote internal |:s yet - (string-append (string-append "|" str) "|")) - (else str))) - (error "Not a symbol: " x))))) + + (define string->symbol + (H interact 'intern)) + + (define (symbol? x) + (eq? (type x) type-symbol)) + + (define (symbol=? x . lst) + (and (symbol? x) (all (C eq? x) lst))) + + (define (symbol->string x) + (if (symbol? x) + (ref x 1) + (error "Not a symbol: " x))) + + (define (render-symbol sym tl) + (let ((str (ref sym 1))) + (cond + ((string=? str "") (ilist #\| #\| tl)) + ((m/ / str) (cons #\| (render-string str (cons #\| tl)))) + (else (render-string str tl))))) +)) diff --git a/owl/sys.scm b/owl/sys.scm index e0b1af35..355ef850 100644 --- a/owl/sys.scm +++ b/owl/sys.scm @@ -1,30 +1,42 @@ -;;; -;;; Extra IO etc exposed via the sys-prim -;;; - -;; Adding some extra system primops to see how much could be added while -;; still keeping the generated .c code portable, win32 being the main -;; reason for worry. +;;; Owl sys library exports various operating system calls and helper +;;; functions for using them. (define-library (owl sys) (export dir-fold dir->list dir->list-all + errno + strerror exec fork + pipe wait - chdir + waitpid kill getenv setenv + unsetenv + umask + getcwd + chdir + readlink + symlink + link + rename unlink rmdir + mknod mkdir - lseek + mkfifo + stat directory? file? - seek-pos + chmod + chown + lseek + seek-current + seek-set seek-end sighup signint @@ -37,16 +49,33 @@ sigpipe sigalrm sigterm + O_RDONLY + O_WRONLY + O_APPEND + O_CREAT + O_TRUNC stdin stdout stderr - fopen - fclose - - set-terminal-rawness) + stdio? + close + fcntl + open + dupfd + read + write + port->non-blocking + set-terminal-rawness + mem-string ;; pointer to null terminated string → raw string + mem-strings ;; **string → (raw-string ...) + ;peek-word ;; these are mainly for internal (owl sys) use + ;peek-byte ;; + get-environment + ) (import (owl defmac) + (owl eof) (owl string) (owl math) (owl equal) @@ -57,22 +86,244 @@ (begin - ;; standard io ports + (define-syntax sc + (syntax-rules (sys-const) + ((sc name index) (define name (sys-const index))))) + + (define (sys-const i) + (lambda () (sys-prim 8 i #f #f))) + (define stdin (fd->port 0)) (define stdout (fd->port 1)) (define stderr (fd->port 2)) + (define stdio? (H has? (list stdin stdout stderr))) - ;; use type 12 for fds - - (define (fclose fd) - (sys-prim 2 fd #false #false)) - - (define (fopen path mode) + ;; owl value → value processable in vm (mainly string conversion) + (define (sys-arg x) (cond - ((c-string path) => - (λ (raw) (sys-prim 1 raw mode #false))) - (else #false))) - + ((string? x) + ;; strings should generally be null-terminated + (c-string x)) + (else x))) + + ;; call fixed arity prim-sys instruction with converted arguments + (define sys + (case-lambda + ((op) + (sys-prim op #f #f #f)) + ((op a) + (sys-prim op (sys-arg a) #f #f)) + ((op a b) + (sys-prim op (sys-arg a) (sys-arg b) #f)) + ((op a b c) + (sys-prim op (sys-arg a) (sys-arg b) (sys-arg c))))) + + (define (n-byte-machine) + (sys 8 1)) + + (define (peek-byte ptr) + (sys 41 ptr 1)) + + (define (peek-word ptr) + (sys 41 ptr)) + + (define (mem-string-bytes ptr) + (let ((this (peek-byte ptr))) + (if (eq? this 0) + null + (cons this (mem-string-bytes (+ ptr 1)))))) + + (define raw-string + (C raw type-string)) + + (define (mem-string ptr) + (if (eq? ptr 0) + #false + (raw-string + (mem-string-bytes ptr)))) + + (define (mem-array-map ptr func) + (if (eq? ptr 0) + #false + (let ((nb (n-byte-machine))) + (let loop ((ptr ptr)) + (let ((next (peek-word ptr))) + (if (eq? next 0) + null + (cons + (func next) + (loop (+ ptr nb))))))))) + + (define mem-strings + (C mem-array-map mem-string)) + + (sc E2BIG 9) + (sc EACCES 10) + (sc EADDRINUSE 11) + (sc EADDRNOTAVAIL 12) + (sc EAFNOSUPPORT 13) + (sc EAGAIN 14) + (sc EALREADY 15) + (sc EBADF 16) + (sc EBADMSG 17) + (sc EBUSY 18) + (sc ECANCELED 19) + (sc ECHILD 20) + (sc ECONNABORTED 21) + (sc ECONNREFUSED 22) + (sc ECONNRESET 23) + (sc EDEADLK 24) + (sc EDESTADDRREQ 25) + (sc EDOM 26) + (sc EDQUOT 27) + (sc EEXIST 28) + (sc EFAULT 29) + (sc EFBIG 30) + (sc EHOSTUNREACH 31) + (sc EIDRM 32) + (sc EILSEQ 33) + (sc EINPROGRESS 34) + (sc EINTR 35) + (sc EINVAL 36) + (sc EIO 37) + (sc EISCONN 38) + (sc EISDIR 39) + (sc ELOOP 40) + (sc EMFILE 41) + (sc EMLINK 42) + (sc EMSGSIZE 43) + (sc EMULTIHOP 44) + (sc ENAMETOOLONG 45) + (sc ENETDOWN 46) + (sc ENETRESET 47) + (sc ENETUNREACH 48) + (sc ENFILE 49) + (sc ENOBUFS 50) + (sc ENODATA 51) + (sc ENODEV 52) + (sc ENOENT 53) + (sc ENOEXEC 54) + (sc ENOLCK 55) + (sc ENOLINK 56) + (sc ENOMEM 57) + (sc ENOMSG 58) + (sc ENOPROTOOPT 59) + (sc ENOSPC 60) + (sc ENOSR 61) + (sc ENOSTR 62) + (sc ENOSYS 63) + (sc ENOTCONN 64) + (sc ENOTDIR 65) + (sc ENOTEMPTY 66) + (sc ENOTRECOVERABLE 67) + (sc ENOTSOCK 68) + (sc ENOTSUP 69) + (sc ENOTTY 70) + (sc ENXIO 71) + (sc EOPNOTSUPP 72) + (sc EOVERFLOW 73) + (sc EOWNERDEAD 74) + (sc EPERM 75) + (sc EPIPE 76) + (sc EPROTO 77) + (sc EPROTONOSUPPORT 78) + (sc EPROTOTYPE 79) + (sc ERANGE 80) + (sc EROFS 81) + (sc ESPIPE 82) + (sc ESRCH 83) + (sc ESTALE 84) + (sc ETIME 85) + (sc ETIMEDOUT 86) + (sc ETXTBSY 87) + (sc EWOULDBLOCK 88) + (sc EXDEV 89) + + (define (errno) + (sys 9 0)) + + (define (strerror errnum) + (mem-string (sys 14 errnum))) + + (sc O_EXEC 93) + (sc O_RDONLY 94) + (sc O_RDWR 95) + (sc O_SEARCH 96) + (sc O_WRONLY 97) + (sc O_APPEND 98) + (sc O_CLOEXEC 99) + (sc O_CREAT 100) + (sc O_DIRECTORY 101) + (sc O_DSYNC 102) + (sc O_EXCL 103) + (sc O_NOCTTY 104) + (sc O_NOFOLLOW 105) + (sc O_NONBLOCK 106) + (sc O_RSYNC 107) + (sc O_SYNC 108) + (sc O_TRUNC 109) + (sc O_TTY_INIT 110) + (sc O_ACCMODE 111) + (sc FD_CLOEXEC 112) + (sc F_DUPFD 113) + (sc F_DUPFD_CLOEXEC 114) + (sc F_GETFD 115) + (sc F_SETFD 116) + (sc F_GETFL 117) + (sc F_SETFL 118) + (sc F_GETOWN 119) + (sc F_SETOWN 120) + (sc F_GETLK 121) + (sc F_SETLK 122) + (sc F_SETLKW 123) + (sc F_RDLCK 124) + (sc F_UNLCK 125) + (sc F_WRLCK 126) + + (define (close fd) + (sys 2 fd)) + + (define (fcntl port cmd arg) + (sys 15 port cmd arg)) + + (define (toggle-file-status-flag port flag on?) + (if-lets ((flags (fcntl port (F_GETFL) 0))) + (or + (eq? (band flags flag) (if on? flag 0)) + (fcntl port (F_SETFL) (bxor flags flag))))) + + (define (port->non-blocking port) + (if port + (toggle-file-status-flag port (O_NONBLOCK) (not (stdio? port)))) + port) + + (define (open path flags mode) + (port->non-blocking (sys 1 path flags mode))) + + ;; → (fixed ? fd == new-fd : fd >= new-fd) | #false + (define (dupfd port new-fd fixed?) + (let ((port + (if fixed? + (sys 30 port new-fd) + (let ((fd (fcntl port (F_DUPFD) new-fd))) + (and fd (fd->port fd)))))) + (if (stdio? port) + (toggle-file-status-flag port (O_NONBLOCK) #f)) + port)) + + (define (read port len) + (or + (sys 5 port len) + (let ((err (errno))) + (or (eq? (EAGAIN) err) (eq? (EWOULDBLOCK) err))))) + + (define (write port data len) + (or + (sys 0 port data len) + (and + (let ((err (errno))) + (or (eq? (EAGAIN) err) (eq? (EWOULDBLOCK) err))) + 0))) ;;; ;;; Unsafe operations not to be exported @@ -80,36 +331,22 @@ ;; string → #false | unsafe-dirptr (define (open-dir path) - (let ((cs (c-string path))) - (if (and cs (<= (string-length cs) #xffff)) - (sys-prim 11 cs #false #false) - #false))) + (sys 11 path)) - (define (directory? path) - (if (string? path) - (let ((dfd (open-dir path))) - (if dfd - (begin (fclose dfd) #true) - #false)) - #false)) - - (define (file? path) - (let ((fd (fopen path 0))) - (if fd - (begin (fclose fd) #true) - #false))) - - ;; unsafe-dirfd → #false | eof | bvec + ;; unsafe-dirfd → #false | eof | raw-string (define (read-dir obj) - (sys-prim 12 obj #false #false)) + (and + (integer? obj) + (or + (mem-string (sys 12 obj)) + (and (zero? (errno)) (eof-object))))) - ;; _ → #true (define (close-dir obj) - (sys-prim 13 obj #false #false)) + (sys 13 obj)) - ;;; + ;;; ;;; Safe derived operations - ;;; + ;;; ;; dir elements are #false or fake strings, which have the type of small raw ASCII ;; strings, but may in fact contain anything the OS happens to allow in a file name. @@ -119,7 +356,7 @@ (if dfd (let loop ((st st)) (let ((val (read-dir dfd))) - (if (eof? val) + (if (eof-object? val) (begin (close-dir dfd) st) @@ -128,54 +365,61 @@ ;; no dotfiles (define (dir->list path) - (dir-fold - (λ (seen this) + (dir-fold + (λ (seen this) (if (eq? #\. (refb this 0)) seen (cons this seen))) - null path)) + null path)) ;; everything reported by OS (define (dir->list-all path) - (dir-fold + (dir-fold (λ (seen this) (cons this seen)) - null path)) - - (define (chdir path) - (let ((path (c-string path))) - (and path - (sys-prim 20 path #false #false)))) + null path)) - ;;; + ;;; ;;; Processes - ;;; + ;;; ;; path (arg0 ...), arg0 customarily being path ;; returns only if exec fails + ;; list->tuple + internal conversion might also be worth doing in sys-arg instead (define (exec path args) - (lets - ((path (c-string path)) - (args (map c-string args))) - (if (and path (all (λ (x) x) args)) - (sys-prim 17 path args #false) - (cons path args)))) + (lets ((args (map c-string args))) + (if (all self args) + (sys 17 path args) + #false))) + + ;; → #false on failure, else '(read-port . write-port) + (define (pipe) + (let ((ports (sys 31))) + (if (pair? ports) + (begin + (port->non-blocking (car ports)) + (port->non-blocking (cdr ports)))) + ports)) ;; → #false = fork failed, #true = ok, we're in child, n = ok, child pid is n (define (fork) - (sys-prim 18 #false #false #false)) + (let ((pid (sys 18))) + (or (eq? pid 0) pid))) - (define (wait pid) - (let ((res (sys-prim 19 pid (cons #false #false) #false))) + ;; warning, easily collides with owl wait + (define (waitpid pid) + (let ((res (sys 19 pid (cons #false #false)))) (cond ((not res) res) ((eq? res #true) (interact 'iomux (tuple 'alarm 100)) - (wait pid)) - (else + (waitpid pid)) + (else ;; pair of ( . ) res)))) + (define wait waitpid) + (define sighup 1) ; hangup from controlling terminal or proces (define signint 2) ; interrupt (keyboard) (define sigquit 3) ; quit (keyboard) @@ -190,53 +434,134 @@ ;; pid signal → success? (define (kill pid signal) - (sys-prim 21 pid signal #false)) + (sys 21 pid signal)) + + ;;; + ;;; Filesystem operation + ;;; + + (sc S_IFMT 0) + (sc S_IFBLK 2) + (sc S_IFCHR 3) + (sc S_IFIFO 4) + (sc S_IFREG 5) + (sc S_IFDIR 6) + (sc S_IFLNK 7) + (sc S_IFSOCK 8) + + (define (umask mask) + (sys 37 mask)) + + (define (getcwd) + (sys 36)) + + (define (chdir path) + (sys 20 path)) + + (define (readlink path) + (sys 35 path)) + + (define (symlink src dst) + (sys 34 src dst)) + + (define (link src dst) + (sys 33 src dst)) + + (define (rename src dst) + (sys 32 src dst)) (define (unlink path) - (sys-prim 22 path #false #false)) - + (sys 22 path)) + (define (rmdir path) - (sys-prim 23 path #false #false)) + (sys 23 path)) + + (define (mknod path type mode dev) + (sys 24 path (cons type mode) dev)) (define (mkdir path mode) - (sys-prim 24 path mode #false)) + (mknod path (S_IFDIR) mode 0)) + + (define (mkfifo path mode) + (mknod path 0 mode 0)) - (define seek/set 0) ;; set position to pos - (define seek/cur 1) ;; increment position by pos - (define seek/end 2) ;; set position to file end + pos + (define (stat arg follow) + (zip cons + '(dev ino mode nlink uid gid rdev size atim mtim ctim blksize blocks) + (sys 38 arg follow))) - (define (lseek fd pos whence) - (sys-prim 25 fd pos whence)) + (define (file-type? path type) + (let ((mode (getq (stat path #t) 'mode))) + (and mode (= (band (S_IFMT) (cdr mode)) type)))) - (define (seek-end fd) - (lseek fd 0 seek/end)) + (define (directory? path) + (file-type? path (S_IFDIR))) + + (define (file? path) + (file-type? path (S_IFREG))) - (define (seek-pos fd pos) - (lseek fd pos seek/set)) + (define (chmod arg mode follow) + (sys 39 arg mode follow)) + + (define (chown arg uid gid follow) + (sys 40 arg (cons uid gid) follow)) + + (sc SEEK_SET 90) + (sc SEEK_CUR 91) + (sc SEEK_END 92) + + (define (lseek port pos whence) + (sys 25 port pos whence)) + + (define (seek-end port) + (lseek port 0 (SEEK_END))) + + (define (seek-current port) + (lseek port 0 (SEEK_CUR))) + + (define (seek-set port pos) + (lseek port pos (SEEK_SET))) ;;; ;;; Environment variables ;;; - ;; str → bvec | F (define (getenv str) - (let ((str (c-string str))) - (if str - (let ((bvec (sys-prim 16 str #false #false))) - (if bvec - (bytes->string (vec->list bvec)) - #false)) - #false))) + (mem-string (sys 16 str))) (define (setenv var val) - (sys-prim 28 (c-string var) (c-string val) #false)) + (sys 28 var val)) + (define (unsetenv var) + (sys 28 var)) - ;;; + (define (get-environment-pointer) + (sys 9 1)) + + (define (split-env-value bytes) + (let loop ((l null) (r bytes)) + (cond + ((null? r) + (values (reverse l) null)) + ((eq? (car r) #\=) + (values (reverse l) (cdr r))) + (else + (loop (cons (car r) l) (cdr r)))))) + + ;; ((keystr . valstr) ...) + (define (get-environment) + (mem-array-map + (get-environment-pointer) + (λ (ptr) + (lets ((k v (split-env-value (mem-string-bytes ptr)))) + (cons + (raw-string k) + (raw-string v)))))) + + ;;; ;;; terminal control - ;;; - + ;;; + (define (set-terminal-rawness bool) - (sys-prim 26 bool #f #f)) - - )) + (sys 26 bool)) +)) diff --git a/owl/syscall.scm b/owl/syscall.scm index 6ded9b8a..6f639ce0 100644 --- a/owl/syscall.scm +++ b/owl/syscall.scm @@ -1,14 +1,15 @@ (define-library (owl syscall) (export - syscall error interact fork accept-mail wait-mail check-mail + syscall error interact accept-mail wait-mail check-mail exit-owl release-thread catch-thread set-signal-action - single-thread? kill mail fork-linked-server fork-server - return-mails fork-server fork-linked fork-named exit-thread exit-owl + single-thread? kill link mail + return-mails fork-named exit-thread exit-owl poll-mail-from start-profiling stop-profiling running-threads par* - par por* por) + par por* por + thread thunk->thread) - (import + (import (owl defmac) (owl primop)) @@ -22,13 +23,7 @@ ;; 3 = vm thrown error (define (fork-named name thunk) - (syscall 4 (list name) thunk)) - - (define (fork-linked name thunk) - (syscall 4 (list name 'link) thunk)) - - (define (fork-server name handler) - (syscall 4 (list name 'mailbox) handler)) + (syscall 4 name thunk)) (define (error reason info) (syscall 5 reason info)) @@ -36,21 +31,18 @@ (define (return-mails rmails) (syscall 6 rmails rmails)) - (define (fork-linked-server name handler) - (syscall 4 (list name 'mailbox 'link) handler)) - (define (running-threads) (syscall 8 #false #false)) (define (mail id msg) (syscall 9 id msg)) - (define (kill id) + (define (kill id) (syscall 15 id #false)) (define (single-thread?) (syscall 7 #true #true)) - + (define (set-signal-action choice) (syscall 12 choice #false)) @@ -78,14 +70,14 @@ (let loop ((rss (par* ts))) (cond ((null? rss) #false) - ((car rss) => (λ (result) result)) + ((car rss) => self) (else (loop ((cdr rss))))))) - + (define-syntax por (syntax-rules () ((por exp ...) (por* (list (λ () exp) ...))))) - + (define (wait-mail) (syscall 13 #false #false)) (define (check-mail) (syscall 13 #false #true)) @@ -115,7 +107,7 @@ (if (eq? rounds 0) (return-from-wait default spam) ;; no mail, request a thread switch and recurse, at which point all other threads have moved - (begin + (begin ;(set-ticker 0) ;; FIXME restore this when librarized ;; no bignum math yet at this point (lets ((rounds _ (fx- rounds 1))) @@ -126,17 +118,31 @@ (else ;; got spam, keep waiting (loop (check-mail) (cons envp spam) rounds))))) - - - (define (fork thunk) - ; the tuple is fresh and therefore a proper although rather - ; nondescriptive thread name - (fork-named (tuple 'anonimas) thunk)) - - ; Message passing (aka mailing) is asynchronous, and at least - ; in a one-core environment order-preserving. interact is like - ; mail, but it blocks the thread until the desired response + (define thunk->thread + (case-lambda + ((id thunk) + (fork-named id thunk)) + ((thunk) + ;; get a fresh name unless otherwise specified + (fork-named (tuple 'anonimas) thunk)))) + + (define fork thunk->thread) + + (define-syntax thread + (syntax-rules (quote) + ((thread id val) + (thunk->thread id (lambda () val))) + ((thread val) + (thunk->thread (lambda () val))))) + + ;; (thread (op . args)) → id + ;; (wait-thread (thread (op . args)) [default]) → value + ;; thread scheduler should keep the exit value + + ; Message passing (aka mailing) is asynchronous, and at least + ; in a one-core environment order-preserving. interact is like + ; mail, but it blocks the thread until the desired response ; arrives. Messages are of the form #( ). (define (interact whom message) @@ -148,4 +154,8 @@ (define (stop-profiling) (syscall 21 #true #true)) + + (define (link id) + (syscall 23 id id)) + )) diff --git a/owl/test.scm b/owl/test.scm deleted file mode 100644 index 2192e1f4..00000000 --- a/owl/test.scm +++ /dev/null @@ -1,124 +0,0 @@ -;;; -;;; A simple algorithm benchmarking/correctness library -;;; - -; todo -; - compare should show 2.21x instead of percentage -; - and a logarithmically scaled chart with ansi colors -; - [ ****| ] 2.21x (avg 1.91x) - rand -; - [ *****| ] 2.31x (avg 1.92x) - dec -; - [ |* ] -0.19x (avg 1.92x) - ord -; - [ **| ] 1.02 (avg 1.92x) - rand - -(define-module lib-test - (export - test ; vals x a x b -> simple comparison (equality and speed), show stats and return on differences - compare ; ((msg . val) ...) fn1 fn2 -> speed (and result equivalence) test - time ; timing macro for single-valued computations - elapsed-ms ; thunk -> ms + val - ) - - ;(import-old lib-lazy) - - (define (elapsed-ms thunk) ; -> ms + value - (lets - ((start (time-ms)) - (result (thunk)) - (elapsed (- (time-ms) start))) - (values elapsed result))) - - (define-syntax time - (syntax-rules () - ((time op) - (time op "elapsed time: ")) - ((time op comment ...) - (lets ((ms val (elapsed-ms (lambda () op)))) - (for-each display (list comment ...)) - (print ms "ms") - val)))) - - (define (percentage ams bms) - (cond - ((= bms 0) 0) - ((> ams bms) (- 0 (percentage bms ams))) - (else (floor (* 100 (/ (- bms ams) bms)))))) - - (define (score-of a b) - (cond - ((<= (+ a b) 2) 0) ; too little to be of interest - ((< a b) - (if (= a 0) - 100 - (- (floor (* 100 (/ b a))) 100))) - ((= a b) 0) - (else - (- 0 (score-of b a))))) - - (define (try a b txt val total) ; -> (n-tests+1 . n-avg') - (lets ((n-tests a-total b-total total)) - (if (list? txt) - (for-each display txt) - (display txt)) - (flush-port 1) - (lets - ((ams av (elapsed-ms (lambda () (a val)))) - (bms bv (elapsed-ms (lambda () (b val)))) - (n-tests (+ 1 n-tests)) - (a-total (+ a-total ams)) - (b-total (+ b-total bms)) - (score (score-of ams bms))) - (print* (list " at " ams "ms vs " bms "ms, " - " first is " score "% better (average " (score-of a-total b-total) "%)")) - (if (equal? av bv) - (tuple n-tests a-total b-total) - (error "results differ" (list val 'gives av 'and bv)))))) - - (define (compare cases a b) - (lfold - (lambda (total val) - (try a b (car val) (cdr val) total)) - (tuple 0 0 0) cases)) - - (define (test cases a b) - (print "Testing ops:") - (call/cc - (λ (ret) - (lfold - (λ (stats case) - (lets - ((ams bms stats) - (elapsed-a this-a (elapsed-ms (λ () (a case)))) - (elapsed-b this-b (elapsed-ms (λ () (b case))))) - (print* - (list " " (div (* (max ams bms) 100) (max 1 (min ams bms))) "% diff in total " ams "ms/" bms "ms, here " - elapsed-a "ms/" elapsed-b "ms")) - (if (equal? this-a this-b) - (tuple (+ ams elapsed-a) (+ bms elapsed-b)) - (begin - (print "results differ for " case) - (ret (list 'a this-a 'b this-b)))))) - (tuple 0 0) cases)))) - - ;; examples for quick checks speed/correctness tests (with test) - ; - ;(import-old lib-random) - ;(test - ; (lmap (λ (i) (lets ((rst n (rand i 10000000))) n)) (lnums 1)) - ; (λ (n) (prime? n)) - ; (λ (n) (let ((f (factor n))) (and (null? (cdr f)) (= 1 (cdar f)))))) - - ;(define nums (iota 0 1 100000)) - ;(define ff (fold (λ (ff n) (put ff n n)) #false nums)) - ;(test - ; (lmap (λ (i) (lets ((rst n (rnd (seed->rands i) #x10000))) n)) (lnums 1)) - ; (λ (n) (fold (λ (ff i) (fupd ff i i)) ff nums)) - ; (λ (n) (fold (λ (ff i) (put ff i i)) ff nums))) - - ;(import-old lib-random) - ;(test - ; (lmap (λ (i) (lets ((rst n (rand i 10000))) n)) (lnums 1)) - ; (λ (n) (<< 1 n)) - ; (λ (n) (expt 2 n))) -) - - diff --git a/owl/thread.scm b/owl/thread.scm index 34912314..a6100e5a 100644 --- a/owl/thread.scm +++ b/owl/thread.scm @@ -2,21 +2,19 @@ ;;; Thread controller ;;; -;; thread controller is like the kernel of owl lisp. it handles -;; activation and suspension of threads, and has a tuple of +;; thread controller is like the kernel of owl lisp. it handles +;; activation and suspension of threads, and has a tuple of ;; functions which are like the system calls, via which a thread -;; send requests via the thread scheduler to other threads or +;; send requests via the thread scheduler to other threads or ;; the underlying system. -;; todo: make it a bug to send mail to a thread having no inbox. - (define-library (owl thread) - (export + (export start-thread-controller - thread-controller + thread-controller repl-signal-handler - try) + try-thunk try) (import (owl defmac) @@ -44,20 +42,18 @@ (let ((st (get state to #false))) (cond ((pair? st) ;; currently working, leave a mail to inbox queue - (values (fupd state to (qsnoc envelope st)) #false)) - ((not st) ;; no current state, start the server + leave first mail - ;(print-to stderr "No inbox for " to " for mail from " (ref envelope 1)) - ;(values - ; (put state to (qcons envelope qnull)) - ; (tuple to to)) - ;; drop mail to non-receptive thread - (values state #false)) - (else ;; activate the state function - (values + (values + (fupd state to (qsnoc envelope st)) + #false)) + ((not st) ;; no current state, message to an inbox + (values + (put state to (qcons envelope qnull)) + #false)) + (else ;; thread was waiting activate it + (values (fupd state to qnull) ;; leave an inbox (tuple to (λ () (st envelope)))))))) ;; activate it - (define (deliver-messages todo done state subs msg tc) (if (null? subs) (tc tc todo done state) @@ -71,15 +67,15 @@ (define (subscribers-of state id) (get (get state link-tag empty) id null)) - ; remove the thread and report to any interested parties about the event + ; remove the thread and report to any interested parties about the event (define (drop-delivering todo done state id msg tc) (let ((subs (subscribers-of state id))) (if (null? subs) (begin ;; no threads were waiting for something that is being removed, so tell stderr about it - ;(print*-to stderr "VM: thread " id " exited due to " msg) + ;(print*-to stderr "VM: thread " id " exited") (tc tc todo done (del state id))) - (deliver-messages todo done + (deliver-messages todo done (del (fupd state link-tag (del (get state link-tag empty) id)) id) subs msg tc)))) @@ -88,20 +84,20 @@ (cond ((null? lst) lst) ((eq? (ref (car lst) 1) tid) (cdr lst)) - (else - (cons (car lst) + (else + (cons (car lst) (drop-from-list (cdr lst) tid))))) - ; drop a possibly running thread and notify linked + ; drop a possibly running thread and notify linked (define (drop-thread id todo done state msg tc) ; -> todo' x done' x state' - (drop-delivering + (drop-delivering (drop-from-list todo id) (drop-from-list done id) state id msg tc)) ; l id → #false|thread l', O(n) running threads (define (catch-thread l id) - (if (null? l) + (if (null? l) (values #false l) (let ((this (car l))) (if (eq? id (ref this 1)) @@ -111,7 +107,7 @@ (define return-value-tag "rval") ; a unique key if thread state ff - ; mcp syscalls grab the functions from here to transform the state + ; mcp syscalls grab the functions from here to transform the state ;; syscalls used when profiler is running (define mcp-syscalls-during-profiling @@ -125,48 +121,33 @@ ; 2, thread finished, drop (λ (id a b c todo done state tc) ; (system-println "mcp: syscall 2 -- thread finished") - (drop-delivering todo done state id + (drop-delivering todo done state id (tuple id (tuple 'finished a b c)) tc)) ; 3, vm thrown error (λ (id a b c todo done state tc) ;(system-println "mcp: syscall 3 -- vm error") - ;; set crashed exit value proposal - (let ((state (put state return-value-tag 127))) - (drop-delivering todo done state id + ;; set crashed exit value proposal + (let ((state (put state return-value-tag 126))) + (drop-delivering todo done state id (tuple id (tuple 'crashed a b c)) tc))) - + ; 4, fork - (λ (id cont opts thunk todo done state tc) - (lets - ((new-id (car opts)) - (todo (ilist (tuple new-id thunk) (tuple id (λ () (cont new-id))) todo)) - (state - (fold - (λ (state req) - (cond - ((eq? req 'link) - ;; forker wants to receive any issues the thread runs into - (let ((links (get state link-tag empty))) - (put state link-tag - (put links new-id (list id))))) - ((eq? req 'mailbox) - ;; the thread should have a mailbox for communication in state - (put state new-id qnull)) - (else - (system-println "fork: bad parameter") - state))) - state (cdr opts)))) - (tc tc todo done state))) + (λ (id cont new-id thunk todo done state tc) + (tc tc + (ilist + (tuple new-id thunk) + (tuple id (λ () (cont new-id))) + todo) + done state)) ; 5, user thrown error (λ (id a b c todo done state tc) ; (system-println "mcp: syscall 5 -- user poof") - (drop-delivering todo done state id + (drop-delivering todo done state id (tuple id (tuple 'error a b c)) tc)) ;; return mails to my own inbox (in reverse order, newest on top) - ; 6, (return-mails rl) (λ (id cont rmails foo todo done state tc) (let ((queue (get state id qnull))) @@ -175,28 +156,26 @@ ; 7, am i the only thread? (λ (id cont b c todo done state tc) - (tc tc + (tc tc (cons (tuple id (λ () (cont (and (null? todo) (null? done))))) todo) done state)) - + ; 8, get running thread ids (sans self) (λ (id cont b c todo done state tc) - (let + (let ((ids (append - (map (λ (x) (ref x 1)) todo) - (map (λ (x) (ref x 1)) done)))) - (tc tc - (cons + (map (C ref 1) todo) + (map (C ref 1) done)))) + (tc tc + (cons (tuple id (λ () (cont ids))) todo) done state))) ; 9, send mail (λ (id cont to msg todo done state tc) - ;(system-println "syscall 9 - mail") (let ((todo (cons (tuple id (λ () (cont 'delivered))) todo))) - ; send a normal mail (lets ((state waked (deliver-mail state to (tuple id msg)))) (if waked (tc tc (ilist (car todo) waked (cdr todo)) done state) @@ -207,9 +186,9 @@ ; (system-println "syscall 10 - break") (let ((all-threads (cons (tuple id a) (append todo done)))) ;; tailcall signal handler and pass controller to allow resuming operation - ((get state signal-tag signal-halt) ; default to standard mcp + ((get state signal-tag signal-halt) ; default to standard mcp all-threads state thread-controller))) - + ; 11, reset mcp state (usually means exit from mcp repl) (λ (id cont threads state xtodo xdone xstate tc) ; (system-println "syscall 11 - swapping mcp state") @@ -217,7 +196,7 @@ ; 12, set break action (λ (id cont choice x todo done state tc) - (tc tc + (tc tc (cons (tuple id (λ () (cont #true))) todo) done (put state signal-tag choice))) @@ -234,11 +213,11 @@ (tc tc todo done (put state id cont)))))) ;; todo: switch memory limit to a hard one in ovm.c - ; 14, memory limit was exceeded + ; 14, memory limit was exceeded (λ (id a b c todo done state tc) (system-println "syscall 14 - memlimit exceeded, dropping a thread") - ; for now, kill the currently active thread (a bit dangerous) - (drop-delivering todo done state id + ; for now, kill the currently active thread (a bit dangerous) + (drop-delivering todo done state id (tuple id (tuple 'crashed 'memory-limit b c)) tc)) ; 15, drop local thread @@ -279,20 +258,20 @@ ; 19, set return value proposal (λ (id cont b c todo done state tc) (tc tc (cons (tuple id (λ () (cont b))) todo) done (put state return-value-tag b))) - - ;;; 20 & 21 change during profiling + + ;;; 20 & 21 change during profiling ; 20, start profiling, no-op during profiling returning 'already-profiling - (λ (id cont b c todo done state tc) + (λ (id cont b c todo done state tc) (tc tc (cons (tuple id (λ () (cont 'already-profiling))) todo) done state)) - - ; 21, end profiling, resume old ones, pass profiling info - (λ (id cont b c todo done state tc) + + ; 21, end profiling, resume old ones, pass profiling info + (λ (id cont b c todo done state tc) (lets ((prof (get state 'prof #false)) ;; ff storing profiling info (tc (get prof 'tc #false)) ;; normal thread scheduler (prof (del prof 'tc))) ;; give just the collected data to thread - (tc tc (cons (tuple id (λ () (cont prof))) todo) done + (tc tc (cons (tuple id (λ () (cont prof))) todo) done (del state 'prof)))) ; 22, nestable parallel computation @@ -300,6 +279,20 @@ (lets ((por-state (tuple cont opts c))) (tc tc (cons (tuple id por-state) todo) done state))) + + ; 23, link thread + (λ (id cont target c todo done state tc) + (lets + ((links (get state link-tag empty)) + (followers (get links target null)) + (links + (if (has? followers id) + links + (put links target (cons id followers))))) + (tc tc + (cons (tuple id (λ () (cont target))) todo) + done + (put state link-tag links)))) )) ;; todo: add deadlock detection here (and other bad terminal waits) @@ -313,9 +306,9 @@ (else default))) ;; store profiling info about this call - ;; the exec is either a thunk to be run in a thread as a result of - ;; forking or a syscall being answered, or a vm-generated tuple which - ;; has arguments for the next function call and the function at the + ;; the exec is either a thunk to be run in a thread as a result of + ;; forking or a syscall being answered, or a vm-generated tuple which + ;; has arguments for the next function call and the function at the ;; *last* slot of the tuple. (define (update-state state exec) @@ -342,7 +335,7 @@ (if (null? done) (halt-thread-controller state) (self self done null state)) - (lets + (lets ((this todo todo) (id st this) (state (update-state state st)) @@ -352,20 +345,20 @@ (self self todo (cons (tuple id a) done) state) ((ref mcp-syscalls-during-profiling op) id a b c todo done state self))))) ; <- difference here - (scheduler scheduler (cons (tuple id (λ () (cont 'started-profiling))) todo) done + (scheduler scheduler (cons (tuple id (λ () (cont 'started-profiling))) todo) done (put state 'prof ;; profiling data is stored under key 'prof (put empty 'tc tc)))))) ;; store normal scheduler there for resuming on syscall 21 (syscalls (set syscalls 21 ;; end-profiling syscall doesn't do anything when not profiling - (λ (id cont b c todo done state tc) + (λ (id cont b c todo done state tc) (tc tc (cons (tuple id (λ () (cont 'not-profiling-you-fool))) todo) done state))))) syscalls)) (define (enter-mcp controller threads state) ; could break here also when threads is just repl-input (controller controller - (list - (tuple 'mcp + (list + (tuple 'mcp (λ () ((get state signal-tag signal-halt) ; exit by default threads state controller)))) @@ -376,7 +369,7 @@ ;; nested thread steps cause ;; - exit and false -> forget todo & done - ;; - crash -> forget + ;; - crash -> forget ;; st=#(cont todo done) → finished? st' ;; finished? = #f -> new state but no result yet, #t = result found and state is thunk, else error @@ -395,19 +388,19 @@ (if (eq? fini null) ;; crashed, propagate (values null state) - ;; either par->single or single->value state change, + ;; either par->single or single->value state change, ;; but consumed a quantum already so handle it in next round (values #false (tuple cont todo (cons state done))))) (lets ((op a b c (run state thread-quantum))) (cond ((eq? op 1) ;; out of time, a is new state - (values #false + (values #false (tuple cont todo (cons a done)))) ((eq? op 2) ;; finished, return value and thunk to continue computation (values #true (λ () (cont (cons a (λ () (syscall 22 todo done))))))) ((eq? op 22) ;; start nested parallel computation - (lets ((contp a) (todop b) (donep c) + (lets ((contp a) (todop b) (donep c) (por-state (tuple contp todop donep))) (values #false (tuple cont todo (cons por-state done))))) @@ -421,53 +414,47 @@ (if (null? done) (halt-thread-controller state) ;; nothing left to run (self self done null state)) ;; new scheduler round - (lets + (lets ((this todo todo) (id st this)) - (if (eq? (type st) type-tuple) - ;; parallel or node, hunt next slice to run and proceed - (lets ((fini stp (step-parallel st))) - (cond - ((not fini) - ;; no result found yet but options remaining - keep on truckin - (self self todo (cons (tuple id stp) done) state)) - ((eq? fini #true) - ;; some result was found and stp is a thunk to proceed computation - (self self todo (cons (tuple id stp) done) state)) - (else - ;; TODO: something failed and stp is an error code. time to crash. - (print "GONDOR!") - "GONDOR!"))) - (lets ((op a b c (run st thread-quantum))) - (if (eq? op 1) - (self self todo (cons (tuple id a) done) state) - ((ref mcp-syscalls op) id a b c todo done state self))))))) + (lets ((op a b c (run st thread-quantum))) + (if (eq? op 1) + (self self todo (cons (tuple id a) done) state) + ((ref mcp-syscalls op) id a b c todo done state self)))))) (define (start-thread-controller threads state-alist) (thread-controller thread-controller threads null (list->ff state-alist))) - (define (try thunk fail-val) - ; run the compiler chain in a new task + (define (try-thunk thunk fail-fn) (let ((id (list 'thread))) - (fork-linked-server id thunk) - (tuple-case (ref (accept-mail (λ (env) (eq? (ref env 1) id))) 2) - ((finished result not used) - result) + (link id) + (thunk->thread id thunk) + (let ((outcome (ref (accept-mail (λ (env) (eq? (ref env 1) id))) 2))) + (if (eq? (ref outcome 1) 'finished) + (ref outcome 2) + (fail-fn outcome))))) + + (define (default-failure retval) + (λ (outcome) + (tuple-case outcome ((crashed opcode a b) (print-to stderr (verbose-vm-error empty opcode a b)) - fail-val) + retval) ((error cont reason info) - ; note, these could easily be made resumable by storing cont + ;; note: these could be restored via cont (print-to stderr (list->string (foldr render '(10) (list "error: " reason info)))) - fail-val) - (else is bad ;; should not happen - (print-to stderr (list "que? " bad)) - fail-val)))) + retval) + (else + (print-to stderr (list "bug: " outcome)) + retval)))) + + (define (try thunk retval) + (try-thunk thunk (default-failure retval))) - ;; signal handler which kills the 'repl-eval thread if there, or repl + ;; signal handler which kills the 'repl-eval thread if there, or repl ;; if not, meaning we are just at toplevel minding our own business. (define (repl-signal-handler threads state controller) (if (first (λ (x) (eq? (ref x 1) 'repl-eval)) threads #false) diff --git a/owl/time.scm b/owl/time.scm index 9aa6dfe8..c58b7a76 100644 --- a/owl/time.scm +++ b/owl/time.scm @@ -2,7 +2,7 @@ (define-library (owl time) - (export + (export elapsed-real-time timed time @@ -18,7 +18,6 @@ (define (elapsed-real-time thunk) (display "timing: ") - (flush-port 1) (lets ((ss sms (clock)) (res (thunk)) @@ -48,7 +47,7 @@ (define (time) (lets ((ss ms (clock))) ss)) - (define (time-ms) - (lets ((ss ms (clock))) - (+ (* ss 1000) ms))))) - + (define (time-ms) + (lets ((ss ms (clock))) + (+ (* ss 1000) ms))) +)) diff --git a/owl/tuple.scm b/owl/tuple.scm index f9ddc9d6..ec094e22 100644 --- a/owl/tuple.scm +++ b/owl/tuple.scm @@ -1,3 +1,18 @@ +;; Tuples are an early simple data structure for holding multiple values. +;; *You should probably not be using them*. +;; Values are indexed from 1 and there is little error detection +;; apart from range checks. +;; +;; ``` +;; > (define x (list->tuple '(a b c))) +;; > (ref x 1) +;; 'a +;; > (size x) +;; 3 +;; > (equal? x (tuple 'a 'b 'c)) +;; #true +;; ``` + (define-library (owl tuple) (export tuple? diff --git a/owl/unicode.scm b/owl/unicode.scm index cddf5f79..8f10a740 100644 --- a/owl/unicode.scm +++ b/owl/unicode.scm @@ -22,9 +22,9 @@ valid-code-point?) (import + (owl defmac) (except (owl list) render) (owl list-extra) - (owl defmac) (owl lazy) (owl math) (only (owl syscall) error)) @@ -98,7 +98,7 @@ ; grab low 6 bits of a number (define (ext n) - (fxbor extension + (fxbor extension (band n #b111111))) (define (encode-point point tl) @@ -245,16 +245,12 @@ (bor (<< (fxband a #x1f) 6) (fxband b #x3f))) (define (three-byte-point a b c) - (bor (bor (<< (fxband a #x0f) 12) (<< (fxband b #x3f) 6)) + (bor (bor (<< (fxband a #x0f) 12) (<< (fxband b #x3f) 6)) (fxband c #x3f))) (define (four-byte-point a b c d) - (bor - (bor (<< (fxband a #x07) 18) (<< (fxband b #x3f) 12)) + (bor + (bor (<< (fxband a #x07) 18) (<< (fxband b #x3f) 12)) (bor (<< (fxband c #x3f) 6) (fxband d #x3f)))) )) - - - - diff --git a/owl/variable.scm b/owl/variable.scm new file mode 100644 index 00000000..948d7e70 --- /dev/null +++ b/owl/variable.scm @@ -0,0 +1,54 @@ +;;; +;;; Minimal thread-based pseudo-mutable values +;;; + +(define-library (owl variable) + + (export + make-variable + link-variable) + + (import + (owl defmac) + (only (owl syscall) mail interact wait-mail thread thunk->thread) + (owl ff)) + + (begin + + ;; unique value + (define read-msg (list 1)) + + (define (handler id) + (case-lambda + (() (interact id read-msg)) ;; read (sync) + ((val) (mail id (cons 'set val))) ;; write (async) + ((op val) (mail id (cons op val))))) ;; write (async) + + (define (store val) + (lets ((envelope (wait-mail)) + (from msg envelope)) + (if (eq? msg read-msg) + (begin + (mail from val) + (store val)) + (let ((op (car msg))) + (cond + ((eq? op 'set) + (store (cdr msg))) + ((eq? op 'call) + (store ((cdr msg) val))) + (else + (store val))))))) + + (define (start-variable id val) + (thread id (store val)) + (handler id)) + + (define make-variable + (case-lambda + ((id val) (start-variable id val)) + ((id) (start-variable id #false)) + (() (start-variable (list 'var) #false)))) + + (define link-variable handler) +)) diff --git a/owl/vector.scm b/owl/vector.scm index eb7a5d71..fc0b895b 100644 --- a/owl/vector.scm +++ b/owl/vector.scm @@ -71,14 +71,14 @@ merge-chunks ; exported for use in lib-io (may be moved later) make-vector ; n elem → #(elem ...) leaf-data vec-leaf-of - vector-ref + vector-ref vector-length vec-leaves vec-cat ; vec x vec → vec vec-rev *vec-leaf-size*) ; needed for vector IO - (import + (import (owl defmac) (owl lazy) (owl list) @@ -95,7 +95,7 @@ (define *vec-leaf-size* (<< 1 *vec-bits*)) (define *vec-leaf-max* (- *vec-leaf-size* 1)) - (define (byte-vector? x) + (define (byte-vector? x) (eq? (type x) type-vector-raw)) ;;; @@ -115,7 +115,7 @@ (define (vec-dispatch-2 v d) ; -> v' (case (type v) (type-vector-dispatch - (lets + (lets ((p _ (fx>> d *vec-bits*)) (p _ (fx+ p 2))) (ref v p))) @@ -142,19 +142,19 @@ (refb v (fxband n *vec-leaf-max*))) (type-vector-dispatch (vec-ref-digit (ref v 1) n)) ; read the leaf of the node - (type-vector-leaf + (type-vector-leaf (if (eq? n *vec-leaf-max*) (ref v *vec-leaf-size*) (lets ((n _ (fx+ (fxband n *vec-leaf-max*) 1))) (ref v n)))) - (else + (else (error "bad vector node in vec-ref-digit: type " (type v))))) ; find the node holding the last digit and read it (define (vec-ref-big v n) - (vec-ref-digit + (vec-ref-digit (vec-dispatch-2 - (vec-seek v (ncdr n)) + (vec-seek v (ncdr n)) (ncar n)) (ncar n))) @@ -171,11 +171,11 @@ (vec-ref-digit (vec-dispatch-2 v n) (fxband n *vec-leaf-max*))))) (type-int+ (vec-ref-big v n)) - (else + (else (error "vec-ref: bad index: " n)))) ;;; searching the leaves containing a pos - + ;; todo: switch vec-ref to use vec-leaf-of for int+ indeces (define (vec-leaf-big v n) @@ -193,7 +193,7 @@ (else (error "vec-leaf-of: bad index: " n)))) - + ;; others (define (vec-len vec) @@ -215,11 +215,11 @@ ; note, a blank vector must use a raw one, since there are no such things as 0-tuples - (define empty-vector - (raw null type-vector-raw #false)) + (define empty-vector + (raw null type-vector-raw)) - (define (list->byte-vector bs) - (raw bs type-vector-raw #false)) + (define list->byte-vector + (C raw type-vector-raw)) (define (make-leaf rvals n raw?) (if raw? @@ -228,9 +228,9 @@ ;; the leaf contains other values, so need full 4/8-byte descriptors (listuple type-vector-leaf n (reverse rvals)))) - (define (byte? val) - (and - (eq? (type val) type-fix+) + (define (byte? val) + (and + (eq? (type val) type-fix+) (eq? val (fxband val 255)))) ;; list -> list of leaf nodes @@ -256,7 +256,7 @@ ((eq? n 0) (values (reverse taken) l)) (else (loop (cdr l) (- n 1) (cons (car l) taken)))))) - + (define (merge-each l s) (cond ((null? l) null) @@ -303,13 +303,13 @@ (cons here (levels below (* width *vec-leaf-size*)))))) ; everything below the first level branches 256-ways (define (merge-levels lst) - (foldr + (foldr (λ (this below) ;; this = list of leaves which will be as such or in dispatch nodes ;; on this level of the tree ;; below = possible list of nodes up to 256 of which will be attached ;; as subtrees to each leaf of this level, starting from left - (let loop ((below below) (this this)) + (let loop ((below below) (this this)) (cond ((null? below) this) ((null? this) @@ -342,7 +342,7 @@ (subtrees (merge-levels fields))) ;; construct the subtrees (listuple type-vector-dispatch (+ 2 (length subtrees)) (ilist low len subtrees)))))) - + (define (list->vector l) (cond ((null? l) @@ -367,7 +367,7 @@ (if (eq? pos 0) (cons (refb bv pos) tail) (lets - ((byte (refb bv pos)) + ((byte (refb bv pos)) (pos _ (fx- pos 1))) (copy-bvec bv pos (cons byte tail))))) @@ -376,7 +376,7 @@ (if (eq? size 0) null (copy-bvec bv (- size 1) null)))) - + ;;; ;;; Vector iterators ;;; @@ -443,7 +443,7 @@ (define (vec-iter-range v p e) (if (<= e (vec-len v)) (cond - ((< p e) + ((< p e) (iter-range-really v p (- e p))) ((= p e) null) (else (error "vec-iter-range: bad range " (cons p e)))) @@ -453,10 +453,10 @@ ;; todo: vec-iterr could also chunk whole leaves directly with fixnums like vec-iterr (define (iterr-raw-leaf v last tl) - (if (eq? last 0) + (if (eq? last 0) tl (lets ((last (- last 1))) - (cons (refb v last) + (cons (refb v last) (λ () (iterr-raw-leaf v last tl)))))) (define (iterr-leaf v p tl) @@ -469,9 +469,9 @@ (type-vector-dispatch (iterr-any-leaf (ref v 1) tl)) (type-vector-raw (iterr-raw-leaf v (sizeb v) tl)) (type-vector-leaf (iterr-leaf v (size v) tl)) - (else + (else tl))) ; size field in root is a number → skip - + (define (vec-iterr-loop v p) (if (eq? type-fix- (type p)) null @@ -479,7 +479,7 @@ (λ () (vec-iterr-loop v (- p *vec-leaf-size*)))))) (define (vec-iterr v) - (lets + (lets ((end (vec-len v)) (last (band end *vec-leaf-max*))) (cond @@ -487,7 +487,7 @@ (if (eq? end 0) ; blank vector null (vec-iterr-loop v (- end 1)))) ; start from previous leaf - (else + (else (vec-iterr-loop v (- end 1)))))) ;; vector folds @@ -497,7 +497,7 @@ ;; list conversions - (define (vec->list vec) + (define (vec->list vec) (cond ((eq? (type vec) type-vector-raw) ;; convert raw vectors directly to allow this to be used also for large chunks @@ -527,8 +527,7 @@ ;; fixme: proper vec-range not implemented (define (vec-range-naive vec from to) ; O(m log n) - (list->vector - (map (λ (p) (vec-ref vec p)) (iota from 1 to)))) + (list->vector (map (H vec-ref vec) (iota from 1 to)))) (define vec-range vec-range-naive) @@ -553,13 +552,12 @@ (vector->list a) (vector->list b)))) - (define (vec-rev a) - (list->vector - (vec-iterr a))) + (define vec-rev + (B list->vector vec-iterr)) ;; fixme: make-vector does not share the nodes despite most being equal - (define make-vector - (case-lambda + (define make-vector + (case-lambda ((n) (list->vector (repeat #false n))) ((n val) @@ -578,4 +576,3 @@ (define vector-length vec-len) (define vector-ref vec-ref) )) - diff --git a/scheme/base.scm b/scheme/base.scm index 8ea746de..d45512f7 100644 --- a/scheme/base.scm +++ b/scheme/base.scm @@ -1,5 +1,5 @@ (define-library (scheme base) - (export + (export * + - @@ -61,6 +61,7 @@ current-input-port current-output-port define + define-library define-record-type define-syntax define-values @@ -240,18 +241,19 @@ string->integer ;; NOT R7RS but used currently in many places in owl stuff ) - (import + (import (owl defmac) + (owl eof) (owl equal) (owl list) + (only (owl function) procedure?) (only (owl syscall) error) (owl string) (owl primop) (owl math-extra) - (owl intern) (owl vector) (owl port) - (owl symbol) + (only (owl symbol) string->symbol symbol? symbol=? symbol->string) (only (owl sexp) list->number) (owl list-extra) (owl io) @@ -261,26 +263,26 @@ (begin (define-syntax define-symbols - (syntax-rules () - ((define-symbols x ...) - (define-values (x ...) - (values (quote x) ...))))) + (syntax-rules () + ((define-symbols x ...) + (define-values (x ...) + (values (quote x) ...))))) (define-symbols ... => unquote unquote-splicing) - (define-syntax define-missing-bad + (define-syntax define-missing-bad (syntax-rules () ((define-missing-bad name) - (define name + (define name (lambda args (error "Implementation restriction:" (cons (quote name) args))))))) - (define-syntax define-missing-my-bad + (define-syntax define-missing-my-bad (syntax-rules () ((define-missing-my-bad name) - (define name + (define name (lambda args - (error "Currently missing or incompatible:" (cons (quote name) args))))))) + (error "Currently missing or incompatible:" (cons (quote name) args))))))) ;; grr, scheme member functions don't follow the argument conventions of other functions used in owl... @@ -294,17 +296,11 @@ (define memv member) (define (memq x lst) - (cond - ((null? lst) #false) - ((eq? x (car lst)) lst) - (else (memq x (cdr lst))))) + (has? lst x)) + + (define (assq k lst) + (getq lst k)) - (define (assq k l) - (cond - ((null? l) #f) - ((eq? (caar l) k) (car l)) - (else (assq k (cdr l))))) - (define (assv k l) (cond ((null? l) #f) @@ -327,7 +323,7 @@ ;; owl doesn't have inexact numbers, so any argument ;; coming in will always be rational differing by 0 - (define (rationalize n max-delta) n) + (define rationalize K) (define string->number (case-lambda @@ -338,20 +334,15 @@ (define (string->integer str) (let ((n (string->number str 10))) - (cond - ((eq? (type n) type-fix+) n) - ((eq? (type n) type-fix-) n) - ((eq? (type n) type-int+) n) - ((eq? (type n) type-int-) n) - (else #false)))) + (and (integer? n) n))) (define (number->string/base n base) (list->string (render-number n null base))) (define-syntax when - (syntax-rules () - ((when test exp ...) - (if test (begin exp ...))))) + (syntax-rules () + ((when test exp ...) + (if test (begin exp ...))))) (define number->string (case-lambda @@ -381,8 +372,6 @@ (define-missing-bad truncate-quotient) (define-missing-bad textual-port?) (define-missing-bad syntax-rules) - (define-missing-bad symbol=?) - (define-missing-bad symbol->string) (define-missing-bad string-set!) (define-missing-bad string-map) (define-missing-bad string-for-each) @@ -402,7 +391,6 @@ (define-missing-bad read-bytevector) (define-missing-bad raise-continuable) (define-missing-bad raise) - (define-missing-bad procedure?) (define-missing-bad peek-u8) (define-missing-bad peek-char) (define-missing-bad parameterize) @@ -442,8 +430,6 @@ (define-missing-bad error-object?) (define-missing-bad error-object-message) (define-missing-bad error-object-irritants) - (define-missing-bad eof-object?) - (define-missing-bad eof-object) (define-missing-bad else) (define-missing-bad dynamic-wind) (define-missing-bad current-output-port) diff --git a/scheme/complex.scm b/scheme/complex.scm index 01a70227..7f06fcb1 100644 --- a/scheme/complex.scm +++ b/scheme/complex.scm @@ -1,8 +1,16 @@ (define-library (scheme complex) - (import (owl base)) + + (import + (scheme base) + (only (owl defmac) lets) + (only (owl math-extra) sqrt) + (only (owl syscall) error)) + (export angle imag-part magnitude make-polar make-rectangular real-part) + (begin + (define (angle z) (error "angle" "Not supported by the implementation.")) diff --git a/scheme/cxr.scm b/scheme/cxr.scm index 485d3309..d4a714cb 100644 --- a/scheme/cxr.scm +++ b/scheme/cxr.scm @@ -1,16 +1,16 @@ (define-library (scheme cxr) - (import - (owl defmac)) + (import + (scheme base)) - (export - caaar - caadr - cadar + (export + caaar + caadr + cadar caddr - cdaar - cdadr - cddar + cdaar + cdadr + cddar cdddr caaaar caaadr @@ -29,7 +29,7 @@ cdddar cddddr) - (begin + (begin (define (caaar x) (car (car (car x)))) (define (caadr x) (car (car (cdr x)))) (define (cadar x) (car (cdr (car x)))) @@ -54,6 +54,5 @@ (define (cddaar x) (cdr (cdr (car (car x))))) (define (cddadr x) (cdr (cdr (car (cdr x))))) (define (cdddar x) (cdr (cdr (cdr (car x))))) - (define (cddddr x) (cdr (cdr (cdr (cdr x))))))) - - + (define (cddddr x) (cdr (cdr (cdr (cdr x))))) +)) diff --git a/scheme/process-context.scm b/scheme/process-context.scm new file mode 100644 index 00000000..8d28dbb4 --- /dev/null +++ b/scheme/process-context.scm @@ -0,0 +1,41 @@ +(define-library (scheme process-context) + + (import + (scheme base) + (only (owl primop) halt) + (only (owl ff) get) + (only (owl syscall) error) + (only (owl sys) getenv get-environment) + (only (owl variable) link-variable)) + + (export + command-line + emergency-exit + exit + get-environment-variable + get-environment-variables) + + (begin + + ;; link to app state variable started at repl startup + (define owl-state + (link-variable '*state*)) + + (define (command-line) + (get (owl-state) 'command-line-arguments #false)) + + (define (exit . x) + (halt + (if (pair? x) + (let ((x (car x))) (if x (if (integer? x) x 0) 1)) + 0))) + + (define emergency-exit exit) + + (define get-environment-variable + getenv) + + (define get-environment-variables + get-environment) + +)) diff --git a/scheme/write.scm b/scheme/write.scm index d22dc2c9..7fec4656 100644 --- a/scheme/write.scm +++ b/scheme/write.scm @@ -1,10 +1,10 @@ (define-library (scheme write) (import - (owl base) + (scheme base) (only (owl io) display write)) - (export + (export display write write-shared @@ -15,8 +15,5 @@ (define write-shared write) (define (write-simple . x) - (error "implementation restriction: " "write-simple is currently missing")))) - - - - + (error "implementation restriction: " "write-simple is currently missing")) +)) diff --git a/tests/appendfile.scm b/tests/appendfile.scm index 7a1ee391..7218f502 100644 --- a/tests/appendfile.scm +++ b/tests/appendfile.scm @@ -5,8 +5,11 @@ (print "start -> " (file->vector "tmp/app")) +(print "1st size -> " (cdr (assq 'size (stat "tmp/app" #f)))) + (let ((port (open-append-file "tmp/app"))) (print-to port "aaa") + (print "2nd size -> " (cdr (assq 'size (stat port #f)))) (close-port port)) (print "*** + append aaa\\n -> " (file->vector "tmp/app")) diff --git a/tests/appendfile.scm.ok b/tests/appendfile.scm.ok index 540e760f..8f9afd2d 100644 --- a/tests/appendfile.scm.ok +++ b/tests/appendfile.scm.ok @@ -1,5 +1,7 @@ init -> #true start -> #(42 42 42) +1st size -> 3 +2nd size -> 7 *** + append aaa\n -> #(42 42 42 97 97 97 10) truncate + bbb -> #(98 98 98 10) remove -> #true diff --git a/tests/bare.sh b/tests/bare.sh_ similarity index 100% rename from tests/bare.sh rename to tests/bare.sh_ diff --git a/tests/bingo-rand.scm b/tests/bingo-rand.scm index 5df791bc..fc3a5056 100644 --- a/tests/bingo-rand.scm +++ b/tests/bingo-rand.scm @@ -16,7 +16,7 @@ (wait-for msg)))) ;; ff of all numbers -(define wanted +(define wanted (fold (λ (ff n) (put ff n n)) empty (iota 0 1 n))) (define (drop-mails) @@ -38,7 +38,7 @@ (mail 'fini "i has all") (drop-mails)) (else - (lets + (lets ((rst to (rand rst n)) (rst num (rand rst n)) (rst rounds (rand rst 3))) @@ -46,22 +46,19 @@ (wait rounds) (loop wanted rst))))))) -(fork-server 'fini - (λ () +(thread 'fini + (begin (print (ref (wait-mail) 2)) ; omit the id to make output equal in all cases - (for-each (λ (id) (mail id 'halt)) - (drop-mails)))) + (for-each (C mail 'halt) (drop-mails)))) (fold (λ (rst id) (lets ((rst n (rand rst #xffffffff))) - (fork-server id - (λ () (spammer (seed->rands n)))) + (thread id + (spammer (seed->rands n))) rst)) (seed->rands seed) (iota 0 1 n)) ;; start all threads -(for-each - (λ (id) (mail id 'start)) - (iota 0 1 n)) +(for-each (C mail 'start) (iota 0 1 n)) diff --git a/tests/bisect-rand.scm b/tests/bisect-rand.scm index b5572223..b6be60fe 100644 --- a/tests/bisect-rand.scm +++ b/tests/bisect-rand.scm @@ -12,4 +12,4 @@ (print* (list " -> square ok " limit))) (if (= (div n m) (divide n m)) (print* (list " -> divide ok " limit))))) - (map (λ (x) (expt 2 x)) (iota 3 1 100))) + (map (H expt 2) (iota 3 1 100))) diff --git a/tests/circle.scm b/tests/circle.scm index 9c771d6e..2f2b30c0 100644 --- a/tests/circle.scm +++ b/tests/circle.scm @@ -3,30 +3,28 @@ (define n 10000) (define (forwarder to) - (lambda () (let loop () (mail to (ref (wait-mail) 2)) - (loop)))) + (loop))) (print* (list "Starting " n " threads.")) -;; first one is special -(fork-server 1 - (lambda () +;; first one is special +(thread 1 (let ((msg (ref (wait-mail) 2))) (mail 2 "pass this around") (let ((result (wait-mail))) - (print* (list "Thread 1: " (ref result 1) " sent me \"" (ref result 2)"\"")))))) + (print* (list "Thread 1: " (ref result 1) " sent me \"" (ref result 2)"\""))))) ;; 2-(n-1) just forward to the next (let loop ((id (- n 1)) (next n)) (if (> id 1) (begin - (fork-server id (forwarder next)) + (thread id (forwarder next)) (loop (- id 1) id)))) ;; last one sends to first -(fork-server n (forwarder 1)) +(thread n (forwarder 1)) (print "Sending message.") diff --git a/tests/commandline.sh b/tests/commandline.sh new file mode 100755 index 00000000..363a94fe --- /dev/null +++ b/tests/commandline.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +LISP="(import (scheme process-context)) (print (cdr (command-line)))" + +$@ -e "$LISP" | grep "$LISP" + diff --git a/tests/commandline.sh.ok b/tests/commandline.sh.ok new file mode 100644 index 00000000..0741d42e --- /dev/null +++ b/tests/commandline.sh.ok @@ -0,0 +1 @@ +(-e (import (scheme process-context)) (print (cdr (command-line)))) diff --git a/tests/echo.scm b/tests/echo.scm index 9653d0f3..acf17b67 100644 --- a/tests/echo.scm +++ b/tests/echo.scm @@ -11,7 +11,7 @@ (mail from msg) (echoer))) -(fork-server echo echoer) +(thunk->thread echo echoer) (let loop ((n 1)) (cond diff --git a/tests/env.scm b/tests/env.scm index 168a39e4..3acfe189 100644 --- a/tests/env.scm +++ b/tests/env.scm @@ -1,5 +1,9 @@ -(import (owl sys)) +(import + (only (owl sys) setenv unsetenv) + (scheme process-context)) -(print (getenv "FOO")) (setenv "FOO" "BAR") -(print (getenv "FOO")) +(print (assoc "FOO" (get-environment-variables))) +(print (get-environment-variable "FOO")) +(unsetenv "FOO") +(print (get-environment-variable "FOO")) diff --git a/tests/env.scm.ok b/tests/env.scm.ok index 445a8064..96a223aa 100644 --- a/tests/env.scm.ok +++ b/tests/env.scm.ok @@ -1,2 +1,3 @@ -#false +(FOO . BAR) BAR +#false diff --git a/tests/exec.sh b/tests/exec.sh index 2bc90ace..39bd5ece 100755 --- a/tests/exec.sh +++ b/tests/exec.sh @@ -1,3 +1,5 @@ #!/bin/sh -$@ -e '(import (owl sys)) (exec "/bin/echo" (list "/bin/echo" "foo")) (print "fail")' +ECHO=$(which echo) + +$@ -e "(import (owl sys)) (exec \"$ECHO\" (list \"$ECHO\" \"foo\")) (print \"fail\")" diff --git a/tests/fasl-exit.sh b/tests/fasl-exit.sh index 33104b08..b7482860 100755 --- a/tests/fasl-exit.sh +++ b/tests/fasl-exit.sh @@ -6,10 +6,10 @@ echo '(lambda (args) (if (equal? (cadr args) "slartibartfast") 0 1))' > tmp/exit $@ -o tmp/exit.fasl tmp/exit.scm bin/vm tmp/exit.fasl 2>/dev/null -echo "vm error exit $? should be 127" +echo "vm error exit $? should be 126" bin/vm tmp/exit.fasl foo -echo "normal nonzer exit $? should be 1" +echo "normal nonzero exit $? should be 1" bin/vm tmp/exit.fasl slartibartfast echo "ok exit $? should be 0" diff --git a/tests/fasl-exit.sh.ok b/tests/fasl-exit.sh.ok index f7bfe1b5..273de95e 100644 --- a/tests/fasl-exit.sh.ok +++ b/tests/fasl-exit.sh.ok @@ -1,3 +1,3 @@ -vm error exit 127 should be 127 -normal nonzer exit 1 should be 1 +vm error exit 126 should be 126 +normal nonzero exit 1 should be 1 ok exit 0 should be 0 diff --git a/tests/fasl-out.sh b/tests/fasl-out.sh_ similarity index 100% rename from tests/fasl-out.sh rename to tests/fasl-out.sh_ diff --git a/tests/filevec.sh b/tests/filevec.sh index f2ce69ae..4200b5d3 100755 --- a/tests/filevec.sh +++ b/tests/filevec.sh @@ -4,6 +4,5 @@ for string in "foo" "b" "ar" do echo "(display \"$string\")" | $@ -q - sleep 0.1 + sleep 0.1 2>/dev/null done | $@ -e '(file->vector "-")' - diff --git a/tests/hashbang.sh b/tests/hashbang.sh index 54722cd3..972128ce 100755 --- a/tests/hashbang.sh +++ b/tests/hashbang.sh @@ -3,7 +3,7 @@ ME=$$ HERE=$(pwd) -echo '(lambda (args) (print (foldr string-append "" (list "#!" (foldr (lambda (a b) (if (equal? b "") a (string-append a (string-append " " b)))) "" (map (lambda (x) (string-append ' "\"$HERE/\"" ' x)) (cdr args))) "\n" "(print \"ohai\")"))))' | $@ --run - $@ > tmp/script-$ME +echo '(lambda (args) (print (foldr string-append "" (list "#!" (foldr (lambda (a b) (if (equal? b "") a (string-append a " " b))) "" (map (lambda (x) (string-append ' "\"$HERE/\"" ' x)) (cdr args))) "\n" "(print \"ohai\")"))))' | $@ --run - $@ > tmp/script-$ME chmod +x tmp/script-$ME diff --git a/tests/lazy.scm b/tests/lazy.scm index 0da776cd..b3b009ec 100644 --- a/tests/lazy.scm +++ b/tests/lazy.scm @@ -9,7 +9,7 @@ (print (force-ll (ltake (ledit editor (lnums 1)) 20))) -;; start checking laziness/eagerness preservation +;; start checking laziness/eagerness preservation (define (boom . tail) (lambda () @@ -25,9 +25,7 @@ ((function? x) 'TBC) (else 'ERROR))) -(define print-computed - (o print computed)) - -;; +(define print-computed + (B print computed)) (print-computed three-elems) diff --git a/tests/link.scm b/tests/link.scm new file mode 100644 index 00000000..6afbdc29 --- /dev/null +++ b/tests/link.scm @@ -0,0 +1,15 @@ +(thread 'crasher + (begin + (wait-mail) ;; wait for a message before crashing + (/ 1 0))) + +(begin + ;; link current thread to thread about to crash + (link 'crasher) + ;; trigger the crash + (mail 'crasher 'itstime) + ;; check that we get a crash + (let ((envelope (wait-mail))) + (print (ref envelope 1) + " -> " (ref (ref envelope 2) 1)))) + diff --git a/tests/link.scm.ok b/tests/link.scm.ok new file mode 100644 index 00000000..0df9fa13 --- /dev/null +++ b/tests/link.scm.ok @@ -0,0 +1 @@ +crasher -> error diff --git a/tests/mail-async-rand.scm b/tests/mail-async-rand.scm index 1aaee06e..ff8e88c8 100644 --- a/tests/mail-async-rand.scm +++ b/tests/mail-async-rand.scm @@ -37,11 +37,10 @@ (lets ((rst seed-1 (rand rst #xfffffffffffffff)) (rst seed-2 (rand rst #xfffffffffffffff))) - (fork-server id (λ () (mailer (seed->rands seed-1) (+ id 1)))) - (fork-server (+ id 1) (λ () (mailer (seed->rands seed-2) id))) + (thread id (mailer (seed->rands seed-1) (+ id 1))) + (thread (+ id 1) (mailer (seed->rands seed-2) id)) rst)) (seed->rands (* (time-ms) (<< (time-ms) 9))) (iota 0 2 n-threads)) -(for-each (λ (id) (mail id 'start)) (iota 0 1 n-threads)) - +(for-each (C mail 'start) (iota 0 1 n-threads)) diff --git a/tests/mail-order.scm b/tests/mail-order.scm index 7818de85..7c9af8be 100644 --- a/tests/mail-order.scm +++ b/tests/mail-order.scm @@ -11,7 +11,7 @@ (mail from msg) (echoer))) -(fork-server echo echoer) +(thunk->thread echo echoer) (begin ;; send 0-99 mails and leave the responses to inbox diff --git a/tests/math-rand.scm b/tests/math-rand.scm index 4d2688bc..ecbafae1 100644 --- a/tests/math-rand.scm +++ b/tests/math-rand.scm @@ -119,16 +119,14 @@ (define funny-numbers (let* - ((ns - (map (lambda (x) (<< 1 x)) - (map (lambda (x) (expt 2 x)) (iota 0 1 6)))) - (ns (append ns (map (lambda (x) (- x 1)) ns))) - (ns (append ns (map (lambda (x) (- 0 x)) ns)))) + ((ns (map (H << 1) (map (H expt 2) (iota 0 1 6)))) + (ns (append ns (map (C - 1) ns))) + (ns (append ns (map (H - 0) ns)))) ; positive first (sort > (cons 0 ns)))) (define simple-numbers - (map (lambda (x) (expt 2 x)) (iota 0 1 17))) + (map (H expt 2) (iota 0 1 17))) ;;; ;;; Unit tests @@ -274,7 +272,7 @@ (if (= step 0) (print "Tests complete.") (begin - (for-each (lambda (x) (run-test rst x)) math-tests) + (for-each (H run-test rst) math-tests) (lets ((rst n (rand rst 10000000))) (run-tests rst (- step 1)))))) @@ -341,5 +339,4 @@ ; these occasionally dig out issues (print "Running random tests:") (run-tests (seed->rands seed) 50) - ) - +) diff --git a/tests/no-threads.sh b/tests/no-threads.sh_ similarity index 100% rename from tests/no-threads.sh rename to tests/no-threads.sh_ diff --git a/tests/par-nested-rand.scm b/tests/par-nested-rand.scm deleted file mode 100644 index 82d28bf9..00000000 --- a/tests/par-nested-rand.scm +++ /dev/null @@ -1,39 +0,0 @@ - -(define (small-range? lo hi) - (< (- hi lo) 100)) - -(define (seek rs lo hi n) - (if (small-range? lo hi) - (if (has? (iota lo 1 hi) n) - (begin - (print "found it!") - #true) - #false) - (lets - ((rs mid (rand-range rs lo hi)) - (rs a (rand rs 3)) ;; delays for thread stepping randomization - (rs b (rand rs 3)) - (rs seed (rand rs #xfffffffffff)) ;; new seed for new random state in the other branch - (rsp (seed->rands seed))) - (por - (begin - (set-ticker a) - (seek rs lo mid n)) - (begin - (set-ticker b) - (seek rsp mid hi n)))))) - -(define seed (time-ms)) - -(define rs (seed->rands seed)) - -(define lo 0) - -(define hi 10000) - -(define-values (rs needle) (rand-range rs lo hi)) - -(print "looking...") - -(seek rs lo hi needle) - diff --git a/tests/par-nested-rand.scm.ok b/tests/par-nested-rand.scm.ok deleted file mode 100644 index 35ab684f..00000000 --- a/tests/par-nested-rand.scm.ok +++ /dev/null @@ -1,2 +0,0 @@ -looking... -found it! diff --git a/tests/par-nested.scm b/tests/par-nested.scm deleted file mode 100644 index 2dfb67ed..00000000 --- a/tests/par-nested.scm +++ /dev/null @@ -1,8 +0,0 @@ - -(print - (map force-ll - (force-ll - (par - (par 1 2 3) - (par 4 5 6))))) - diff --git a/tests/par-nested.scm.ok b/tests/par-nested.scm.ok deleted file mode 100644 index 3e716a9f..00000000 --- a/tests/par-nested.scm.ok +++ /dev/null @@ -1 +0,0 @@ -((1 2 3) (4 5 6)) diff --git a/tests/par-rand.scm b/tests/par-rand.scm deleted file mode 100644 index 2e640d64..00000000 --- a/tests/par-rand.scm +++ /dev/null @@ -1,32 +0,0 @@ - -;; check that threads which return a given value after n context switches return them -;; when computed via par in the same order as if the values were sorted by n. - -(define (step-down r n) - (if (eq? n 0) - r - (begin - (set-ticker 0) ;; force thread switch - (step-down r (- n 1))))) - -(define (stepper r n) - (λ () (step-down r n))) - -(define seed (time-ms)) - -(define rs (seed->rands seed)) - -(define-values (rs n) (rand-range rs 10 100)) - -(define-values (rs nums) (random-numbers rs 1000 n)) - -(define-values (rs steps) (random-permutation rs (iota 0 1 n))) - -(define step-order (map car (sort (λ (a b) (< (cdr a) (cdr b))) (zip cons nums steps)))) - -(define par-order (force-ll (par* (zip stepper nums steps)))) - -(if (equal? step-order par-order) - (print "good") - (print "failed with seed " seed)) - diff --git a/tests/par-rand.scm.ok b/tests/par-rand.scm.ok deleted file mode 100644 index 12799ccb..00000000 --- a/tests/par-rand.scm.ok +++ /dev/null @@ -1 +0,0 @@ -good diff --git a/tests/parse.scm b/tests/parse.scm new file mode 100644 index 00000000..ef948d82 --- /dev/null +++ b/tests/parse.scm @@ -0,0 +1,170 @@ +(import + (owl parse)) + +(define (enlist x) + (if (string? x) + (string->list x) + x)) + +(define (try data parser want-value want-tail) + (print "testing '" data "' = " want-value) + (lets + ((input (string->list data)) + (res (parse-head parser input #f))) + (if (pair? res) + (if want-value + (begin + (if (not (equal? (enlist want-value) (enlist (car res)))) + (print "ERROR: wanted '" want-value "', but got '" (car res) "'")) + (if (not (equal? (enlist want-tail) (cdr res))) + (print "ERROR: tailing data is " (cdr res) " instead of " want-tail))) + (print "ERROR: wanted failure, but got " res)) + (if want-value + (print "ERROR: wanted " want-value ", but failed"))))) + +(define (cat a b) + (cond + ((number? a) + (cat (list->string (list a)) b)) + ((number? b) + (cat a (list->string (list b)))) + ((and (string? a) (string? b)) + (string-append a b)) + ((null? a) b) + ((null? b) a) + (else + (list a b)))) + +(define (seq pa pb) + (let-parses + ((a pa) + (b pb)) + (cat a b))) + +(try "x" (ε 42) 42 "x") + +(try "x" (imm #\x) + #\x "") + +(try "x" (imm #\a) + #false "x") + +(try "xxxa" (star (imm #\x)) + "xxx" "a") + +(try "ababax" (star (seq (imm #\a) (imm #\b))) + '("ab" "ab") "ax") + +(try "abax" (plus (seq (imm #\a) (imm #\b))) + '("ab") "ax") + +(try "ax" (plus (seq (imm #\a) (imm #\b))) + #false "ax") + +(define aab (seq (plus (imm #\a)) (imm #\b))) +(define aac (seq (plus (imm #\a)) (imm #\c))) +(define aad (seq (plus (imm #\a)) (imm #\d))) + +(try "adxy" + (seq + (star aad) + (seq (imm #\a) + (imm #\d))) + "ad" + "xy") + +(try "ax" + (seq + (either (imm #\a) (ε 42)) + (imm #\a)) + "*a" + "x") + +(try "abc" + (seq (imm #\a) + (seq (imm #\b) + (imm #\d))) + #false + #false) + +(try "abc" + (either + (let-parses + ((a (imm #\a)) + (b (imm #\b)) + (d (imm #\d))) + (list a b d)) + (imm #\a)) + 97 + "bc") + +(try "aaaax" + (let-parses + ((as1 (plus (imm #\a))) + (as2 (plus (imm #\a))) + (as3 (plus (imm #\a)))) + (list as1 as2 as3)) + '((#\a #\a) (#\a) (#\a)) + "x") + +(define get-num + (let-parses + ((digits + (plus + (byte-between 47 58)))) + (fold + (λ (n t) (+ (* n 10) (- t 48))) + 0 digits))) + +(try "1234x" + get-num + 1234 + "x") + +(define ws + (star + (byte-if + (H has? '(#\space #\tab #\newline #\return))))) + +(define get-exp + (let-parses + ((drop ws) + (exp get-num)) + exp)) + +(define get-list + (let-parses + ((drop ws) + (left (imm #\{)) + (ns + (star get-exp)) + (drop ws) + (right (imm #\}))) + ns)) + +(try " { 11 22 33 44 }x" + get-list + (list 11 22 33 44) + "x") + +(try "aaax" + (seq + (star (imm #\a)) + (imm #\a)) + '((#\a #\a) "a") + "x") + +(try "aaax" + (seq + (greedy-star (imm #\a)) + (imm #\a)) + #false #false) + +(try "aabcx" + (seq + (greedy-star (either (imm #\a) (imm #\b))) + (imm #\c)) + '((#\a #\a #\b) "c") + "x") + + diff --git a/tests/parse.scm.ok b/tests/parse.scm.ok new file mode 100644 index 00000000..a805b752 --- /dev/null +++ b/tests/parse.scm.ok @@ -0,0 +1,17 @@ +testing 'x' = 42 +testing 'x' = 120 +testing 'x' = #false +testing 'xxxa' = xxx +testing 'ababax' = (ab ab) +testing 'abax' = (ab) +testing 'ax' = #false +testing 'adxy' = ad +testing 'ax' = *a +testing 'abc' = #false +testing 'abc' = 97 +testing 'aaaax' = ((97 97) (97) (97)) +testing '1234x' = 1234 +testing ' { 11 22 33 44 }x' = (11 22 33 44) +testing 'aaax' = ((97 97) a) +testing 'aaax' = #false +testing 'aabcx' = ((97 97 98) c) diff --git a/tests/pipe.scm b/tests/pipe.scm new file mode 100644 index 00000000..1d1d3a06 --- /dev/null +++ b/tests/pipe.scm @@ -0,0 +1,22 @@ +(import (owl sys)) + +(define p (pipe)) ;; (read . write) + +(define (listen) + (let ((res (try-get-block (car p) 1000 #false))) + (print + (if (eq? res #true) + 'nothing + res)))) + +(listen) +(write-bytes (cdr p) (list 1 2 3 4)) +(listen) +(listen) +(write-bytes (cdr p) (list 11 22 33 44)) +(listen) +(listen) +(close-port (cdr p)) +(listen) +(close-port (car p)) +(listen) diff --git a/tests/pipe.scm.ok b/tests/pipe.scm.ok new file mode 100644 index 00000000..07ad0031 --- /dev/null +++ b/tests/pipe.scm.ok @@ -0,0 +1,7 @@ +nothing +#(1 2 3 4) +nothing +#(11 22 33 44) +nothing +#eof +#false diff --git a/tests/por-prime-rand.scm b/tests/por-prime-rand.scm deleted file mode 100644 index 0a9cda75..00000000 --- a/tests/por-prime-rand.scm +++ /dev/null @@ -1,14 +0,0 @@ -(define num (+ (band (time-ms) #b1111111111) 2)) - -(define por-opts - (map - (λ (try) (λ () (ediv num try))) - (iota 2 1 (+ 1 (isqrt num))))) - -(define (xor a b) - (if a b (if b #false (not a)))) - -(print - (if (equal? (prime? num) (not (por* por-opts))) - "OK" - num)) diff --git a/tests/por-prime-rand.scm.ok b/tests/por-prime-rand.scm.ok deleted file mode 100644 index d86bac9d..00000000 --- a/tests/por-prime-rand.scm.ok +++ /dev/null @@ -1 +0,0 @@ -OK diff --git a/tests/por-terminate.scm b/tests/por-terminate.scm deleted file mode 100644 index afae614f..00000000 --- a/tests/por-terminate.scm +++ /dev/null @@ -1,44 +0,0 @@ - -(define (iter-ret n r) - (if (= n 0) - r - (iter-ret (- n 1) r))) - -(define (walk n) - (iter-ret n 'ok)) - -(print "First terminate order: " - (por - (walk -1) ;; won't terminate - (walk 1000))) - -(print "Second terminate order: " - (por - (walk 1000) - (walk -1))) ;; won't terminate - -(print "Third nonterminate + fail: " - (por - (walk -1) ;; nonterminating - (iter-ret 100 #false) ;; fails - (iter-ret 1000 #false) ;; fails - (iter-ret 2000 'ok) ;; succeeds after failures - (walk -1))) - -;; walk down, but switch thread every time -(define (iter-ret-step n r) - (if (= n 0) - r - (begin - (set-ticker 0) ;; thread context switch in next function call (-) - (iter-ret-step (- n 1) r)))) - -(print "Por termination order: " - (por - (walk -1) - (iter-ret-step 101 'bad-a) - (iter-ret-step 102 'bad-b) - (iter-ret-step 100 'ok) - (iter-ret-step 103 'bad-c) - (walk -1) - (iter-ret-step 104 'bad-d))) diff --git a/tests/por-terminate.scm.ok b/tests/por-terminate.scm.ok deleted file mode 100644 index 7136922e..00000000 --- a/tests/por-terminate.scm.ok +++ /dev/null @@ -1,4 +0,0 @@ -First terminate order: ok -Second terminate order: ok -Third nonterminate + fail: ok -Por termination order: ok diff --git a/tests/process.scm b/tests/process.scm index 97ed2c55..ba885b56 100644 --- a/tests/process.scm +++ b/tests/process.scm @@ -2,6 +2,7 @@ (import (prefix (owl sys) sys-)) (define exit-values '(42 43 44)) +(define (wait-pid pid) (print "child exited with " (sys-wait pid))) (print "forking children") @@ -23,10 +24,32 @@ (print "forked child processes") -(for-each - (λ (pid) - (print "child exited with " (sys-wait pid))) - pids) +(for-each wait-pid pids) + +(print "starting sub-process") + +(define pipefd (sys-pipe)) + +(if pipefd + (case (sys-fork) + ((#false) + (print "fork FAILED")) + ((#true) + ;; child: close read end + (close-port (car pipefd)) + (sys-dupfd (cdr pipefd) stdout #true) + (close-port (cdr pipefd)) + (for-each + (λ (path) + (if (m/^\// path) + (sys-exec (string-append path "/echo") '("echo" "hello")))) + (c/:/ (sys-getenv "PATH"))) + (halt 45)) + (else => (λ (pid) + ;; parent: close write end + (close-port (cdr pipefd)) + (print (car ((lines (car pipefd)))) " from sub-process") + (wait-pid pid)))) + (print "pipe creation failed")) (print "done") - diff --git a/tests/process.scm.ok b/tests/process.scm.ok index cbfa5fff..9d3a4570 100644 --- a/tests/process.scm.ok +++ b/tests/process.scm.ok @@ -3,4 +3,7 @@ forked child processes child exited with (1 . 42) child exited with (1 . 43) child exited with (1 . 44) +starting sub-process +hello from sub-process +child exited with (1 . 0) done diff --git a/tests/r7rs.scm b/tests/r7rs.scm index 1ac9b20a..b7028781 100644 --- a/tests/r7rs.scm +++ b/tests/r7rs.scm @@ -14,15 +14,13 @@ Testing block comments. They could also be nested on second thought... (let ((a '|foo bar|) (b (string->symbol "foo bar"))) - (if (not (eq? a b)) + (if (not (eq? a b)) (print "symbolic failure 1"))) (if (not (= 42 ((lambda (|foo|) foo) 42))) (print "symbolic failure 2")) -;; returning both "" and "||" make sense. using the latter for now, but -;; might be that that behavior should only be done for write. -(if (not (string=? "||" (symbol->string (string->symbol "")))) +(if (not (string=? (symbol->string (string->symbol "")) "")) (print "symbolic failure 3")) ;; test _ wildcard in macros diff --git a/tests/regex.scm b/tests/regex.scm index abdc6406..deadd021 100644 --- a/tests/regex.scm +++ b/tests/regex.scm @@ -2,8 +2,7 @@ ;;; Testing ;;; -;,r "owl/regex.l" -(import (owl regex)) ;; when testing without a heap rebuild +; (import (owl regex)) ;; when testing without a heap rebuild ;; regex str → did-match-ok? (define (test regex input should?) diff --git a/tests/rlist-rand.scm b/tests/rlist-rand.scm index 9c58deb6..5ce81afd 100644 --- a/tests/rlist-rand.scm +++ b/tests/rlist-rand.scm @@ -12,14 +12,14 @@ (define max-list-size 10000) ; run a battery of operations to a list and an equal rlist -; and stop on inconsistencies +; and stop on inconsistencies (define (list-test rst rl l len steps) (if (= steps 0) (print "ok") (lets ((rst n (rand rst 25)) (steps (- steps 1))) - ;; draw a graph of the list length + ;; draw a graph of the list length ;(mail stdout (fold (lambda (out n) (cons 45 out)) '(124 10) (iota 0 1 len))) (case n ((0 1 2) ; cons a new head @@ -27,7 +27,7 @@ (lets ((rst x (rand rst 1000))) (list-test rst (rcons x rl) (cons x l) (+ len 1) steps)) (list-test rst rl l len steps))) - ((3 4 5) ; drop a head, slightly less frequent + ((3 4 5) ; drop a head, slightly less frequent (if (= len 0) (list-test rst rl l len steps) (list-test rst (rcdr rl) (cdr l) (- len 1) steps))) @@ -39,15 +39,15 @@ ((9 10) ; set a random element (if (= len 0) (list-test rst rl l len steps) - (lets + (lets ((rst p (rand rst len)) (rst v (rand rst 10000))) ;(print* (list "L[" p "] = " v)) (list-test rst (rset rl p v) (lset l p v) len steps)))) ((11) ; map increment (list-test rst - (rmap (lambda (x) (+ x 1)) rl) - (map (lambda (x) (+ x 1)) l) + (rmap (C + 1) rl) + (map (C + 1) l) len steps)) ((12) ; fold (if (= (fold - 0 l) (rfold - 0 rl)) diff --git a/tests/run b/tests/run index 7067a4d7..4eff5a0d 100755 --- a/tests/run +++ b/tests/run @@ -1,60 +1,71 @@ #!/bin/sh -SUFFIX="" -MAXJOBS=4 +CURJOBS=0 MAXJOBS=4 +LOG=tmp/units-$$.out PID=$$ waitnjobs() { - while true + while test $CURJOBS -ge $1 do - test $(jobs | grep Running | wc -l) -lt $1 && break - sleep 0.2 + wait # until interrupted by SIGUSR1 done } +difflog() { + if diff "$1.ok" - >>"$LOG" + then + echo '.\c' + else + echo '|\c' + echo "ERROR: $file" >>"$LOG" + fi + kill -USR1 $PID # job done +} -case $1 in - random) SUFFIX=-rand;; - all) SUFFIX="";; - *) - echo "$ run (random | all) cmd [flags]"; - exit 1;; +case $1 in +(random) + SUFFIX='-rand' + ;; +(all) + SUFFIX='' + ;; +(*) + echo '$ run (random|all) cmd [flags]' + exit 1 esac shift -test -x $1 || { echo "No executable at '$1'."; exit 2; } - +test -x "$1" || { + echo "No executable at '$1'." + exit 2 +} test -d tmp && rm -rf tmp # don't want old files screwing up tests mkdir tmp -LOG=tmp/units-$$.out - -fail() { - cat $LOG - exit 1 -} - -echo -n "Running tests/ against $@:" - -touch $LOG +echo "Running tests/ against $@: \\c" +trap 'CURJOBS=$((CURJOBS - 1))' USR1 for file in tests/*$SUFFIX.scm do - ($@ -q $file 2>&1 | grep -v SEED | diff $file.ok - >> $LOG || echo "ERROR: $file" >> $LOG; /bin/echo -n " o") & + ("$@" -q "$file" 2>&1 | grep -v SEED | difflog "$file") & + CURJOBS=$((CURJOBS + 1)) waitnjobs $MAXJOBS done for file in tests/*$SUFFIX.sh do - ((sh $file $@ 2>&1 || echo "NONZERO: $file $?") | grep -v SEED | diff $file.ok - >> $LOG || echo "ERROR: $file" >> $LOG; /bin/echo -n " o") & + ( (sh "$file" "$@" 2>&1 || echo "NONZERO: $file $?") | grep -v SEED | difflog "$file") & + CURJOBS=$((CURJOBS + 1)) waitnjobs $MAXJOBS done -wait - -grep ERROR $LOG && fail $LOG - -rm $LOG - -echo " ok" +trap '' USR1 # ignore remaining "done" signals +wait +grep -q ERROR "$LOG" && { + echo ' FAILED' + cat "$LOG" + exit 1 +} +rm "$LOG" +echo ' PASSED' diff --git a/tests/seek.scm b/tests/seek.scm index 0011e7eb..80c292b2 100644 --- a/tests/seek.scm +++ b/tests/seek.scm @@ -10,7 +10,7 @@ (write-vector foo fd) -(print "start -> " (seek-pos fd 0)) +(print "start -> " (seek-set fd 0)) (write-vector #(100 101 102) fd) @@ -18,7 +18,7 @@ (write-vector #(10 11 12) fd) -(print "take five -> " (seek-pos fd 5)) +(print "take five -> " (seek-set fd 5)) (write-vector #(55 66 77) fd) diff --git a/tests/sexp.scm b/tests/sexp.scm new file mode 100644 index 00000000..822deb2f --- /dev/null +++ b/tests/sexp.scm @@ -0,0 +1,25 @@ + +'(foo (bar baz)) + +42 + +2+3i + +(import + (owl sexp) + (owl parse)) + +(define foo + (open-input-file "tests/sexp.scm")) + +(print + (read foo)) ;; → (quote (foo (bar (baz)))) + +(close-port foo) + +(define fd (open-input-file "tests/sexp.scm")) + +(define es (fd->exp-stream fd sexp-parser (silent-syntax-fail null))) + +(print (force-ll (ltake es 3))) + diff --git a/tests/sexp.scm.ok b/tests/sexp.scm.ok new file mode 100644 index 00000000..0b178adb --- /dev/null +++ b/tests/sexp.scm.ok @@ -0,0 +1,2 @@ +(quote (foo (bar baz))) +((quote (foo (bar baz))) 42 2+3i) diff --git a/tests/signal.scm b/tests/signal.scm index 7ffc69ec..28ec959c 100644 --- a/tests/signal.scm +++ b/tests/signal.scm @@ -1,12 +1,12 @@ -(import +(import (prefix (owl sys) sys-)) (define (loop) (loop)) (define (fork-inf) (let ((r (sys-fork))) - (if (number? r) + (if (integer? r) r ;; return pid (loop)))) ;; get stuck diff --git a/tests/sys-fork.scm b/tests/sys-fork.scm new file mode 100644 index 00000000..66683862 --- /dev/null +++ b/tests/sys-fork.scm @@ -0,0 +1,39 @@ +(import + (owl sys) + (owl date)) + +;; create a communication channel + +(define p1 (pipe)) ;; parent read, child write +(define p2 (pipe)) ;; child read, parent write + +(if (and p1 p2) + (print "Pipes check")) + +(define sub (fork)) + +(define (child infd outfd) + (write-bytes outfd + (cons 42 + (vector->list (get-block infd #xffff))))) + +(define (main sub in out) + (let ((data (string->bytes (date-str (time))))) + (write-bytes out data) + (if (equal? (list->vector (cons 42 data)) + (get-block in #xffff)) + (begin + (print "Subprocess echo with star ok") + (print "Closing parent end of port " (close-port out)) + (print "Waiting child: " (waitpid sub))) + + (print "Echo failed")))) + +(cond + ((eq? sub #true) + (child (car p2) (cdr p1))) + ((integer? sub) + (print "Subprocess forked") + (main sub (car p1) (cdr p2))) + (else + (print "Fork failed"))) diff --git a/tests/sys-fork.scm.ok b/tests/sys-fork.scm.ok new file mode 100644 index 00000000..56ae20e0 --- /dev/null +++ b/tests/sys-fork.scm.ok @@ -0,0 +1,5 @@ +Pipes check +Subprocess forked +Subprocess echo with star ok +Closing parent end of port #true +Waiting child: (1 . 0) diff --git a/tests/tcp-bidi-large.scm_ b/tests/tcp-bidi-large.scm_ index 3394e16d..56e5a710 100644 --- a/tests/tcp-bidi-large.scm_ +++ b/tests/tcp-bidi-large.scm_ @@ -9,7 +9,7 @@ (let loop ((port 1025)) (if (< port #x10000) (let ((sock (open-socket port))) - (if sock + (if sock (cons sock port) (loop (+ port 1)))) (error "Couldn't open any ports" port)))) @@ -54,10 +54,10 @@ ((eq? n 1) ;; check for arrived data (lets ((envelope (check-mail))) (if envelope - (lets + (lets ((from msg envelope) (reqs (- reqs 1))) - (if (eof? msg) + (if (eof-object? msg) (io fd rst data left reqs) (explode msg (io fd rst data (- left (vec-len msg)) reqs)))) ;; you have no new email @@ -72,10 +72,10 @@ (io fd rst data left reqs))) ((and (null? data) (= left 0)) ;; all sent and enough received (let loop ((reqs reqs)) ;; read responses to remaining requests - (if (= reqs 0) + (if (= reqs 0) null ;; all done (let ((env (wait-mail))) - (if (eof? (ref env 2)) ;; check that we get an eof now + (if (eof-object? (ref env 2)) ;; check that we get an eof now (loop (- reqs 1)) (error "bad finale message: " env)))))) (else diff --git a/tests/tcp-bidi.scm_ b/tests/tcp-bidi.scm_ index f72b6f51..aed106c7 100644 --- a/tests/tcp-bidi.scm_ +++ b/tests/tcp-bidi.scm_ @@ -36,8 +36,8 @@ ;; send chunks and drop read requests (define (sender fd) - (for-each (λ (x) (mail fd x)) elems)) - + (for-each (H mail fd) elems)) + (fork-server 'socket-thread (λ () (let ((cli (interact sock 'accept))) diff --git a/tests/tcp-request.scm_ b/tests/tcp-request.scm_ index 6f267887..f7e03144 100644 --- a/tests/tcp-request.scm_ +++ b/tests/tcp-request.scm_ @@ -17,12 +17,11 @@ (define message (render "hello there" null)) -(fork-server 'socket-thread - (lambda () +(thread 'socket-thread (let ((cli (interact sock 'accept))) ; <- blocks the thread (print "Client connected") (show "Client says: " (list->string (vector->list (interact cli 'input)))) - (close-port cli)))) + (close-port cli))) (let ((conn (open-connection (vector 127 0 0 1) port))) (if conn diff --git a/tests/tcp-response.scm_ b/tests/tcp-response.scm_ index ba072b9e..8db8dbf5 100644 --- a/tests/tcp-response.scm_ +++ b/tests/tcp-response.scm_ @@ -16,11 +16,10 @@ (define message (render "hello there" null)) -(fork-server 'socket-thread - (lambda () - (let ((cli (interact sock 'accept))) - (mail cli message) - (close-port cli)))) +(thread 'socket-thread + (let ((cli (interact sock 'accept))) + (mail cli message) + (close-port cli))) (let ((conn (open-connection (vector 127 0 0 1) port))) (if conn diff --git a/tests/tcp.scm b/tests/tcp.scm index e7ae479e..8969af48 100644 --- a/tests/tcp.scm +++ b/tests/tcp.scm @@ -18,7 +18,7 @@ (let ((clis (tcp-clients port))) (if clis (begin - (fork-server name (lambda () (tcp-echo clis))) + (thread name (tcp-echo clis)) port) (loop (+ port 1)))) #false))) @@ -30,8 +30,8 @@ (define cli (open-connection (vector 127 0 0 1) port)) -(if cli - (print "client connected")) +(if (not cli) + (print "client not connected")) (print-to cli "SLARTIBARTFAST") diff --git a/tests/tcp.scm.ok b/tests/tcp.scm.ok index b54edfb3..f6e7da09 100644 --- a/tests/tcp.scm.ok +++ b/tests/tcp.scm.ok @@ -1,4 +1,3 @@ server running server serving client 1 -client connected SLARTIBARTFAST diff --git a/tests/test.sh b/tests/test.sh index e7bb3e6d..55e645fc 100755 --- a/tests/test.sh +++ b/tests/test.sh @@ -7,9 +7,9 @@ $@ -t '(= 1 2)' test $? = 1 || echo bad2 $@ -t ')lambda(' 2>/dev/null # error should go to stderr -test $? = 127 || echo bad3 +test $? = 126 || echo bad3 $@ -t '(/ 1 0)' 2>/dev/null # ditto -test $? = 127 || echo bad4 +test $? = 126 || echo bad4 echo ok diff --git a/tests/theorem-rand.scm b/tests/theorem-rand.scm index d9971da9..f432f154 100755 --- a/tests/theorem-rand.scm +++ b/tests/theorem-rand.scm @@ -139,8 +139,8 @@ ;; get one rand, pick low bit (values rs (eq? 1 (band d 1))))) -(define (Byte rs) - (rand rs 256)) +(define Byte + (C rand 256)) (define (Short rs) (lets ((digit rs (uncons rs 0))) @@ -232,8 +232,8 @@ (loop rs (iput out x x))))))) ;; FIXME: have full range and correct holes -(define (UChar rs) - (rand rs #xffff)) +(define UChar + (C rand #xffff)) (define (String rs) (let loop ((rs rs) (out null)) @@ -257,7 +257,7 @@ ∀ a ∊ Nat (< a 100000000) ⇒ (prime? a) ⇒ (= 1 (length (factor a))) - + theorem factor-1 ∀ a ∊ Nat (and (< 1 a) (< a 1000000)) ⇒ @@ -282,7 +282,7 @@ theorem mul-distrib ∀ a b c ∊ Num (* a (+ b c)) = (+ (* a b) (* a c)) - + theorem mul-add-1 ∀ a b ∊ Num (* a (+ b 1)) = (+ (* a b) a) @@ -310,7 +310,7 @@ theorem mul-comm ∀ a b ∊ Num (* a b) = (* b a) - + theorem mul-assoc ∀ a b c ∊ Num (* a (* b c)) = (* (* a b) c) @@ -362,7 +362,7 @@ theorem ff-del ∀ f ∊ (Ff-of Byte) ∀ a b ∊ Byte b = (get (del (put f a a) a) a b) - + theorem ff-del-all ∀ f ∊ (Ff-of Byte) empty = (ff-fold (λ (ff key val) (del ff key)) f f) @@ -370,7 +370,7 @@ theorem ff-put ∀ f ∊ (Ff-of Byte) ∀ a b ∊ Byte b = (get (put f a b) a #false) - + theorem ff-keys-sorted ∀ f ∊ (Ff-of Short) ks ← (keys f) ;; inorder @@ -422,7 +422,7 @@ ∀ a n m ∊ Nat b ← (+ a n) c ← (+ b (+ m 1)) - b = (bisect (λ (p) (>= p b)) a c) + b = (bisect (C >= b) a c) theorem rlist-car-cons ∀ a ∊ Byte ∀ r ∊ Rlist @@ -467,7 +467,7 @@ theorem lazy-1 ∀ n ∊ Byte (fold + 0 (iota 0 1 n)) = (lfold + 0 (liota 0 1 n)) - + theorem lazy-2 ∀ n ∊ Byte (zip cons (iota 0 1 n) (iota n -1 0)) @@ -600,5 +600,3 @@ (begin (print "TESTS FAILED: " (list 'fails fails 'seed seed 'n n)) 2)))))))))) - - diff --git a/tests/udp.scm b/tests/udp.scm new file mode 100644 index 00000000..7e3d5fb8 --- /dev/null +++ b/tests/udp.scm @@ -0,0 +1,20 @@ +(import (owl io)) + +(thread + (lfold + (λ (nth packet) + (print packet) + (if (= nth 3) + (halt 0) + (+ nth 1))) + 1 + (udp-packets 31337))) + +(sleep 100) + +(define sock (udp-client-socket)) + +(for-each + (λ (n) + (send-udp-packet sock (vector 127 0 0 1) 31337 (vector 42 42 42 n))) + (iota 240 5 255)) diff --git a/tests/udp.scm.ok b/tests/udp.scm.ok new file mode 100644 index 00000000..0523b4bb --- /dev/null +++ b/tests/udp.scm.ok @@ -0,0 +1,3 @@ +(#(127 0 0 1) . #(42 42 42 240)) +(#(127 0 0 1) . #(42 42 42 245)) +(#(127 0 0 1) . #(42 42 42 250)) diff --git a/tests/variable.scm b/tests/variable.scm new file mode 100644 index 00000000..52359bd8 --- /dev/null +++ b/tests/variable.scm @@ -0,0 +1,32 @@ +(import + (owl variable)) + +(define foo (make-variable)) + +(foo 42) +(print (foo)) +(foo "new value") +(print (foo)) + +;; many async writes +(for-each foo (iota 0 1 100)) + +;; sync read -> last +(print (foo)) + +(foo 0) +(print (fold + 0 (iota 0 1 1000))) +(for-each + (lambda (x) (foo 'call (C + x))) + (iota 0 1 1000)) +(print (foo)) + +(define foo (make-variable 'foo)) +(define foo2 (link-variable 'foo)) + +(foo 11) +(print (foo)) +(print (foo2)) +(foo2 22) +(print (foo)) +(print (foo2)) diff --git a/tests/variable.scm.ok b/tests/variable.scm.ok new file mode 100644 index 00000000..24014bcf --- /dev/null +++ b/tests/variable.scm.ok @@ -0,0 +1,9 @@ +42 +new value +99 +499500 +499500 +11 +11 +22 +22 diff --git a/tests/vector-rand.scm b/tests/vector-rand.scm index cdd57759..c97ee131 100644 --- a/tests/vector-rand.scm +++ b/tests/vector-rand.scm @@ -7,14 +7,10 @@ (rs nums (random-numbers rs max n)) (vec (list->vector nums))) (print (list (if (equal? (vector->list vec) nums) 'ok 'fail) 'n n 'max max)))) - -(for-each - (λ (n) - (for-each - (λ (max) - (test n max)) - (list 1 255 260 100000000000))) + +(for-each + (λ (n) (for-each (H test n) (list 1 255 260 100000000000))) (list 1 10 100 1000 10000)) ;(test ;; vec-iter-range = read values separately @@ -28,7 +24,7 @@ ; (tuple vec start end))) ; (liter rand-succ (lets ((ss ms (clock))) (+ (* ss 1000) ms)))) ; (λ (t) (lets ((v s e t)) (force (vec-iter-range v s e)))) -; (λ (t) (lets ((v s e t)) (map (λ (p) (vec-ref v p)) (iota s 1 e))))) +; (λ (t) (lets ((v s e t)) (map (H vec-ref v) (iota s 1 e))))) ;(test ;; vector fold[r] ; (lmap ; (λ (rst) @@ -39,4 +35,3 @@ ; (liter rand-succ (lets ((ss ms (clock))) (+ (* ss 1000) ms)))) ; (λ (v) (vec-foldr cons null v)) ; (λ (v) (reverse (vec-fold (λ (a b) (cons b a)) null v)))) -