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