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
49decimal
50
51: define?  ( -- flag )
52  bl word find  nip 0= ;
53
54define? cell  [IF]
551 cells Constant cell
56[THEN]
57
58define? \G [IF]
59: \G postpone \ ; immediate
60[THEN]
61
62define? ?EXIT [IF]
63: ?EXIT  postpone IF  postpone EXIT postpone THEN ; immediate
64[THEN]
65
66define? Vocabulary [IF]
67: Vocabulary wordlist create ,
68DOES> @ >r get-order nip r> swap set-order ;
69[THEN]
70
71define? 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
78Vocabulary Objects  also Objects also definitions
79
80Vocabulary types  types also
81
820 cells Constant :wordlist
831 cells Constant :parent
842 cells Constant :child
853 cells Constant :next
864 cells Constant :method#
875 cells Constant :var#
886 cells Constant :newlink
897 cells Constant :iface
908 cells Constant :init
91
920 cells Constant :inext
931 cells Constant :ilist
942 cells Constant :ilen
953 cells Constant :inum
96
97Variable op
98: op! ( o -- )  op ! ;
99
100Forth definitions
101
102Create 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
118Objects definitions
119
120\ Coding                                               27dec95py
121
1220 Constant #static
1231 Constant #method
1242 Constant #early
1253 Constant #var
1264 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
137false 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
154Variable lastob
155Variable lastparent   0 lastparent !
156Variable vars
157Variable methods
158Variable decl  0 decl !
159Variable 'link
160
161: crash  true abort" unbound method" ;
162
163: link, ( addr -- ) align here 'link !  , 0 , 0 , ;
164
1650 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 ! ;
176define? faligned 0= [IF]
177: vfalign ( -- )  vars @ faligned vars ! ;
178[THEN]
179
180: mallot ( -- offset )    methods @ cell methods +! ;
181
182types definitions
183
184: static   ( -- ) \ oof- oof
185    \G Create a class-wide cell-sized variable.
186    mallot Create , #static ,
187DOES> @ o@ + ;
188: method   ( -- ) \ oof- oof
189    \G Create a method selector.
190    mallot Create , #method ,
191DOES> @ o@ + @ execute ;
192: early    ( -- ) \ oof- oof
193    \G Create a method selector for early binding.
194    Create ['] crash , #early ,
195DOES> @ execute ;
196: var ( size -- ) \ oof- oof
197    \G Create an instance variable
198    vallot Create , #var ,
199DOES> @ ^ + ;
200: defer    ( -- ) \ oof- oof
201    \G Create an instance defer
202    valign cell vallot Create , #defer ,
203DOES> @ ^ + @ execute ;
204
205\ dealing with threads                                 29oct94py
206
207Objects 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
238false 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
257previous Objects definitions
258
259Variable alloc
2600 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
292Create 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
324Forth definitions
325
326: dynamic ['] Dalloc alloc ! ;  dynamic
327: static  ['] Salloc alloc ! ;
328
329Objects 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
347Variable voc#
348Variable classlist
349Variable old-current
350Variable 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
413Forth definitions
414
415: bind ( o -- )  '  state @
416  IF   postpone Literal postpone >body postpone (sbound EXIT  THEN
417  >body (sbound ;  immediate
418
419Objects definitions
420
421\ method implementation                                29oct94py
422
423Variable m-name
424Variable 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
454types 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
487Forth
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
496Forth definitions
497
498\ object                                               23mar95py
499
500Create 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
549how:
5500 parento !
5510 childo !
5520 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 ;
593class; \ object
594
595\ interface                                            01sep96py
596
597Objects 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
611Variable inter-list
612Variable lastif
613Variable inter#
614
615Vocabulary interfaces  interfaces definitions
616
617: method  ( -- ) \ oof-interface- oof
618    mallot Create , inter# @ ,
619DOES> 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
639Forth
640
641: ; ( xt colon-sys -- ) \ oof-interface- oof
642  postpone ;
643  m-name @ >body @ lastif @ @ + ! ; immediate
644
645Forth 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
658previous previous
659
660
661