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