author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
Sun, 29 Jul 2018 18:06:07 +0100 | |
changeset 426 | 930c499509be |
parent 418 | 0e9aa45d4ba9 |
permissions | -rw-r--r-- |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1 |
#lang racket/gui |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
2 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
3 |
(provide *primitive-handlers* |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
4 |
*primitive-code-snippets* |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
5 |
define-primitive |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
6 |
gen:vm-callback |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
7 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
8 |
;; These are referred to by spliced-in S-expression code |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
9 |
;; fragments, indirectly via the eval namespace used to |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
10 |
;; instantiate compiled code. |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
11 |
;; |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
12 |
vm-block-callback |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
13 |
smalltalk-frame% |
407
050363358370
Forgot a few identifiers relied on by primitive code snippets
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
14 |
oneshot |
050363358370
Forgot a few identifiers relied on by primitive code snippets
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
15 |
oneshot-set! |
050363358370
Forgot a few identifiers relied on by primitive code snippets
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
16 |
oneshot-ref |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
17 |
log-vm/gui-debug |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
18 |
log-vm/gui-info |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
19 |
log-vm/gui-warning |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
20 |
log-vm/gui-error) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
21 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
22 |
(require racket/generic) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
23 |
(require "object-memory.rkt") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
24 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
25 |
(define-logger vm) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
26 |
(define-logger vm/gui) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
27 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
28 |
(define *primitive-handlers* (make-hash)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
29 |
(define *primitive-code-snippets* (make-hash)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
30 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
31 |
(define-syntax-rule (define-primitive vm [n arg-pat ...] body ...) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
32 |
(begin (hash-set! *primitive-handlers* |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
33 |
n |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
34 |
(lambda (vm args) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
35 |
(match (obj-slots args) [(vector arg-pat ...) (let () body ...)]))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
36 |
(hash-set! *primitive-code-snippets* |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
37 |
n |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
38 |
(lambda (vm-exp arg-exps) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
39 |
`(match* [,vm-exp ,@arg-exps] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
40 |
[[vm arg-pat ...] (let () body ...)]))))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
41 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
42 |
(define-generics vm-callback |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
43 |
(vm-block-callback vm-callback action)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
44 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
45 |
;;=========================================================================== |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
46 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
47 |
(define (oneshot) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
48 |
(thread (lambda () |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
49 |
(define (no-value waiters) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
50 |
(match (thread-receive) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
51 |
[(list 'get ch) (no-value (cons ch waiters))] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
52 |
[(list 'set v) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
53 |
(for [(ch waiters)] (channel-put ch v)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
54 |
(value v)])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
55 |
(define (value v) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
56 |
(match (thread-receive) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
57 |
[(list 'get ch) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
58 |
(channel-put ch v) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
59 |
(value v)] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
60 |
[(list 'set v) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
61 |
(value v)])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
62 |
(no-value '())))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
63 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
64 |
(define (oneshot-set! o v) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
65 |
(thread-send o (list 'set v))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
66 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
67 |
(define (oneshot-ref o) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
68 |
(define ch (make-channel)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
69 |
(thread-send o (list 'get ch)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
70 |
(channel-get ch)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
71 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
72 |
;;=========================================================================== |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
73 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
74 |
(define-primitive vm [1 b a] (boolean->obj vm (eq? a b))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
75 |
(define-primitive vm [2 x] (obj-class* vm x)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
76 |
(define-primitive vm [4 o] (cond [(bv? o) (bytes-length (bv-bytes o))] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
77 |
[(obj? o) (slotCount o)] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
78 |
[(number? o) 0] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
79 |
[else (error 'execute "Primitive 4 failed")])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
80 |
(define-primitive vm [5 value target index] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
81 |
(slotAtPut target (- index 1) value) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
82 |
target) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
83 |
;; 6 - "new context execute" |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
84 |
(define-primitive vm [7 class count] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
85 |
(obj class (make-vector count (VM-nil vm)))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
86 |
|
418
0e9aa45d4ba9
Missing primitive 13; correct (?) argument ordering (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
407
diff
changeset
|
87 |
(define-primitive vm [10 a b] (+ a b)) ;; TODO: overflow |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
88 |
(define-primitive vm [11 n d] (quotient n d)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
89 |
(define-primitive vm [12 n d] (modulo n d)) |
418
0e9aa45d4ba9
Missing primitive 13; correct (?) argument ordering (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
407
diff
changeset
|
90 |
(define-primitive vm [13 a b] (boolean->obj vm (< a b))) |
0e9aa45d4ba9
Missing primitive 13; correct (?) argument ordering (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
407
diff
changeset
|
91 |
(define-primitive vm [14 a b] (boolean->obj vm (= a b))) |
0e9aa45d4ba9
Missing primitive 13; correct (?) argument ordering (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
407
diff
changeset
|
92 |
(define-primitive vm [15 a b] (* a b)) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
93 |
(define-primitive vm [16 a b] (- a b)) ;; NB. ordering |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
94 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
95 |
(define-primitive vm [18 v] (log-vm-info "DEBUG: value ~v class ~v" v (obj-class* vm v))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
96 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
97 |
(define-primitive vm [20 class count] (mkbv class (make-bytes count))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
98 |
(define-primitive vm [21 source index] (bytes-ref (bv-bytes source) (- index 1))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
99 |
(define-primitive vm [22 value target index] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
100 |
(bytes-set! (bv-bytes target) (- index 1) value) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
101 |
target) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
102 |
(define-primitive vm [24 (unbv b) (unbv* av a)] (mkbv (obj-class av) (bytes-append a b))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
103 |
(define-primitive vm [26 (unbv a) (unbv b)] ;; NB. ordering |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
104 |
(cond [(bytes<? a b) -1] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
105 |
[(bytes=? a b) 0] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
106 |
[(bytes>? a b) 1])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
107 |
|
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
418
diff
changeset
|
108 |
(define-primitive vm [29 filename] (save-image-to-file vm (bv->string filename))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
418
diff
changeset
|
109 |
|
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
110 |
(define-primitive vm [30 source index] (slotAt source (- index 1))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
111 |
(define-primitive vm [31 v o] (obj (obj-class o) (vector-append (obj-slots o) (vector v)))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
112 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
113 |
(define-primitive vm [41 class (unstr filename)] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
114 |
(mkffiv class (open-output-file filename #:exists 'replace))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
115 |
(define-primitive vm [42 class (unstr filename)] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
116 |
(mkffiv class (open-input-file filename))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
117 |
(define-primitive vm [44 class (unffiv fh)] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
118 |
(match (read-bytes-line fh) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
119 |
[(? eof-object?) (VM-nil vm)] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
120 |
[bs (mkbv class bs)])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
121 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
122 |
;;--------------------------------------------------------------------------- |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
123 |
;; GUI |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
124 |
;;--------------------------------------------------------------------------- |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
125 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
126 |
(define smalltalk-frame% |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
127 |
(class frame% |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
128 |
(field [close-handler void]) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
129 |
(define/public (set-close-handler new-handler) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
130 |
(set! close-handler new-handler)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
131 |
(define/augment (on-close) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
132 |
(close-handler this)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
133 |
(super-new))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
134 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
135 |
(define-primitive vm [60 class] ;; make window |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
136 |
(log-vm/gui-debug "Creating window") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
137 |
(mkffiv class (new smalltalk-frame% [label "Racket SmallWorld"]))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
138 |
(define-primitive vm [61 (unffiv window) flag] ;; show/hide text window |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
139 |
(log-vm/gui-debug "Show/hide window ~a" (eq? flag (VM-true vm))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
140 |
(send window show (eq? flag (VM-true vm))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
141 |
flag) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
142 |
(define-primitive vm [62 (unffiv* wv window) (unffiv (list _item factory))] ;; set content pane |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
143 |
(log-vm/gui-debug "Set content pane") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
144 |
(factory window) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
145 |
wv) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
146 |
(define-primitive vm [63 (unffiv* wv window) height width] ;; set size |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
147 |
(log-vm/gui-debug "Window resize ~ax~a" width height) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
148 |
(send window resize width height) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
149 |
wv) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
150 |
(define-primitive vm [64 (unffiv* wv window) (unffiv (list _queue-item add-menu-bar-to))] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
151 |
;; add menu to window |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
152 |
(define mb (or (send window get-menu-bar) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
153 |
(new menu-bar% [parent window]))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
154 |
(log-vm/gui-debug "Add menu to window") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
155 |
(add-menu-bar-to mb) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
156 |
wv) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
157 |
(define-primitive vm [65 (unffiv* wv window) (unstr text)] ;; set title |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
158 |
(log-vm/gui-debug "Set window title ~v" text) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
159 |
(send window set-label text) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
160 |
wv) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
161 |
(define-primitive vm [66 window] ;; repaint window |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
162 |
;; nothing needed |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
163 |
window) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
164 |
(define-primitive vm [70 class (unstr label)] ;; new label panel |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
165 |
(log-vm/gui-debug "Schedule label panel ~v" label) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
166 |
(define (create-label-in parent) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
167 |
(log-vm/gui-debug "Create label panel ~v" label) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
168 |
(new message% [parent parent] [label label])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
169 |
(mkffiv class (list 'label create-label-in))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
170 |
(define-primitive vm [71 class (unstr label) action] ;; new button |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
171 |
(define callback (vm-block-callback vm action)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
172 |
(log-vm/gui-debug "Schedule button ~v" label) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
173 |
(define (create-button-in parent) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
174 |
(log-vm/gui-debug "Create button ~v" label) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
175 |
(new button% |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
176 |
[label label] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
177 |
[parent parent] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
178 |
[callback (lambda args (queue-callback callback))])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
179 |
(mkffiv class (list 'button create-button-in))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
180 |
(define-primitive vm [72 class] ;; new text line |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
181 |
(log-vm/gui-debug "Schedule textfield") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
182 |
(define textfield-editor #f) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
183 |
(define (add-textfield-to parent) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
184 |
(set! textfield-editor (send (new text-field% [label #f] [parent parent]) get-editor)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
185 |
textfield-editor) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
186 |
(mkffiv class (list (lambda () textfield-editor) add-textfield-to))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
187 |
(define-primitive vm [73 class] ;; new text area |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
188 |
(log-vm/gui-debug "Schedule textarea") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
189 |
(define editor (new text%)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
190 |
(define (add-editor-to frame) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
191 |
(log-vm/gui-debug "Create textarea") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
192 |
(new editor-canvas% [parent frame] [editor editor])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
193 |
(mkffiv class (list (lambda () editor) add-editor-to))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
194 |
(define-primitive vm [74 class width height data] ;; new grid panel |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
195 |
(log-vm/gui-debug "Schedule grid panel ~ax~a ~a" width height data) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
196 |
(define (create-grid-in parent) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
197 |
(log-vm/gui-debug "Create grid panel ~ax~a ~a" width height data) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
198 |
(define vp (new vertical-pane% [parent parent])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
199 |
(for [(row height)] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
200 |
(define hp (new horizontal-pane% [parent vp])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
201 |
(for [(col width)] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
202 |
(define i (+ col (* row width))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
203 |
(when (< i (slotCount data)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
204 |
(match (slotAt data i) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
205 |
[(unffiv (list _ factory)) (factory hp)])))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
206 |
vp) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
207 |
(mkffiv class (list 'grid create-grid-in))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
208 |
(define-primitive vm [75 class data action] ;; new list panel |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
209 |
(define callback (vm-block-callback vm action)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
210 |
(log-vm/gui-debug "Schedule listpanel ~a" data) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
211 |
(define lb #f) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
212 |
(define old-selection #f) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
213 |
(define (create-list-panel-in parent) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
214 |
(log-vm/gui-debug "Create listpanel ~a" data) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
215 |
(set! lb (new list-box% |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
216 |
[label #f] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
217 |
[parent parent] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
218 |
[choices (for/list [(c (obj-slots data))] (bv->string c))] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
219 |
[callback (lambda _args |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
220 |
(log-vm/gui-debug "_args: ~v for listpanel ~a" |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
221 |
_args |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
222 |
(eq-hash-code lb)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
223 |
(define selection (send lb get-selection)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
224 |
(when (not (equal? old-selection selection)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
225 |
(set! old-selection selection) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
226 |
(queue-callback |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
227 |
(lambda () |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
228 |
(log-vm/gui-debug "Item selected ~v" selection) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
229 |
(callback (if selection (+ selection 1) 0))))))])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
230 |
(log-vm/gui-debug "The result is ~a" (eq-hash-code lb)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
231 |
lb) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
232 |
(mkffiv class (list (lambda () lb) create-list-panel-in))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
233 |
(define-primitive vm [76 class north south east west center] ;; new border panel |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
234 |
(log-vm/gui-debug "Schedule borderpanel") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
235 |
(define (add-w w p) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
236 |
(when (not (eq? (VM-nil vm) w)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
237 |
(match w [(unffiv (list _ factory)) (factory p)]))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
238 |
(define (create-border-panel-in parent) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
239 |
(log-vm/gui-debug "Create borderpanel") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
240 |
(define vp (new vertical-pane% [parent parent])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
241 |
(add-w north vp) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
242 |
(when (for/or [(w (list west center east))] (not (eq? (VM-nil vm) w))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
243 |
(define hp (new horizontal-pane% [parent vp])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
244 |
(add-w west hp) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
245 |
(add-w center hp) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
246 |
(add-w east hp)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
247 |
(add-w south vp) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
248 |
vp) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
249 |
(mkffiv class (list 'border-panel create-border-panel-in))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
250 |
(define-primitive vm [80 class (unffiv (list get-textarea _factory))] ;; content of text area |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
251 |
(mkbv class (string->bytes/utf-8 (send (get-textarea) get-text)))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
252 |
(define-primitive vm [81 class (unffiv (list get-textarea _factory))] ;; content of selected text area |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
253 |
(define start (box 0)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
254 |
(define end (box 0)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
255 |
(send (get-textarea) get-position start end) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
256 |
(define has-selection (not (= (unbox start) (unbox end)))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
257 |
(mkbv class |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
258 |
(string->bytes/utf-8 (send (get-textarea) get-text |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
259 |
(if has-selection (unbox start) 0) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
260 |
(if has-selection (unbox end) 'eof))))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
261 |
(define-primitive vm [82 (unffiv (list get-textarea _factory)) (and textv (unstr text))] ;; set text area |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
262 |
(log-vm/gui-debug "Update textarea ~v" text) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
263 |
(send (get-textarea) erase) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
264 |
(send (get-textarea) insert text) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
265 |
textv) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
266 |
(define-primitive vm [83 (unffiv (list get-lb _factory))] ;; get selected index |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
267 |
(log-vm/gui-debug "Get selected index") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
268 |
(define lb (get-lb)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
269 |
(define s (send lb get-selection)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
270 |
(if s (+ s 1) 0)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
271 |
(define-primitive vm [84 (unffiv* lbv (list get-lb _factory)) data] ;; set list data |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
272 |
(define lb (get-lb)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
273 |
(log-vm/gui-debug "Update list ~a data ~v" (eq-hash-code lb) data) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
274 |
(send lb set (for/list [(c (obj-slots data))] (bv->string c))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
275 |
lbv) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
276 |
(define-primitive vm [89 (unffiv (list get-textarea _factory)) (and textv (unstr text))] ;; set selected text area |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
277 |
(define start (box 0)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
278 |
(define end (box 0)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
279 |
(send (get-textarea) get-position start end) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
280 |
(define has-selection (not (= (unbox start) (unbox end)))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
281 |
(if has-selection |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
282 |
(send (get-textarea) insert text (unbox start) (unbox end)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
283 |
(begin (send (get-textarea) erase) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
284 |
(send (get-textarea) insert text))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
285 |
textv) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
286 |
(define-primitive vm [90 class (unstr title)] ;; new menu |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
287 |
(define pending-items '()) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
288 |
(define (queue-item i) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
289 |
(set! pending-items (cons i pending-items))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
290 |
(define (add-menu-bar-to frame) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
291 |
(define m (new menu% [parent frame] [label title])) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
292 |
(for [(i (reverse pending-items))] (i m)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
293 |
m) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
294 |
(mkffiv class (list queue-item add-menu-bar-to))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
295 |
(define-primitive vm [91 (unffiv* menu (list queue-item _add-menu-bar-to)) (unstr title) action] ;; new menu item |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
296 |
(define callback (vm-block-callback vm action)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
297 |
(queue-item (lambda (m) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
298 |
(new menu-item% |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
299 |
[label title] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
300 |
[parent m] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
301 |
[callback (lambda args (queue-callback callback))]))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
302 |
menu) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
303 |
(define-primitive vm [100 class] (mkffiv class (oneshot))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
304 |
(define-primitive vm [101 (unffiv o)] (oneshot-ref o)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
305 |
(define-primitive vm [102 (unffiv o) v] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
306 |
(oneshot-set! o v) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
307 |
v) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
308 |
;; 116 - save image to preset filename |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
309 |
(define-primitive vm [117 _self] (exit)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
310 |
(define-primitive vm [118 (unffiv* wv window) action] ;; "onWindow close b" |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
311 |
(define callback (vm-block-callback vm action)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
312 |
(send window set-close-handler (lambda (_frame) (queue-callback callback) (sleep 0.2))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
313 |
wv) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
314 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
315 |
;;--------------------------------------------------------------------------- |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
316 |
;; END GUI |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
317 |
;;--------------------------------------------------------------------------- |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
318 |
|
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
319 |
(define-primitive vm [119] (inexact->exact (round (current-inexact-milliseconds)))) |