(ero "initializing mu.. (takes ~5s)") ;; profiler (http://arclanguage.org/item?id=11556) ; Keeping this right on top as a reminder to profile before guessing at why my ; program is slow. (mac proc (name params . body) `(def ,name ,params ,@body nil)) (mac filter-log (msg f x) `(ret x@ ,x (prn ,msg (,f x@)))) (= times* (table)) (mac deftimed (name args . body) `(do (def ,(sym (string name "_core")) ,args ,@body) (def ,name ,args (let t0 (msec) (ret ans ,(cons (sym (string name "_core")) args) (update-time ,(string name) t0)))))) (proc update-time(name t0) ; call directly in recursive functions (or= times*.name (list 0 0)) (with ((a b) times*.name timing (- (msec) t0)) (= times*.name (list (+ a timing) (+ b 1))))) (def print-times() (prn (current-process-milliseconds)) (prn "gc " (current-gc-milliseconds)) (each (name time) (tablist times*) (prn name " " time))) ;; what happens when our virtual machine starts up (= initialization-fns* (queue)) (def reset () (each f (as cons initialization-fns*) (f))) (mac on-init body `(enq (fn () ,@body) initialization-fns*)) ;; persisting and checking traces for each test (= traces* (queue)) (= trace-dir* ".traces/") (ensure-dir trace-dir*) (= curr-trace-file* nil) (on-init (awhen curr-trace-file* (tofile (+ trace-dir* it) (each (label trace) (as cons traces*) (pr label ": " trace)))) (= curr-trace-file* nil) (= traces* (queue))) (def new-trace (filename) (prn "== @filename") ;? ) (= curr-trace-file* filename)) (= dump-trace* nil) (def trace (label . args) (when (or (is dump-trace* t) (and dump-trace* (is label "-")) (and dump-trace* (pos label dump-trace*!whitelist)) (and dump-trace* (no dump-trace*!whitelist) (~pos label dump-trace*!blacklist))) (apply prn label ": " args)) (enq (list label (apply tostring:prn args)) traces*) (car args)) (on-init (wipe dump-trace*)) (redef tr args ; why am I still returning to prn when debugging? Will this help? (do1 nil (apply trace "-" args))) (def tr2 (msg arg) (tr msg arg) arg) (def check-trace-contents (msg expected-contents) (unless (trace-contents-match expected-contents) (prn "F - " msg) (prn " trace contents") (print-trace-contents-mismatch expected-contents))) (def trace-contents-match (expected-contents) (each (label msg) (as cons traces*) (when (and expected-contents (is label expected-contents.0.0) (posmatch expected-contents.0.1 msg)) (pop expected-contents))) (no expected-contents)) (def print-trace-contents-mismatch (expected-contents) (each (label msg) (as cons traces*) (whenlet (expected-label expected-msg) expected-contents.0 (if (and (is label expected-label) (posmatch expected-msg msg)) (do (pr " * ") (pop expected-contents)) (pr " ")) (pr label ": " msg))) (prn " couldn't find") (each (expected-label expected-msg) expected-contents (prn " ! " expected-label ": " expected-msg))) (def check-trace-doesnt-contain (msg (label unexpected-contents)) (when (some (fn ((l s)) (and (is l label) (posmatch unexpected-contents msg))) (as cons traces*)) (prn "F - " msg) (prn " trace contents") (each (l msg) (as cons traces*) (if (and (is l label) (posmatch unexpected-contents msg)) (pr " X ") (pr " ")) (pr label ": " msg)))) ;; virtual machine state ; things that a future assembler will need separate memory for: ; code; types; args channel ; at compile time: mapping names to locations (on-init (= type* (table)) ; name -> type info (= memory* (table)) ; address -> value (make this a vector?) (= function* (table)) ; name -> [instructions] ; transforming mu programs (= location* (table)) ; function -> {name -> index into default-space} (= next-space-generator* (table)) ; function -> name of function generating next space ; each function's next space will usually always come from a single function (= next-routine-id* 0) (= continuation* (table)) ) (on-init (= type* (obj ; Each type must be scalar or array, sum or product or primitive type (obj size 1) ; implicitly scalar and primitive type-address (obj size 1 address t elem '(type)) type-array (obj array t elem '(type)) type-array-address (obj size 1 address t elem '(type-array)) location (obj size 1 address t elem '(location)) ; assume it points to an atom integer (obj size 1) boolean (obj size 1) boolean-address (obj size 1 address t elem '(boolean)) byte (obj size 1) byte-address (obj size 1 address t elem '(byte)) string (obj array t elem '(byte)) ; inspired by Go ; an address contains the location of a specific type string-address (obj size 1 address t elem '(string)) string-address-address (obj size 1 address t elem '(string-address)) string-address-array (obj array t elem '(string-address)) string-address-array-address (obj size 1 address t elem '(string-address-array)) string-address-array-address-address (obj size 1 address t elem '(string-address-array-address)) ; 'character' will be of larger size when mu supports unicode ; we're currently undisciplined about mixing 'byte' and 'character' ; realistic test of indiscipline in general character (obj size 1) ; int32 like a Go rune character-address (obj size 1 address t elem '(character)) ; a buffer makes it easy to append to a string/array ; todo: make this generic ; data isn't a 'real' array: its length is stored outside it, ; so for example, 'print-string' won't work on it. buffer (obj size 2 and-record t elems '((integer) (string-address)) fields '(length data)) buffer-address (obj size 1 address t elem '(buffer)) ; a stream makes it easy to read from a string/array stream (obj size 2 and-record t elems '((integer) (string-address)) fields '(pointer data)) stream-address (obj size 1 address t elem '(stream)) ; isolating function calls space (obj array t elem '(location)) ; by convention index 0 points to outer space space-address (obj size 1 address t elem '(space)) ; arrays consist of an integer length followed by that many ; elements, all of the same type integer-array (obj array t elem '(integer)) integer-array-address (obj size 1 address t elem '(integer-array)) integer-array-address-address (obj size 1 address t elem '(integer-array-address)) integer-address (obj size 1 address t elem '(integer)) ; pointer to int integer-address-address (obj size 1 address t elem '(integer-address)) ; and-records consist of a multiple fields of different types integer-boolean-pair (obj size 2 and-record t elems '((integer) (boolean)) fields '(int bool)) integer-boolean-pair-address (obj size 1 address t elem '(integer-boolean-pair)) integer-boolean-pair-array (obj array t elem '(integer-boolean-pair)) integer-boolean-pair-array-address (obj size 1 address t elem '(integer-boolean-pair-array)) integer-integer-pair (obj size 2 and-record t elems '((integer) (integer))) integer-integer-pair-address (obj size 1 address t elem '(integer-integer-pair)) integer-point-pair (obj size 2 and-record t elems '((integer) (integer-integer-pair))) integer-point-pair-address (obj size 1 address t elem '(integer-point-pair)) integer-point-pair-address-address (obj size 1 address t elem '(integer-point-pair-address)) ; tagged-values are the foundation of dynamic types tagged-value (obj size 2 and-record t elems '((type) (location)) fields '(type payload)) tagged-value-address (obj size 1 address t elem '(tagged-value)) tagged-value-array (obj array t elem '(tagged-value)) tagged-value-array-address (obj size 1 address t elem '(tagged-value-array)) tagged-value-array-address-address (obj size 1 address t elem '(tagged-value-array-address)) ; heterogeneous lists list (obj size 2 and-record t elems '((tagged-value) (list-address)) fields '(car cdr)) list-address (obj size 1 address t elem '(list)) list-address-address (obj size 1 address t elem '(list-address)) ; parallel routines use channels to synchronize channel (obj size 3 and-record t elems '((integer) (integer) (tagged-value-array-address)) fields '(first-full first-free circular-buffer)) ; be careful of accidental copies to channels channel-address (obj size 1 address t elem '(channel)) ; opaque pointer to a call stack ; todo: save properly in allocated memory continuation (obj size 1) ; editor line (obj array t elem '(character)) line-address (obj size 1 address t elem '(line)) line-address-address (obj size 1 address t elem '(line-address)) screen (obj array t elem '(line-address)) screen-address (obj size 1 address t elem '(screen)) ; fake screen terminal (obj size 5 and-record t elems '((integer) (integer) (integer) (integer) (string-address)) fields '(num-rows num-cols cursor-row cursor-col data)) terminal-address (obj size 1 address t elem '(terminal)) ; fake keyboard keyboard (obj size 2 and-record t elems '((integer) (string-address)) fields '(index data)) keyboard-address (obj size 1 address t elem '(keyboard)) ))) ;; managing concurrent routines (on-init ;? (prn "-- resetting memory allocation") (= Memory-allocated-until 1000) (= Allocation-chunk 100000)) ; routine = runtime state for a serial thread of execution (def make-routine (fn-name . args) (let curr-alloc Memory-allocated-until ;? (prn "-- allocating routine: @curr-alloc") (++ Memory-allocated-until Allocation-chunk) (annotate 'routine (obj alloc curr-alloc alloc-max Memory-allocated-until call-stack (list (obj fn-name fn-name pc 0 args args caller-arg-idx 0)))) ; other fields we use in routine: ; sleep: conditions ; limit: number of cycles this routine can use ; running-since: start of the clock for counting cycles this routine has used ; todo: do memory management in mu )) (defextend empty (x) (isa x 'routine) (no rep.x!call-stack)) (def stack (routine) ((rep routine) 'call-stack)) (def push-stack (routine op) (push (obj fn-name op pc 0 caller-arg-idx 0 t0 (msec)) rep.routine!call-stack)) (def pop-stack (routine) ;? (update-time label.routine (msec)) ;? 1 (pop rep.routine!call-stack)) (def top (routine) stack.routine.0) (def label (routine) (whenlet stack stack.routine (or= stack.0!label (label2 stack)))) (def label2 (stack) (string:intersperse "/" (map [_ 'fn-name] stack)));)) (def body (routine) (function* stack.routine.0!fn-name)) (mac pc (routine (o idx 0)) ; assignable `((((rep ,routine) 'call-stack) ,idx) 'pc)) (mac caller-arg-idx (routine (o idx 0)) ; assignable `((((rep ,routine) 'call-stack) ,idx) 'caller-arg-idx)) (mac caller-args (routine) ; assignable `((((rep ,routine) 'call-stack) 0) 'args)) (mac caller-operands (routine) ; assignable `((((rep ,routine) 'call-stack) 0) 'caller-operands)) (mac caller-results (routine) ; assignable `((((rep ,routine) 'call-stack) 0) 'caller-results)) (mac results (routine) ; assignable `((((rep ,routine) 'call-stack) 0) 'results)) (mac reply-args (routine) ; assignable `((((rep ,routine) 'call-stack) 0) 'reply-args)) (def waiting-for-exact-cycle? (routine) (is 'until rep.routine!sleep.0)) (def ready-to-wake-up (routine) (assert no.routine*) (case rep.routine!sleep.0 until (> curr-cycle* rep.routine!sleep.1) until-location-changes (~is rep.routine!sleep.2 (memory* rep.routine!sleep.1)) until-routine-done (find [and _ (is rep._!id rep.routine!sleep.1)] completed-routines*) )) (on-init (= running-routines* (queue)) ; simple round-robin scheduler ; set of sleeping routines; don't modify routines while they're in this table (= sleeping-routines* (table)) (= completed-routines* nil) ; audit trail (= routine* nil) (= abort-routine* (parameter nil)) (= curr-cycle* 0) (= scheduling-interval* 500) (= scheduler-switch-table* nil) ; hook into scheduler for debugging ) ; like arc's 'point' but you can also call ((abort-routine*)) in nested calls (mac routine-mark body (w/uniq (g p) `(ccc (fn (,g) (parameterize abort-routine* (fn ((o ,p)) (,g ,p)) ,@body))))) (def run fn-names (freeze function*) ;? (prn function*!main) ;? 1 (load-system-functions) (apply run-more fn-names)) ; assume we've already frozen; throw on a few more routines and continue scheduling (def run-more fn-names (each it fn-names (enq make-routine.it running-routines*)) (while (~empty running-routines*) (= routine* deq.running-routines*) (when rep.routine*!limit ; start the clock if it wasn't already running (or= rep.routine*!running-since curr-cycle*)) (trace "schedule" label.routine*) (routine-mark (run-for-time-slice scheduling-interval*)) (update-scheduler-state))) ; prepare next iteration of round-robin scheduler ; ; state before: routine* running-routines* sleeping-routines* ; state after: running-routines* (with next routine to run at head) sleeping-routines* ; ; responsibilities: ; add routine* to either running-routines* or sleeping-routines* or completed-routines* ; wake up any necessary sleeping routines (which might be waiting for a ; particular time or for a particular memory location to change) ; detect termination: all non-helper routines completed ; detect deadlock: kill all sleeping routines when none can be woken (def update-scheduler-state () (when routine* ;? (prn "update scheduler state: " routine*) (if rep.routine*!sleep (do (trace "schedule" "pushing " label.routine* " to sleep queue") ; keep the clock ticking at rep.routine*!running-since (set sleeping-routines*.routine*)) rep.routine*!error (do (trace "schedule" "done with dead routine " label.routine*) ;? (tr rep.routine*) (push routine* completed-routines*)) empty.routine* (do (trace "schedule" "done with routine " label.routine*) (push routine* completed-routines*)) (no rep.routine*!limit) (do (trace "schedule" "sc
/*
 * (C)opyright MMVI Anselm R. Garbe <garbeam at gmail dot com>
 * See LICENSE file for license details.
 */
#include "dwm.h"
#include <stdlib.h>
#include <X11/keysym.h>
#include <X11/Xatom.h>

/* static */

typedef struct {
	unsigned long mod;
	KeySym keysym;
	void (*func)(Arg *arg);
	Arg arg;
} Key;

KEYS

#define CLEANMASK(mask) (mask & ~(NUMLOCKMASK | LockMask))

static void
movemouse(Client *c)
{
	int x1, y1, ocx, ocy, di;
	unsigned int dui;
	Window dummy;
	XEvent ev;

	ocx = c->x;
	ocy = c->y;
	if(XGrabPointer(dpy, root, False, MOUSEMASK, GrabModeAsync, GrabModeAsync,
			None, cursor[CurMove], CurrentTime) != GrabSuccess)
		return;
	XQueryPointer(dpy, root, &dummy, &dummy, &x1, &y1, &di, &di, &dui);
	for(;;) {
		XMaskEvent(dpy, MOUSEMASK | ExposureMask, &ev);
		switch (ev.type) {
		default: break;
		case Expose:
			handler[Expose](&ev);
			break;
		case MotionNotify:
			XSync(dpy, False);
			c->x = ocx + (ev.xmotion.x - x1);
			c->y = ocy + (ev.xmotion.y - y1);
			resize(c, False, TopLeft);
			break;
		case ButtonRelease:
			XUngrabPointer(dpy, CurrentTime);
			return;
		}
	}
}

static void
resizemouse(Client *c)
{
	int ocx, ocy;
	Corner sticky;
	XEvent ev;

	ocx = c->x;
	ocy = c->y;
	if(XGrabPointer(dpy, root, False, MOUSEMASK, GrabModeAsync, GrabModeAsync,
				None, cursor[CurResize], CurrentTime) != GrabSuccess)
		return;
	XWarpPointer(dpy, None, c->win, 0, 0, 0, 0, c->w, c->h);
	for(;;) {
		XMaskEvent(dpy, MOUSEMASK | ExposureMask, &ev);
		switch(ev.type) {
		default: break;
		case Expose:
			handler[Expose](&ev);
			break;
		case MotionNotify:
			XSync(dpy, False);
			c->w = abs(ocx - ev.xmotion.x);
			c->h = abs(ocy - ev.xmotion.y);
			c->x = (ocx <= ev.xmotion.x) ? ocx : ocx - c->w;
			c->y = (ocy <= ev.xmotion.y) ? ocy : ocy - c->h;
			if(ocx <= ev.xmotion.x)
				sticky = (ocy <= ev.xmotion.y) ? TopLeft : BotLeft;
			else
				sticky = (ocy <= ev.xmotion.y) ? TopRight : BotRight;
			resize(c, True, sticky);
			break;
		case ButtonRelease:
			XUngrabPointer(dpy, CurrentTime);
			return;
		}
	}
}

static void
buttonpress(XEvent *e)
{
	int x;
	Arg a;
	Client *c;
	XButtonPressedEvent *ev = &e->xbutton;

	if(barwin == ev->window) {
		switch(ev->button) {
		default:
			x = 0;
			for(a.i = 0; a.i < ntags; a.i++) {
				x += textw(tags[a.i]);
				if(ev->x < x) {
					view(&a);
					return;
				}
			}
			if(ev->button == Button1)
				viewprev(&a);
			else if(ev->button == Button3)
				viewnext(&a);
			break;
		case Button4:
			viewprev(&a);
			break;
		case Button5:
			viewnext(&a);
			break;
		}
	}
	else if((c = getclient(ev->window))) {
		higher(c);
		focus(c);
		switch(ev->button) {
		default:
			break;
		case Button1:
			if(!c->ismax && (arrange == dofloat || c->isfloat))
				movemouse(c);
			break;
		case Button2:
			zoom(NULL);
			break;
		case Button3:
			if(!c->ismax && (arrange == dofloat || c->isfloat))
				resizemouse(c);
			break;
		}
	}
}

static void
configurerequest(XEvent *e)
{
	Client *c;
	XConfigureRequestEvent *ev = &e->xconfigurerequest;
	XEvent synev;
	XWindowChanges wc;
	unsigned long newmask;

	if((c = getclient(ev->window))) {
		gravitate(c, True);
		if(ev->value_mask & CWX)
			c->x = ev->x;
		if(ev->value_mask & CWY)
			c->y = ev->y;
		if(ev->value_mask & CWWidth)
			c->w = ev->width;
		if(ev->value_mask & CWHeight)
			c->h = ev->height;
		if(ev->value_mask & CWBorderWidth)
			c->border = ev->border_width;
		gravitate(c, False);
		wc.x = c->x;
		wc.y = c->y;
		wc.width = c->w;
		wc.height = c->h;
		newmask = ev->value_mask & (~(CWSibling | CWStackMode | CWBorderWidth));
		if(newmask)
			XConfigureWindow(dpy, c->win, newmask, &wc);
		else {
			synev.type = ConfigureNotify;
			synev.xconfigure.display = dpy;
			synev.xconfigure.event = c->win;
			synev.xconfigure.window = c->win;
			synev.xconfigure.x = c->x;
			synev.xconfigure.y = c->y;
			synev.xconfigure.width = c->w;
			synev.xconfigure.height = c->h;
			synev.xconfigure.border_width = c->border;
			synev.xconfigure.above = None;
			/* Send synthetic ConfigureNotify */
			XSendEvent(dpy, c->win, True, NoEventMask, &synev);
		}
		XSync(dpy, False);
		if(c->isfloat)
			resize(c, False, TopLeft);
		else
			arrange(NULL);
	}
	else {
		wc.x = ev->x;
		wc.y = ev->y;
		wc.width = ev->width;
		wc.height = ev->height;
		wc.border_width = ev->border_width;
		wc.sibling = ev->above;
		wc.stack_mode = ev->detail;
		XConfigureWindow(dpy, ev->window, ev->value_mask, &wc);
		XSync(dpy, False);
	}
}

static void
destroynotify(XEvent *e)
{
	Client *c;
	XDestroyWindowEvent *ev = &e->xdestroywindow;

	if((c = getclient(ev->window)))
		unmanage(c);
}

static void
enternotify(XEvent *e)
{
	Client *c;
	XCrossingEvent *ev = &e->xcrossing;

	if(ev->mode != NotifyNormal || ev->detail == NotifyInferior)
		return;

	if((c = getclient(ev->window)) || (c = getctitle(ev->window)))
		focus(c);
	else if(ev->window == root) {
		issel = True;
		XSetInputFocus(dpy, root, RevertToPointerRoot, CurrentTime);
		drawall();
	}
}

static void
expose(XEvent *e)
{
	Client *c;
	XExposeEvent *ev = &e->xexpose;

	if(ev->count == 0) {
		if(barwin == ev->window)
			drawstatus();
		else if((c = getctitle(ev->window)))
			drawtitle(c);
	}
}

static void
keypress(XEvent *e)
{
	static unsigned int len = sizeof(key) / sizeof(key[0]);
	unsigned int i;
	KeySym keysym;
	XKeyEvent *ev = &e->xkey;

	keysym = XKeycodeToKeysym(dpy, (KeyCode)ev->keycode, 0);
	for(i = 0; i < len; i++)
		if(keysym == key[i].keysym &&
				CLEANMASK(key[i].mod) == CLEANMASK(ev->state)) {
			if(key[i].func)
				key[i].func(&key[i].arg);
			return;
		}
}

static void
leavenotify(XEvent *e)
{
	XCrossingEvent *ev = &e->xcrossing;

	if((ev->window == root) && !ev->same_screen) {
		issel = False;
		drawall();
	}
}

static void
maprequest(XEvent *e)
{
	static XWindowAttributes wa;
	XMapRequestEvent *ev = &e->xmaprequest;

	if(!XGetWindowAttributes(dpy, ev->window, &wa))
		return;

	if(wa.override_redirect) {
		XSelectInput(dpy, ev->window,
				(StructureNotifyMask | PropertyChangeMask));
		return;
	}

	if(!getclient(ev->window))
		manage(ev->window, &wa);
}

static void
propertynotify(XEvent *e)
{
	Client *c;
	Window trans;
	XPropertyEvent *ev = &e->xproperty;

	if(ev->state == PropertyDelete)
		return; /* ignore */

	if((c = getclient(ev->window))) {
		if(ev->atom == wmatom[WMProtocols]) {
			c->proto = getproto(c->win);
			return;
		}
		switch (ev->atom) {
			default: break;
			case XA_WM_TRANSIENT_FOR:
				XGetTransientForHint(dpy, c->win, &trans);
				if(!c->isfloat && (c->isfloat = (trans != 0)))
					arrange(NULL);
				break;
			case XA_WM_NORMAL_HINTS:
				setsize(c);
				break;
		}
		if(ev->atom == XA_WM_NAME || ev->atom == netatom[NetWMName]) {
			settitle(c);
			drawtitle(c);
		}
	}
}

static void
unmapnotify(XEvent *e)
{
	Client *c;
	XUnmapEvent *ev = &e->xunmap;

	if((c = getclient(ev->window)))
		unmanage(c);
}

/* extern */

void (*handler[LASTEvent]) (XEvent *) = {
	[ButtonPress] = buttonpress,
	[ConfigureRequest] = configurerequest,
	[DestroyNotify] = destroynotify,
	[EnterNotify] = enternotify,
	[LeaveNotify] = leavenotify,
	[Expose] = expose,
	[KeyPress] = keypress,
	[MapRequest] = maprequest,
	[PropertyNotify] = propertynotify,
	[UnmapNotify] = unmapnotify
};

void
grabkeys()
{
	static unsigned int len = sizeof(key) / sizeof(key[0]);
	unsigned int i;
	KeyCode code;

	for(i = 0; i < len; i++) {
		code = XKeysymToKeycode(dpy, key[i].keysym);
		XGrabKey(dpy, code, key[i].mod, root, True,
				GrabModeAsync, GrabModeAsync);
		XGrabKey(dpy, code, key[i].mod | LockMask, root, True,
				GrabModeAsync, GrabModeAsync);
		XGrabKey(dpy, code, key[i].mod | NUMLOCKMASK, root, True,
				GrabModeAsync, GrabModeAsync);
		XGrabKey(dpy, code, key[i].mod | NUMLOCKMASK | LockMask, root, True,
				GrabModeAsync, GrabModeAsync);
	}
}
generated by cgit-pink 1.4.1-2-gfad0 (git 2.36.2.497.gbbea4dcf42) at 2025-07-30 09:49:24 +0000
qual idx:integer len:integer) (break-if done?:boolean) (idx:integer <- add idx:integer 1:literal) (count:integer <- add count:integer 1:literal) (loop) } ; allocate space ;? ($print (("alloc: " literal))) ;? ($print count:integer) ;? ($print (("\n" literal))) (result:string-address-array-address <- new string-address-array:literal count:integer) ; repeatedly copy slices (start..end) until delimiter into result[curr-result] (curr-result:integer <- copy 0:literal) (start:integer <- copy 0:literal) { begin ; while next delim exists (done?:boolean <- greater-or-equal start:integer len:integer) (break-if done?:boolean) (end:integer <- find-next s:string-address delim:character start:integer) ;? ($print start:integer) ;? 1 ;? ($print ((" " literal))) ;? 1 ;? ($print end:integer) ;? 1 ;? ($print (("\n" literal))) ;? 1 ; copy start..end into result[curr-result] (dest:string-address-address <- index-address result:string-address-array-address/deref curr-result:integer) (dest:string-address-address/deref <- string-copy s:string-address start:integer end:integer) ; slide over to next slice (start:integer <- add end:integer 1:literal) (curr-result:integer <- add curr-result:integer 1:literal) (loop) } (reply result:string-address-array-address) ) (init-fn split-first-at-substring/variant:split-first ; string text, string delim -> string first, string rest (default-space:space-address <- new space:literal 30:literal) (text:string-address <- next-input) (delim:string-address <- next-input) ; empty string? return empty strings (len:integer <- length text:string-address/deref) { begin (empty?:boolean <- equal len:integer 0:literal) (break-unless empty?:boolean) (x:string-address <- new "") (y:string-address <- new "") (reply x:string-address y:string-address) } (idx:integer <- find-substring text:string-address delim:string-address 0:literal) (x:string-address <- string-copy text:string-address 0:literal idx:integer) (k:integer <- length delim:string-address/deref) (idx:integer <- add idx:integer k:integer) (y:string-address <- string-copy text:string-address idx:integer len:integer) (reply x:string-address y:string-address) ) (init-fn split-first ; string text, character delim -> string first, string rest (default-space:space-address <- new space:literal 30:literal) (text:string-address <- next-input) (delim:character <- next-input) ; empty string? return empty strings (len:integer <- length text:string-address/deref) { begin (empty?:boolean <- equal len:integer 0:literal) (break-unless empty?:boolean) (x:string-address <- new "") (y:string-address <- new "") (reply x:string-address y:string-address) } (idx:integer <- find-next text:string-address delim:character 0:literal) (x:string-address <- string-copy text:string-address 0:literal idx:integer) (idx:integer <- add idx:integer 1:literal) (y:string-address <- string-copy text:string-address idx:integer len:integer) (reply x:string-address y:string-address) ) ; todo: make this generic (init-fn string-copy ; buf start end -> address of new array (default-space:space-address <- new space:literal 30:literal) (buf:string-address <- next-input) (start:integer <- next-input) (end:integer <- next-input) ;? ($print ((" copy: " literal))) ;? 1 ;? ($print start:integer) ;? 1 ;? ($print (("-" literal))) ;? 1 ;? ($print end:integer) ;? 1 ;? ($print (("\n" literal))) ;? 1 ; if end is out of bounds, trim it (len:integer <- length buf:string-address/deref) (end:integer <- min len:integer end:integer) ; allocate space for result (len:integer <- subtract end:integer start:integer) (result:string-address <- new string:literal len:integer) ; copy start..end into result[curr-result] (src-idx:integer <- copy start:integer) (dest-idx:integer <- copy 0:literal) { begin (done?:boolean <- greater-or-equal src-idx:integer end:integer) (break-if done?:boolean) (src:character <- index buf:string-address/deref src-idx:integer) ;? ($print ((" copying " literal))) ;? 1 ;? ($print src:character) ;? 1 ;? ($print (("\n" literal))) ;? 1 (dest:character-address <- index-address result:string-address/deref dest-idx:integer) (dest:character-address/deref <- copy src:character) (src-idx:integer <- add src-idx:integer 1:literal) (dest-idx:integer <- add dest-idx:integer 1:literal) (loop) } (reply result:string-address) ) (init-fn min (default-space:space-address <- new space:literal 30:literal) (x:integer <- next-input) (y:integer <- next-input) { begin (return-x?:boolean <- less-than x:integer y:integer) (break-if return-x?:boolean) (reply y:integer) } (reply x:integer) ) (init-fn max (default-space:space-address <- new space:literal 30:literal) (x:integer <- next-input) (y:integer <- next-input) { begin (return-x?:boolean <- greater-than x:integer y:integer) (break-if return-x?:boolean) (reply y:integer) } (reply x:integer) ) (init-fn init-stream (default-space:space-address <- new space:literal 30:literal) (in:string-address <- next-input) (result:stream-address <- new stream:literal) (x:integer-address <- get-address result:stream-address/deref pointer:offset) (x:integer-address/deref <- copy 0:literal) (y:string-address-address <- get-address result:stream-address/deref data:offset) (y:string-address-address/deref <- copy in:string-address) (reply result:stream-address) ) (init-fn rewind-stream (default-space:space-address <- new space:literal 30:literal) (in:stream-address <- next-input) (x:integer-address <- get-address in:stream-address/deref pointer:offset) (x:integer-address/deref <- copy 0:literal) (reply in:stream-address/same-as-arg:0) ) (init-fn read-line (default-space:space-address <- new space:literal 30:literal) (in:stream-address <- next-input) (idx:integer-address <- get-address in:stream-address/deref pointer:offset) (s:string-address <- get in:stream-address/deref data:offset) ;? ($print (("idx before: " literal))) ;? 1 ;? ($print idx:integer-address/deref) ;? 1 ;? ($print (("\n" literal))) ;? 1 (next-idx:integer <- find-next s:string-address ((#\newline literal)) idx:integer-address/deref) ;? ($print (("next-idx: " literal))) ;? 1 ;? ($print next-idx:integer) ;? 1 ;? ($print (("\n" literal))) ;? 1 (result:string-address <- string-copy s:string-address idx:integer-address/deref next-idx:integer) (idx:integer-address/deref <- add next-idx:integer 1:literal) ; skip newline ;? ($print (("idx now: " literal))) ;? 1 ;? ($print idx:integer-address/deref) ;? 1 ;? ($print (("\n" literal))) ;? 1 (reply result:string-address) ) (init-fn read-character (default-space:space-address <- new space:literal 30:literal) (in:stream-address <- next-input) (idx:integer-address <- get-address in:stream-address/deref pointer:offset) (s:string-address <- get in:stream-address/deref data:offset) (c:character <- index s:string-address/deref idx:integer-address/deref) (idx:integer-address/deref <- add idx:integer-address/deref 1:literal) (reply c:character) ) (init-fn end-of-stream? (default-space:space-address <- new space:literal 30:literal) (in:stream-address <- next-input) (idx:integer <- get in:stream-address/deref pointer:offset) (s:string-address <- get in:stream-address/deref data:offset) (len:integer <- length s:string-address/deref) ;? ($print (("eos: " literal))) ;? 1 ;? ($print len:integer) ;? 1 ;? ($print (("\n" literal))) ;? 1 ;? ($print (("idx: " literal))) ;? 1 ;? ($print idx:integer) ;? 1 ;? ($print (("\n" literal))) ;? 1 (result:boolean <- greater-or-equal idx:integer len:integer) (reply result:boolean) ) (init-fn init-keyboard (default-space:space-address <- new space:literal 30:literal) (result:keyboard-address <- new keyboard:literal) (buf:string-address-address <- get-address result:keyboard-address/deref data:offset) (buf:string-address-address/deref <- next-input) (idx:integer-address <- get-address result:keyboard-address/deref index:offset) (idx:integer-address/deref <- copy 0:literal) (reply result:keyboard-address) ) (init-fn read-key (default-space:space-address <- new space:literal 30:literal) (x:keyboard-address <- next-input) (screen:terminal-address <- next-input) { begin (break-unless x:keyboard-address) (idx:integer-address <- get-address x:keyboard-address/deref index:offset) (buf:string-address <- get x:keyboard-address/deref data:offset) (max:integer <- length buf:string-address/deref) { begin (done?:boolean <- greater-or-equal idx:integer-address/deref max:integer) (break-unless done?:boolean) (reply ((#\null literal))) } (c:character <- index buf:string-address/deref idx:integer-address/deref) (idx:integer-address/deref <- add idx:integer-address/deref 1:literal) (reply c:character) } ; real keyboard input is infrequent; avoid polling it too much (sleep for-some-cycles:literal 1:literal) (c:character <- read-key-from-host) ; when we read from a real keyboard we print to screen as well { begin (break-unless c:character) (silent?:boolean <- equal screen:terminal-address ((silent literal))) (break-if silent?:boolean) ;? ($print (("aaaa\n" literal))) ;? 1 (print-character-to-host c:character) } (reply c:character) ) (init-fn wait-for-key (default-space:space-address <- new space:literal 30:literal) (k:keyboard-address <- next-input) (screen:terminal-address <- next-input) { begin (result:character <- read-key k:keyboard-address screen:terminal-address) (loop-unless result:character) } (reply result:character) ) (init-fn send-keys-to-stdin (default-space:space-address <- new space:literal 30:literal) (k:keyboard-address <- next-input) (stdin:channel-address <- next-input) ;? (c:character <- copy ((#\a literal))) ;? 1 ;? (curr:tagged-value <- save-type c:character) ;? 1 ;? (stdin:channel-address/deref <- write stdin:channel-address curr:tagged-value) ;? 1 ;? (c:character <- copy ((#\newline literal))) ;? 1 ;? (curr:tagged-value <- save-type c:character) ;? 1 ;? (stdin:channel-address/deref <- write stdin:channel-address curr:tagged-value) ;? 1 { begin (c:character <- read-key k:keyboard-address) (loop-unless c:character) (curr:tagged-value <- save-type c:character) (stdin:channel-address/deref <- write stdin:channel-address curr:tagged-value) (eof?:boolean <- equal c:character ((#\null literal))) (break-if eof?:boolean) (loop) } ) ; collect characters until newline before sending out (init-fn buffer-lines (default-space:space-address <- new space:literal 30:literal) (stdin:channel-address <- next-input) (buffered-stdin:channel-address <- next-input) ; repeat forever { begin (line:buffer-address <- init-buffer 30:literal) ;? ($dump-channel 1093:literal) ;? 1 ; read characters from stdin until newline, copy into line { begin (x:tagged-value stdin:channel-address/deref <- read stdin:channel-address) (c:character <- maybe-coerce x:tagged-value character:literal) (assert c:character) ;? ($print line:buffer-address) ;? 2 ;? ($print (("\n" literal))) ;? 2 ;? ($print c:character) ;? 2 ;? ($print (("\n" literal))) ;? 2 ; handle backspace { begin (backspace?:boolean <- equal c:character ((#\backspace literal))) (break-unless backspace?:boolean) (len:integer-address <- get-address line:buffer-address/deref length:offset) ; but only if we need to { begin ;? ($print (("backspace: " literal))) ;? 1 ;? ($print len:integer-address/deref) ;? 1 ;? ($print (("\n" literal))) ;? 1 (zero?:boolean <- lesser-or-equal len:integer-address/deref 0:literal) (break-if zero?:boolean) (len:integer-address/deref <- subtract len:integer-address/deref 1:literal) } (loop 2:blocks) } (line:buffer-address <- append line:buffer-address c:character) (line-done?:boolean <- equal c:character ((#\newline literal))) (break-if line-done?:boolean) (eof?:boolean <- equal c:character ((#\null literal))) (break-if eof?:boolean 2:blocks) (loop) } ; copy line into buffered-stdout (i:integer <- copy 0:literal) (line-contents:string-address <- get line:buffer-address/deref data:offset) (max:integer <- get line:buffer-address/deref length:offset) ;? ($print (("len: " literal))) ;? 1 ;? ($print max:integer) ;? 1 ;? ($print (("\n" literal))) ;? 1 { begin (done?:boolean <- greater-or-equal i:integer max:integer) (break-if done?:boolean) (c:character <- index line-contents:string-address/deref i:integer) (curr:tagged-value <- save-type c:character) ;? ($dump-channel 1093:literal) ;? 1 ;? ($start-tracing) ;? 1 ;? ($print (("bufferout: " literal))) ;? 2 ;? ($print c:character) ;? 1 ;? (x:integer <- character-to-integer c:character) ;? 1 ;? ($print x:integer) ;? 1 ;? ($print (("\n" literal))) ;? 2 (buffered-stdin:channel-address/deref <- write buffered-stdin:channel-address curr:tagged-value) ;? ($stop-tracing) ;? 1 ;? ($dump-channel 1093:literal) ;? 1 ;? ($quit) ;? 1 (i:integer <- add i:integer 1:literal) (loop) } (loop) } ) (init-fn clear-screen (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) { begin (break-unless x:terminal-address) ;? ($print (("AAA" literal))) (buf:string-address <- get x:terminal-address/deref data:offset) (max:integer <- length buf:string-address/deref) (i:integer <- copy 0:literal) { begin (done?:boolean <- greater-or-equal i:integer max:integer) (break-if done?:boolean) (x:byte-address <- index-address buf:string-address/deref i:integer) (x:byte-address/deref <- copy ((#\space literal))) (i:integer <- add i:integer 1:literal) (loop) } (reply) } (clear-host-screen) ) (init-fn cursor (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) (newrow:integer <- next-input) (newcol:integer <- next-input) { begin (break-unless x:terminal-address) (row:integer-address <- get-address x:terminal-address/deref cursor-row:offset) (row:integer-address/deref <- copy newrow:integer) (col:integer-address <- get-address x:terminal-address/deref cursor-col:offset) (col:integer-address/deref <- copy newcol:integer) (reply) } (cursor-on-host row:integer col:integer) ) (init-fn cursor-to-next-line (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) { begin (break-unless x:terminal-address) (row:integer-address <- get-address x:terminal-address/deref cursor-row:offset) ;? ($print row:integer-address/deref) ;? ($print (("\n" literal))) (row:integer-address/deref <- add row:integer-address/deref 1:literal) (col:integer-address <- get-address x:terminal-address/deref cursor-col:offset) ;? ($print col:integer-address/deref) ;? ($print (("\n" literal))) (col:integer-address/deref <- copy 0:literal) (reply) } (cursor-on-host-to-next-line) ) (init-fn cursor-down (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) ;? ($print ((#\# literal))) ;? 1 (height:integer-address <- get-address x:terminal-address/deref num-rows:offset) ;? ($print height:integer-address/deref) ;? 1 { begin (break-unless x:terminal-address) ;? ($print ((#\% literal))) ;? 1 (row:integer-address <- get-address x:terminal-address/deref cursor-row:offset) ;? ($print (("cursor down: " literal))) ;? 1 ;? ($print row:integer-address/deref) ;? 1 ;? ($print (("\n" literal))) ;? 1 { begin (bottom?:boolean <- greater-or-equal row:integer-address/deref height:integer-address/deref) (break-if bottom?:boolean) (row:integer-address/deref <- add row:integer-address/deref 1:literal) ;? ($print ((#\* literal))) ;? 1 ;? ($print row:integer-address/deref) ;? 1 } (reply) } (cursor-down-on-host) ) (init-fn cursor-up (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) { begin (break-unless x:terminal-address) (row:integer-address <- get-address x:terminal-address/deref cursor-row:offset) ;? ($print (("cursor up: " literal))) ;? 1 ;? ($print row:integer-address/deref) ;? 1 ;? ($print (("\n" literal))) ;? 1 { begin (top?:boolean <- lesser-or-equal row:integer-address/deref 0:literal) (break-if top?:boolean) (row:integer-address/deref <- subtract row:integer-address/deref 1:literal) } (reply) } (cursor-up-on-host) ) (init-fn cursor-left (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) { begin (break-unless x:terminal-address) (col:integer-address <- get-address x:terminal-address/deref cursor-col:offset) { begin (edge?:boolean <- lesser-or-equal col:integer-address/deref 0:literal) (break-if edge?:boolean) (col:integer-address/deref <- subtract col:integer-address/deref 1:literal) } (reply) } (cursor-left-on-host) ) (init-fn cursor-right (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) (width:integer-address <- get-address x:terminal-address/deref num-cols:offset) { begin (break-unless x:terminal-address) (col:integer-address <- get-address x:terminal-address/deref cursor-col:offset) { begin (edge?:boolean <- lesser-or-equal col:integer-address/deref width:integer-address/deref) (break-if edge?:boolean) (col:integer-address/deref <- add col:integer-address/deref 1:literal) } (reply) } (cursor-right-on-host) ) (init-fn replace-character (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) (c:character <- next-input) (print-character x:terminal-address c:character) (cursor-left x:terminal-address) ) (init-fn clear-line (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) { begin (break-unless x:terminal-address) (n:integer <- get x:terminal-address/deref num-cols:offset) (col:integer-address <- get-address x:terminal-address/deref cursor-col:offset) (orig-col:integer <- copy col:integer-address/deref) ; space over the entire line { begin (done?:boolean <- greater-or-equal col:integer-address/deref n:integer) (break-if done?:boolean) (print-character x:terminal-address ((#\space literal))) ; implicitly updates 'col' (loop) } ; now back to where the cursor was (col:integer-address/deref <- copy orig-col:integer) (reply) } (clear-line-on-host) ) (init-fn print-character (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) (c:character <- next-input) (fg:integer/color <- next-input) (bg:integer/color <- next-input) ;? ($print (("printing character to screen " literal))) ;? ($print c:character) ;? (reply) ;? ($print (("\n" literal))) { begin (break-unless x:terminal-address) (row:integer-address <- get-address x:terminal-address/deref cursor-row:offset) ;? ($print row:integer-address/deref) ;? 2 ;? ($print ((", " literal))) ;? 1 (col:integer-address <- get-address x:terminal-address/deref cursor-col:offset) ;? ($print col:integer-address/deref) ;? 1 ;? ($print (("\n" literal))) ;? 1 (width:integer <- get x:terminal-address/deref num-cols:offset) (t1:integer <- multiply row:integer-address/deref width:integer) (idx:integer <- add t1:integer col:integer-address/deref) (buf:string-address <- get x:terminal-address/deref data:offset) (cursor:byte-address <- index-address buf:string-address/deref idx:integer) (cursor:byte-address/deref <- copy c:character) ; todo: newline, etc. (col:integer-address/deref <- add col:integer-address/deref 1:literal) ; we don't rely on any auto-wrap functionality ; maybe die if we go out of screen bounds? (reply) } (print-character-to-host c:character fg:integer/color bg:integer/color) ) (init-fn print-string (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) (s:string-address <- next-input) (len:integer <- length s:string-address/deref) ;? ($print (("print/string: len: " literal))) ;? ($print len:integer) ;? ($print (("\n" literal))) (i:integer <- copy 0:literal) { begin (done?:boolean <- greater-or-equal i:integer len:integer) (break-if done?:boolean) (c:character <- index s:string-address/deref i:integer) (print-character x:terminal-address c:character) (i:integer <- add i:integer 1:literal) (loop) } ) (init-fn print-integer (default-space:space-address <- new space:literal 30:literal) (x:terminal-address <- next-input) (n:integer <- next-input) ; todo: other bases besides decimal ;? ($print (("AAA " literal))) ;? ($print n:integer) (s:string-address <- integer-to-decimal-string n:integer) ;? ($print s:string-address) (print-string x:terminal-address s:string-address) ) (init-fn init-buffer (default-space:space-address <- new space:literal 30:literal) (result:buffer-address <- new buffer:literal) (len:integer-address <- get-address result:buffer-address/deref length:offset) (len:integer-address/deref <- copy 0:literal) (s:string-address-address <- get-address result:buffer-address/deref data:offset) (capacity:integer <- next-input) (s:string-address-address/deref <- new string:literal capacity:integer) (reply result:buffer-address) ) (init-fn grow-buffer (default-space:space-address <- new space:literal 30:literal) (in:buffer-address <- next-input) ; double buffer size (x:string-address-address <- get-address in:buffer-address/deref data:offset) (oldlen:integer <- length x:string-address-address/deref/deref) ;? ($print oldlen:integer) ;? 1 (newlen:integer <- multiply oldlen:integer 2:literal) ;? ($print newlen:integer) ;? 1 (olddata:string-address <- copy x:string-address-address/deref) (x:string-address-address/deref <- new string:literal newlen:integer) ; copy old contents (i:integer <- copy 0:literal) { begin (done?:boolean <- greater-or-equal i:integer oldlen:integer) (break-if done?:boolean) (src:byte <- index olddata:string-address/deref i:integer) (dest:byte-address <- index-address x:string-address-address/deref/deref i:integer) (dest:byte-address/deref <- copy src:byte) (i:integer <- add i:integer 1:literal) (loop) } (reply in:buffer-address) ) (init-fn buffer-full? (default-space:space-address <- new space:literal 30:literal) (in:buffer-address <- next-input) (len:integer <- get in:buffer-address/deref length:offset) (s:string-address <- get in:buffer-address/deref data:offset) (capacity:integer <- length s:string-address/deref) (result:boolean <- greater-or-equal len:integer capacity:integer) (reply result:boolean) ) (init-fn buffer-index (default-space:space-address <- new space:literal 30:literal) (in:buffer-address <- next-input) (idx:integer <- next-input) { begin (len:integer <- get in:buffer-address/deref length:offset) (not-too-high?:boolean <- less-than idx:integer len:integer) (not-too-low?:boolean <- greater-or-equal idx:integer 0:literal) (in-bounds?:boolean <- and not-too-low?:boolean not-too-high?:boolean) (break-if in-bounds?:boolean) (assert nil:literal (("buffer-index out of bounds" literal))) } (s:string-address <- get in:buffer-address/deref data:offset) (result:character <- index s:string-address/deref idx:integer) (reply result:character) ) (init-fn to-array ; from buffer (default-space:space-address <- new space:literal 30:literal) (in:buffer-address <- next-input) (len:integer <- get in:buffer-address/deref length:offset) (s:string-address <- get in:buffer-address/deref data:offset) { begin ; test: ctrl-d -> s is nil -> to-array returns nil -> read-expression returns t -> exit repl (break-if s:string-address) (reply nil:literal) } ; we can't just return s because it is usually the wrong length (result:string-address <- new string:literal len:integer) (i:integer <- copy 0:literal) { begin (done?:boolean <- greater-or-equal i:integer len:integer) (break-if done?:boolean) (src:byte <- index s:string-address/deref i:integer) ;? (foo:integer <- character-to-integer src:byte) ;? 1 ;? ($print (("a: " literal))) ;? 1 ;? ($print foo:integer) ;? 1 ;? ($print ((#\newline literal))) ;? 1 (dest:byte-address <- index-address result:string-address/deref i:integer) (dest:byte-address/deref <- copy src:byte) (i:integer <- add i:integer 1:literal) (loop) } (reply result:string-address) ) (init-fn append (default-space:space-address <- new space:literal 30:literal) (in:buffer-address <- next-input) (c:character <- next-input) ;? ($print c:character) ;? 1 { begin ; grow buffer if necessary (full?:boolean <- buffer-full? in:buffer-address) ;? ($print (("aa\n" literal))) ;? 1 (break-unless full?:boolean) ;? ($print (("bb\n" literal))) ;? 1 (in:buffer-address <- grow-buffer in:buffer-address) ;? ($print (("cc\n" literal))) ;? 1 } (len:integer-address <- get-address in:buffer-address/deref length:offset) (s:string-address <- get in:buffer-address/deref data:offset) (dest:byte-address <- index-address s:string-address/deref len:integer-address/deref) (dest:byte-address/deref <- copy c:character) (len:integer-address/deref <- add len:integer-address/deref 1:literal) (reply in:buffer-address/same-as-arg:0) ) (init-fn last (default-space:space-address <- new space:literal 30:literal) (in:buffer-address <- next-input) (n:integer <- get in:buffer-address/deref length:offset) { begin ; if empty return nil (empty?:boolean <- equal n:integer 0:literal) (break-unless empty?:boolean) (reply nil:literal) } (n:integer <- subtract n:integer 1:literal) (s:string-address <- get in:buffer-address/deref data:offset) (result:character <- index s:string-address/deref n:integer) (reply result:character) ) (init-fn integer-to-decimal-string (default-space:space-address <- new space:literal 30:literal) (n:integer <- next-input) ; is it zero? { begin (zero?:boolean <- equal n:integer 0:literal) (break-unless zero?:boolean) (s:string-address <- new "0") (reply s:string-address) } ; save sign (negate-result:boolean <- copy nil:literal) { begin (negative?:boolean <- less-than n:integer 0:literal) (break-unless negative?:boolean) ;? ($print (("is negative " literal))) (negate-result:boolean <- copy t:literal) (n:integer <- multiply n:integer -1:literal) } ; add digits from right to left into intermediate buffer (tmp:buffer-address <- init-buffer 30:literal) (zero:character <- copy ((#\0 literal))) (digit-base:integer <- character-to-integer zero:character) { begin (done?:boolean <- equal n:integer 0:literal) (break-if done?:boolean) (n:integer digit:integer <- divide-with-remainder n:integer 10:literal) (digit-codepoint:integer <- add digit-base:integer digit:integer) (c:character <- integer-to-character digit-codepoint:integer) (tmp:buffer-address <- append tmp:buffer-address c:character) (loop) } ; add sign { begin (break-unless negate-result:boolean) (tmp:buffer-address <- append tmp:buffer-address ((#\- literal))) } ; reverse buffer into string result (len:integer <- get tmp:buffer-address/deref length:offset) (buf:string-address <- get tmp:buffer-address/deref data:offset) (result:string-address <- new string:literal len:integer) (i:integer <- subtract len:integer 1:literal) (j:integer <- copy 0:literal) { begin ; while (i >= 0) (done?:boolean <- less-than i:integer 0:literal) (break-if done?:boolean) ; result[j] = tmp[i] (src:byte <- index buf:string-address/deref i:integer) (dest:byte-address <- index-address result:string-address/deref j:integer) (dest:byte-address/deref <- copy src:byte) ; ++i (i:integer <- subtract i:integer 1:literal) ; --j (j:integer <- add j:integer 1:literal) (loop) } (reply result:string-address) ) (init-fn send-prints-to-stdout (default-space:space-address <- new space:literal 30:literal) (screen:terminal-address <- next-input) (stdout:channel-address <- next-input) ;? (i:integer <- copy 0:literal) ;? 1 { begin (x:tagged-value stdout:channel-address/deref <- read stdout:channel-address) (c:character <- maybe-coerce x:tagged-value character:literal) (done?:boolean <- equal c:character ((#\null literal))) (break-if done?:boolean) ;? ($print (("printing " literal))) ;? 1 ;? ($print i:integer) ;? 1 ;? ($print ((" -- " literal))) ;? 1 ;? (x:integer <- character-to-integer c:character) ;? 1 ;? ($print x:integer) ;? 1 ;? ($print (("\n" literal))) ;? 1 ;? (i:integer <- add i:integer 1:literal) ;? 1 (print-character screen:terminal-address c:character) (loop) } ) ; remember to call this before you clear the screen or at any other milestone ; in an interactive program (init-fn flush-stdout (default-space:boolean <- copy nil:literal) ; silence warning, but die if locals used (sleep for-some-cycles:literal 1:literal) ) (init-fn init-fake-terminal (default-space:space-address <- new space:literal 30:literal/capacity) (result:terminal-address <- new terminal:literal) (width:integer-address <- get-address result:terminal-address/deref num-cols:offset) (width:integer-address/deref <- next-input) (height:integer-address <- get-address result:terminal-address/deref num-rows:offset) (height:integer-address/deref <- next-input) (row:integer-address <- get-address result:terminal-address/deref cursor-row:offset) (row:integer-address/deref <- copy 0:literal) (col:integer-address <- get-address result:terminal-address/deref cursor-col:offset) (col:integer-address/deref <- copy 0:literal) (bufsize:integer <- multiply width:integer-address/deref height:integer-address/deref) (buf:string-address-address <- get-address result:terminal-address/deref data:offset) (buf:string-address-address/deref <- new string:literal bufsize:integer) (clear-screen result:terminal-address) (reply result:terminal-address) ) (init-fn divides? (default-space:space-address <- new space:literal 30:literal/capacity) (x:integer <- next-input) (y:integer <- next-input) (_ remainder:integer <- divide-with-remainder x:integer y:integer) (result:boolean <- equal remainder:integer 0:literal) (reply result:boolean) ) ; after all system software is loaded: ;? (= dump-trace* (obj whitelist '("cn0" "cn1"))) (freeze system-function*) ) ; section 100 for system software ;; initialization (reset) (awhen (pos "--" argv) ; batch mode: load all provided files and start at 'main' (map add-code:readfile (cut argv (+ it 1))) ;? (set dump-trace*) (run 'main) (if ($.current-charterm) ($.close-charterm)) (when ($.graphics-open?) ($.close-viewport Viewport) ($.close-graphics)) ;? (pr "\nmemory: ") ;? (write int-canon.memory*) (prn) (each routine completed-routines* (awhen rep.routine!error (prn "error - " it) ;? (prn routine) )) ) ; repl (def run-interactive (stmt) ; careful to avoid re-processing functions and adding noise to traces (= function*!interactive (convert-labels:convert-braces:tokenize-args (list stmt))) (add-next-space-generator function*!interactive 'interactive) (= location*!interactive (assign-names-to-location function*!interactive 'interactive location*!interactive)) (replace-names-with-location function*!interactive 'interactive) (= traces* (queue)) ; skip preprocessing (run-more 'interactive)) (when (no cdr.argv) (add-code:readfile "trace.mu") (wipe function*!main) (add-code:readfile "factorial.mu") ;? (add-code:readfile "chessboard.mu") ; takes too long (wipe function*!main) (freeze function*) (load-system-functions) (wipe interactive-commands*) (wipe interactive-traces*) (= interactive-cmdidx* 0) (= traces* (queue)) ;? (set dump-trace*) ;? 2 ; interactive mode (point break (while t (pr interactive-cmdidx*)(pr "> ") (let expr (read) (unless expr (break)) (push expr interactive-commands*) (run-interactive expr)) (push traces* interactive-traces*) (++ interactive-cmdidx*) ))) (if ($.current-charterm) ($.close-charterm)) (reset) ;? (print-times)