--- gforth/oof.fs 1996/10/13 19:56:22 1.3 +++ gforth/oof.fs 1997/02/16 20:51:10 1.7 @@ -15,7 +15,9 @@ decimal : define? ( -- flag ) bl word find nip 0= ; -define? cell [IF] 1 cells Constant cell [THEN] +define? cell [IF] +1 cells Constant cell +[THEN] define? ?EXIT [IF] : ?EXIT postpone IF postpone EXIT postpone THEN ; immediate @@ -26,6 +28,13 @@ define? Vocabulary [IF] DOES> @ >r get-order nip r> swap set-order ; [THEN] +define? faligned [IF] false [ELSE] 1 faligned 8 = [THEN] +[IF] +: 8aligned ( n1 -- n2 ) faligned ; +[ELSE] +: 8aligned ( n1 -- n2 ) 7 + -8 and ; +[THEN] + Vocabulary Objects also Objects also definitions Vocabulary types types also @@ -85,11 +94,6 @@ Objects definitions : defer? ( addr -- flag ) >body cell+ @ #defer = ; -define? faligned [IF] false [ELSE] 1 faligned 8 = [THEN] -[IF] : 8aligned ( n1 -- n2 ) faligned ; -[ELSE] : 8aligned ( n1 -- n2 ) 7 + -8 and ; -[THEN] - : o+, ( addr offset -- ) postpone Literal postpone ^ postpone + postpone >o drop ; @@ -157,8 +161,9 @@ Objects definitions dup IF 2@ >r recurse r> :ilist + @ swap 1+ ELSE drop THEN ; -: add-order ( addr -- n ) >r - get-order r> swap >r 0 swap object-order +: add-order ( addr -- n ) dup 0= ?EXIT >r + get-order r> swap >r 0 swap + dup >r object-order r> :iface + @ interface-order r> over >r + set-order r> ; : drop-order ( n -- ) 0 ?DO previous LOOP ; @@ -173,22 +178,22 @@ Objects definitions drop dup early? IF >body @ THEN compile, ; : findo ( string -- cfa n ) - >r get-order 0 - o@ object-order - o@ :iface + @ interface-order set-order - r> find + o@ add-order >r + find ?dup 0= IF drop set-order true abort" method not found!" THEN - >r >r set-order r> r> ; + r> drop-order ; false Value method? +false Value oset? + : method, ( object early? -- ) true to method? swap >o >r bl word findo 0< state @ and IF r> o, ELSE r> drop execute THEN o> false to method? ; -: early, ( object -- ) true method, - state @ IF postpone o> THEN ; -: late, ( object -- ) false method, - state @ IF postpone o> THEN ; +: early, ( object -- ) true to oset? true method, + state @ IF postpone o> THEN false to oset? ; +: late, ( object -- ) true to oset? false method, + state @ IF postpone o> THEN false to oset? ; \ new, 29oct94py @@ -241,7 +246,7 @@ Create chunks here 16 cells dup allot er >r drop r@ @ rot ! r@ swap erase r> ; : >chunk ( n -- root n' ) - 8aligned dup 3 rshift cells chunks + swap ; + 1- -8 and dup 3 rshift cells chunks + swap 8 + ; : Dalloc ( size -- addr ) dup 128 > IF allocate throw EXIT THEN @@ -272,7 +277,7 @@ Objects definitions DOES> state @ IF dup postpone Literal postpone >o THEN early, ; : ptr, ( o -- ) 0 , , DOES> state @ - IF postpone Literal postpone @ postpone >o cell+ + IF dup postpone Literal postpone @ postpone >o cell+ ELSE @ THEN late, ; : array, ( n o -- ) alloc @ >r static new[], r> alloc ! drop @@ -372,7 +377,7 @@ Variable last-interface 0 last-interfac : lastob! ( -- ) lastob @ dup BEGIN nip dup @ here cell+ 2 pick ! dup 0= UNTIL drop - dup , [ order ] op! o@ lastob ! ; + dup , op! o@ lastob ! ; : thread, ( -- ) classlist @ , ; : var, ( -- ) methods @ , vars @ , ; @@ -451,41 +456,54 @@ Create object immediate 0 (class \ do early link immediate early ' immediate early send immediate + early with immediate + early endwith immediate \ base object class implementation part 23mar95py -how: 0 parento ! - 0 childo ! - 0 nexto ! - : class ( -- ) Create immediate o@ (class ; - : : ( -- ) Create immediate o@ - decl @ IF instvar, ELSE instance, THEN ; - : ptr ( -- ) Create immediate o@ - decl @ IF instptr, ELSE ptr, THEN ; - : asptr ( addr -- ) - decl @ 0= abort" only in declaration!" - Create immediate o@ , cell+ @ , instptr> ; - : [] ( n -- ) Create immediate o@ - decl @ IF instarray, ELSE array, THEN ; - : new ( -- o ) o@ state @ - IF postpone Literal postpone new, ELSE new, THEN ; - : new[] ( n -- o ) o@ state @ - IF postpone Literal postpone new[], ELSE new[], THEN ; - : dispose ( -- ) ^ size @ dispose, ; - : bind ( addr -- ) (bind ; - : bound ( o1 o2 addr2 -- ) (bound ; - : link ( -- o addr ) (link ; - : class? ( class -- flag ) ^ parent? nip 0<> ; - : :: ( -- ) - state @ IF ^ true method, ELSE inherit THEN ; - : super ( -- ) parento true method, ; - : is ( cfa -- ) (is ; - : self ( -- obj ) ^ ; - : init ( -- ) ; - - : ' ( -- xt ) bl word findo 0= abort" not found!" - state @ IF postpone Literal THEN ; - : send ( xt -- ) execute ; +how: 0 parento ! + 0 childo ! + 0 nexto ! + : class ( -- ) Create immediate o@ (class ; + : : ( -- ) Create immediate o@ + decl @ IF instvar, ELSE instance, THEN ; + : ptr ( -- ) Create immediate o@ + decl @ IF instptr, ELSE ptr, THEN ; + : asptr ( addr -- ) + decl @ 0= abort" only in declaration!" + Create immediate o@ , cell+ @ , instptr> ; + : [] ( n -- ) Create immediate o@ + decl @ IF instarray, ELSE array, THEN ; + : new ( -- o ) o@ state @ + IF postpone Literal postpone new, ELSE new, THEN ; + : new[] ( n -- o ) o@ state @ + IF postpone Literal postpone new[], ELSE new[], THEN ; + : dispose ( -- ) ^ size @ dispose, ; + : bind ( addr -- ) (bind ; + : bound ( o1 o2 addr2 -- ) (bound ; + : link ( -- o addr ) (link ; + : class? ( class -- flag ) ^ parent? nip 0<> ; + : :: ( -- ) + state @ IF ^ true method, ELSE inherit THEN ; + : super ( -- ) parento true method, ; + : is ( cfa -- ) (is ; + : self ( -- obj ) ^ ; + : init ( -- ) ; + + : ' ( -- xt ) bl word findo 0= abort" not found!" + state @ IF postpone Literal THEN ; + : send ( xt -- ) execute ; + + : with ( -- ) + state @ oset? 0= and IF postpone >o THEN + o@ add-order voc# ! false to oset? + r> drop state @ + IF o> + ELSE oset? IF ^ THEN o> postpone >o + THEN + r> drop r> drop ; + : endwith postpone o> + voc# @ drop-order ; class; \ object \ interface 01sep96py @@ -515,7 +533,8 @@ Vocabulary interfaces interfaces defini : how: ( -- ) align here lastif @ ! 0 decl ! - last-interface @ , inter-list @ , methods @ , inter# @ , + here last-interface @ , last-interface ! + inter-list @ , methods @ , inter# @ , methods @ :inum cell+ ?DO ['] crash , LOOP ; : interface; ( -- ) old-current @ set-current @@ -544,3 +563,35 @@ Forth definitions DOES> @ decl @ IF implement ELSE inter-method, THEN ; previous previous + +\ The program uses the following words +\ from CORE : +\ decimal : bl word 0= ; cells Constant POSTPONE IF EXIT THEN immediate +\ Create , DOES> @ >r r> swap + and Variable ! allot ELSE +! dup * >body +\ cell+ = Literal drop align here aligned execute ['] 2@ recurse 1+ over +\ LOOP ?dup 0< rot r@ - i negate +LOOP 2drop BEGIN WHILE 2dup REPEAT 1- +\ rshift > / ' move UNTIL or count +\ from CORE-EXT : +\ nip tuck true ?DO compile, false Value erase pick :noname 0<> +\ from BLOCK-EXT : +\ \ +\ from EXCEPTION : +\ throw +\ from EXCEPTION-EXT : +\ abort" +\ from FILE : +\ ( S" +\ from FLOAT : +\ faligned +\ from LOCAL : +\ TO +\ from MEMORY : +\ allocate free +\ from SEARCH : +\ find wordlist get-order set-order definitions get-current set-current search-wordlist +\ from SEARCH-EXT : +\ also Forth previous +\ from STRING : +\ /string compare +\ from TOOLS-EXT : +\ state [IF] [THEN]