/
oof.fs
661 lines (522 loc) · 18.8 KB
/
oof.fs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
\ oof.fs Object Oriented FORTH
\ This file is (c) 1996,2000 by Bernd Paysan
\ e-mail: bernd.paysan@gmx.de
\
\ Please copy and share this program, modify it for your system
\ and improve it as you like. But don't remove this notice.
\
\ Thank you.
\
\ The program uses the following words
\ from CORE :
\ decimal : bl word 0= ; = cells Constant Variable ! Create , allot @
\ IF POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+
\ Literal drop align here aligned DOES> execute ['] 2@ recurse swap
\ 1+ over LOOP and EXIT ?dup 0< ] [ rot r@ - i negate +LOOP 2drop
\ BEGIN WHILE 2dup REPEAT 1- rshift > / ' move UNTIL or count
\ from CORE-EXT :
\ nip false Value tuck true ?DO compile, erase pick :noname 0<>
\ from BLOCK-EXT :
\ \
\ from EXCEPTION :
\ throw
\ from EXCEPTION-EXT :
\ abort"
\ from FILE :
\ ( S"
\ from FLOAT :
\ faligned
\ from LOCAL :
\ TO
\ from MEMORY :
\ allocate free
\ from SEARCH :
\ find definitions get-order set-order get-current wordlist
\ set-current search-wordlist
\ from SEARCH-EXT :
\ also Forth previous
\ from STRING :
\ /string compare
\ from TOOLS-EXT :
\ [IF] [THEN] [ELSE] state
\ from non-ANS :
\ cell dummy [THEN] ?EXIT Vocabulary [ELSE] ( \G
\ Loadscreen 27dec95py
decimal
: define? ( -- flag )
bl word find nip 0= ;
define? cell [IF]
1 cells Constant cell
[THEN]
define? \G [IF]
: \G postpone \ ; immediate
[THEN]
define? ?EXIT [IF]
: ?EXIT postpone IF postpone EXIT postpone THEN ; immediate
[THEN]
define? Vocabulary [IF]
: Vocabulary wordlist create ,
DOES> @ >r get-order nip r> swap set-order ;
[THEN]
define? faligned [IF] false [ELSE] 1 faligned 8 = [THEN]
[IF]
: 8aligned ( n1 -- n2 ) faligned ;
[ELSE]
: 8aligned ( n1 -- n2 ) 7 + -8 and ;
[THEN]
Vocabulary Objects also Objects also definitions
Vocabulary types types also
0 cells Constant :wordlist
1 cells Constant :parent
2 cells Constant :child
3 cells Constant :next
4 cells Constant :method#
5 cells Constant :var#
6 cells Constant :newlink
7 cells Constant :iface
8 cells Constant :init
0 cells Constant :inext
1 cells Constant :ilist
2 cells Constant :ilen
3 cells Constant :inum
Variable op
: op! ( o -- ) op ! ;
Forth definitions
Create ostack 0 , 16 cells allot
: ^ ( -- o ) op @ ;
: o@ ( -- o ) op @ @ ;
: >o ( o -- )
state @
IF postpone ^ postpone >r postpone op!
ELSE 1 ostack +! ^ ostack dup @ cells + ! op!
THEN ; immediate
: o> ( -- )
state @
IF postpone r> postpone op!
ELSE ostack dup @ cells + @ op! -1 ostack +!
THEN ; immediate
: o[] ( n -- ) o@ :var# + @ * ^ + op! ;
Objects definitions
\ Coding 27dec95py
0 Constant #static
1 Constant #method
2 Constant #early
3 Constant #var
4 Constant #defer
: exec? ( addr -- flag )
>body cell+ @ #method = ;
: static? ( addr -- flag )
>body cell+ @ #static = ;
: early? ( addr -- flag )
>body cell+ @ #early = ;
: defer? ( addr -- flag )
>body cell+ @ #defer = ;
false Value oset?
: o+, ( addr offset -- )
postpone Literal postpone ^ postpone +
oset? IF postpone op! ELSE postpone >o THEN drop ;
: o*, ( addr offset -- )
postpone Literal postpone * postpone Literal postpone +
oset? IF postpone op! ELSE postpone >o THEN ;
: ^+@ ( offset -- addr ) ^ + @ ;
: o+@, ( addr offset -- )
postpone Literal postpone ^+@ oset? IF postpone op! ELSE postpone >o THEN drop ;
: ^*@ ( offset -- addr ) ^ + @ tuck @ :var# + @ 8aligned * + ;
: o+@*, ( addr offset -- )
postpone Literal postpone ^*@ oset? IF postpone op! ELSE postpone >o THEN drop ;
\ variables / memory allocation 30oct94py
Variable lastob
Variable lastparent 0 lastparent !
Variable vars
Variable methods
Variable decl 0 decl !
Variable 'link
: crash true abort" unbound method" ;
: link, ( addr -- ) align here 'link ! , 0 , 0 , ;
0 link,
\ type declaration 30oct94py
: vallot ( size -- offset ) vars @ >r dup vars +!
'link @ 0=
IF lastparent @ dup IF :newlink + @ THEN link,
THEN
'link @ 2 cells + +! r> ;
: valign ( -- ) vars @ aligned vars ! ;
define? faligned 0= [IF]
: vfalign ( -- ) vars @ faligned vars ! ;
[THEN]
: mallot ( -- offset ) methods @ cell methods +! ;
types definitions
: static ( -- ) \ oof- oof
\G Create a class-wide cell-sized variable.
mallot Create , #static ,
DOES> @ o@ + ;
: method ( -- ) \ oof- oof
\G Create a method selector.
mallot Create , #method ,
DOES> @ o@ + @ execute ;
: early ( -- ) \ oof- oof
\G Create a method selector for early binding.
Create ['] crash , #early ,
DOES> @ execute ;
: var ( size -- ) \ oof- oof
\G Create an instance variable
vallot Create , #var ,
DOES> @ ^ + ;
: defer ( -- ) \ oof- oof
\G Create an instance defer
valign cell vallot Create , #defer ,
DOES> @ ^ + @ execute ;
\ dealing with threads 29oct94py
Objects definitions
: object-order ( wid0 .. widm m addr -- wid0 .. widn n )
dup IF 2@ >r recurse r> swap 1+ ELSE drop THEN ;
: interface-order ( wid0 .. widm m addr -- wid0 .. widn n )
dup IF 2@ >r recurse r> :ilist + @ swap 1+
ELSE drop THEN ;
: add-order ( addr -- n ) dup 0= ?EXIT >r
get-order r> swap >r 0 swap
dup >r object-order r> :iface + @ interface-order
r> over >r + set-order r> ;
: drop-order ( n -- ) 0 ?DO previous LOOP ;
\ object compiling/executing 20feb95py
: o, ( xt early? -- )
over exec? over and IF
drop >body @ o@ + @ compile, EXIT THEN
over static? over and IF
drop >body @ o@ + @ postpone Literal EXIT THEN
drop dup early? IF >body @ THEN compile, ;
: findo ( string -- cfa n )
o@ add-order >r
find
?dup 0= IF drop set-order true abort" method not found!" THEN
r> drop-order ;
false Value method?
: method, ( object early? -- ) true to method?
swap >o >r bl word findo 0< state @ and
IF r> o, ELSE r> drop execute THEN o> false to method? ;
: cmethod, ( object early? -- )
state @ dup >r
0= IF postpone ] THEN
method,
r> 0= IF postpone [ THEN ;
: early, ( object -- ) true to oset? true method,
state @ oset? and IF postpone o> THEN false to oset? ;
: late, ( object -- ) true to oset? false method,
state @ oset? and IF postpone o> THEN false to oset? ;
\ new, 29oct94py
previous Objects definitions
Variable alloc
0 Value ohere
: oallot ( n -- ) ohere + to ohere ;
: ((new, ( link -- )
dup @ ?dup IF recurse THEN cell+ 2@ swap ohere + >r
?dup IF ohere >r dup >r :newlink + @ recurse r> r> ! THEN
r> to ohere ;
: (new ( object -- )
ohere >r dup >r :newlink + @ ((new, r> r> ! ;
: init-instance ( pos link -- pos )
dup >r @ ?dup IF recurse THEN r> cell+ 2@
IF drop dup >r ^ +
>o o@ :init + @ execute 0 o@ :newlink + @ recurse o>
r> THEN + ;
: init-object ( object -- size )
>o o@ :init + @ execute 0 o@ :newlink + @ init-instance o> ;
: (new, ( object -- ) ohere dup >r over :var# + @ erase (new
r> init-object drop ;
: size@ ( objc -- size ) :var# + @ 8aligned ;
: (new[], ( n o -- addr ) ohere >r
dup size@ rot over * oallot r@ ohere dup >r 2 pick -
?DO I to ohere >r dup >r (new, r> r> dup negate +LOOP
2drop r> to ohere r> ;
\ new, 29oct94py
Create chunks here 16 cells dup allot erase
: DelFix ( addr root -- ) dup @ 2 pick ! ! ;
: NewFix ( root size # -- addr )
BEGIN 2 pick @ ?dup 0=
WHILE 2dup * allocate throw over 0
?DO dup 4 pick DelFix 2 pick +
LOOP
drop
REPEAT
>r drop r@ @ rot ! r@ swap erase r> ;
: >chunk ( n -- root n' )
1- -8 and dup 3 rshift cells chunks + swap 8 + ;
: Dalloc ( size -- addr )
dup 128 > IF allocate throw EXIT THEN
>chunk 2048 over / NewFix ;
: Salloc ( size -- addr ) align here swap allot ;
: dispose, ( addr size -- )
dup 128 > IF drop free throw EXIT THEN
>chunk drop DelFix ;
: new, ( o -- addr ) dup :var# + @
alloc @ execute dup >r to ohere (new, r> ;
: new[], ( n o -- addr ) dup :var# + @ 8aligned
2 pick * alloc @ execute to ohere (new[], ;
Forth definitions
: dynamic ['] Dalloc alloc ! ; dynamic
: static ['] Salloc alloc ! ;
Objects definitions
\ instance creation 29mar94py
: instance, ( o -- ) alloc @ >r static new, r> alloc ! drop
DOES> state @ IF dup postpone Literal oset? IF postpone op! ELSE postpone >o THEN THEN early,
;
: ptr, ( o -- ) 0 , ,
DOES> state @
IF dup postpone Literal postpone @ oset? IF postpone op! ELSE postpone >o THEN cell+
ELSE @ THEN late, ;
: array, ( n o -- ) alloc @ >r static new[], r> alloc ! drop
DOES> ( n -- ) dup dup @ size@
state @ IF o*, ELSE nip rot * + THEN early, ;
\ class creation 29mar94py
Variable voc#
Variable classlist
Variable old-current
Variable ob-interface
: voc! ( addr -- ) get-current old-current !
add-order 2 + voc# !
get-order wordlist tuck classlist ! 1+ set-order
also types classlist @ set-current ;
: (class-does> DOES> false method, ;
: (class ( parent -- ) (class-does>
here lastob ! true decl ! 0 ob-interface !
0 , dup voc! dup lastparent !
dup 0= IF 0 ELSE :method# + 2@ THEN methods ! vars ! ;
: (is ( addr -- ) bl word findo drop
dup defer? abort" not deferred!"
>body @ state @
IF postpone ^ postpone Literal postpone + postpone !
ELSE ^ + ! THEN ;
: inherit ( -- ) bl word findo drop
dup exec? IF >body @ dup o@ + @ swap lastob @ + ! EXIT THEN
abort" Not a polymorph method!" ;
\ instance variables inside objects 27dec93py
: instvar, ( addr -- ) dup , here 0 , 0 vallot swap !
'link @ 2 cells + @ IF 'link @ link, THEN
'link @ >r dup r@ cell+ ! :var# + @ dup vars +! r> 2 cells + !
DOES> dup 2@ swap state @ IF o+, ELSE ^ + nip nip THEN
early, ;
: instptr> ( -- ) DOES> dup 2@ swap
state @ IF o+@, ELSE ^ + @ nip nip THEN late, ;
: instptr, ( addr -- ) , here 0 , cell vallot swap !
instptr> ;
: (o* ( i addr -- addr' ) dup @ :var# + @ 8aligned rot * + ;
: instarray, ( addr -- ) , here 0 , cell vallot swap !
DOES> dup 2@ swap
state @ IF o+@*, ELSE ^ + @ nip nip (o* THEN
late, ;
\ bind instance pointers 27mar94py
: ((link ( addr -- o addr' ) 2@ swap ^ + ;
: (link ( -- o addr ) bl word findo drop >body state @
IF postpone Literal postpone ((link EXIT THEN ((link ;
: parent? ( class o -- class class' ) @
BEGIN 2dup = ?EXIT dup WHILE :parent + @ REPEAT ;
: (bound ( obj1 obj2 adr2 -- ) >r over parent?
nip 0= abort" not the same class !" r> ! ;
: (bind ( addr -- )
\ <name>
(link state @ IF postpone (bound EXIT THEN (bound ;
: (sbound ( o addr -- ) dup cell+ @ swap (bound ;
Forth definitions
: bind ( o -- ) ' state @
IF postpone Literal postpone >body postpone (sbound EXIT THEN
>body (sbound ; immediate
Objects definitions
\ method implementation 29oct94py
Variable m-name
Variable last-interface 0 last-interface !
: interface, ( -- ) last-interface @
BEGIN dup WHILE dup , @ REPEAT drop ;
: inter, ( iface -- )
align here over :inum + @ lastob @ + !
here over :ilen + @ dup allot move ;
: interfaces, ( -- ) ob-interface @ lastob @ :iface + !
ob-interface @
BEGIN dup WHILE 2@ inter, REPEAT drop ;
: lastob! ( -- ) lastob @ dup
BEGIN nip dup @ here cell+ 2 pick ! dup 0= UNTIL drop
dup , op! o@ lastob ! ;
: thread, ( -- ) classlist @ , ;
: var, ( -- ) methods @ , vars @ , ;
: parent, ( -- o parent )
o@ lastparent @ 2dup dup , 0 ,
dup IF :child + dup @ , ! ELSE , drop THEN ;
: 'link, ( -- )
'link @ ?dup 0=
IF lastparent @ dup IF :newlink + @ THEN THEN , ;
: cells, ( -- )
methods @ :init ?DO ['] crash , cell +LOOP ;
\ method implementation 20feb95py
types definitions
: how: ( -- ) \ oof- oof how-to
\G End declaration, start implementation
decl @ 0= abort" not twice!" 0 decl !
align interface,
lastob! thread, parent, var, 'link, 0 , cells, interfaces,
dup
IF dup :method# + @ >r :init + swap r> :init /string move
ELSE 2drop THEN ;
: class; ( -- ) \ oof- oof end-class
\G End class declaration or implementation
decl @ IF how: THEN 0 'link !
voc# @ drop-order old-current @ set-current ;
: ptr ( -- ) \ oof- oof
\G Create an instance pointer
Create immediate lastob @ here lastob ! instptr, ;
: asptr ( class -- ) \ oof- oof
\G Create an alias to an instance pointer, cast to another class.
cell+ @ Create immediate
lastob @ here lastob ! , , instptr> ;
: Fpostpone postpone postpone ; immediate
: : ( <methodname> -- ) \ oof- oof colon
decl @ abort" HOW: missing! "
bl word findo drop
dup exec? over early? or over >body cell+ @ 0< or
0= abort" not a method"
m-name ! :noname ;
Forth
: ; ( xt colon-sys -- ) \ oof- oof
postpone ;
m-name @ dup >body swap exec?
IF @ o@ +
ELSE dup cell+ @ 0< IF 2@ swap o@ + @ + THEN
THEN ! ; immediate
Forth definitions
\ object 23mar95py
Create object immediate 0 (class \ do not create as subclass
cell var oblink \ create offset for backlink
static thread \ method/variable wordlist
static parento \ pointer to parent
static childo \ ptr to first child
static nexto \ ptr to next child of parent
static method# \ number of methods (bytes)
static size \ number of variables (bytes)
static newlink \ ptr to allocated space
static ilist \ interface list
method init ( ... -- ) \ oof-object- oof
method dispose ( -- ) \ oof-object- oof
early class ( "name" -- ) \ oof-object- oof
early new ( -- o ) \ oof-object- oof
immediate
early new[] ( n -- o ) \ oof-object- oof new-array
immediate
early : ( "name" -- ) \ oof-object- oof define
early ptr ( "name" -- ) \ oof-object- oof
early asptr ( o "name" -- ) \ oof-object- oof
early [] ( n "name" -- ) \ oof-object- oof array
early :: ( "name" -- ) \ oof-object- oof scope
immediate
early class? ( o -- flag ) \ oof-object- oof class-query
early super ( "name" -- ) \ oof-object- oof
immediate
early self ( -- o ) \ oof-object- oof
early bind ( o "name" -- ) \ oof-object- oof
immediate
early bound ( class addr "name" -- ) \ oof-object- oof
early link ( "name" -- class addr ) \ oof-object- oof
immediate
early is ( xt "name" -- ) \ oof-object- oof
immediate
early send ( xt -- ) \ oof-object- oof
immediate
early with ( o -- ) \ oof-object- oof
immediate
early endwith ( -- ) \ oof-object- oof
immediate
early ' ( "name" -- xt ) \ oof-object- oof tick
immediate
early postpone ( "name" -- ) \ oof-object- oof
immediate
early definitions ( -- ) \ oof-object- oof
\ base object class implementation part 23mar95py
how:
0 parento !
0 childo !
0 nexto !
: class ( -- ) Create immediate o@ (class ;
: : ( -- ) Create immediate o@
decl @ IF instvar, ELSE instance, THEN ;
: ptr ( -- ) Create immediate o@
decl @ IF instptr, ELSE ptr, THEN ;
: asptr ( addr -- )
decl @ 0= abort" only in declaration!"
Create immediate o@ , cell+ @ , instptr> ;
: [] ( n -- ) Create immediate o@
decl @ IF instarray, ELSE array, THEN ;
: new ( -- o ) o@ state @
IF Fpostpone Literal Fpostpone new, ELSE new, THEN ;
: new[] ( n -- o ) o@ state @
IF Fpostpone Literal Fpostpone new[], ELSE new[], THEN ;
: dispose ( -- ) ^ size @ dispose, ;
: bind ( addr -- ) (bind ;
: bound ( o1 o2 addr2 -- ) (bound ;
: link ( -- o addr ) (link ;
: class? ( class -- flag ) ^ parent? nip 0<> ;
: :: ( -- )
state @ IF ^ true method, ELSE inherit THEN ;
: super ( -- ) parento true method, ;
: is ( cfa -- ) (is ;
: self ( -- obj ) ^ ;
: init ( -- ) ;
: ' ( -- xt ) bl word findo drop
state @ IF Fpostpone Literal THEN ;
: send ( xt -- ) execute ;
: postpone ( -- ) o@ add-order Fpostpone Fpostpone drop-order ;
: with ( -- )
state @ oset? 0= and IF Fpostpone >o THEN
o@ add-order voc# ! false to oset? ;
: endwith Fpostpone o> voc# @ drop-order ;
: definitions
o@ add-order 1+ voc# ! also types o@ lastob !
false to oset? get-current old-current !
thread @ set-current ;
class; \ object
\ interface 01sep96py
Objects definitions
: implement ( interface -- ) \ oof-interface- oof
align here over , ob-interface @ , ob-interface !
:ilist + @ >r get-order r> swap 1+ set-order 1 voc# +! ;
: inter-method, ( interface -- ) \ oof-interface- oof
:ilist + @ bl word count 2dup s" '" str=
dup >r IF 2drop bl word count THEN
rot search-wordlist
dup 0= abort" Not an interface method!"
r> IF drop state @ IF postpone Literal THEN EXIT THEN
0< state @ and IF compile, ELSE execute THEN ;
Variable inter-list
Variable lastif
Variable inter#
Vocabulary interfaces interfaces definitions
: method ( -- ) \ oof-interface- oof
mallot Create , inter# @ ,
DOES> 2@ swap o@ + @ + @ execute ;
: how: ( -- ) \ oof-interface- oof
align
here lastif @ ! 0 decl !
here last-interface @ , last-interface !
inter-list @ , methods @ , inter# @ ,
methods @ :inum cell+ ?DO ['] crash , LOOP ;
: interface; ( -- ) \ oof-interface- oof
old-current @ set-current
previous previous ;
: : ( <methodname> -- ) \ oof-interface- oof colon
decl @ abort" HOW: missing! "
bl word count lastif @ @ :ilist + @
search-wordlist 0= abort" not found"
dup >body cell+ @ 0< 0= abort" not a method"
m-name ! :noname ;
Forth
: ; ( xt colon-sys -- ) \ oof-interface- oof
postpone ;
m-name @ >body @ lastif @ @ + ! ; immediate
Forth definitions
: interface-does>
DOES> @ decl @ IF implement ELSE inter-method, THEN ;
: interface ( -- ) \ oof-interface- oof
Create interface-does>
here lastif ! 0 , get-current old-current !
last-interface @ dup IF :inum + @ THEN cell- inter# !
get-order wordlist
dup inter-list ! dup set-current swap 1+ set-order
true decl !
0 vars ! :inum cell+ methods ! also interfaces ;
previous previous