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