smalltalk-tng

view r1/kernel-methods.scm @ 321:c4a0718c2d3c

find changesets by author, revision, files, or words in the commit message
Sketch of dependencies
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
date Sat Oct 08 15:36:03 2011 -0400 (7 months ago)
parents
children
line source
1 ;; This file is included in a couple of different contexts to
2 ;; initialise the primitive table and to build a bootstrap image, and
3 ;; should only contain define-method forms.
4
5 (define-method (primListen (port *traits-number*)) primListenSocket
6 (or (sdl-net-tcp-open (make-sdl-ip-address 0 0 0 0 port))
7 *nil*))
8
9 (define-method (primConnect: (hostname *traits-string*) (port *traits-number*)) primConnectSocket
10 (or (sdl-net-tcp-open (sdl-net-resolve-host hostname port))
11 *nil*))
12
13 (define-method (accept (sock *traits-socket*)) primSocketAccept
14 (or (accept-from-socket sock)
15 *nil*))
16
17 (define-method (primPeerAddress (sock *traits-socket*)) primSocketPeerAddress
18 (or (and-let* ((ipa (sdl-net-tcp-get-peer-address sock))
19 (hostname (sdl-net-resolve-ip ipa)))
20 (vector hostname (sdl-ip-address-port ipa)))
21 *nil*))
22
23 (define-method (close (sock *traits-socket*)) primSocketClose
24 (sdl-net-tcp-close sock)
25 *nil*)
26
27 (define-method (printOn: o (out *traits-socket*)) displayPrintString
28 (let ((string-port (open-output-string)))
29 (display (send/previous-method/missing-handler #f
30 (lambda (argv) "#<OBJECT>")
31 'printString
32 (vector o))
33 string-port)
34 (let ((representation (get-output-string string-port)))
35 (sdl-net-tcp-send-string out representation)
36 *nil*)))
37
38 (define-method (printString (x *traits-root*)) rootPrintString
39 (send as: x *traits-string*))
40
41 (define-method (primStringAppend: (s1 *traits-string*) (s2 *traits-string*)) primStringAppend
42 (string-append s1 s2))
43
44 (define-method (- (n1 *traits-number*) (n2 *traits-number*)) numSub (- n1 n2))
45 (define-method (+ (n1 *traits-number*) (n2 *traits-number*)) numPlus (+ n1 n2))
46 (define-method (* (n1 *traits-number*) (n2 *traits-number*)) numTimes (* n1 n2))
47 (define-method (/ (n1 *traits-number*) (n2 *traits-number*)) numDiv (/ n1 n2))
48
49 (define-method (< (n1 *traits-number*) (n2 *traits-number*)) numLT (< n1 n2))
50 (define-method (> (n1 *traits-number*) (n2 *traits-number*)) numGT (> n1 n2))
51 (define-method (<= (n1 *traits-number*) (n2 *traits-number*)) numLE (<= n1 n2))
52 (define-method (>= (n1 *traits-number*) (n2 *traits-number*)) numGE (>= n1 n2))
53
54 (define-method (= (x *traits-root*) (y *traits-root*)) primEgal
55 (let egal ((x x) (y y))
56 (or (eq? x y)
57 (cond
58 ((and (object? x) (object? y))
59 (let ((lx (object-layout x)) (sx (object-slots x))
60 (ly (object-layout y)) (sy (object-slots y)))
61 (and (eq? lx ly)
62 (call-with-current-continuation
63 (lambda (escape)
64 (layout-for-each lx
65 (lambda (slot-name slot)
66 (case (slot-kind slot)
67 ((mutable) (escape #f))
68 ((immutable)
69 (let ((index (slot-index slot)))
70 (if (not (egal (vector-ref sx index)
71 (vector-ref sy index)))
72 (escape #f))))
73 ((method) 'ignore-methods)
74 (else (error "Unknown slot kind in egal"
75 (slot-kind slot))))))
76 #t)))))
77 ((and (pair? x) (pair? y))
78 (and (egal (car x) (car y))
79 (egal (cdr x) (cdr y))))
80 ((and (vector? x) (vector? y))
81 (let ((len (vector-length x)))
82 (and (= len (vector-length y))
83 (let loop ((i 0))
84 (if (= i len)
85 #t
86 (and (egal (vector-ref x i)
87 (vector-ref y i))
88 (loop (+ i 1))))))))
89 ((and (number? x) (number? y))
90 (= x y))
91 (else #f)))))
92
93 (define-method (as: x (y *traits-string*)) rootAsString
94 (if (eq? x *no-role*)
95 "NoRole"
96 (send name x)))
97
98 (define-method (as: (x '()) (y *traits-string*)) nilAsString "Nil")
99 (define-method (as: (x '#t) (y *traits-string*)) trueAsString "True")
100 (define-method (as: (x '#f) (y *traits-string*)) falseAsString "False")
101
102 (define-method (as: (x *traits-traits*) (y *traits-string*)) traitsAsString
103 (string-append "#<"(send name x)" traits>"))
104
105 (define-method (as: (x *traits-string*) (y *traits-string*)) stringAsString
106 (if (string? x)
107 x
108 (resend)))
109
110 (define-method (as: (x *traits-symbol*) (y *traits-string*)) symbolAsString
111 (if (symbol? x)
112 (symbol->string x)
113 (resend)))
114
115 (define-method (as: (x *traits-number*) (y *traits-string*)) numberAsString
116 (if (number? x)
117 (number->string x)
118 (resend)))
119
120 (define-method (new (c *traits-cell*)) newCell
121 (clone-object *cell*))
122
123 (define-method (key (o *traits-pair*)) pairCar
124 (car o))
125
126 (define-method (value (o *traits-pair*)) pairCdr
127 (cdr o))
128
129 (define-method (size (v *traits-tuple*)) tupleSize
130 (vector-length v))
131
132 (define-method (at: (v *traits-tuple*) (n *traits-number*)) tupleAt
133 (vector-ref v n))
134
135 (define-method (-> (x *traits-root*) y) pairCons
136 (cons x y))
137
138 (define-method (--> (c *traits-cell*) (m *traits-block*)) cellExtract
139 (send applyWith: m (metalevel-extract-cell-value c)))
140
141 (define-method (peek (c *traits-cell*)) cellPeek
142 (metalevel-peek-cell-value c))
143
144 (define-method (<-- (c *traits-cell*) v) cellInject
145 (metalevel-inject-cell-value c v))
146
147 (define-method (withSlot:value: template (name *traits-symbol*) val) primAddSlot
148 (let ((o (clone-object template)))
149 (if (has-slot? o name)
150 (set-slot! o name val)
151 (add-slot! o name val #f 'immutable))
152 o))
153
154 (define-method (fork: (loc *traits-location*) (block *traits-block*)) forkBlockInLocation
155 (metalevel-spawn loc (lambda () (send do block)))
156 *nil*)
157
158 (define-method (fileIn (filename *traits-string*)) stringFileIn
159 (ThiNG-load-file filename))
160
161 (define-method (compileOneStatement (sock *traits-socket*)) primCompileOneStatement
162 (let-values (((success ast) (parse-ThiNG (external-representation sock)
163 ThiNG-topexpr-parser
164 (make-char-provider-thunk-for-socket sock))))
165 (if success
166 (cons *true* (metalevel-eval `(block () (,ast))))
167 (cons *false* ast))))
168
169 (define-method (saveImage (filename *traits-string*)) primSaveImage
170 (debug 0 "Saving image...")
171 (call-with-output-file filename
172 (lambda (port)
173 (write (serialize-image!) port)
174 (newline port))))
175
176 (define-method (primQuit (r *traits-root*)) primQuit
177 (shutdown-sdl!)
178 *nil*)
179
180 ;---------------------------------------------------------------------------
181
182 (define-method (handle (e *traits-sdl-event*)) handleBasicSdlEvent
183 #t)
184
185 (define-method (handle (e (traits-for-sdl-event-type SDL_QUIT))) handleQuitSdlEvent
186 (metalevel-stop!)
187 #f)
188
189 (define-method (handle (e (traits-for-sdl-event-type SDL_MOUSEBUTTONDOWN))) handleSdlClick
190 (let ((s2 (ttf-render-text-blended *system-font*
191 "(click)"
192 (make-sdl-color 255 255 255))))
193 (sdl-blit-surface s2 #f
194 *video-surface* (make-sdl-rect (sdl-event-x e)
195 (sdl-event-y e)
196 0 0))
197 (sdl-free-surface s2))
198 (sdl-flip *video-surface*)
199 (resend))
200
201 (define-method (handle (e (traits-for-sdl-event-type SDL_VIDEORESIZE))) handleSdlVideoResize
202 (let ((w (sdl-event-w e))
203 (h (sdl-event-h e)))
204 (display (list 'resize w h))
205 (newline)
206 (sdl-set-video-mode w h 0 (+ SDL_HWSURFACE
207 SDL_HWPALETTE
208 SDL_RESIZABLE
209 SDL_DOUBLEBUF)))
210 (sdl-fill-rect *video-surface*
211 (make-sdl-rect 0 0
212 (sdl-surface-width *video-surface*)
213 (sdl-surface-height *video-surface*))
214 (sdl-map-rgb (sdl-surface-pixel-format *video-surface*) 0 0 64))
215 (let ((s2 (ttf-render-text-blended *system-font*
216 "Hello, world!"
217 (make-sdl-color 255 255 255))))
218 (sdl-blit-surface s2 #f *video-surface* (make-sdl-rect 0 0 0 0))
219 (sdl-free-surface s2))
220 (sdl-flip *video-surface*)
221 (resend))
222
223 (define-method (handle (e (traits-for-sdl-event-type SDL_KEYDOWN))) handleSdlKeydown
224 (let* ((i (sdl-event-sym e))
225 (c (integer->char i)))
226 (if (or (= i 27) (memv c '(#\q #\Q)))
227 (shutdown-sdl!)
228 (begin (display (list 'got-key c))
229 (newline))))
230 (resend))