2015-01-02 19:34:24 +00:00
|
|
|
;; profiler (http://arclanguage.org/item?id=11556)
|
2015-01-02 19:52:58 +00:00
|
|
|
; Keeping this right on top as a reminder to profile before guessing at why my
|
|
|
|
; program is slow.
|
2015-01-02 19:34:24 +00:00
|
|
|
(mac proc (name params . body)
|
|
|
|
`(def ,name ,params ,@body nil))
|
|
|
|
|
|
|
|
(= 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()
|
2015-01-05 09:21:39 +00:00
|
|
|
(prn (current-process-milliseconds))
|
2015-01-02 19:34:24 +00:00
|
|
|
(prn "gc " (current-gc-milliseconds))
|
|
|
|
(each (name time) (tablist times*)
|
|
|
|
(prn name " " time)))
|
|
|
|
|
2014-10-10 22:09:16 +00:00
|
|
|
;; what happens when our virtual machine starts up
|
2014-08-19 17:31:58 +00:00
|
|
|
(= initialization-fns* (queue))
|
2015-01-02 19:39:22 +00:00
|
|
|
(def reset ()
|
2014-08-19 17:31:58 +00:00
|
|
|
(each f (as cons initialization-fns*)
|
|
|
|
(f)))
|
|
|
|
|
2014-08-29 02:53:41 +00:00
|
|
|
(mac on-init body
|
|
|
|
`(enq (fn () ,@body)
|
|
|
|
initialization-fns*))
|
|
|
|
|
2014-10-10 22:09:16 +00:00
|
|
|
;; persisting and checking traces for each test
|
2014-10-07 17:26:14 +00:00
|
|
|
(= traces* (queue))
|
|
|
|
(= trace-dir* ".traces/")
|
|
|
|
(ensure-dir trace-dir*)
|
|
|
|
(= curr-trace-file* nil)
|
2014-08-29 02:53:41 +00:00
|
|
|
(on-init
|
2014-10-07 17:26:14 +00:00
|
|
|
(awhen curr-trace-file*
|
|
|
|
(tofile (+ trace-dir* it)
|
|
|
|
(each (label trace) (as cons traces*)
|
|
|
|
(pr label ": " trace))))
|
|
|
|
(= curr-trace-file* nil)
|
2014-08-29 03:42:15 +00:00
|
|
|
(= traces* (queue)))
|
2014-10-07 17:26:14 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def new-trace (filename)
|
2014-12-18 07:10:49 +00:00
|
|
|
(prn "== @filename")
|
2014-11-25 05:40:59 +00:00
|
|
|
;? )
|
2014-10-07 17:26:14 +00:00
|
|
|
(= curr-trace-file* filename))
|
|
|
|
|
2014-10-07 20:26:01 +00:00
|
|
|
(= dump-trace* nil)
|
2015-01-06 07:28:21 +00:00
|
|
|
(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))
|
2015-01-10 19:16:57 +00:00
|
|
|
traces*)
|
|
|
|
(car args))
|
2014-08-29 03:42:15 +00:00
|
|
|
|
2015-01-10 20:47:59 +00:00
|
|
|
(on-init
|
|
|
|
(wipe dump-trace*))
|
|
|
|
|
2014-11-21 22:40:03 +00:00
|
|
|
(redef tr args ; why am I still returning to prn when debugging? Will this help?
|
|
|
|
(do1 nil
|
|
|
|
(apply trace "-" args)))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def tr2 (msg arg)
|
2014-11-22 02:21:15 +00:00
|
|
|
(tr msg arg)
|
|
|
|
arg)
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def check-trace-contents (msg expected-contents)
|
2014-08-29 03:42:15 +00:00
|
|
|
(unless (trace-contents-match expected-contents)
|
|
|
|
(prn "F - " msg)
|
|
|
|
(prn " trace contents")
|
|
|
|
(print-trace-contents-mismatch expected-contents)))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def trace-contents-match (expected-contents)
|
2014-08-29 03:42:15 +00:00
|
|
|
(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))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def print-trace-contents-mismatch (expected-contents)
|
2014-08-29 03:42:15 +00:00
|
|
|
(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)))
|
2014-08-29 02:53:41 +00:00
|
|
|
|
2014-11-25 05:56:12 +00:00
|
|
|
;; virtual machine state
|
|
|
|
|
|
|
|
; things that a future assembler will need separate memory for:
|
|
|
|
; code; types; args channel
|
2014-12-31 03:04:01 +00:00
|
|
|
; at compile time: mapping names to locations
|
2015-01-10 21:10:23 +00:00
|
|
|
(on-init
|
2014-12-30 22:41:12 +00:00
|
|
|
(= type* (table)) ; name -> type info
|
|
|
|
(= memory* (table)) ; address -> value
|
|
|
|
(= function* (table)) ; name -> [instructions]
|
2015-01-03 02:13:04 +00:00
|
|
|
(= 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
|
2015-01-10 21:10:23 +00:00
|
|
|
(= next-routine-id* 0)
|
2014-11-27 13:24:24 +00:00
|
|
|
)
|
2014-11-25 05:56:12 +00:00
|
|
|
|
|
|
|
(on-init
|
2014-12-17 18:52:54 +00:00
|
|
|
(= type* (obj
|
2014-11-25 05:56:12 +00:00
|
|
|
; Each type must be scalar or array, sum or product or primitive
|
|
|
|
type (obj size 1) ; implicitly scalar and primitive
|
2014-12-17 22:03:34 +00:00
|
|
|
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
|
2014-11-25 05:56:12 +00:00
|
|
|
integer (obj size 1)
|
|
|
|
boolean (obj size 1)
|
2014-12-17 22:03:34 +00:00
|
|
|
boolean-address (obj size 1 address t elem '(boolean))
|
2014-11-25 05:56:12 +00:00
|
|
|
byte (obj size 1)
|
2014-12-17 22:03:34 +00:00
|
|
|
byte-address (obj size 1 address t elem '(byte))
|
|
|
|
string (obj array t elem '(byte)) ; inspired by Go
|
2014-12-28 20:29:35 +00:00
|
|
|
; an address contains the location of a specific type
|
2014-12-17 22:03:34 +00:00
|
|
|
string-address (obj size 1 address t elem '(string))
|
2014-12-20 06:18:41 +00:00
|
|
|
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))
|
2014-11-25 05:56:12 +00:00
|
|
|
character (obj size 1) ; int32 like a Go rune
|
2014-12-17 22:03:34 +00:00
|
|
|
character-address (obj size 1 address t elem '(character))
|
2014-11-25 05:56:12 +00:00
|
|
|
; isolating function calls
|
2015-01-03 02:13:04 +00:00
|
|
|
space (obj array t elem '(location)) ; by convention index 0 points to outer space
|
|
|
|
space-address (obj size 1 address t elem '(space))
|
2014-12-28 20:29:35 +00:00
|
|
|
; arrays consist of an integer length followed by that many
|
|
|
|
; elements, all of the same type
|
2014-12-17 22:03:34 +00:00
|
|
|
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))
|
2014-12-28 20:29:35 +00:00
|
|
|
; and-records consist of a multiple fields of different types
|
2014-12-17 22:03:34 +00:00
|
|
|
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)))
|
2015-01-01 05:24:48 +00:00
|
|
|
integer-integer-pair-address (obj size 1 address t elem '(integer-integer-pair))
|
2014-12-17 22:03:34 +00:00
|
|
|
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))
|
2014-11-25 05:56:12 +00:00
|
|
|
; tagged-values are the foundation of dynamic types
|
2014-12-17 22:03:34 +00:00
|
|
|
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))
|
2014-11-25 05:56:12 +00:00
|
|
|
; heterogeneous lists
|
2014-12-17 22:03:34 +00:00
|
|
|
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))
|
2014-11-25 05:56:12 +00:00
|
|
|
; parallel routines use channels to synchronize
|
2014-12-17 22:03:34 +00:00
|
|
|
channel (obj size 3 and-record t elems '((integer) (integer) (tagged-value-array-address)) fields '(first-full first-free circular-buffer))
|
2014-12-28 23:57:55 +00:00
|
|
|
; be careful of accidental copies to channels
|
2014-12-17 22:03:34 +00:00
|
|
|
channel-address (obj size 1 address t elem '(channel))
|
2014-11-25 05:56:12 +00:00
|
|
|
; editor
|
2014-12-17 22:03:34 +00:00
|
|
|
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))
|
2014-11-25 05:56:12 +00:00
|
|
|
)))
|
2014-07-06 07:07:03 +00:00
|
|
|
|
2014-11-06 18:22:33 +00:00
|
|
|
;; managing concurrent routines
|
2014-11-06 23:24:00 +00:00
|
|
|
|
2014-12-29 17:15:42 +00:00
|
|
|
(on-init
|
|
|
|
(= Memory-allocated-until 1000))
|
|
|
|
|
2014-11-06 23:24:00 +00:00
|
|
|
; routine = runtime state for a serial thread of execution
|
2014-11-19 08:19:57 +00:00
|
|
|
(def make-routine (fn-name . args)
|
2014-12-29 17:15:42 +00:00
|
|
|
(do1
|
2015-01-10 11:32:14 +00:00
|
|
|
(annotate 'routine (obj alloc 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
|
|
|
|
|
2014-12-29 17:17:12 +00:00
|
|
|
; todo: allow routines to expand past initial allocation
|
|
|
|
; todo: do memory management in mu
|
2014-12-29 17:15:42 +00:00
|
|
|
(++ Memory-allocated-until 1000)))
|
2014-11-06 23:24:00 +00:00
|
|
|
|
|
|
|
(defextend empty (x) (isa x 'routine)
|
|
|
|
(no rep.x!call-stack))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def stack (routine)
|
2014-11-06 23:24:00 +00:00
|
|
|
((rep routine) 'call-stack))
|
|
|
|
|
|
|
|
(mac push-stack (routine op)
|
|
|
|
`(push (obj fn-name ,op pc 0 caller-arg-idx 0)
|
|
|
|
((rep ,routine) 'call-stack)))
|
|
|
|
|
|
|
|
(mac pop-stack (routine)
|
|
|
|
`(pop ((rep ,routine) 'call-stack)))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def top (routine)
|
2014-11-06 23:24:00 +00:00
|
|
|
stack.routine.0)
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def body (routine)
|
2015-01-02 19:34:24 +00:00
|
|
|
(function* stack.routine.0!fn-name))
|
2014-11-06 23:24:00 +00:00
|
|
|
|
|
|
|
(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))
|
2014-12-24 09:00:36 +00:00
|
|
|
(mac caller-operands (routine) ; assignable
|
|
|
|
`((((rep ,routine) 'call-stack) 0) 'caller-operands))
|
|
|
|
(mac caller-results (routine) ; assignable
|
|
|
|
`((((rep ,routine) 'call-stack) 0) 'caller-results))
|
2014-11-06 23:24:00 +00:00
|
|
|
|
|
|
|
(mac results (routine) ; assignable
|
|
|
|
`((((rep ,routine) 'call-stack) 0) 'results))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def waiting-for-exact-cycle? (routine)
|
2015-01-10 21:20:13 +00:00
|
|
|
(is 'until rep.routine!sleep.0))
|
2014-11-22 03:29:37 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def ready-to-wake-up (routine)
|
2014-11-22 04:25:41 +00:00
|
|
|
(assert no.routine*)
|
2015-01-09 07:21:56 +00:00
|
|
|
(case rep.routine!sleep.0
|
2015-01-10 21:20:13 +00:00
|
|
|
until
|
2015-01-09 07:21:56 +00:00
|
|
|
(> curr-cycle* rep.routine!sleep.1)
|
|
|
|
until-location-changes
|
|
|
|
(~is rep.routine!sleep.2 (memory* rep.routine!sleep.1))
|
2015-01-10 21:49:16 +00:00
|
|
|
until-routine-done
|
|
|
|
(find [and _ (is rep._!id rep.routine!sleep.1)]
|
|
|
|
completed-routines*)
|
2015-01-09 08:48:13 +00:00
|
|
|
))
|
2014-11-22 04:25:41 +00:00
|
|
|
|
2014-11-06 18:22:33 +00:00
|
|
|
(on-init
|
2014-11-21 22:36:22 +00:00
|
|
|
(= running-routines* (queue)) ; simple round-robin scheduler
|
2014-11-06 23:38:00 +00:00
|
|
|
; set of sleeping routines; don't modify routines while they're in this table
|
|
|
|
(= sleeping-routines* (table))
|
2014-11-21 22:36:22 +00:00
|
|
|
(= completed-routines* nil) ; audit trail
|
2014-11-06 18:22:33 +00:00
|
|
|
(= routine* nil)
|
2014-11-06 19:36:16 +00:00
|
|
|
(= abort-routine* (parameter nil))
|
2014-11-06 23:24:16 +00:00
|
|
|
(= curr-cycle* 0)
|
|
|
|
(= scheduling-interval* 500)
|
2014-11-23 15:19:14 +00:00
|
|
|
(= scheduler-switch-table* nil) ; hook into scheduler for tests
|
2014-11-06 23:24:16 +00:00
|
|
|
)
|
2014-11-06 18:22:33 +00:00
|
|
|
|
|
|
|
; 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
|
2014-12-30 23:13:51 +00:00
|
|
|
(freeze function*)
|
|
|
|
(load-system-functions)
|
2015-01-01 19:11:02 +00:00
|
|
|
;? (write function*)
|
|
|
|
;? (quit)
|
2014-11-27 07:23:44 +00:00
|
|
|
(= traces* (queue))
|
2014-11-06 19:36:16 +00:00
|
|
|
(each it fn-names
|
|
|
|
(enq make-routine.it running-routines*))
|
2014-11-21 22:36:22 +00:00
|
|
|
(while (~empty running-routines*)
|
2014-11-06 19:36:16 +00:00
|
|
|
(= routine* deq.running-routines*)
|
2015-01-10 11:32:14 +00:00
|
|
|
(when rep.routine*!limit
|
|
|
|
; start the clock if it wasn't already running
|
|
|
|
(or= rep.routine*!running-since curr-cycle*))
|
2014-11-06 19:36:16 +00:00
|
|
|
(trace "schedule" top.routine*!fn-name)
|
2014-11-21 22:36:22 +00:00
|
|
|
(routine-mark
|
|
|
|
(run-for-time-slice scheduling-interval*))
|
2014-11-22 03:29:37 +00:00
|
|
|
(update-scheduler-state)
|
|
|
|
;? (tr "after run iter " running-routines*)
|
|
|
|
;? (tr "after run iter " empty.running-routines*)
|
|
|
|
))
|
2014-11-21 22:36:22 +00:00
|
|
|
|
|
|
|
; 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*
|
2014-12-28 23:57:55 +00:00
|
|
|
; wake up any necessary sleeping routines (which might be waiting for a
|
|
|
|
; particular time or for a particular memory location to change)
|
2014-11-21 22:36:22 +00:00
|
|
|
; detect deadlock: kill all sleeping routines when none can be woken
|
2015-01-02 19:39:22 +00:00
|
|
|
(def update-scheduler-state ()
|
2015-01-10 11:32:14 +00:00
|
|
|
;? (tr curr-cycle*)
|
2014-11-22 02:31:48 +00:00
|
|
|
(when routine*
|
|
|
|
(if
|
|
|
|
rep.routine*!sleep
|
|
|
|
(do (trace "schedule" "pushing " top.routine*!fn-name " to sleep queue")
|
2015-01-10 11:32:14 +00:00
|
|
|
; keep the clock ticking at rep.routine*!running-since
|
2014-11-22 02:31:48 +00:00
|
|
|
(set sleeping-routines*.routine*))
|
2015-01-12 02:44:32 +00:00
|
|
|
rep.routine*!error
|
|
|
|
(do (trace "schedule" "done with dead routine " top.routine*!fn-name)
|
2015-01-12 06:03:16 +00:00
|
|
|
;? (prn rep.routine*)
|
2015-01-12 02:44:32 +00:00
|
|
|
(push routine* completed-routines*))
|
2015-01-12 02:41:23 +00:00
|
|
|
empty.routine*
|
|
|
|
(do (trace "schedule" "done with routine")
|
|
|
|
(push routine* completed-routines*))
|
|
|
|
(no rep.routine*!limit)
|
2014-11-22 03:31:30 +00:00
|
|
|
(do (trace "schedule" "scheduling " top.routine*!fn-name " for further processing")
|
2014-11-22 02:31:48 +00:00
|
|
|
(enq routine* running-routines*))
|
2015-01-12 02:41:23 +00:00
|
|
|
(> rep.routine*!limit 0)
|
2015-01-10 11:32:14 +00:00
|
|
|
(do (trace "schedule" "scheduling " top.routine*!fn-name " for further processing (limit)")
|
|
|
|
; stop the clock and debit the time on it from the routine
|
|
|
|
(-- rep.routine*!limit (- curr-cycle* rep.routine*!running-since))
|
|
|
|
(wipe rep.routine*!running-since)
|
|
|
|
(if (<= rep.routine*!limit 0)
|
|
|
|
(do (trace "schedule" "routine ran out of time")
|
|
|
|
(push routine* completed-routines*))
|
|
|
|
(enq routine* running-routines*)))
|
2014-11-22 02:31:48 +00:00
|
|
|
:else
|
2015-01-12 02:41:23 +00:00
|
|
|
(err "illegal scheduler state"))
|
2014-11-22 02:31:48 +00:00
|
|
|
(= routine* nil))
|
2014-12-04 10:50:33 +00:00
|
|
|
;? (tr 111)
|
2014-11-22 03:29:37 +00:00
|
|
|
(each (routine _) canon.sleeping-routines*
|
2015-01-10 11:32:14 +00:00
|
|
|
;? (tr routine)
|
|
|
|
(when (aand rep.routine!limit (<= it (- curr-cycle* rep.routine!running-since)))
|
|
|
|
(trace "schedule" "routine timed out")
|
|
|
|
(wipe sleeping-routines*.routine)
|
|
|
|
(push routine completed-routines*)
|
|
|
|
;? (tr completed-routines*)
|
|
|
|
))
|
|
|
|
(each (routine _) canon.sleeping-routines*
|
2014-11-22 04:25:41 +00:00
|
|
|
(when (ready-to-wake-up routine)
|
|
|
|
(trace "schedule" "waking up " top.routine!fn-name)
|
|
|
|
(wipe sleeping-routines*.routine) ; do this before modifying routine
|
|
|
|
(wipe rep.routine!sleep)
|
|
|
|
(++ pc.routine)
|
|
|
|
(enq routine running-routines*)))
|
2014-12-04 10:50:33 +00:00
|
|
|
;? (tr 112)
|
2015-01-10 11:32:14 +00:00
|
|
|
; optimization for simulated time
|
2014-11-22 03:29:37 +00:00
|
|
|
(when (empty running-routines*)
|
|
|
|
(whenlet exact-sleeping-routines (keep waiting-for-exact-cycle? keys.sleeping-routines*)
|
2015-01-09 07:21:56 +00:00
|
|
|
(let next-wakeup-cycle (apply min (map [rep._!sleep 1] exact-sleeping-routines))
|
2014-11-22 03:29:37 +00:00
|
|
|
(= curr-cycle* (+ 1 next-wakeup-cycle))
|
|
|
|
(trace "schedule" "skipping to cycle " curr-cycle*)
|
2014-11-22 04:47:48 +00:00
|
|
|
(update-scheduler-state))))
|
2015-01-12 06:54:51 +00:00
|
|
|
(when (and (all [rep._ 'helper] (as cons running-routines*))
|
|
|
|
(all [rep._ 'helper] keys.sleeping-routines*))
|
|
|
|
(until (empty running-routines*)
|
|
|
|
(push (deq running-routines*) completed-routines*))
|
|
|
|
(until sleeping-routines*
|
|
|
|
(push (pop sleeping-routines*) completed-routines*)))
|
2014-12-04 10:50:33 +00:00
|
|
|
;? (tr 113)
|
|
|
|
(detect-deadlock)
|
|
|
|
;? (tr 114)
|
|
|
|
)
|
2014-11-21 22:36:22 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def detect-deadlock ()
|
2014-11-22 07:43:27 +00:00
|
|
|
(when (and (empty running-routines*)
|
|
|
|
(~empty sleeping-routines*)
|
2014-11-08 05:39:00 +00:00
|
|
|
(~some 'literal (map (fn(_) rep._!sleep.1)
|
|
|
|
keys.sleeping-routines*)))
|
|
|
|
(each (routine _) sleeping-routines*
|
|
|
|
(wipe sleeping-routines*.routine)
|
|
|
|
(= rep.routine!error "deadlock detected")
|
2014-11-22 04:47:48 +00:00
|
|
|
(push routine completed-routines*))))
|
2014-11-08 05:39:00 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def die (msg)
|
2014-11-29 09:38:54 +00:00
|
|
|
(tr "die: " msg)
|
2014-11-06 18:22:33 +00:00
|
|
|
(= rep.routine*!error msg)
|
|
|
|
(= rep.routine*!stack-trace rep.routine*!call-stack)
|
2014-11-29 01:43:33 +00:00
|
|
|
(iflet abort-continuation (abort-routine*)
|
|
|
|
(abort-continuation)))
|
2014-11-06 18:22:33 +00:00
|
|
|
|
|
|
|
;; running a single routine
|
2014-11-29 02:02:16 +00:00
|
|
|
|
2014-12-14 20:36:42 +00:00
|
|
|
; value of an arg or oarg, stripping away all metadata
|
|
|
|
; wish I could have this flag an error when arg is incorrectly formed
|
2014-10-29 07:18:58 +00:00
|
|
|
(mac v (operand) ; for value
|
2014-12-13 10:07:48 +00:00
|
|
|
`((,operand 0) 0))
|
2014-07-31 08:53:14 +00:00
|
|
|
|
2014-12-14 17:46:49 +00:00
|
|
|
; routines consist of instrs
|
|
|
|
; instrs consist of oargs, op and args
|
2015-01-02 19:39:22 +00:00
|
|
|
(def parse-instr (instr)
|
2014-12-31 07:38:50 +00:00
|
|
|
;? (prn instr)
|
2014-12-14 17:46:49 +00:00
|
|
|
(iflet delim (pos '<- instr)
|
|
|
|
(list (cut instr 0 delim) ; oargs
|
|
|
|
(v (instr (+ delim 1))) ; op
|
|
|
|
(cut instr (+ delim 2))) ; args
|
|
|
|
(list nil (v car.instr) cdr.instr)))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def metadata (operand)
|
2014-08-21 02:49:05 +00:00
|
|
|
cdr.operand)
|
2014-07-31 09:27:41 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def ty (operand)
|
2014-12-13 10:07:48 +00:00
|
|
|
(cdr operand.0))
|
2014-07-31 08:53:14 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def literal? (operand)
|
2014-12-28 22:07:30 +00:00
|
|
|
(in ty.operand.0 'literal 'offset 'fn))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def typeinfo (operand)
|
2014-12-17 18:52:54 +00:00
|
|
|
(or (type* ty.operand.0)
|
2014-11-07 08:59:23 +00:00
|
|
|
(err "unknown type @(tostring prn.operand)")))
|
2014-08-22 02:55:16 +00:00
|
|
|
|
2014-12-14 20:36:42 +00:00
|
|
|
; operand accessors
|
2015-01-02 19:39:22 +00:00
|
|
|
(def nondummy (operand) ; precondition for helpers below
|
2014-12-14 20:36:42 +00:00
|
|
|
(~is '_ operand))
|
|
|
|
|
|
|
|
; just for convenience, 'new' instruction sometimes takes a raw string and
|
|
|
|
; allocates just enough space to store it
|
2015-01-02 19:39:22 +00:00
|
|
|
(def not-raw-string (operand)
|
2014-12-14 20:36:42 +00:00
|
|
|
(~isa operand 'string))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def address? (operand)
|
2014-12-18 07:14:58 +00:00
|
|
|
(or (is ty.operand.0 'location)
|
|
|
|
typeinfo.operand!address))
|
|
|
|
|
2014-10-05 03:18:55 +00:00
|
|
|
($:require "charterm/main.rkt")
|
2014-12-24 07:38:16 +00:00
|
|
|
($:require graphics/graphics)
|
|
|
|
(= Viewport nil)
|
2014-10-05 03:18:55 +00:00
|
|
|
|
2014-11-29 02:02:16 +00:00
|
|
|
; run instructions from 'routine*' for 'time-slice'
|
2015-01-06 07:28:21 +00:00
|
|
|
(def run-for-time-slice (time-slice)
|
2014-08-28 23:40:28 +00:00
|
|
|
(point return
|
2014-08-28 23:47:09 +00:00
|
|
|
(for ninstrs 0 (< ninstrs time-slice) (++ ninstrs)
|
2014-10-29 20:05:08 +00:00
|
|
|
(if (empty body.routine*) (err "@stack.routine*.0!fn-name not defined"))
|
2014-12-26 03:39:32 +00:00
|
|
|
; falling out of end of function = implicit reply
|
2014-10-29 20:05:08 +00:00
|
|
|
(while (>= pc.routine* (len body.routine*))
|
|
|
|
(pop-stack routine*)
|
|
|
|
(if empty.routine* (return ninstrs))
|
2014-12-31 02:51:34 +00:00
|
|
|
(when (pos '<- (body.routine* pc.routine*))
|
2015-01-01 19:11:02 +00:00
|
|
|
(die "No results returned: @(tostring:prn (body.routine* pc.routine*))"))
|
2014-10-29 20:05:08 +00:00
|
|
|
(++ pc.routine*))
|
2014-11-06 19:36:16 +00:00
|
|
|
(++ curr-cycle*)
|
2015-01-02 19:34:24 +00:00
|
|
|
;? (trace "run" "-- " int-canon.memory*)
|
2014-11-06 19:36:16 +00:00
|
|
|
(trace "run" curr-cycle* " " top.routine*!fn-name " " pc.routine* ": " (body.routine* pc.routine*))
|
2014-11-01 00:35:24 +00:00
|
|
|
;? (trace "run" routine*)
|
2014-11-23 06:26:11 +00:00
|
|
|
(when (atom (body.routine* pc.routine*)) ; label
|
2014-11-23 15:19:14 +00:00
|
|
|
(when (aand scheduler-switch-table*
|
|
|
|
(alref it (body.routine* pc.routine*)))
|
|
|
|
(++ pc.routine*)
|
|
|
|
(trace "run" "context-switch forced " abort-routine*)
|
|
|
|
((abort-routine*)))
|
2014-11-23 06:26:11 +00:00
|
|
|
(++ pc.routine*)
|
|
|
|
(continue))
|
2014-10-29 20:05:08 +00:00
|
|
|
(let (oarg op arg) (parse-instr (body.routine* pc.routine*))
|
2014-11-18 18:53:33 +00:00
|
|
|
(let results
|
2014-07-31 10:46:05 +00:00
|
|
|
(case op
|
2014-10-10 22:04:14 +00:00
|
|
|
; arithmetic
|
2014-07-31 10:46:05 +00:00
|
|
|
add
|
|
|
|
(+ (m arg.0) (m arg.1))
|
2014-12-13 01:54:31 +00:00
|
|
|
subtract
|
2014-07-31 10:46:05 +00:00
|
|
|
(- (m arg.0) (m arg.1))
|
2014-12-13 01:54:31 +00:00
|
|
|
multiply
|
2014-07-31 10:46:05 +00:00
|
|
|
(* (m arg.0) (m arg.1))
|
2014-12-13 01:54:31 +00:00
|
|
|
divide
|
2014-07-31 10:46:05 +00:00
|
|
|
(/ (real (m arg.0)) (m arg.1))
|
2014-12-13 01:54:31 +00:00
|
|
|
divide-with-remainder
|
2014-08-27 05:00:23 +00:00
|
|
|
(list (trunc:/ (m arg.0) (m arg.1))
|
|
|
|
(mod (m arg.0) (m arg.1)))
|
2014-10-10 22:04:14 +00:00
|
|
|
|
|
|
|
; boolean
|
2014-07-31 10:46:05 +00:00
|
|
|
and
|
|
|
|
(and (m arg.0) (m arg.1))
|
|
|
|
or
|
|
|
|
(or (m arg.0) (m arg.1))
|
|
|
|
not
|
|
|
|
(not (m arg.0))
|
2014-10-10 22:04:14 +00:00
|
|
|
|
|
|
|
; comparison
|
2014-12-13 01:54:31 +00:00
|
|
|
equal
|
2015-01-12 06:03:16 +00:00
|
|
|
;? (do (prn (m arg.0) " vs " (m arg.1))
|
2014-07-31 10:46:05 +00:00
|
|
|
(is (m arg.0) (m arg.1))
|
2015-01-12 06:03:16 +00:00
|
|
|
;? )
|
2014-12-13 01:54:31 +00:00
|
|
|
not-equal
|
2014-07-31 10:46:05 +00:00
|
|
|
(~is (m arg.0) (m arg.1))
|
2014-12-13 01:54:31 +00:00
|
|
|
less-than
|
2014-07-31 10:46:05 +00:00
|
|
|
(< (m arg.0) (m arg.1))
|
2014-12-13 01:54:31 +00:00
|
|
|
greater-than
|
2014-07-31 10:46:05 +00:00
|
|
|
(> (m arg.0) (m arg.1))
|
2014-12-13 01:54:31 +00:00
|
|
|
lesser-or-equal
|
2014-07-31 10:46:05 +00:00
|
|
|
(<= (m arg.0) (m arg.1))
|
2014-12-13 01:54:31 +00:00
|
|
|
greater-or-equal
|
2014-07-31 10:46:05 +00:00
|
|
|
(>= (m arg.0) (m arg.1))
|
2014-10-10 22:04:14 +00:00
|
|
|
|
|
|
|
; control flow
|
2014-10-15 00:51:30 +00:00
|
|
|
jump
|
2014-10-29 20:05:08 +00:00
|
|
|
(do (= pc.routine* (+ 1 pc.routine* (v arg.0)))
|
2014-07-31 10:46:05 +00:00
|
|
|
(continue))
|
2014-10-15 00:51:30 +00:00
|
|
|
jump-if
|
2015-01-10 18:36:59 +00:00
|
|
|
(when (m arg.0)
|
|
|
|
(= pc.routine* (+ 1 pc.routine* (v arg.1)))
|
|
|
|
(continue))
|
2014-10-15 01:24:46 +00:00
|
|
|
jump-unless ; convenient helper
|
2015-01-10 18:36:59 +00:00
|
|
|
(unless (m arg.0)
|
|
|
|
(= pc.routine* (+ 1 pc.routine* (v arg.1)))
|
|
|
|
(continue))
|
2014-10-10 22:04:14 +00:00
|
|
|
|
2014-12-17 18:39:58 +00:00
|
|
|
; data management: scalars, arrays, and-records (structs)
|
2014-07-31 10:46:05 +00:00
|
|
|
copy
|
|
|
|
(m arg.0)
|
2014-08-20 04:33:48 +00:00
|
|
|
get
|
2014-11-29 04:08:24 +00:00
|
|
|
(with (operand (canonize arg.0)
|
|
|
|
idx (v arg.1))
|
2014-12-14 17:46:49 +00:00
|
|
|
(assert (iso '(offset) (ty arg.1)) "record index @arg.1 must have type 'offset'")
|
2014-11-29 04:08:24 +00:00
|
|
|
(assert (< -1 idx (len typeinfo.operand!elems)) "@idx is out of bounds of record @operand")
|
2014-12-14 17:46:49 +00:00
|
|
|
(m `((,(apply + v.operand
|
2014-12-17 22:03:34 +00:00
|
|
|
(map (fn(x) (sizeof `((_ ,@x))))
|
|
|
|
(firstn idx typeinfo.operand!elems)))
|
|
|
|
,@typeinfo.operand!elems.idx)
|
2014-12-27 06:21:25 +00:00
|
|
|
(raw))))
|
2014-10-05 18:34:23 +00:00
|
|
|
get-address
|
2014-11-29 04:08:24 +00:00
|
|
|
(with (operand (canonize arg.0)
|
|
|
|
idx (v arg.1))
|
2014-12-14 17:46:49 +00:00
|
|
|
(assert (iso '(offset) (ty arg.1)) "record index @arg.1 must have type 'offset'")
|
2014-11-29 04:08:24 +00:00
|
|
|
(assert (< -1 idx (len typeinfo.operand!elems)) "@idx is out of bounds of record @operand")
|
|
|
|
(apply + v.operand
|
2014-12-17 22:03:34 +00:00
|
|
|
(map (fn(x) (sizeof `((_ ,@x))))
|
|
|
|
(firstn idx typeinfo.operand!elems))))
|
2014-10-06 03:03:03 +00:00
|
|
|
index
|
2014-11-29 04:08:24 +00:00
|
|
|
(withs (operand (canonize arg.0)
|
|
|
|
elemtype typeinfo.operand!elem
|
|
|
|
idx (m arg.1))
|
2015-01-01 19:11:02 +00:00
|
|
|
;? (write arg.0)
|
|
|
|
;? (pr " => ")
|
|
|
|
;? (write operand)
|
|
|
|
;? (prn)
|
2014-11-29 04:08:24 +00:00
|
|
|
(unless (< -1 idx array-len.operand)
|
|
|
|
(die "@idx is out of bounds of array @operand"))
|
2014-12-14 17:46:49 +00:00
|
|
|
(m `((,(+ v.operand
|
|
|
|
1 ; for array size
|
2014-12-17 22:03:34 +00:00
|
|
|
(* idx (sizeof `((_ ,@elemtype)))))
|
|
|
|
,@elemtype)
|
2014-12-27 06:21:25 +00:00
|
|
|
(raw))))
|
2014-10-06 03:03:03 +00:00
|
|
|
index-address
|
2014-11-29 04:08:24 +00:00
|
|
|
(withs (operand (canonize arg.0)
|
|
|
|
elemtype typeinfo.operand!elem
|
|
|
|
idx (m arg.1))
|
|
|
|
(unless (< -1 idx array-len.operand)
|
|
|
|
(die "@idx is out of bounds of array @operand"))
|
|
|
|
(+ v.operand
|
|
|
|
1 ; for array size
|
2014-12-17 22:03:34 +00:00
|
|
|
(* idx (sizeof `((_ ,@elemtype))))))
|
2014-08-31 18:20:28 +00:00
|
|
|
new
|
2014-11-27 06:43:51 +00:00
|
|
|
(if (isa arg.0 'string)
|
|
|
|
; special-case: allocate space for a literal string
|
|
|
|
(new-string arg.0)
|
|
|
|
(let type (v arg.0)
|
2014-12-14 17:46:49 +00:00
|
|
|
(assert (iso '(literal) (ty arg.0)) "new: second arg @arg.0 must be literal")
|
2014-12-17 18:52:54 +00:00
|
|
|
(if (no type*.type) (err "no such type @type"))
|
2014-11-27 06:43:51 +00:00
|
|
|
; todo: initialize memory. currently racket does it for us
|
2014-12-17 18:52:54 +00:00
|
|
|
(if type*.type!array
|
2014-11-27 06:43:51 +00:00
|
|
|
(new-array type (m arg.1))
|
|
|
|
(new-scalar type))))
|
2014-10-05 18:32:25 +00:00
|
|
|
sizeof
|
2014-12-17 22:03:34 +00:00
|
|
|
(sizeof `((_ ,(m arg.0))))
|
2014-12-13 01:54:31 +00:00
|
|
|
length
|
2014-10-05 18:32:25 +00:00
|
|
|
(let base arg.0
|
2014-12-18 07:14:58 +00:00
|
|
|
(if (or typeinfo.base!array address?.base)
|
2014-10-05 18:32:25 +00:00
|
|
|
array-len.base
|
|
|
|
-1))
|
2014-10-05 03:19:12 +00:00
|
|
|
|
2014-10-24 18:38:02 +00:00
|
|
|
; tagged-values require one primitive
|
|
|
|
save-type
|
2014-12-14 20:36:42 +00:00
|
|
|
(annotate 'record `(,((ty arg.0) 0) ,(m arg.0)))
|
2014-10-24 18:38:02 +00:00
|
|
|
|
2015-01-01 05:24:48 +00:00
|
|
|
; code points for characters
|
|
|
|
character-to-integer
|
|
|
|
($.char->integer (m arg.0))
|
2015-01-02 23:30:33 +00:00
|
|
|
integer-to-character
|
|
|
|
($.integer->char (m arg.0))
|
2015-01-01 05:24:48 +00:00
|
|
|
|
2014-10-05 03:19:12 +00:00
|
|
|
; multiprocessing
|
|
|
|
fork
|
2014-12-29 00:42:18 +00:00
|
|
|
; args: fn globals-table args ...
|
2015-01-10 20:38:14 +00:00
|
|
|
(let routine (apply make-routine (m arg.0) (map m (nthcdr 3 arg)))
|
2015-01-10 21:10:23 +00:00
|
|
|
(= rep.routine!id ++.next-routine-id*)
|
2014-12-28 23:57:55 +00:00
|
|
|
(= rep.routine!globals (when (len> arg 1) (m arg.1)))
|
2015-01-10 20:38:14 +00:00
|
|
|
(= rep.routine!limit (when (len> arg 2) (m arg.2)))
|
2015-01-10 21:10:23 +00:00
|
|
|
(enq routine running-routines*)
|
|
|
|
rep.routine!id)
|
2015-01-12 06:54:51 +00:00
|
|
|
fork-helper
|
|
|
|
; args: fn globals-table args ...
|
|
|
|
(let routine (apply make-routine (m arg.0) (map m (nthcdr 3 arg)))
|
|
|
|
(= rep.routine!id ++.next-routine-id*)
|
|
|
|
(set rep.routine!helper)
|
|
|
|
(= rep.routine!globals (when (len> arg 1) (m arg.1)))
|
|
|
|
(= rep.routine!limit (when (len> arg 2) (m arg.2)))
|
|
|
|
(enq routine running-routines*)
|
|
|
|
rep.routine!id)
|
2014-11-06 23:38:00 +00:00
|
|
|
sleep
|
2015-01-09 07:21:56 +00:00
|
|
|
(do
|
|
|
|
(case (v arg.0)
|
|
|
|
for-some-cycles
|
|
|
|
(let wakeup-time (+ curr-cycle* (v arg.1))
|
2015-01-10 19:16:57 +00:00
|
|
|
(trace "run" "sleeping until " wakeup-time) ; TODO
|
2015-01-10 21:20:13 +00:00
|
|
|
(= rep.routine*!sleep `(until ,wakeup-time)))
|
2015-01-09 07:21:56 +00:00
|
|
|
until-location-changes
|
|
|
|
(= rep.routine*!sleep `(until-location-changes ,(addr arg.1) ,(m arg.1)))
|
2015-01-10 21:49:16 +00:00
|
|
|
until-routine-done
|
|
|
|
(= rep.routine*!sleep `(until-routine-done ,(m arg.1)))
|
2015-01-10 20:28:00 +00:00
|
|
|
; else
|
|
|
|
(die "badly formed 'sleep' call @(tostring:prn (body.routine* pc.routine*))")
|
2015-01-09 08:48:13 +00:00
|
|
|
)
|
2014-11-07 03:05:20 +00:00
|
|
|
((abort-routine*)))
|
2015-01-10 21:15:10 +00:00
|
|
|
assert
|
|
|
|
(unless (m arg.0)
|
|
|
|
(die (v arg.1))) ; other routines will be able to look at the error status
|
2014-10-05 03:19:12 +00:00
|
|
|
|
2015-01-04 08:34:14 +00:00
|
|
|
; cursor-based (text mode) interaction
|
2014-12-13 01:54:31 +00:00
|
|
|
clear-screen
|
2015-01-04 08:34:14 +00:00
|
|
|
(do1 nil
|
|
|
|
(if ($.current-charterm)
|
|
|
|
($.charterm-clear-screen)
|
|
|
|
($.graphics-open?)
|
|
|
|
($.clear-viewport Viewport)))
|
2014-12-13 01:54:31 +00:00
|
|
|
clear-line
|
2014-10-05 06:00:19 +00:00
|
|
|
(do1 nil ($.charterm-clear-line))
|
|
|
|
cursor
|
|
|
|
(do1 nil ($.charterm-cursor (m arg.0) (m arg.1)))
|
2015-01-02 22:46:19 +00:00
|
|
|
cursor-to-next-line
|
|
|
|
(do1 nil ($.charterm-newline))
|
2014-10-15 00:27:10 +00:00
|
|
|
print-primitive
|
2014-10-05 17:44:14 +00:00
|
|
|
(do1 nil ((if ($.current-charterm) $.charterm-display pr) (m arg.0)))
|
2014-12-13 01:54:31 +00:00
|
|
|
read-key
|
2015-01-06 07:28:21 +00:00
|
|
|
(if ($.current-charterm)
|
|
|
|
(and ($.charterm-byte-ready?) ($.charterm-read-key))
|
|
|
|
($.graphics-open?)
|
|
|
|
($.ready-key-press Viewport))
|
2015-01-01 05:24:48 +00:00
|
|
|
wait-for-key
|
2015-01-06 07:28:21 +00:00
|
|
|
(if ($.current-charterm)
|
|
|
|
($.charterm-read-key)
|
|
|
|
($.graphics-open?)
|
|
|
|
($.get-key-press Viewport))
|
2014-10-05 06:00:19 +00:00
|
|
|
bold-mode
|
|
|
|
(do1 nil ($.charterm-bold))
|
|
|
|
non-bold-mode
|
|
|
|
(do1 nil ($.charterm-normal))
|
2014-10-05 17:44:14 +00:00
|
|
|
console-on
|
2014-10-15 00:21:39 +00:00
|
|
|
(do1 nil (if (no ($.current-charterm)) ($.open-charterm)))
|
2014-10-05 17:44:14 +00:00
|
|
|
console-off
|
|
|
|
(do1 nil (if ($.current-charterm) ($.close-charterm)))
|
2014-10-05 06:00:19 +00:00
|
|
|
|
2014-12-24 07:38:16 +00:00
|
|
|
; graphics
|
|
|
|
graphics-on
|
|
|
|
(do1 nil
|
|
|
|
($.open-graphics)
|
2015-01-05 09:21:39 +00:00
|
|
|
(= Viewport ($.open-viewport (m arg.0) ; name
|
|
|
|
(m arg.1) (m arg.2)))) ; width height
|
2014-12-24 07:38:16 +00:00
|
|
|
graphics-off
|
|
|
|
(do1 nil
|
2015-01-04 08:34:14 +00:00
|
|
|
($.close-viewport Viewport) ; why doesn't this close the window? works in naked racket. not racket vs arc.
|
2014-12-24 07:38:16 +00:00
|
|
|
($.close-graphics)
|
|
|
|
(= Viewport nil))
|
|
|
|
mouse-position
|
|
|
|
(aif ($.ready-mouse-click Viewport)
|
|
|
|
(let posn ($.mouse-click-posn it)
|
|
|
|
(list (annotate 'record (list ($.posn-x posn) ($.posn-y posn))) t))
|
|
|
|
(list nil nil))
|
2015-01-04 08:34:14 +00:00
|
|
|
wait-for-mouse
|
|
|
|
(let posn ($.mouse-click-posn ($.get-mouse-click Viewport))
|
|
|
|
(list (annotate 'record (list ($.posn-x posn) ($.posn-y posn))) t))
|
|
|
|
; clear-screen in cursor mode above
|
|
|
|
rectangle
|
|
|
|
(do1 nil
|
|
|
|
(($.draw-solid-rectangle Viewport)
|
|
|
|
($.make-posn (m arg.0) (m arg.1)) ; origin
|
|
|
|
(m arg.2) (m arg.3) ; width height
|
|
|
|
(m arg.4))) ; color
|
2015-01-05 09:21:39 +00:00
|
|
|
point
|
|
|
|
(do1 nil
|
|
|
|
(($.draw-pixel Viewport) ($.make-posn (m arg.0) (m arg.1))
|
2015-01-06 07:28:21 +00:00
|
|
|
(m arg.2))) ; color
|
2015-01-05 09:21:39 +00:00
|
|
|
|
|
|
|
image
|
|
|
|
(do1 nil
|
|
|
|
(($.draw-pixmap Viewport) (m arg.0) ; filename
|
|
|
|
($.make-posn (m arg.1) (m arg.2))))
|
|
|
|
color-at
|
|
|
|
(let pixel (($.get-color-pixel Viewport) ($.make-posn (m arg.0) (m arg.1)))
|
|
|
|
(prn ($.rgb-red pixel) " " ($.rgb-blue pixel) " " ($.rgb-green pixel))
|
|
|
|
($:rgb-red pixel))
|
|
|
|
foo
|
|
|
|
(= times* (table))
|
2014-12-24 07:38:16 +00:00
|
|
|
|
2014-10-10 22:04:14 +00:00
|
|
|
; user-defined functions
|
2014-12-13 01:54:31 +00:00
|
|
|
next-input
|
|
|
|
(let idx caller-arg-idx.routine*
|
|
|
|
(++ caller-arg-idx.routine*)
|
|
|
|
(trace "arg" arg " " idx " " caller-args.routine*)
|
|
|
|
(if (len> caller-args.routine* idx)
|
|
|
|
(list caller-args.routine*.idx t)
|
|
|
|
(list nil nil)))
|
|
|
|
input
|
2014-12-14 17:46:49 +00:00
|
|
|
(do (assert (iso '(literal) (ty arg.0)))
|
2014-12-13 01:54:31 +00:00
|
|
|
(= caller-arg-idx.routine* (v arg.0))
|
2014-11-27 14:16:02 +00:00
|
|
|
(let idx caller-arg-idx.routine*
|
|
|
|
(++ caller-arg-idx.routine*)
|
|
|
|
(trace "arg" arg " " idx " " caller-args.routine*)
|
|
|
|
(if (len> caller-args.routine* idx)
|
|
|
|
(list caller-args.routine*.idx t)
|
|
|
|
(list nil nil))))
|
2014-12-24 09:00:36 +00:00
|
|
|
; type and otype won't always easily compile. be careful.
|
|
|
|
type
|
|
|
|
(ty (caller-operands.routine* (v arg.0)))
|
|
|
|
otype
|
|
|
|
(ty (caller-results.routine* (v arg.0)))
|
2014-10-31 23:22:21 +00:00
|
|
|
prepare-reply
|
2014-10-31 23:24:17 +00:00
|
|
|
(prepare-reply arg)
|
2014-07-31 10:46:05 +00:00
|
|
|
reply
|
2014-10-31 23:24:17 +00:00
|
|
|
(do (when arg
|
|
|
|
(prepare-reply arg))
|
2014-10-31 23:18:13 +00:00
|
|
|
(let results results.routine*
|
2014-10-29 20:05:08 +00:00
|
|
|
(pop-stack routine*)
|
2014-10-31 23:18:13 +00:00
|
|
|
(if empty.routine* (return ninstrs))
|
|
|
|
(let (caller-oargs _ _) (parse-instr (body.routine* pc.routine*))
|
|
|
|
(trace "reply" arg " " caller-oargs)
|
|
|
|
(each (dest val) (zip caller-oargs results)
|
2014-11-07 19:56:34 +00:00
|
|
|
(when nondummy.dest
|
2014-11-07 19:50:41 +00:00
|
|
|
(trace "reply" val " => " dest)
|
|
|
|
(setm dest val))))
|
2014-10-31 23:18:13 +00:00
|
|
|
(++ pc.routine*)
|
|
|
|
(while (>= pc.routine* (len body.routine*))
|
|
|
|
(pop-stack routine*)
|
|
|
|
(when empty.routine* (return ninstrs))
|
|
|
|
(++ pc.routine*))
|
|
|
|
(continue)))
|
2014-10-10 22:04:14 +00:00
|
|
|
; else try to call as a user-defined function
|
2014-10-05 18:33:25 +00:00
|
|
|
(do (if function*.op
|
2014-12-24 09:00:36 +00:00
|
|
|
(with (callee-args (accum yield
|
|
|
|
(each a arg
|
|
|
|
(yield (m a))))
|
|
|
|
callee-operands (accum yield
|
|
|
|
(each a arg
|
|
|
|
(yield a)))
|
|
|
|
callee-results (accum yield
|
|
|
|
(each a oarg
|
|
|
|
(yield a))))
|
2014-11-01 00:35:24 +00:00
|
|
|
(push-stack routine* op)
|
2014-12-24 09:00:36 +00:00
|
|
|
(= caller-args.routine* callee-args)
|
|
|
|
(= caller-operands.routine* callee-operands)
|
|
|
|
(= caller-results.routine* callee-results))
|
2014-10-05 18:33:25 +00:00
|
|
|
(err "no such op @op"))
|
2014-08-28 19:44:01 +00:00
|
|
|
(continue))
|
2014-07-31 10:46:05 +00:00
|
|
|
)
|
2014-11-18 18:53:33 +00:00
|
|
|
; opcode generated some 'results'
|
2014-10-10 22:04:14 +00:00
|
|
|
; copy to output args
|
2014-11-18 18:53:33 +00:00
|
|
|
(if (acons results)
|
|
|
|
(each (dest val) (zip oarg results)
|
2014-11-07 19:57:45 +00:00
|
|
|
(unless (is dest '_)
|
2014-11-18 19:02:22 +00:00
|
|
|
(trace "run" val " => " dest)
|
2014-11-07 19:57:45 +00:00
|
|
|
(setm dest val)))
|
2014-07-31 10:46:05 +00:00
|
|
|
(when oarg ; must be a list
|
2014-11-18 18:58:51 +00:00
|
|
|
(trace "run" results " => " oarg.0)
|
2014-11-18 18:53:33 +00:00
|
|
|
(setm oarg.0 results)))
|
2014-08-28 19:44:01 +00:00
|
|
|
)
|
2014-10-29 20:05:08 +00:00
|
|
|
(++ pc.routine*)))
|
2014-08-28 23:47:09 +00:00
|
|
|
(return time-slice)))
|
2014-07-06 07:07:03 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def prepare-reply (args)
|
2014-10-31 23:24:17 +00:00
|
|
|
(= results.routine*
|
|
|
|
(accum yield
|
|
|
|
(each a args
|
|
|
|
(yield (m a))))))
|
|
|
|
|
2014-11-29 02:02:16 +00:00
|
|
|
; helpers for memory access respecting
|
|
|
|
; immediate addressing - 'literal' and 'offset'
|
|
|
|
; direct addressing - default
|
|
|
|
; indirect addressing - 'deref'
|
2015-01-03 02:13:04 +00:00
|
|
|
; relative addressing - if routine* has 'default-space'
|
2014-11-27 06:43:51 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def m (loc) ; read memory, respecting metadata
|
2014-11-29 02:02:16 +00:00
|
|
|
(point return
|
2014-12-28 22:07:30 +00:00
|
|
|
(when (literal? loc)
|
2014-11-29 02:02:16 +00:00
|
|
|
(return v.loc))
|
2015-01-03 02:13:04 +00:00
|
|
|
(when (is v.loc 'default-space)
|
|
|
|
(return rep.routine*!call-stack.0!default-space))
|
2014-11-29 02:02:16 +00:00
|
|
|
(trace "m" loc)
|
|
|
|
(assert (isa v.loc 'int) "addresses must be numeric (problem in convert-names?) @loc")
|
2014-11-29 02:16:22 +00:00
|
|
|
(with (n sizeof.loc
|
2014-11-29 02:02:16 +00:00
|
|
|
addr addr.loc)
|
|
|
|
;? (trace "m" "reading " n " locations starting at " addr)
|
|
|
|
(if (is 1 n)
|
2014-11-29 02:19:09 +00:00
|
|
|
memory*.addr
|
2014-11-29 02:02:16 +00:00
|
|
|
:else
|
|
|
|
(annotate 'record
|
|
|
|
(map memory* (addrs addr n)))))))
|
2014-08-26 19:20:08 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def setm (loc val) ; set memory, respecting metadata
|
2014-11-29 02:02:16 +00:00
|
|
|
(point return
|
2015-01-03 02:13:04 +00:00
|
|
|
(when (is v.loc 'default-space)
|
|
|
|
(assert (is 1 sizeof.loc) "can't store compounds in default-space @loc")
|
|
|
|
(= rep.routine*!call-stack.0!default-space val)
|
2014-11-29 02:02:16 +00:00
|
|
|
(return))
|
|
|
|
(assert (isa v.loc 'int) "can't store to non-numeric address (problem in convert-names?)")
|
|
|
|
(trace "setm" loc " <= " val)
|
2014-11-29 02:52:34 +00:00
|
|
|
(with (n (if (isa val 'record) (len rep.val) 1)
|
2014-12-17 22:03:34 +00:00
|
|
|
addr addr.loc
|
|
|
|
typ typeof.loc)
|
2014-11-29 02:02:16 +00:00
|
|
|
(trace "setm" "size of " loc " is " n)
|
|
|
|
(assert n "setm: can't compute type of @loc")
|
|
|
|
(assert addr "setm: null pointer @loc")
|
|
|
|
(if (is 1 n)
|
|
|
|
(do (assert (~isa val 'record) "setm: record of size 1 @(tostring prn.val)")
|
|
|
|
(trace "setm" loc ": setting " addr " to " val)
|
2014-11-29 02:19:09 +00:00
|
|
|
(= memory*.addr val))
|
2014-12-17 22:03:34 +00:00
|
|
|
(do (if type*.typ!array
|
2014-11-29 02:58:38 +00:00
|
|
|
; size check for arrays
|
2014-11-29 08:57:06 +00:00
|
|
|
(when (~is n
|
|
|
|
(+ 1 ; array length
|
2014-12-17 22:03:34 +00:00
|
|
|
(* rep.val.0 (sizeof `((_ ,@type*.typ!elem))))))
|
2014-11-29 02:58:38 +00:00
|
|
|
(die "writing invalid array @(tostring prn.val)"))
|
|
|
|
; size check for non-arrays
|
2014-11-29 02:52:34 +00:00
|
|
|
(when (~is sizeof.loc n)
|
2015-01-12 06:03:16 +00:00
|
|
|
(die "writing to incorrect size @(tostring pr.val) => @loc")))
|
2014-11-29 02:40:47 +00:00
|
|
|
(let addrs (addrs addr n)
|
|
|
|
(each (dest src) (zip addrs rep.val)
|
|
|
|
(trace "setm" loc ": setting " dest " to " src)
|
|
|
|
(= memory*.dest src))))))))
|
2014-08-26 19:20:08 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def typeof (operand)
|
2014-11-29 02:52:34 +00:00
|
|
|
(let loc absolutize.operand
|
2014-12-13 10:07:48 +00:00
|
|
|
(while (pos '(deref) metadata.loc)
|
2014-11-29 02:52:34 +00:00
|
|
|
(zap deref loc))
|
2014-12-13 10:07:48 +00:00
|
|
|
ty.loc.0))
|
2014-11-29 02:52:34 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def addr (operand)
|
2014-12-28 02:20:13 +00:00
|
|
|
(v canonize.operand))
|
2014-11-29 02:02:16 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def addrs (n sz)
|
2014-11-29 02:02:16 +00:00
|
|
|
(accum yield
|
|
|
|
(repeat sz
|
|
|
|
(yield n)
|
|
|
|
(++ n))))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def canonize (operand)
|
2015-01-01 19:11:02 +00:00
|
|
|
;? (tr "0: @operand")
|
2014-11-29 04:08:24 +00:00
|
|
|
(ret operand
|
2015-01-01 19:11:02 +00:00
|
|
|
;? (prn "1: " operand)
|
|
|
|
;? (tr "1: " operand) ; todo: why does this die?
|
2014-11-29 04:08:24 +00:00
|
|
|
(zap absolutize operand)
|
2015-01-01 19:11:02 +00:00
|
|
|
;? (tr "2: @(tostring write.operand)")
|
2014-12-13 10:07:48 +00:00
|
|
|
(while (pos '(deref) metadata.operand)
|
2015-01-01 19:11:02 +00:00
|
|
|
(zap deref operand)
|
|
|
|
;? (tr "3: @(tostring write.operand)")
|
|
|
|
)))
|
2014-11-29 02:02:16 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def array-len (operand)
|
2014-11-29 02:02:16 +00:00
|
|
|
(trace "array-len" operand)
|
2014-11-29 09:05:39 +00:00
|
|
|
(zap canonize operand)
|
2014-11-29 02:02:16 +00:00
|
|
|
(if typeinfo.operand!array
|
2014-12-13 10:07:48 +00:00
|
|
|
(m `((,v.operand integer) ,@metadata.operand))
|
2014-11-29 02:02:16 +00:00
|
|
|
:else
|
|
|
|
(err "can't take len of non-array @operand")))
|
2014-11-27 06:43:51 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def sizeof (x)
|
2014-11-29 00:13:28 +00:00
|
|
|
(trace "sizeof" x)
|
2014-12-17 22:03:34 +00:00
|
|
|
(assert acons.x)
|
|
|
|
(zap canonize x)
|
2014-11-29 00:13:28 +00:00
|
|
|
(point return
|
2014-12-17 22:03:34 +00:00
|
|
|
;? (tr "sizeof: checking @x for array")
|
|
|
|
(when typeinfo.x!array
|
|
|
|
;? (tr "sizeof: @x is an array")
|
|
|
|
(assert (~is '_ v.x) "sizeof: arrays require a specific variable")
|
|
|
|
(return (+ 1 (* array-len.x (sizeof `((_ ,@typeinfo.x!elem)))))))
|
|
|
|
;? (tr "sizeof: not an array")
|
|
|
|
(when typeinfo.x!and-record
|
|
|
|
;? (tr "sizeof: @x is an and-record")
|
|
|
|
(return (sum idfn
|
|
|
|
(accum yield
|
|
|
|
(each elem typeinfo.x!elems
|
|
|
|
(yield (sizeof `((_ ,@elem)))))))))
|
|
|
|
;? (tr "sizeof: @x is a primitive")
|
|
|
|
(return typeinfo.x!size)))
|
2014-08-26 19:20:08 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def absolutize (operand)
|
2014-11-29 01:43:33 +00:00
|
|
|
(if (no routine*)
|
|
|
|
operand
|
2014-12-17 22:03:34 +00:00
|
|
|
(is '_ v.operand)
|
|
|
|
operand
|
2014-12-27 06:21:25 +00:00
|
|
|
(pos '(raw) metadata.operand)
|
2014-11-29 01:43:33 +00:00
|
|
|
operand
|
2014-12-29 17:24:11 +00:00
|
|
|
(is 'global space.operand)
|
2014-12-28 02:27:54 +00:00
|
|
|
(aif rep.routine*!globals
|
2014-12-29 17:20:51 +00:00
|
|
|
`((,(+ it 1 v.operand) ,@(cdr operand.0))
|
2014-12-28 02:27:54 +00:00
|
|
|
,@(rem [caris _ 'space] metadata.operand)
|
|
|
|
(raw))
|
|
|
|
(die "routine has no globals: @operand"))
|
2014-11-29 01:43:33 +00:00
|
|
|
:else
|
2015-01-03 02:13:04 +00:00
|
|
|
(iflet base rep.routine*!call-stack.0!default-space
|
2014-12-30 09:27:26 +00:00
|
|
|
(lookup-space (rem [caris _ 'space] operand)
|
|
|
|
base
|
|
|
|
space.operand)
|
2014-11-29 01:43:33 +00:00
|
|
|
operand)))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def lookup-space (operand base space)
|
2014-12-30 09:27:26 +00:00
|
|
|
(if (is 0 space)
|
|
|
|
; base case
|
|
|
|
(if (< v.operand memory*.base)
|
|
|
|
`((,(+ base 1 v.operand) ,@(cdr operand.0))
|
|
|
|
,@metadata.operand
|
|
|
|
(raw))
|
|
|
|
(die "no room for var @operand in routine of size @memory*.base"))
|
|
|
|
; recursive case
|
2015-01-03 02:13:04 +00:00
|
|
|
(lookup-space operand (memory* (+ base 1)) ; location 0 points to next space
|
2014-12-30 09:27:26 +00:00
|
|
|
(- space 1))))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def space (operand)
|
2014-12-28 02:27:54 +00:00
|
|
|
(or (alref operand 'space)
|
|
|
|
0))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def deref (operand)
|
2014-12-13 10:07:48 +00:00
|
|
|
(assert (pos '(deref) metadata.operand))
|
2014-12-18 07:14:58 +00:00
|
|
|
(assert address?.operand)
|
2014-12-17 22:03:34 +00:00
|
|
|
(cons `(,(memory* v.operand) ,@typeinfo.operand!elem)
|
2014-12-13 10:07:48 +00:00
|
|
|
(drop-one '(deref) metadata.operand)))
|
2014-11-29 00:49:11 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def drop-one (f x)
|
2014-11-29 00:49:11 +00:00
|
|
|
(when acons.x ; proper lists only
|
|
|
|
(if (testify.f car.x)
|
|
|
|
cdr.x
|
2014-12-18 04:49:23 +00:00
|
|
|
(cons car.x (drop-one f cdr.x)))))
|
2014-11-29 00:49:11 +00:00
|
|
|
|
2014-11-29 02:02:16 +00:00
|
|
|
; memory allocation
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def new-scalar (type)
|
2014-12-04 10:50:33 +00:00
|
|
|
;? (tr "new scalar: @type")
|
|
|
|
(ret result rep.routine*!alloc
|
2014-12-17 22:03:34 +00:00
|
|
|
(++ rep.routine*!alloc (sizeof `((_ ,type))))))
|
2014-11-29 02:02:16 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def new-array (type size)
|
2014-12-04 10:50:33 +00:00
|
|
|
;? (tr "new array: @type @size")
|
|
|
|
(ret result rep.routine*!alloc
|
2014-12-17 22:03:34 +00:00
|
|
|
(++ rep.routine*!alloc (+ 1 (* (sizeof `((_ ,@type*.type!elem))) size)))
|
2014-11-29 02:19:09 +00:00
|
|
|
(= memory*.result size)))
|
2014-11-29 02:02:16 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def new-string (literal-string)
|
2014-12-04 10:50:33 +00:00
|
|
|
;? (tr "new string: @literal-string")
|
|
|
|
(ret result rep.routine*!alloc
|
|
|
|
(= (memory* rep.routine*!alloc) len.literal-string)
|
|
|
|
(++ rep.routine*!alloc)
|
2014-11-29 02:02:16 +00:00
|
|
|
(each c literal-string
|
2014-12-04 10:50:33 +00:00
|
|
|
(= (memory* rep.routine*!alloc) c)
|
|
|
|
(++ rep.routine*!alloc))))
|
2014-11-29 02:02:16 +00:00
|
|
|
|
2014-10-10 22:09:16 +00:00
|
|
|
;; desugar structured assembly based on blocks
|
2014-10-10 22:04:14 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def convert-braces (instrs)
|
2014-12-14 20:36:42 +00:00
|
|
|
;? (prn "convert-braces " instrs)
|
2014-07-17 16:02:43 +00:00
|
|
|
(let locs () ; list of information on each brace: (open/close pc)
|
|
|
|
(let pc 0
|
|
|
|
(loop (instrs instrs)
|
|
|
|
(each instr instrs
|
2014-12-14 17:46:49 +00:00
|
|
|
;? (tr instr)
|
2014-11-23 06:26:11 +00:00
|
|
|
(if (or atom.instr (~is 'begin instr.0)) ; label or regular instruction
|
|
|
|
(do
|
|
|
|
(trace "c{0" pc " " instr " -- " locs)
|
|
|
|
(++ pc))
|
2014-11-27 16:48:38 +00:00
|
|
|
; hack: racket replaces braces with parens, so we need the
|
2014-11-25 02:52:15 +00:00
|
|
|
; keyword 'begin' to delimit blocks.
|
2014-11-27 16:48:38 +00:00
|
|
|
; ultimately there'll be no nesting and braces will just be
|
2014-11-25 02:52:15 +00:00
|
|
|
; in an instr by themselves.
|
2014-11-23 06:26:11 +00:00
|
|
|
:else ; brace
|
|
|
|
(do
|
|
|
|
(push `(open ,pc) locs)
|
|
|
|
(recur cdr.instr)
|
|
|
|
(push `(close ,pc) locs))))))
|
2014-07-17 16:02:43 +00:00
|
|
|
(zap rev locs)
|
2014-12-14 17:46:49 +00:00
|
|
|
;? (tr "-")
|
2014-07-17 16:02:43 +00:00
|
|
|
(with (pc 0
|
|
|
|
stack ()) ; elems are pcs
|
|
|
|
(accum yield
|
|
|
|
(loop (instrs instrs)
|
|
|
|
(each instr instrs
|
2014-12-14 17:46:49 +00:00
|
|
|
;? (tr "- " instr)
|
2014-10-07 20:26:01 +00:00
|
|
|
(point continue
|
2014-11-23 06:26:11 +00:00
|
|
|
(when (atom instr) ; label
|
|
|
|
(yield instr)
|
2014-11-23 14:06:04 +00:00
|
|
|
(++ pc)
|
2014-11-23 06:26:11 +00:00
|
|
|
(continue))
|
2014-12-14 17:46:49 +00:00
|
|
|
(when (is car.instr 'begin)
|
|
|
|
(push pc stack)
|
|
|
|
(recur cdr.instr)
|
|
|
|
(pop stack)
|
|
|
|
(continue))
|
2015-01-10 19:16:57 +00:00
|
|
|
(with ((oarg op arg) (parse-instr instr)
|
|
|
|
yield-new-instr (fn (new-instr)
|
|
|
|
(trace "c{1" "@pc X " instr " => " new-instr)
|
|
|
|
(yield new-instr))
|
|
|
|
yield-unchanged (fn ()
|
2015-01-10 21:54:21 +00:00
|
|
|
(trace "c{1" "@pc ✓ " instr)
|
2015-01-10 19:16:57 +00:00
|
|
|
(yield instr)))
|
|
|
|
(when (in op 'break 'break-if 'break-unless 'loop 'loop-if 'loop-unless)
|
|
|
|
(assert (is oarg nil) "@op: can't take oarg in @instr"))
|
2014-12-14 17:50:10 +00:00
|
|
|
(case op
|
|
|
|
break
|
2015-01-10 19:16:57 +00:00
|
|
|
(yield-new-instr `(((jump)) ((,(close-offset pc locs (and arg (v arg.0))) offset))))
|
2014-12-14 17:50:10 +00:00
|
|
|
break-if
|
2015-01-10 19:16:57 +00:00
|
|
|
(yield-new-instr `(((jump-if)) ,arg.0 ((,(close-offset pc locs (and cdr.arg (v arg.1))) offset))))
|
2014-12-14 17:50:10 +00:00
|
|
|
break-unless
|
2015-01-10 19:16:57 +00:00
|
|
|
(yield-new-instr `(((jump-unless)) ,arg.0 ((,(close-offset pc locs (and cdr.arg (v arg.1))) offset))))
|
2014-12-14 17:50:10 +00:00
|
|
|
loop
|
2015-01-10 19:16:57 +00:00
|
|
|
(yield-new-instr `(((jump)) ((,(open-offset pc stack (and arg (v arg.0))) offset))))
|
2014-12-14 17:50:10 +00:00
|
|
|
loop-if
|
2015-01-10 19:16:57 +00:00
|
|
|
(yield-new-instr `(((jump-if)) ,arg.0 ((,(open-offset pc stack (and cdr.arg (v arg.1))) offset))))
|
2014-12-14 17:50:10 +00:00
|
|
|
loop-unless
|
2015-01-10 19:16:57 +00:00
|
|
|
(yield-new-instr `(((jump-unless)) ,arg.0 ((,(open-offset pc stack (and cdr.arg (v arg.1))) offset))))
|
2014-12-14 17:50:10 +00:00
|
|
|
;else
|
2015-01-10 19:16:57 +00:00
|
|
|
(yield-unchanged)))
|
2014-10-07 20:26:01 +00:00
|
|
|
(++ pc))))))))
|
2014-07-17 16:02:43 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def close-offset (pc locs nblocks)
|
2014-11-27 17:30:43 +00:00
|
|
|
(or= nblocks 1)
|
|
|
|
;? (tr nblocks)
|
2014-11-23 14:12:15 +00:00
|
|
|
(point return
|
2014-11-23 14:06:04 +00:00
|
|
|
;? (tr "close " pc " " locs)
|
2014-11-23 14:12:15 +00:00
|
|
|
(let stacksize 0
|
|
|
|
(each (state loc) locs
|
|
|
|
(point continue
|
|
|
|
;? (tr stacksize "/" done " " state " " loc)
|
|
|
|
(when (<= loc pc)
|
|
|
|
(continue))
|
|
|
|
;? (tr "process " stacksize loc)
|
|
|
|
(if (is 'open state) (++ stacksize) (-- stacksize))
|
|
|
|
; last time
|
|
|
|
;? (tr "process2 " stacksize loc)
|
2014-11-27 17:30:43 +00:00
|
|
|
(when (is stacksize (* -1 nblocks))
|
2014-11-23 14:12:15 +00:00
|
|
|
;? (tr "close now " loc)
|
|
|
|
(return (- loc pc 1))))))))
|
2014-07-17 16:02:43 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def open-offset (pc stack nblocks)
|
2014-11-27 17:30:43 +00:00
|
|
|
(or= nblocks 1)
|
|
|
|
(- (stack (- nblocks 1)) 1 pc))
|
|
|
|
|
2014-11-27 16:49:18 +00:00
|
|
|
;; convert jump targets to offsets
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def convert-labels (instrs)
|
2014-11-27 16:49:18 +00:00
|
|
|
;? (tr "convert-labels " instrs)
|
|
|
|
(let labels (table)
|
|
|
|
(let pc 0
|
|
|
|
(each instr instrs
|
|
|
|
(when (~acons instr)
|
|
|
|
;? (tr "label " pc)
|
|
|
|
(= labels.instr pc))
|
|
|
|
(++ pc)))
|
|
|
|
(let pc 0
|
|
|
|
(each instr instrs
|
|
|
|
(when (and acons.instr
|
2014-12-14 17:46:49 +00:00
|
|
|
(acons car.instr)
|
|
|
|
(in (v car.instr) 'jump 'jump-if 'jump-unless))
|
2014-11-27 16:49:18 +00:00
|
|
|
(each arg cdr.instr
|
|
|
|
;? (tr "trying " arg " " ty.arg ": " v.arg " => " (labels v.arg))
|
2014-12-14 17:46:49 +00:00
|
|
|
(when (and (is ty.arg.0 'offset)
|
2014-11-27 16:49:18 +00:00
|
|
|
(isa v.arg 'sym)
|
|
|
|
(labels v.arg))
|
|
|
|
(= v.arg (- (labels v.arg) pc 1)))))
|
|
|
|
(++ pc))))
|
|
|
|
instrs)
|
|
|
|
|
2014-11-07 19:59:22 +00:00
|
|
|
;; convert symbolic names to raw memory locations
|
2014-10-29 07:18:58 +00:00
|
|
|
|
2015-01-03 02:13:04 +00:00
|
|
|
(def add-next-space-generator (instrs name)
|
2014-12-30 22:52:58 +00:00
|
|
|
;? (prn "== @name")
|
|
|
|
(each instr instrs
|
|
|
|
(when acons.instr
|
|
|
|
(let (oargs op args) (parse-instr instr)
|
|
|
|
(each oarg oargs
|
|
|
|
(when (and (nondummy oarg)
|
|
|
|
(is v.oarg 0)
|
2015-01-03 02:13:04 +00:00
|
|
|
(iso ty.oarg '(space-address)))
|
|
|
|
(assert (no next-space-generator*.name) "function can have only one next-space-generator environment")
|
|
|
|
(tr "next-space-generator of @name is @(alref oarg 'names)")
|
|
|
|
(= next-space-generator*.name (alref oarg 'names))))))))
|
2014-12-30 22:52:58 +00:00
|
|
|
|
|
|
|
; just a helper for testing; in practice we unbundle assign-names-to-location
|
|
|
|
; and replace-names-with-location.
|
|
|
|
(def convert-names (instrs (o name))
|
2014-12-13 22:00:14 +00:00
|
|
|
;? (tr "convert-names " instrs)
|
2014-12-30 22:52:58 +00:00
|
|
|
(let location (table)
|
|
|
|
(= location*.name (assign-names-to-location instrs name))
|
|
|
|
;? (tr "save names for function @name: @(tostring:pr location*.name)")
|
|
|
|
)
|
|
|
|
(replace-names-with-location instrs name))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def assign-names-to-location (instrs name)
|
2014-12-30 22:52:58 +00:00
|
|
|
(ret location (table)
|
|
|
|
(with (isa-field (table)
|
2015-01-03 02:13:04 +00:00
|
|
|
idx 1) ; 0 always reserved for next space
|
2014-10-29 07:18:58 +00:00
|
|
|
(each instr instrs
|
2014-11-23 06:26:11 +00:00
|
|
|
(point continue
|
|
|
|
(when atom.instr
|
|
|
|
(continue))
|
2014-11-07 19:59:22 +00:00
|
|
|
(trace "cn0" instr " " canon.location " " canon.isa-field)
|
2014-10-29 07:18:58 +00:00
|
|
|
(let (oargs op args) (parse-instr instr)
|
2015-01-01 05:24:48 +00:00
|
|
|
;? (tr "about to rename args: @op")
|
2014-11-04 06:34:58 +00:00
|
|
|
(if (in op 'get 'get-address)
|
2014-12-30 22:41:12 +00:00
|
|
|
; special case: map field offset by looking up type table
|
2014-12-17 22:03:34 +00:00
|
|
|
(with (basetype (typeof args.0)
|
2014-11-04 06:34:58 +00:00
|
|
|
field (v args.1))
|
2015-01-01 05:24:48 +00:00
|
|
|
;? (tr 111 " " args.0 " " basetype)
|
2014-12-17 22:03:34 +00:00
|
|
|
(assert type*.basetype!and-record "get on non-record @args.0")
|
2015-01-01 05:24:48 +00:00
|
|
|
;? (tr 112)
|
2014-12-17 22:03:34 +00:00
|
|
|
(trace "cn0" "field-access @field in @args.0 of type @basetype")
|
2014-11-04 06:34:58 +00:00
|
|
|
(when (isa field 'sym)
|
2014-11-07 19:59:22 +00:00
|
|
|
(assert (or (~location field) isa-field.field) "field @args.1 is also a variable")
|
|
|
|
(when (~location field)
|
|
|
|
(trace "cn0" "new field; computing location")
|
2014-12-17 22:03:34 +00:00
|
|
|
;? (tr "aa " type*.basetype)
|
|
|
|
(assert type*.basetype!fields "no field names available for @instr")
|
|
|
|
;? (tr "bb")
|
|
|
|
(iflet idx (pos field type*.basetype!fields)
|
2014-11-07 08:56:42 +00:00
|
|
|
(do (set isa-field.field)
|
2014-11-07 20:01:20 +00:00
|
|
|
(trace "cn0" "field location @idx")
|
2014-11-07 19:59:22 +00:00
|
|
|
(= location.field idx))
|
2014-11-07 08:56:42 +00:00
|
|
|
(assert nil "couldn't find field in @instr")))))
|
2014-12-30 22:41:12 +00:00
|
|
|
; map args to location indices
|
2014-11-04 06:34:58 +00:00
|
|
|
(each arg args
|
2015-01-01 05:18:22 +00:00
|
|
|
(trace "cn0" "checking arg " arg)
|
2014-12-14 20:36:42 +00:00
|
|
|
(when (and nondummy.arg not-raw-string.arg)
|
|
|
|
(assert (~isa-field v.arg) "arg @arg is also a field name")
|
|
|
|
(when (maybe-add arg location idx)
|
|
|
|
(err "use before set: @arg")))))
|
2014-12-17 22:03:34 +00:00
|
|
|
;? (tr "about to rename oargs")
|
2014-12-30 22:41:12 +00:00
|
|
|
; map oargs to location indices
|
2014-10-29 07:18:58 +00:00
|
|
|
(each arg oargs
|
2015-01-01 05:18:22 +00:00
|
|
|
(trace "cn0" "checking oarg " arg)
|
2014-12-14 20:36:42 +00:00
|
|
|
(when (and nondummy.arg not-raw-string.arg)
|
2014-11-07 19:50:41 +00:00
|
|
|
(assert (~isa-field v.arg) "oarg @arg is also a field name")
|
2014-11-07 19:59:22 +00:00
|
|
|
(when (maybe-add arg location idx)
|
2015-01-01 05:18:22 +00:00
|
|
|
(trace "cn0" "location for oarg " arg ": " idx)
|
2014-11-27 08:34:29 +00:00
|
|
|
; todo: can't allocate arrays on the stack
|
2014-12-30 22:52:58 +00:00
|
|
|
(++ idx (sizeof `((_ ,@ty.arg)))))))))))))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def replace-names-with-location (instrs name)
|
2014-12-30 22:52:58 +00:00
|
|
|
(each instr instrs
|
|
|
|
(when (acons instr)
|
|
|
|
(let (oargs op args) (parse-instr instr)
|
|
|
|
(each arg args
|
|
|
|
(convert-name arg name))
|
|
|
|
(each arg oargs
|
|
|
|
(convert-name arg name)))))
|
2015-01-10 21:53:00 +00:00
|
|
|
(each instr instrs
|
|
|
|
(trace "cn1" instr))
|
2014-12-30 22:52:58 +00:00
|
|
|
instrs)
|
2014-10-29 07:18:58 +00:00
|
|
|
|
2014-12-30 22:52:58 +00:00
|
|
|
; assign an index to an arg
|
2015-01-02 19:39:22 +00:00
|
|
|
(def maybe-add (arg location idx)
|
2014-11-07 19:50:41 +00:00
|
|
|
(trace "maybe-add" arg)
|
2014-11-07 19:56:34 +00:00
|
|
|
(when (and nondummy.arg
|
2014-12-30 22:52:58 +00:00
|
|
|
;? (prn arg " " (assoc 'space arg))
|
|
|
|
(~assoc 'space arg)
|
2014-12-28 22:07:30 +00:00
|
|
|
(~literal? arg)
|
2014-11-07 19:59:22 +00:00
|
|
|
(~location v.arg)
|
2014-11-04 06:38:28 +00:00
|
|
|
(isa v.arg 'sym)
|
2015-01-03 02:13:04 +00:00
|
|
|
(~in v.arg 'nil 'default-space)
|
2014-12-27 06:21:25 +00:00
|
|
|
(~pos '(raw) metadata.arg))
|
2014-11-07 19:59:22 +00:00
|
|
|
(= (location v.arg) idx)))
|
2014-10-29 07:18:58 +00:00
|
|
|
|
2014-12-30 22:52:58 +00:00
|
|
|
; convert the arg to corresponding index
|
2015-01-02 19:39:22 +00:00
|
|
|
(def convert-name (arg default-name)
|
2014-12-30 22:52:58 +00:00
|
|
|
;? (prn "111 @arg @default-name")
|
2015-01-01 05:15:26 +00:00
|
|
|
(when (and nondummy.arg not-raw-string.arg
|
|
|
|
(~is ty.arg.0 'literal)) ; can't use 'literal?' because we want to rename offsets
|
2014-12-30 22:52:58 +00:00
|
|
|
;? (prn "112 @arg")
|
|
|
|
(let name (space-to-name arg default-name)
|
|
|
|
;? (prn "113 @arg @name @keys.location* @(tostring:pr location*.name)")
|
|
|
|
;? (when (is arg '((y integer) (space 1)))
|
|
|
|
;? (prn "@arg => @name"))
|
|
|
|
(when (aand location*.name (it v.arg))
|
|
|
|
;? (prn 114)
|
|
|
|
(zap location*.name v.arg))
|
|
|
|
;? (prn 115)
|
|
|
|
)))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def space-to-name (arg default-name)
|
2014-12-30 22:52:58 +00:00
|
|
|
(ret name default-name
|
|
|
|
(when (~is space.arg 'global)
|
|
|
|
(repeat space.arg
|
2015-01-03 02:13:04 +00:00
|
|
|
(zap next-space-generator* name)))))
|
2014-12-30 22:52:58 +00:00
|
|
|
|
2014-10-29 15:55:00 +00:00
|
|
|
;; literate tangling system for reordering code
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def convert-quotes (instrs)
|
2014-10-29 15:55:00 +00:00
|
|
|
(let deferred (queue)
|
|
|
|
(each instr instrs
|
2014-11-25 02:56:15 +00:00
|
|
|
(when (acons instr)
|
|
|
|
(case instr.0
|
|
|
|
defer
|
|
|
|
(let (q qinstrs) instr.1
|
|
|
|
(assert (is 'make-br-fn q) "defer: first arg must be [quoted]")
|
|
|
|
(each qinstr qinstrs
|
|
|
|
(enq qinstr deferred))))))
|
2014-10-29 15:55:00 +00:00
|
|
|
(accum yield
|
|
|
|
(each instr instrs
|
2014-12-04 02:12:44 +00:00
|
|
|
(if atom.instr ; label
|
|
|
|
(yield instr)
|
|
|
|
(is instr.0 'defer)
|
|
|
|
nil ; skip
|
|
|
|
(is instr.0 'reply)
|
|
|
|
(do
|
2014-12-04 02:19:40 +00:00
|
|
|
(when cdr.instr ; return values
|
|
|
|
(= instr.0 'prepare-reply)
|
|
|
|
(yield instr))
|
2014-12-04 02:12:44 +00:00
|
|
|
(each instr (as cons deferred)
|
|
|
|
(yield instr))
|
2014-12-04 02:19:40 +00:00
|
|
|
(yield '(reply)))
|
2014-12-04 02:12:44 +00:00
|
|
|
:else
|
|
|
|
(yield instr)))
|
2014-10-29 15:55:00 +00:00
|
|
|
(each instr (as cons deferred)
|
|
|
|
(yield instr)))))
|
|
|
|
|
2014-11-25 03:27:52 +00:00
|
|
|
(on-init
|
|
|
|
(= before* (table)) ; label -> queue of fragments
|
|
|
|
(= after* (table))) ; label -> list of fragments
|
|
|
|
|
2014-11-25 05:40:59 +00:00
|
|
|
; see add-code below for adding to before* and after*
|
2014-11-25 03:27:52 +00:00
|
|
|
|
2014-11-27 05:36:14 +00:00
|
|
|
(def insert-code (instrs (o name))
|
2014-12-13 22:00:14 +00:00
|
|
|
;? (tr "insert-code " instrs)
|
2014-11-25 06:05:56 +00:00
|
|
|
(loop (instrs instrs)
|
|
|
|
(accum yield
|
|
|
|
(each instr instrs
|
|
|
|
(if (and (acons instr) (~is 'begin car.instr))
|
|
|
|
; simple instruction
|
|
|
|
(yield instr)
|
|
|
|
(and (acons instr) (is 'begin car.instr))
|
|
|
|
; block
|
|
|
|
(yield `{begin ,@(recur cdr.instr)})
|
|
|
|
(atom instr)
|
|
|
|
; label
|
|
|
|
(do
|
|
|
|
;? (prn "tangling " instr)
|
2014-11-27 05:36:14 +00:00
|
|
|
(each fragment (as cons (or (and name (before* (sym:string name '/ instr)))
|
|
|
|
before*.instr))
|
2014-11-25 06:05:56 +00:00
|
|
|
(each instr fragment
|
|
|
|
(yield instr)))
|
|
|
|
(yield instr)
|
2014-11-27 05:36:14 +00:00
|
|
|
(each fragment (or (and name (after* (sym:string name '/ instr)))
|
|
|
|
after*.instr)
|
2014-11-25 06:05:56 +00:00
|
|
|
(each instr fragment
|
|
|
|
(yield instr)))))))))
|
2014-11-25 03:27:52 +00:00
|
|
|
|
2014-12-15 10:00:18 +00:00
|
|
|
;; loading code into the virtual machine
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def add-code (forms)
|
2014-12-15 10:00:18 +00:00
|
|
|
(each (op . rest) forms
|
|
|
|
(case op
|
2014-12-17 18:41:43 +00:00
|
|
|
; function <name> [ <instructions> ]
|
2014-12-15 10:00:18 +00:00
|
|
|
; don't apply our lightweight tools just yet
|
|
|
|
function!
|
|
|
|
(let (name (_make-br-fn body)) rest
|
|
|
|
(assert (is 'make-br-fn _make-br-fn))
|
|
|
|
(= function*.name body))
|
|
|
|
function
|
|
|
|
(let (name (_make-br-fn body)) rest
|
|
|
|
(assert (is 'make-br-fn _make-br-fn))
|
|
|
|
(= function*.name (join body function*.name)))
|
|
|
|
|
2014-12-17 19:01:38 +00:00
|
|
|
; and-record <type> [ <name:types> ]
|
|
|
|
and-record
|
|
|
|
(let (name (_make-br-fn fields)) rest
|
|
|
|
(assert (is 'make-br-fn _make-br-fn))
|
|
|
|
(let fields (map tokenize-arg fields)
|
|
|
|
(= type*.name (obj size len.fields
|
|
|
|
and-record t
|
2014-12-17 22:03:34 +00:00
|
|
|
; dump all metadata for now except field name and type
|
2014-12-17 19:01:38 +00:00
|
|
|
elems (map cdar fields)
|
|
|
|
fields (map caar fields)))))
|
|
|
|
|
2015-01-02 23:30:11 +00:00
|
|
|
; primitive <type>
|
|
|
|
primitive
|
|
|
|
(let (name) rest
|
|
|
|
(= type*.name (obj size 1)))
|
|
|
|
|
2015-01-01 05:24:48 +00:00
|
|
|
; address <type> <elem-type>
|
|
|
|
address
|
|
|
|
(let (name types) rest
|
|
|
|
(= type*.name (obj size 1
|
|
|
|
address t
|
|
|
|
elem types)))
|
|
|
|
|
|
|
|
; array <type> <elem-type>
|
|
|
|
array
|
|
|
|
(let (name types) rest
|
|
|
|
(= type*.name (obj array t
|
|
|
|
elem types)))
|
|
|
|
|
2014-12-17 18:41:43 +00:00
|
|
|
; before <label> [ <instructions> ]
|
2014-12-15 10:00:18 +00:00
|
|
|
;
|
|
|
|
; multiple before directives => code in order
|
|
|
|
before
|
|
|
|
(let (label (_make-br-fn fragment)) rest
|
|
|
|
(assert (is 'make-br-fn _make-br-fn))
|
|
|
|
(or= before*.label (queue))
|
|
|
|
(enq fragment before*.label))
|
|
|
|
|
2014-12-17 18:41:43 +00:00
|
|
|
; after <label> [ <instructions> ]
|
2014-12-15 10:00:18 +00:00
|
|
|
;
|
|
|
|
; multiple after directives => code in *reverse* order
|
|
|
|
; (if initialization order in a function is A B, corresponding
|
|
|
|
; finalization order should be B A)
|
|
|
|
after
|
|
|
|
(let (label (_make-br-fn fragment)) rest
|
|
|
|
(assert (is 'make-br-fn _make-br-fn))
|
|
|
|
(push fragment after*.label))
|
|
|
|
)))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def freeze (function-table)
|
2014-12-30 23:13:51 +00:00
|
|
|
(each (name body) canon.function-table
|
|
|
|
;? (prn "freeze " name)
|
|
|
|
(= function-table.name (convert-labels:convert-braces:tokenize-args:insert-code body name)))
|
|
|
|
(each (name body) canon.function-table
|
2015-01-03 02:13:04 +00:00
|
|
|
(add-next-space-generator body name))
|
2014-12-30 23:13:51 +00:00
|
|
|
(each (name body) canon.function-table
|
2014-12-30 22:52:58 +00:00
|
|
|
(= location*.name (assign-names-to-location body name)))
|
2014-12-30 23:13:51 +00:00
|
|
|
(each (name body) canon.function-table
|
|
|
|
(= function-table.name (replace-names-with-location body name)))
|
2014-12-30 22:52:58 +00:00
|
|
|
; we could clear location* at this point, but maybe we'll find a use for it
|
|
|
|
)
|
2014-12-15 10:00:18 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def tokenize-arg (arg)
|
2014-12-15 10:00:18 +00:00
|
|
|
;? (tr "tokenize-arg " arg)
|
|
|
|
(if (in arg '<- '_)
|
|
|
|
arg
|
|
|
|
(isa arg 'sym)
|
|
|
|
(map [map [fromstring _ (read)] _]
|
|
|
|
(map [tokens _ #\:]
|
|
|
|
(tokens string.arg #\/)))
|
|
|
|
:else
|
|
|
|
arg))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def tokenize-args (instrs)
|
2014-12-15 10:00:18 +00:00
|
|
|
;? (tr "tokenize-args " instrs)
|
|
|
|
;? (prn2 "@(tostring prn.instrs) => "
|
|
|
|
(accum yield
|
|
|
|
(each instr instrs
|
|
|
|
(if atom.instr
|
|
|
|
(yield instr)
|
|
|
|
(is 'begin instr.0)
|
|
|
|
(yield `{begin ,@(tokenize-args cdr.instr)})
|
|
|
|
:else
|
|
|
|
(yield (map tokenize-arg instr))))))
|
|
|
|
;? )
|
|
|
|
|
|
|
|
(def prn2 (msg . args)
|
|
|
|
(pr msg)
|
|
|
|
(apply prn args))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def canon (table)
|
2014-12-15 10:00:18 +00:00
|
|
|
(sort (compare < [tostring (prn:car _)]) (as cons table)))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def int-canon (table)
|
2014-12-15 10:00:18 +00:00
|
|
|
(sort (compare < car) (as cons table)))
|
|
|
|
|
|
|
|
;; test helpers
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def memory-contains (addr value)
|
2014-12-15 10:00:18 +00:00
|
|
|
;? (prn "Looking for @value starting at @addr")
|
|
|
|
(loop (addr addr
|
|
|
|
idx 0)
|
|
|
|
;? (prn "@idx vs @addr")
|
|
|
|
(if (>= idx len.value)
|
|
|
|
t
|
|
|
|
(~is memory*.addr value.idx)
|
|
|
|
(do1 nil
|
|
|
|
(prn "@addr should contain @value.idx but contains @memory*.addr"))
|
|
|
|
:else
|
|
|
|
(recur (+ addr 1) (+ idx 1)))))
|
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def memory-contains-array (addr value)
|
2014-12-15 10:00:18 +00:00
|
|
|
;? (prn "Looking for @value starting at @addr, size @memory*.addr vs @len.value")
|
|
|
|
(and (>= memory*.addr len.value)
|
|
|
|
(loop (addr (+ addr 1)
|
|
|
|
idx 0)
|
|
|
|
;? (prn "comparing @memory*.addr and @value.idx")
|
|
|
|
(if (>= idx len.value)
|
|
|
|
t
|
|
|
|
(~is memory*.addr value.idx)
|
|
|
|
(do1 nil
|
|
|
|
(prn "@addr should contain @value.idx but contains @memory*.addr"))
|
|
|
|
:else
|
|
|
|
(recur (+ addr 1) (+ idx 1))))))
|
|
|
|
|
2015-01-10 11:32:14 +00:00
|
|
|
(def ran-to-completion (f)
|
|
|
|
; if a routine calling f ran to completion there'll be no sign of it in any
|
|
|
|
; completed call-stacks.
|
2015-01-12 02:45:06 +00:00
|
|
|
(~find [some [is f _!fn-name] stack._]
|
|
|
|
completed-routines*))
|
2015-01-10 11:32:14 +00:00
|
|
|
|
2014-10-11 17:09:41 +00:00
|
|
|
;; system software
|
2014-12-15 10:00:18 +00:00
|
|
|
; create once, load before every test
|
|
|
|
|
|
|
|
(reset)
|
|
|
|
(= system-function* (table))
|
|
|
|
|
|
|
|
(mac init-fn (name . body)
|
2014-12-30 23:13:51 +00:00
|
|
|
`(= (system-function* ',name) ',body))
|
2014-12-15 10:00:18 +00:00
|
|
|
|
2015-01-02 19:39:22 +00:00
|
|
|
(def load-system-functions ()
|
2014-12-15 10:00:18 +00:00
|
|
|
(each (name f) system-function*
|
|
|
|
(= (function* name)
|
|
|
|
(system-function* name))))
|
2014-10-11 17:09:41 +00:00
|
|
|
|
2014-12-13 08:33:20 +00:00
|
|
|
(section 100
|
|
|
|
|
2014-10-11 17:09:41 +00:00
|
|
|
(init-fn maybe-coerce
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-12-14 20:36:42 +00:00
|
|
|
(x:tagged-value-address <- new tagged-value:literal)
|
|
|
|
(x:tagged-value-address/deref <- next-input)
|
|
|
|
(p:type <- next-input)
|
2014-12-31 07:38:50 +00:00
|
|
|
(xtype:type <- get x:tagged-value-address/deref type:offset)
|
2014-12-14 20:36:42 +00:00
|
|
|
(match?:boolean <- equal xtype:type p:type)
|
2014-10-11 17:09:41 +00:00
|
|
|
{ begin
|
2014-12-14 20:36:42 +00:00
|
|
|
(break-if match?:boolean)
|
|
|
|
(reply 0:literal nil:literal)
|
2014-10-11 17:09:41 +00:00
|
|
|
}
|
2014-12-31 07:38:50 +00:00
|
|
|
(xvalue:location <- get x:tagged-value-address/deref payload:offset)
|
2014-12-14 20:36:42 +00:00
|
|
|
(reply xvalue:location match?:boolean))
|
2014-10-11 17:09:41 +00:00
|
|
|
|
2014-12-28 21:03:50 +00:00
|
|
|
(init-fn init-tagged-value
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-12-14 20:36:42 +00:00
|
|
|
; assert sizeof:arg.0 == 1
|
|
|
|
(xtype:type <- next-input)
|
|
|
|
(xtypesize:integer <- sizeof xtype:type)
|
|
|
|
(xcheck:boolean <- equal xtypesize:integer 1:literal)
|
|
|
|
(assert xcheck:boolean)
|
2014-10-12 19:01:04 +00:00
|
|
|
; todo: check that arg 0 matches the type? or is that for the future typechecker?
|
2014-12-14 20:36:42 +00:00
|
|
|
(result:tagged-value-address <- new tagged-value:literal)
|
2014-11-18 12:35:39 +00:00
|
|
|
; result->type = arg 0
|
2014-12-14 20:36:42 +00:00
|
|
|
(resulttype:location <- get-address result:tagged-value-address/deref type:offset)
|
|
|
|
(resulttype:location/deref <- copy xtype:type)
|
2014-11-18 12:35:39 +00:00
|
|
|
; result->payload = arg 1
|
2014-12-14 20:36:42 +00:00
|
|
|
(locaddr:location <- get-address result:tagged-value-address/deref payload:offset)
|
|
|
|
(locaddr:location/deref <- next-input)
|
|
|
|
(reply result:tagged-value-address))
|
2014-10-12 19:01:04 +00:00
|
|
|
|
2014-10-13 01:04:29 +00:00
|
|
|
(init-fn list-next ; list-address -> list-address
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-12-14 20:36:42 +00:00
|
|
|
(base:list-address <- next-input)
|
|
|
|
(result:list-address <- get base:list-address/deref cdr:offset)
|
|
|
|
(reply result:list-address))
|
2014-10-13 01:04:29 +00:00
|
|
|
|
|
|
|
(init-fn list-value-address ; list-address -> tagged-value-address
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-12-14 20:36:42 +00:00
|
|
|
(base:list-address <- next-input)
|
|
|
|
(result:tagged-value-address <- get-address base:list-address/deref car:offset)
|
|
|
|
(reply result:tagged-value-address))
|
2014-10-12 21:27:26 +00:00
|
|
|
|
2015-01-06 07:57:19 +00:00
|
|
|
; create a list out of a list of args
|
|
|
|
; only integers for now
|
2014-12-28 21:03:50 +00:00
|
|
|
(init-fn init-list
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-11-18 12:35:39 +00:00
|
|
|
; new-list = curr = new list
|
2014-12-28 21:03:50 +00:00
|
|
|
(result:list-address <- new list:literal)
|
|
|
|
(curr:list-address <- copy result:list-address)
|
2014-10-25 09:32:30 +00:00
|
|
|
{ begin
|
2014-11-18 12:35:39 +00:00
|
|
|
; while read curr-value
|
2014-12-14 20:36:42 +00:00
|
|
|
(curr-value:integer exists?:boolean <- next-input)
|
|
|
|
(break-unless exists?:boolean)
|
2014-11-18 12:35:39 +00:00
|
|
|
; curr.cdr = new list
|
2014-12-14 20:36:42 +00:00
|
|
|
(next:list-address-address <- get-address curr:list-address/deref cdr:offset)
|
|
|
|
(next:list-address-address/deref <- new list:literal)
|
2014-11-18 12:35:39 +00:00
|
|
|
; curr = curr.cdr
|
2014-12-14 20:36:42 +00:00
|
|
|
(curr:list-address <- list-next curr:list-address)
|
|
|
|
; curr.car = type:curr-value
|
|
|
|
(dest:tagged-value-address <- list-value-address curr:list-address)
|
|
|
|
(dest:tagged-value-address/deref <- save-type curr-value:integer)
|
2014-11-27 06:09:23 +00:00
|
|
|
(loop)
|
2014-10-25 09:32:30 +00:00
|
|
|
}
|
2014-11-18 12:35:39 +00:00
|
|
|
; return new-list.cdr
|
2014-12-28 21:03:50 +00:00
|
|
|
(result:list-address <- list-next result:list-address) ; memory leak
|
|
|
|
(reply result:list-address))
|
2014-10-25 09:32:30 +00:00
|
|
|
|
2014-12-31 06:36:36 +00:00
|
|
|
(init-fn list-length
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-12-31 06:36:36 +00:00
|
|
|
(curr:list-address <- next-input)
|
|
|
|
;? ; recursive
|
|
|
|
;? { begin
|
|
|
|
;? ; if empty list return 0
|
|
|
|
;? (t1:tagged-value-address <- list-value-address curr:list-address)
|
|
|
|
;? (empty?:boolean <- equal t1:tagged-value-address nil:literal)
|
|
|
|
;? (break-unless empty?:boolean)
|
|
|
|
;? (reply 0:literal)
|
|
|
|
;? }
|
|
|
|
;? ; else return 1+length(curr.cdr)
|
|
|
|
;? (print-primitive (("recurse\n" literal)))
|
|
|
|
;? (next:list-address <- list-next curr:list-address)
|
|
|
|
;? (sub:integer <- list-length next:list-address)
|
|
|
|
;? (result:integer <- add sub:integer 1:literal)
|
|
|
|
;? (reply result:integer))
|
|
|
|
; iterative solution
|
|
|
|
(result:integer <- copy 0:literal)
|
|
|
|
{ begin
|
|
|
|
; while curr
|
|
|
|
(t1:tagged-value-address <- list-value-address curr:list-address)
|
|
|
|
(empty?:boolean <- equal t1:tagged-value-address nil:literal)
|
|
|
|
(break-if empty?:boolean)
|
|
|
|
; ++result
|
|
|
|
(result:integer <- add result:integer 1:literal)
|
|
|
|
;? (print-primitive result:integer)
|
|
|
|
;? (print-primitive (("\n" literal)))
|
|
|
|
; curr = curr.cdr
|
|
|
|
(curr:list-address <- list-next curr:list-address)
|
|
|
|
(loop)
|
|
|
|
}
|
|
|
|
(reply result:integer))
|
|
|
|
|
2014-12-28 21:03:50 +00:00
|
|
|
(init-fn init-channel
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-11-18 12:35:39 +00:00
|
|
|
; result = new channel
|
2014-12-14 20:36:42 +00:00
|
|
|
(result:channel-address <- new channel:literal)
|
2014-11-18 12:35:39 +00:00
|
|
|
; result.first-full = 0
|
2014-12-14 20:36:42 +00:00
|
|
|
(full:integer-address <- get-address result:channel-address/deref first-full:offset)
|
|
|
|
(full:integer-address/deref <- copy 0:literal)
|
2014-11-18 12:35:39 +00:00
|
|
|
; result.first-free = 0
|
2014-12-14 20:36:42 +00:00
|
|
|
(free:integer-address <- get-address result:channel-address/deref first-free:offset)
|
|
|
|
(free:integer-address/deref <- copy 0:literal)
|
2014-11-18 12:35:39 +00:00
|
|
|
; result.circular-buffer = new tagged-value[arg+1]
|
2014-12-14 20:36:42 +00:00
|
|
|
(capacity:integer <- next-input)
|
|
|
|
(capacity:integer <- add capacity:integer 1:literal) ; unused slot for full? below
|
|
|
|
(channel-buffer-address:tagged-value-array-address-address <- get-address result:channel-address/deref circular-buffer:offset)
|
|
|
|
(channel-buffer-address:tagged-value-array-address-address/deref <- new tagged-value-array:literal capacity:integer)
|
|
|
|
(reply result:channel-address))
|
2014-11-04 08:01:57 +00:00
|
|
|
|
2014-11-18 12:39:24 +00:00
|
|
|
(init-fn capacity
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-12-14 20:36:42 +00:00
|
|
|
(chan:channel <- next-input)
|
|
|
|
(q:tagged-value-array-address <- get chan:channel circular-buffer:offset)
|
|
|
|
(qlen:integer <- length q:tagged-value-array-address/deref)
|
|
|
|
(reply qlen:integer))
|
2014-11-18 12:39:24 +00:00
|
|
|
|
2014-11-04 21:46:31 +00:00
|
|
|
(init-fn write
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-12-14 20:36:42 +00:00
|
|
|
(chan:channel-address <- next-input)
|
|
|
|
(val:tagged-value <- next-input)
|
2014-11-08 05:39:00 +00:00
|
|
|
{ begin
|
2014-11-08 18:31:37 +00:00
|
|
|
; block if chan is full
|
2014-12-14 20:36:42 +00:00
|
|
|
(full:boolean <- full? chan:channel-address/deref)
|
|
|
|
(break-unless full:boolean)
|
|
|
|
(full-address:integer-address <- get-address chan:channel-address/deref first-full:offset)
|
2015-01-09 07:21:56 +00:00
|
|
|
(sleep until-location-changes:literal full-address:integer-address/deref)
|
2014-11-08 05:39:00 +00:00
|
|
|
}
|
2014-11-23 03:50:21 +00:00
|
|
|
; store val
|
2014-12-14 20:36:42 +00:00
|
|
|
(q:tagged-value-array-address <- get chan:channel-address/deref circular-buffer:offset)
|
|
|
|
(free:integer-address <- get-address chan:channel-address/deref first-free:offset)
|
|
|
|
(dest:tagged-value-address <- index-address q:tagged-value-array-address/deref free:integer-address/deref)
|
|
|
|
(dest:tagged-value-address/deref <- copy val:tagged-value)
|
2014-11-23 03:50:21 +00:00
|
|
|
; increment free
|
2014-12-14 20:36:42 +00:00
|
|
|
(free:integer-address/deref <- add free:integer-address/deref 1:literal)
|
2014-11-07 20:33:12 +00:00
|
|
|
{ begin
|
2014-11-23 03:50:21 +00:00
|
|
|
; wrap free around to 0 if necessary
|
2014-12-14 20:36:42 +00:00
|
|
|
(qlen:integer <- length q:tagged-value-array-address/deref)
|
|
|
|
(remaining?:boolean <- less-than free:integer-address/deref qlen:integer)
|
|
|
|
(break-if remaining?:boolean)
|
|
|
|
(free:integer-address/deref <- copy 0:literal)
|
2014-11-07 20:33:12 +00:00
|
|
|
}
|
2014-12-30 22:37:04 +00:00
|
|
|
(reply chan:channel-address/deref))
|
2014-11-04 21:46:31 +00:00
|
|
|
|
2014-11-05 02:35:13 +00:00
|
|
|
(init-fn read
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-12-14 20:36:42 +00:00
|
|
|
(chan:channel-address <- next-input)
|
2014-11-08 05:39:00 +00:00
|
|
|
{ begin
|
2014-11-08 18:31:37 +00:00
|
|
|
; block if chan is empty
|
2014-12-14 20:36:42 +00:00
|
|
|
(empty:boolean <- empty? chan:channel-address/deref)
|
|
|
|
(break-unless empty:boolean)
|
|
|
|
(free-address:integer-address <- get-address chan:channel-address/deref first-free:offset)
|
2015-01-09 07:21:56 +00:00
|
|
|
(sleep until-location-changes:literal free-address:integer-address/deref)
|
2014-11-08 05:39:00 +00:00
|
|
|
}
|
2014-11-23 03:50:21 +00:00
|
|
|
; read result
|
2014-12-14 20:36:42 +00:00
|
|
|
(full:integer-address <- get-address chan:channel-address/deref first-full:offset)
|
|
|
|
(q:tagged-value-array-address <- get chan:channel-address/deref circular-buffer:offset)
|
|
|
|
(result:tagged-value <- index q:tagged-value-array-address/deref full:integer-address/deref)
|
2014-11-23 03:50:21 +00:00
|
|
|
; increment full
|
2014-12-14 20:36:42 +00:00
|
|
|
(full:integer-address/deref <- add full:integer-address/deref 1:literal)
|
2014-11-07 20:33:12 +00:00
|
|
|
{ begin
|
2014-11-23 03:50:21 +00:00
|
|
|
; wrap full around to 0 if necessary
|
2014-12-14 20:36:42 +00:00
|
|
|
(qlen:integer <- length q:tagged-value-array-address/deref)
|
|
|
|
(remaining?:boolean <- less-than full:integer-address/deref qlen:integer)
|
|
|
|
(break-if remaining?:boolean)
|
|
|
|
(full:integer-address/deref <- copy 0:literal)
|
2014-11-07 20:33:12 +00:00
|
|
|
}
|
2014-12-14 20:36:42 +00:00
|
|
|
(reply result:tagged-value chan:channel-address/deref))
|
2014-11-05 02:35:13 +00:00
|
|
|
|
2014-11-07 22:09:59 +00:00
|
|
|
; An empty channel has first-empty and first-full both at the same value.
|
|
|
|
(init-fn empty?
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-11-18 12:35:39 +00:00
|
|
|
; return arg.first-full == arg.first-free
|
2014-12-14 20:36:42 +00:00
|
|
|
(chan:channel <- next-input)
|
|
|
|
(full:integer <- get chan:channel first-full:offset)
|
|
|
|
(free:integer <- get chan:channel first-free:offset)
|
|
|
|
(result:boolean <- equal full:integer free:integer)
|
|
|
|
(reply result:boolean))
|
2014-11-07 22:09:59 +00:00
|
|
|
|
2014-11-08 18:31:37 +00:00
|
|
|
; A full channel has first-empty just before first-full, wasting one slot.
|
|
|
|
; (Other alternatives: https://en.wikipedia.org/wiki/Circular_buffer#Full_.2F_Empty_Buffer_Distinction)
|
2014-11-07 22:09:59 +00:00
|
|
|
(init-fn full?
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-12-14 20:36:42 +00:00
|
|
|
(chan:channel <- next-input)
|
2014-11-18 12:35:39 +00:00
|
|
|
; curr = chan.first-free + 1
|
2014-12-14 20:36:42 +00:00
|
|
|
(curr:integer <- get chan:channel first-free:offset)
|
|
|
|
(curr:integer <- add curr:integer 1:literal)
|
2014-11-07 22:09:59 +00:00
|
|
|
{ begin
|
2014-11-18 12:35:39 +00:00
|
|
|
; if (curr == chan.capacity) curr = 0
|
2014-12-14 20:36:42 +00:00
|
|
|
(qlen:integer <- capacity chan:channel)
|
|
|
|
(remaining?:boolean <- less-than curr:integer qlen:integer)
|
|
|
|
(break-if remaining?:boolean)
|
|
|
|
(curr:integer <- copy 0:literal)
|
2014-11-07 22:09:59 +00:00
|
|
|
}
|
2014-11-18 12:35:39 +00:00
|
|
|
; return chan.first-full == curr
|
2014-12-14 20:36:42 +00:00
|
|
|
(full:integer <- get chan:channel first-full:offset)
|
|
|
|
(result:boolean <- equal full:integer curr:integer)
|
|
|
|
(reply result:boolean))
|
2014-11-07 22:09:59 +00:00
|
|
|
|
2014-11-27 08:34:29 +00:00
|
|
|
(init-fn strcat
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-11-27 08:34:29 +00:00
|
|
|
; result = new string[a.length + b.length]
|
2014-12-14 20:36:42 +00:00
|
|
|
(a:string-address <- next-input)
|
|
|
|
(a-len:integer <- length a:string-address/deref)
|
|
|
|
(b:string-address <- next-input)
|
|
|
|
(b-len:integer <- length b:string-address/deref)
|
|
|
|
(result-len:integer <- add a-len:integer b-len:integer)
|
|
|
|
(result:string-address <- new string:literal result-len:integer)
|
2014-11-27 08:34:29 +00:00
|
|
|
; copy a into result
|
2014-12-14 20:36:42 +00:00
|
|
|
(result-idx:integer <- copy 0:literal)
|
|
|
|
(i:integer <- copy 0:literal)
|
2014-11-27 08:34:29 +00:00
|
|
|
{ begin
|
|
|
|
; while (i < a.length)
|
2014-12-14 20:36:42 +00:00
|
|
|
(a-done?:boolean <- less-than i:integer a-len:integer)
|
|
|
|
(break-unless a-done?:boolean)
|
2014-11-27 08:34:29 +00:00
|
|
|
; result[result-idx] = a[i]
|
2014-12-14 20:36:42 +00:00
|
|
|
(out:byte-address <- index-address result:string-address/deref result-idx:integer)
|
|
|
|
(in:byte <- index a:string-address/deref i:integer)
|
|
|
|
(out:byte-address/deref <- copy in:byte)
|
2014-11-27 08:34:29 +00:00
|
|
|
; ++i
|
2014-12-14 20:36:42 +00:00
|
|
|
(i:integer <- add i:integer 1:literal)
|
2014-11-27 08:34:29 +00:00
|
|
|
; ++result-idx
|
2014-12-14 20:36:42 +00:00
|
|
|
(result-idx:integer <- add result-idx:integer 1:literal)
|
2014-11-27 08:34:29 +00:00
|
|
|
(loop)
|
|
|
|
}
|
|
|
|
; copy b into result
|
2014-12-14 20:36:42 +00:00
|
|
|
(i:integer <- copy 0:literal)
|
2014-11-27 08:34:29 +00:00
|
|
|
{ begin
|
|
|
|
; while (i < b.length)
|
2014-12-14 20:36:42 +00:00
|
|
|
(b-done?:boolean <- less-than i:integer b-len:integer)
|
|
|
|
(break-unless b-done?:boolean)
|
2014-11-27 08:34:29 +00:00
|
|
|
; result[result-idx] = a[i]
|
2014-12-14 20:36:42 +00:00
|
|
|
(out:byte-address <- index-address result:string-address/deref result-idx:integer)
|
|
|
|
(in:byte <- index b:string-address/deref i:integer)
|
|
|
|
(out:byte-address/deref <- copy in:byte)
|
2014-11-27 08:34:29 +00:00
|
|
|
; ++i
|
2014-12-14 20:36:42 +00:00
|
|
|
(i:integer <- add i:integer 1:literal)
|
2014-11-27 08:34:29 +00:00
|
|
|
; ++result-idx
|
2014-12-14 20:36:42 +00:00
|
|
|
(result-idx:integer <- add result-idx:integer 1:literal)
|
2014-11-27 08:34:29 +00:00
|
|
|
(loop)
|
|
|
|
}
|
2014-12-14 20:36:42 +00:00
|
|
|
(reply result:string-address))
|
2014-11-27 08:34:29 +00:00
|
|
|
|
2014-11-27 18:14:03 +00:00
|
|
|
; replace underscores in first with remaining args
|
2014-11-29 09:38:54 +00:00
|
|
|
(init-fn interpolate ; string-address template, string-address a..
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 60:literal)
|
2014-12-14 20:36:42 +00:00
|
|
|
(template:string-address <- next-input)
|
2014-11-29 09:54:46 +00:00
|
|
|
; compute result-len, space to allocate for result
|
2014-12-14 20:36:42 +00:00
|
|
|
(tem-len:integer <- length template:string-address/deref)
|
|
|
|
(result-len:integer <- copy tem-len:integer)
|
2014-11-29 09:38:54 +00:00
|
|
|
{ begin
|
|
|
|
; while arg received
|
2014-12-14 20:36:42 +00:00
|
|
|
(a:string-address arg-received?:boolean <- next-input)
|
|
|
|
(break-unless arg-received?:boolean)
|
2014-11-29 09:38:54 +00:00
|
|
|
;? (print-primitive ("arg now: " literal))
|
2014-12-14 20:36:42 +00:00
|
|
|
;? (print-primitive a:string-address)
|
|
|
|
;? (print-primitive "@":literal)
|
2015-01-01 19:11:02 +00:00
|
|
|
;? (print-primitive a:string-address/deref) ; todo: test (m on scoped array)
|
2014-12-14 20:36:42 +00:00
|
|
|
;? (print-primitive "\n":literal)
|
|
|
|
;? ;? (assert nil:literal)
|
2014-11-29 09:38:54 +00:00
|
|
|
; result-len = result-len + arg.length - 1 (for the 'underscore' being replaced)
|
2014-12-14 20:36:42 +00:00
|
|
|
(a-len:integer <- length a:string-address/deref)
|
|
|
|
(result-len:integer <- add result-len:integer a-len:integer)
|
|
|
|
(result-len:integer <- subtract result-len:integer 1:literal)
|
2014-11-29 09:38:54 +00:00
|
|
|
;? (print-primitive ("result-len now: " literal))
|
2014-12-14 20:36:42 +00:00
|
|
|
;? (print-primitive result-len:integer)
|
|
|
|
;? (print-primitive "\n":literal)
|
2014-11-29 09:38:54 +00:00
|
|
|
(loop)
|
|
|
|
}
|
|
|
|
; rewind to start of non-template args
|
2014-12-14 20:36:42 +00:00
|
|
|
(_ <- input 0:literal)
|
2014-11-27 18:14:03 +00:00
|
|
|
; result = new string[result-len]
|
2014-12-14 20:36:42 +00:00
|
|
|
(result:string-address <- new string:literal result-len:integer)
|
2014-11-29 09:54:46 +00:00
|
|
|
; repeatedly copy sections of template and 'holes' into result
|
2014-12-14 20:36:42 +00:00
|
|
|
(result-idx:integer <- copy 0:literal)
|
|
|
|
(i:integer <- copy 0:literal)
|
2014-11-27 18:14:03 +00:00
|
|
|
{ begin
|
2014-11-29 09:38:54 +00:00
|
|
|
; while arg received
|
2014-12-14 20:36:42 +00:00
|
|
|
(a:string-address arg-received?:boolean <- next-input)
|
|
|
|
(break-unless arg-received?:boolean)
|
2014-11-27 18:14:03 +00:00
|
|
|
; copy template into result until '_'
|
|
|
|
{ begin
|
|
|
|
; while (i < template.length)
|
2014-12-14 20:36:42 +00:00
|
|
|
(tem-done?:boolean <- less-than i:integer tem-len:integer)
|
|
|
|
(break-unless tem-done?:boolean 2:blocks)
|
2014-11-27 18:14:03 +00:00
|
|
|
; while template[i] != '_'
|
2014-12-14 20:36:42 +00:00
|
|
|
(in:byte <- index template:string-address/deref i:integer)
|
|
|
|
(underscore?:boolean <- equal in:byte ((#\_ literal)))
|
|
|
|
(break-if underscore?:boolean)
|
2014-11-27 18:14:03 +00:00
|
|
|
; result[result-idx] = template[i]
|
2014-12-14 20:36:42 +00:00
|
|
|
(out:byte-address <- index-address result:string-address/deref result-idx:integer)
|
|
|
|
(out:byte-address/deref <- copy in:byte)
|
2014-11-27 18:14:03 +00:00
|
|
|
; ++i
|
2014-12-14 20:36:42 +00:00
|
|
|
(i:integer <- add i:integer 1:literal)
|
2014-11-27 18:14:03 +00:00
|
|
|
; ++result-idx
|
2014-12-14 20:36:42 +00:00
|
|
|
(result-idx:integer <- add result-idx:integer 1:literal)
|
2014-11-27 18:14:03 +00:00
|
|
|
(loop)
|
|
|
|
}
|
|
|
|
;? (print-primitive ("i now: " literal))
|
2014-12-14 20:36:42 +00:00
|
|
|
;? (print-primitive i:integer)
|
|
|
|
;? (print-primitive "\n":literal)
|
2014-11-27 18:14:03 +00:00
|
|
|
; copy 'a' into result
|
2014-12-14 20:36:42 +00:00
|
|
|
(j:integer <- copy 0:literal)
|
2014-11-27 18:14:03 +00:00
|
|
|
{ begin
|
|
|
|
; while (j < a.length)
|
2014-12-14 20:36:42 +00:00
|
|
|
(arg-done?:boolean <- less-than j:integer a-len:integer)
|
|
|
|
(break-unless arg-done?:boolean)
|
2014-11-27 18:14:03 +00:00
|
|
|
; result[result-idx] = a[j]
|
2014-12-14 20:36:42 +00:00
|
|
|
(in:byte <- index a:string-address/deref j:integer)
|
2014-11-29 09:38:54 +00:00
|
|
|
;? (print-primitive ("copying: " literal))
|
2014-12-14 20:36:42 +00:00
|
|
|
;? (print-primitive in:byte)
|
2014-11-29 09:38:54 +00:00
|
|
|
;? (print-primitive (" at: " literal))
|
2014-12-14 20:36:42 +00:00
|
|
|
;? (print-primitive result-idx:integer)
|
|
|
|
;? (print-primitive "\n":literal)
|
|
|
|
(out:byte-address <- index-address result:string-address/deref result-idx:integer)
|
|
|
|
(out:byte-address/deref <- copy in:byte)
|
2014-11-27 18:14:03 +00:00
|
|
|
; ++j
|
2014-12-14 20:36:42 +00:00
|
|
|
(j:integer <- add j:integer 1:literal)
|
2014-11-27 18:14:03 +00:00
|
|
|
; ++result-idx
|
2014-12-14 20:36:42 +00:00
|
|
|
(result-idx:integer <- add result-idx:integer 1:literal)
|
2014-11-27 18:14:03 +00:00
|
|
|
(loop)
|
|
|
|
}
|
|
|
|
; skip '_' in template
|
2014-12-14 20:36:42 +00:00
|
|
|
(i:integer <- add i:integer 1:literal)
|
2014-11-29 09:38:54 +00:00
|
|
|
;? (print-primitive ("i now: " literal))
|
2014-12-14 20:36:42 +00:00
|
|
|
;? (print-primitive i:integer)
|
|
|
|
;? (print-primitive "\n":literal)
|
2014-11-29 09:38:54 +00:00
|
|
|
(loop) ; interpolate next arg
|
|
|
|
}
|
2014-11-29 09:54:46 +00:00
|
|
|
; done with holes; copy rest of template directly into result
|
|
|
|
{ begin
|
|
|
|
; while (i < template.length)
|
2014-12-14 20:36:42 +00:00
|
|
|
(tem-done?:boolean <- less-than i:integer tem-len:integer)
|
|
|
|
(break-unless tem-done?:boolean)
|
2014-11-29 09:54:46 +00:00
|
|
|
; result[result-idx] = template[i]
|
2014-12-14 20:36:42 +00:00
|
|
|
(in:byte <- index template:string-address/deref i:integer)
|
2014-11-29 09:54:46 +00:00
|
|
|
;? (print-primitive ("copying: " literal))
|
2014-12-14 20:36:42 +00:00
|
|
|
;? (print-primitive in:byte)
|
2014-11-29 09:54:46 +00:00
|
|
|
;? (print-primitive (" at: " literal))
|
2014-12-14 20:36:42 +00:00
|
|
|
;? (print-primitive result-idx:integer)
|
|
|
|
;? (print-primitive "\n":literal)
|
|
|
|
(out:byte-address <- index-address result:string-address/deref result-idx:integer)
|
|
|
|
(out:byte-address/deref <- copy in:byte)
|
2014-11-29 09:54:46 +00:00
|
|
|
; ++i
|
2014-12-14 20:36:42 +00:00
|
|
|
(i:integer <- add i:integer 1:literal)
|
2014-11-29 09:54:46 +00:00
|
|
|
; ++result-idx
|
2014-12-14 20:36:42 +00:00
|
|
|
(result-idx:integer <- add result-idx:integer 1:literal)
|
2014-11-29 09:54:46 +00:00
|
|
|
(loop)
|
|
|
|
}
|
2014-12-14 20:36:42 +00:00
|
|
|
(reply result:string-address))
|
2014-11-27 18:14:03 +00:00
|
|
|
|
2014-12-20 02:57:11 +00:00
|
|
|
(init-fn find-next ; string, character, index -> next index
|
|
|
|
(s:string-address <- next-input)
|
|
|
|
(needle:character <- next-input) ; todo: unicode chars
|
|
|
|
(idx:integer <- next-input)
|
|
|
|
(len:integer <- length s:string-address/deref)
|
|
|
|
{ begin
|
|
|
|
(eof?:boolean <- greater-or-equal idx:integer len:integer)
|
|
|
|
(break-if eof?:boolean)
|
|
|
|
(curr:byte <- index s:string-address/deref idx:integer)
|
|
|
|
(found?:boolean <- equal curr:byte needle:character)
|
|
|
|
(break-if found?:boolean)
|
|
|
|
(idx:integer <- add idx:integer 1:literal)
|
|
|
|
(loop)
|
|
|
|
}
|
|
|
|
(reply idx:integer))
|
|
|
|
|
2014-12-20 06:18:41 +00:00
|
|
|
(init-fn split ; string, character -> string-address-array-address
|
2015-01-03 02:13:04 +00:00
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
2014-12-20 06:18:41 +00:00
|
|
|
(s:string-address <- next-input)
|
|
|
|
(delim:character <- next-input) ; todo: unicode chars
|
|
|
|
; empty string? return empty array
|
|
|
|
(len:integer <- length s:string-address/deref)
|
|
|
|
{ begin
|
|
|
|
(empty?:boolean <- equal len:integer 0:literal)
|
|
|
|
(break-unless empty?:boolean)
|
|
|
|
(result:string-address-array-address <- new string-address-array:literal 0:literal)
|
|
|
|
(reply result:string-address-array-address)
|
|
|
|
}
|
|
|
|
; count #pieces we need room for
|
|
|
|
(count:integer <- copy 1:literal) ; n delimiters = n+1 pieces
|
|
|
|
(idx:integer <- copy 0:literal)
|
|
|
|
{ begin
|
|
|
|
(idx:integer <- find-next s:string-address delim:character idx:integer)
|
|
|
|
(done?:boolean <- greater-or-equal 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-primitive (("alloc: " literal)))
|
|
|
|
;? (print-primitive count:integer)
|
|
|
|
;? (print-primitive (("\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-primitive (("i: " literal)))
|
|
|
|
;? (print-primitive start:integer)
|
|
|
|
;? (print-primitive (("-" literal)))
|
|
|
|
;? (print-primitive end:integer)
|
|
|
|
;? (print-primitive ((" => " literal)))
|
|
|
|
;? (print-primitive curr-result:integer)
|
|
|
|
;? (print-primitive (("\n" literal)))
|
|
|
|
; compute length of slice
|
|
|
|
(slice-len:integer <- subtract end:integer start:integer)
|
|
|
|
; allocate result[curr-result]
|
|
|
|
(dest:string-address-address <- index-address result:string-address-array-address/deref curr-result:integer)
|
|
|
|
(dest:string-address-address/deref <- new string:literal slice-len:integer)
|
|
|
|
; copy start..end into result[curr-result]
|
|
|
|
(src-idx:integer <- copy start:integer)
|
|
|
|
(dest-idx:integer <- copy 0:literal)
|
|
|
|
{ begin
|
|
|
|
(end-copy?:boolean <- greater-or-equal src-idx:integer end:integer)
|
|
|
|
(break-if end-copy?:boolean)
|
|
|
|
(src:character <- index s:string-address/deref src-idx:integer)
|
|
|
|
(tmp:character-address <- index-address dest:string-address-address/deref/deref dest-idx:integer)
|
|
|
|
(tmp: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)
|
|
|
|
}
|
|
|
|
; 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)
|
|
|
|
)
|
|
|
|
|
2015-01-12 06:03:16 +00:00
|
|
|
(init-fn send-keys-to-stdin
|
|
|
|
(default-space:space-address <- new space:literal 30:literal)
|
|
|
|
(stdin:channel-address <- next-input)
|
|
|
|
{ begin
|
2015-01-12 07:02:11 +00:00
|
|
|
; keyboard input is infrequent; sleep at the start of each iteration
|
|
|
|
(sleep for-some-cycles:literal 1:literal)
|
2015-01-12 06:03:16 +00:00
|
|
|
(c:character <- read-key)
|
2015-01-12 07:02:11 +00:00
|
|
|
(loop-unless c:character)
|
2015-01-12 06:03:16 +00:00
|
|
|
(curr:tagged-value <- save-type c:character)
|
|
|
|
(stdin:channel-address/deref <- write stdin:channel-address curr:tagged-value)
|
|
|
|
(loop)
|
|
|
|
}
|
|
|
|
)
|
|
|
|
|
2014-12-30 23:13:51 +00:00
|
|
|
; after all system software is loaded:
|
|
|
|
(freeze system-function*)
|
2014-12-13 08:33:20 +00:00
|
|
|
) ; section 100 for system software
|
|
|
|
|
2014-11-25 06:13:39 +00:00
|
|
|
;; load all provided files and start at 'main'
|
2014-08-22 18:05:51 +00:00
|
|
|
(reset)
|
2015-01-12 06:54:51 +00:00
|
|
|
;? (new-trace "main")
|
2015-01-01 05:24:48 +00:00
|
|
|
;? (set dump-trace*)
|
2014-12-13 08:33:20 +00:00
|
|
|
(awhen (pos "--" argv)
|
|
|
|
(map add-code:readfile (cut argv (+ it 1)))
|
2015-01-02 19:22:39 +00:00
|
|
|
;? (= dump-trace* (obj whitelist '("run")))
|
|
|
|
;? (= dump-trace* (obj whitelist '("schedule")))
|
2015-01-10 21:53:00 +00:00
|
|
|
;? (= dump-trace* (obj whitelist '("cn0" "cn1")))
|
2014-12-31 06:36:36 +00:00
|
|
|
;? (set dump-trace*)
|
2014-12-30 23:13:51 +00:00
|
|
|
;? (freeze function*)
|
2014-11-27 03:11:14 +00:00
|
|
|
;? (prn function*!factorial)
|
2014-08-28 19:44:01 +00:00
|
|
|
(run 'main)
|
2015-01-02 19:39:22 +00:00
|
|
|
(if ($.current-charterm) ($.close-charterm))
|
2015-01-12 06:03:16 +00:00
|
|
|
(when ($.graphics-open?) ($.close-viewport Viewport) ($.close-graphics))
|
2015-01-06 07:28:21 +00:00
|
|
|
(prn "\nmemory: " int-canon.memory*)
|
2015-01-01 19:11:02 +00:00
|
|
|
(each routine completed-routines*
|
|
|
|
(aif rep.routine!error (prn "error - " it)))
|
2014-11-01 23:34:33 +00:00
|
|
|
)
|
2015-01-02 19:39:22 +00:00
|
|
|
(reset)
|
2015-01-06 07:28:21 +00:00
|
|
|
;? (print-times)
|