Thread: [Win32forth-cvs] win32forth/src Class.f,1.22,1.23

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/win32forth/win32forth/src
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv18829/win32forth/src

Modified Files:
	Class.f 
Log Message:
gah:Added **and [self]  for late-binding (for MOPS compatatibility) plus tidied up vocabulary switching somewhat. 

Index: Class.f
===================================================================
RCS file: /cvsroot/win32forth/win32forth/src/Class.f,v
retrieving revision 1.22
retrieving revision 1.23
diff -C2 -d -r1.22 -r1.23
*** Class.f	16 Sep 2006 10:44:46 -0000	1.22
--- Class.f	18 Sep 2006 10:14:19 -0000	1.23
***************
*** 11,16 ****
  cr .( Loading Primitive Object Class...)

- only forth also definitions
- 
  -4105 constant warn_clash

--- 11,14 ----
***************
*** 30,34 ****
                  @word count method-hash ;

! classes also definitions

  \ -------------------- Selectors --------------------
--- 28,48 ----
                  @word count method-hash ;

! : [[            ( "code to evaluate< ]]>" -- ) \ W32F          Class   In-System Forth
! \ *G \b Interpretation: \d When preceeded by a selector, parses the input stream up to a
! \ ** terminating ]] evaluates the code and then executes the method for the object
! \ ** address on the stack. An error will occur if "code to evaluate" does not produce
! \ ** a valid object address. \n
! \ ** An error also occurs if [[ isn't preceeded by a selector.
! \ *P \b Compilation: \d When preceeded by a selector, compiles the input stream up to a
! \ ** terminating ]] and then compiles a late-bound call to the method selector
! \ ** address on the stack. A run-time error will occur if "code to evaluate" does not
! \ ** a valid object address. \n
! \ ** An compile-time error also occurs if [[ isn't preceeded by a selector.
!                 true abort"  [[ must be preceeded by a selector "   ; IMMEDIATE
! 
! : **            ( -- )
!                 true abort"  ** must be preceeded by a selector "   ; immediate
! 
! private classes internal

  \ -------------------- Selectors --------------------
***************
*** 49,53 ****
  \ references are from class pfa

! IN-APPLICATION

  voc-pfa-size nostack1
--- 63,67 ----
  \ references are from class pfa

! in-previous

  voc-pfa-size nostack1
***************
*** 104,108 ****
  \ code ((findm))  ( SelID addr -- 0cfa t OR f )

! in-application

  named-new$ tempmsg$
--- 118,122 ----
  \ code ((findm))  ( SelID addr -- 0cfa t OR f )

! in-previous

  named-new$ tempmsg$
***************
*** 143,146 ****
--- 157,163 ----

  LOADED? debug.f [if] \ debug support
+ 
+ also bug
+ 
  : dbg-next-cell-class ( ip cfa -- ip' cfa )
                  dup ['] (Defer) =
***************
*** 155,159 ****
                  if      2drop cr .s
  \ !!! USES A COPY OF THE ADDRESS ON TOP OF THE STACK TO LOCATE THE METHOD !!!
!                 [ bug ] ip @ cell+ @ over Find-Method nip 3 cells+ ip !
                          2 nesting +!
                          true
--- 172,176 ----
                  if      2drop cr .s
  \ !!! USES A COPY OF THE ADDRESS ON TOP OF THE STACK TO LOCATE THE METHOD !!!
!                         ip @ cell+ @ over Find-Method nip 3 cells+ ip !
                          2 nesting +!
                          true
***************
*** 161,167 ****

  dbg-nest-chain chain-add dbg-nest-class
- [then]

! classes

  LOADED? see.f [if] \ decompiler support
--- 178,185 ----

  dbg-nest-chain chain-add dbg-nest-class

! previous
! 
! [then]

  LOADED? see.f [if] \ decompiler support
***************
*** 189,193 ****
  [then]

! in-application

     0 Value  ^Self
--- 207,211 ----
  [then]

! in-previous

     0 Value  ^Self
***************
*** 196,208 ****
  in-system

! : ?isObj    ( cfa -- f )  @ doObj = ;
! : ?isValue  ( cfa -- f )  @ doValue = ;
! : ?isLocal  ( cfa -- f )  @ doLocal = ;
! : ?isVect   ( cfa -- f )  @ dup doValue =
!                            over doDefer = or
!                            swap (iv@)   = or ;

  : ?isParen      ( cfa -- f )
!                 >name nfa-count drop c@ [char] [ = ;

  \ ERROR if not compiling a new class definition
--- 214,241 ----
  in-system

! 
! : [self]        ( -- )
!                 true abort" Use only for self-reference to object" ; immediate
! 
! : ?isObj        ( cfa -- f )
!                 @ doObj = ;
! : ?isValue      ( cfa -- f )
!                 @ doValue = ;
! : ?isLocal      ( cfa -- f )
!                 @ doLocal = ;
! : ?isVect       ( cfa -- f )
!                 @ dup doValue =
!                 over doDefer = or
!                 swap (iv@)   = or ;

  : ?isParen      ( cfa -- f )
! \                >name nfa-count drop c@ [char] [ = ;
!                 dup ['] [ = swap ['] [[ = or ;
! 
! : ?is**         ( cfa -- f )
!                 ['] ** = ;
! 
! : ?is[self]     ( cfa -- f )
!                 ['] [self] = ;

  \ ERROR if not compiling a new class definition
***************
*** 249,253 ****
  ))

! in-application

  2 cells offset iclass     ( ivar -- 'class )
--- 282,286 ----
  ))

! in-previous

  2 cells offset iclass     ( ivar -- 'class )
***************
*** 302,305 ****
--- 335,339 ----

  defer ivar-name
+ ' noop is ivar-name

  \ Compile an instance variable dictionary entry
***************
*** 364,370 ****
  \ gets heap, and returns ptr.

! in-application

! forth definitions

  \           ( <number_of_elements> theClass -- )
--- 398,404 ----
  \ gets heap, and returns ptr.

! in-previous

! external

  \           ( <number_of_elements> theClass -- )
***************
*** 412,416 ****
  \ See " Dispose " later for releasing dynamic objects

! classes definitions

  \ --------------- Build SUPER and SELF pseudo ivars ---------------
--- 446,450 ----
  \ See " Dispose " later for releasing dynamic objects

! internal

  \ --------------- Build SUPER and SELF pseudo ivars ---------------
***************
*** 441,449 ****
  0 value oldcurrent

! also forth definitions

  0 value Obj-CLASS

! previous definitions

  \ Build a class header with its superclass pointer
--- 475,483 ----
  0 value oldcurrent

! external

  0 value Obj-CLASS

! internal

  \ Build a class header with its superclass pointer
***************
*** 462,466 ****
                  obj-class 0= if reveal then ;

! forth definitions

         0 value Obj-LOADLINE
--- 496,500 ----
                  obj-class 0= if reveal then ;

! external

         0 value Obj-LOADLINE
***************
*** 562,570 ****
                  sys-warning? sys-warning-off Build|Class to sys-warning? ;

! 
! classes definitions

  variable new-method

  internal

--- 596,607 ----
                  sys-warning? sys-warning-off Build|Class to sys-warning? ;

! internal

  variable new-method

+ module
+ 
+ classes also definitions
+ 
  internal

***************
*** 673,681 ****
                                          \ by str.
                  parmfind ?missing
!                 dup ?IsObj   if  1 exit  then
!                 dup ?IsClass if  2 exit  then
!                 dup ?IsLocal if  4 exit  then
!                 dup ?IsParen if  5 exit  then   \ needs to preceed next line,
!                 dup ?IsVect  if  3 exit  then   \ because [ is a deferred word
                  1 abort" Invalid object type" ;

--- 710,720 ----
                                          \ by str.
                  parmfind ?missing
!                 dup ?IsObj    if  1 exit  then
!                 dup ?IsClass  if  2 exit  then
!                 dup ?IsLocal  if  4 exit  then
!                 dup ?IsParen  if  5 exit  then   \ needs to preceed next line,
!                 dup ?IsVect   if  3 exit  then   \ because [ is a deferred word
!                 dup ?Is**     if  6 exit  then
!                 dup ?Is[self] if  7 exit  then
                  1 abort" Invalid object type" ;

***************
*** 793,802 ****
  : objRef        ( selID $str -- )  \ Build a reference to an object or vector
                  Case refToken
!                   0 ( ?      ) of  abort                        endof
!                   1 ( object ) of  Obj.Var,                     endof
!                   2 ( class  ) of  >Class (findm) ,             endof
!                   3 ( vector ) of  compile,  POSTPONE (defer) ,        endof
!                   4 ( parm   ) of  compile,  POSTPONE (defer) ,        endof
!                   5 ( paren  ) of  drop LateBound               endof
                  Endcase ;

--- 832,843 ----
  : objRef        ( selID $str -- )  \ Build a reference to an object or vector
                  Case refToken
!                   0 ( ?      ) of  abort                                  endof
!                   1 ( object ) of  Obj.Var,                               endof
!                   2 ( class  ) of  >Class (findm) ,                       endof
!                   3 ( vector ) of  compile,  POSTPONE (defer) ,           endof
!                   4 ( parm   ) of  compile,  POSTPONE (defer) ,           endof
!                   5 ( paren  ) of  drop LateBound                         endof
!                   6 ( **     ) of  drop postpone (defer) ,                endof
!                   7 ( [self] ) of  drop postpone ^base postpone (defer) , endof
                  Endcase ;

***************
*** 804,813 ****
                  0 to varCfa
                  Case refToken
!                   0 ( ?      ) of  abort                        endof
!                   1 ( object ) of  RunObj.Var                   endof
!                   2 ( class  ) of  >Class (findm)               endof
!                   3 ( vector ) of  execute Find-Method          endof
!                   4 ( parm   ) of  abort                        endof
!                   5 ( paren  ) of  2drop ['] noop               endof
                  Endcase ;

--- 845,856 ----
                  0 to varCfa
                  Case refToken
!                   0 ( ?      ) of  abort                                  endof
!                   1 ( object ) of  RunObj.Var                             endof
!                   2 ( class  ) of  >Class (findm)                         endof
!                   3 ( vector ) of  execute Find-Method                    endof
!                   4 ( parm   ) of  abort                                  endof
!                   5 ( paren  ) of  drop LateBound ['] noop                endof
!                   6 ( **     ) of  drop swap Find-Method                  endof
!                   7 ( [self] ) of  abort                                  endof
                  Endcase ;

***************
*** 943,947 ****
  \in-system-ok ' msgfind is find

! in-application

  \ The following definition is used to initialize dynamic classes ( those created with NEW> or
--- 986,990 ----
  \in-system-ok ' msgfind is find

! in-previous

  \ The following definition is used to initialize dynamic classes ( those created with NEW> or
***************
*** 955,960 ****
  in-system

- : [[  true abort"  [[ must be preceeded by a selector "   ; IMMEDIATE
- 
  : <noClassPointer ( -- )
  \ *G Set a class to suppress the class pointer when used for IVARs.
--- 998,1001 ----
***************
*** 995,1000 ****
  \ *G End a group of data fields that need to be contiguous and create a name with the
  \ ** size of the record.
!                 0 to contiguous-data?
!                 ^Class DFA @ BeginningOfRecordAddress - CONSTANT ;

  \ -------------------- Instance Variables --------------------
--- 1036,1040 ----
  \ *G End a group of data fields that need to be contiguous and create a name with the
  \ ** size of the record.
!                 ;Record ^Class DFA @ BeginningOfRecordAddress - CONSTANT ;

  \ -------------------- Instance Variables --------------------
***************
*** 1022,1026 ****
                  1 class-allot ;

! in-application

  cfa-func (ivb@) ( pfa -- bitfield_contents )
--- 1062,1066 ----
                  1 class-allot ;

! in-previous

  cfa-func (ivb@) ( pfa -- bitfield_contents )

Thread: [Win32forth-cvs] win32forth/src Class.f,1.22,1.23

win32forth-cvs