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