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