Defining words to create the getter and setter for a slot at once

compat.fth

\ 2023-02-03 ruv

[undefined] execute-parsing [if] [defined] evaluate-with [if]
  : execute-parsing evaluate-with ;
[else]
  cr
  cr .( \ ERROR: The required word 'execute-parsing' is missed.)
  cr .( \ A portable implementation is available at: )
  cr .( \   web-view: https://theforth.net/package/compat/current-view/execute-parsing.fs )
  cr .( \   raw-file: https://theforth.net/package/compat/current/execute-parsing.fs )
  cr abort
[then] [then]


[undefined] 1+ [if] : 1+ 1 + ; [then]
[undefined] 1- [if] : 1- 1 - ; [then]

[undefined] -rot [if]
  : -rot  ( 3*x -- 3*x ) rot rot ;
[then]

[undefined] rdrop [if]
  : rdrop ( R.runtime: x -- ) postpone r> postpone drop ; immediate
[then]
[undefined] 2rdrop [if]
  : 2rdrop ( R.runtime: x x -- ) postpone rdrop postpone rdrop ; immediate
[then]

[undefined] lit,    [if]
  : lit,  ( x -- ) postpone literal ;
[then]
[undefined] 2lit,   [if] [defined] 2literal [if]
  : 2lit, ( d -- ) postpone 2literal ;
[else]
  : 2lit, ( d -- ) swap lit, lit, ;
[then] [then]
[undefined] slit,   [if]
  : slit,  ( sd -- ) postpone sliteral ;
[then]

[undefined] ndrop [if]
  : ndrop ( i*x u.i -- ) 0 ?do drop loop ;
[then]

[undefined] equals [if]
  : equals ( sd1 sd2 -- flag ) dup 3 pick <> if 2drop 2drop false exit then compare 0= ;
[then]

[undefined] execute-balance [if]
  : execute-balance ( i*x xt -- j*x n ) \ n = j - i
    depth 1- >r execute depth r> -
  ;
[then]


[undefined] parse-lexeme [if]
  : parse-lexeme parse-name ;
[then]
[undefined] parse-lexeme-further [if]
  : parse-lexeme-further ( -- c-addr u|0 )
    begin parse-lexeme dup 0= while refill 0= if exit then 2drop repeat
  ;
[then]



[undefined] find-xt [if]
  [defined] find-name [if]
    [undefined] name> [if]
      : name> ( nt -- xt|0 ) name>interpret ;
    [then]
    : find-xt ( sd.name -- xt|0 ) find-name dup if name> then ;
  [else]
    : find-xt ( sd.name -- xt|0 ) ['] ' ['] execute-parsing catch if drop 2drop 0 then ;
  [then]
[then]
[undefined] ?found [if]
  : ?found ( x|0 -- x ) dup if exit then -13 throw ;
[then]
[undefined] ?find-xt [if]
  : ?find-xt ( sd.name -- xt ) find-xt ?found ;
[then]

[undefined] tt-slit [if]

  : compilation ( -- flag ) state @ 0<> ;

  \ translators for execution tokens and literals
  : tt-xt     ( any xt -- any )   compilation if compile, else execute then ;
  : tt-lit    ( x -- x |      )   compilation if lit,     then ;
  : tt-2lit   ( 2*x -- 2*x |  )   compilation if 2lit,    then ;
  : tt-slit   ( sd -- sd   |  )   compilation if slit,    then ;
[then]

slot.example.fth

\ 2023-10-25

[undefined] find-xt-slot-setter [if]
  include ./slot.fth
[then]

: v: ( "name" -- )
  \ "set-{name}" must be recognizable as a word that is a vector slot setter
  ['] :noname execute-balance 1- roll             ( colong-sys xt )
  parse-name find-xt-slot-setter ?found execute   ( colon-sys )
;


vect( foo bar baz )

v: foo ( -- ) ." (foo)" bar ;
v: bar ( -- ) ." (bar)" baz ;
v: baz ( -- ) ." (baz)" cr ;

foo \ "(foo)(bar)(baz)"

slot.fth

\ 2023-02-03 ruv
\ https://gist.github.com/ruv/438d57d0af6a38e616efb59b43795e1b
\ License: Apache License 2.0. https://www.apache.org/licenses/LICENSE-2.0

\ Definitions for the defining words to create a getter and setter for a slot at once.
\ Usage:
\   slot( name1 name2 ... nameN )    \ create slots for single-cell integers
\   slot2( name1 name2 ... nameN )   \ create slots for double-cell integers or two-cells pairs
\   vect( name1 name2 ... nameN )    \ create slots for vectors
\ A list of names can be spreaded within several lines.
\ A name cannot be equal to ")". A space is obligated before the closing paren of the list.
\ Comments in the list of names are not supported in this version.
\
\ About getters and setters:
\  "slot( foo )" creates the words "foo ( -- x )" and "set-foo ( x -- )"
\  "slot2( foo )" creates the words "foo ( -- xd )" and "set-foo ( xd -- )"
\  "vect( foo )" creates the words "set-foo ( xt -- )", "of-foo ( -- xt )", and "foo ( any -- any )"
\
\ When these defining words are used inside a definition, they action of building a slot
\ is appended into this definition. For example:
\   : bar slot( foo ) ; \ nothing is created, but the "bar" colon definition
\   bar \ the slot "foo" (the getter and setter) is created in the current word list
\
\ Several slots can be set at once via "set( ... )"
\ Thus, the phrase:
\   ( any1 any2 ... anyN ) set( name1 name2 ... nameN )
\ is equivalent to the phrase:
\   ( any1 any2 ... anyN ) set-nameN ... set-name2 set-name1
\
\ DataType: any ⇒ ( F: i*r ;  S: j*x ;  C: k*x ; )
\



[undefined] find-xt [if]
  include ./compat.fth
[then]


: parse-lexeme-till-rparen ( -- c-addr u|0 )
  parse-lexeme-further 2dup s" )" equals 0= and
;
: for-input-lexeme-till-rparen ( any xt -- any )
  >r begin parse-lexeme-till-rparen dup while r@ execute repeat 2drop rdrop
;


: execute-under-auto ( any xt2  k*x xt1 +n.k  -- any )
  >r execute-balance  r> + n>r  execute  nr> drop
;
: :name ( sd.name -- colon-sys )
  ['] :  execute-parsing
;
: build-noname-with ( any xt.builder -- any xt.new  ) \ xt.builder ( any -- any )
  \ xt.builder should compile the new anonymous definition body
  ['] :noname 0 execute-under-auto  postpone ;
;
: build-colon-with  ( any xt.builder sd.name -- any ) \ xt.builder ( any -- any )
  \ xt.builder should compile the new named definition body
  ['] :name   2 execute-under-auto  postpone ;
;

\ Partially apply xt1 to x producing xt2
: partial1  ( x xt1 -- xt2 )  [: swap lit, compile, ;] build-noname-with ;

\ Partially apply xt1 to x producing a word (a colon-definition) named "{sd.name}"
: build-colon-partial1 ( x xt1 sd.name -- ) [: swap lit, compile, ;] -rot build-colon-with ;



: <#+#> ( sd.left sd.right -- sd ) <# holds holds 0. #> ;
: <#-#> ( sd.right sd.left -- sd ) 2swap <#+#> ;



: build-slot ( sd.name -- )
  \ It creates two words named "set-{sd.name}" and "{sd.name}"
  2>r align here 0 ,
  dup ['] !     2r@ s" set-" <#-#>  build-colon-partial1
  dup ['] @     2r@                 build-colon-partial1
  drop 2rdrop
;
: build-slot2 ( sd.name -- )
  \ It creates two words named "set-{sd.name}" and "{sd.name}"
  2>r align here 0 , 0 ,
  dup ['] 2!    2r@ s" set-" <#-#>  build-colon-partial1
  dup ['] 2@    2r@                 build-colon-partial1
  drop 2rdrop
;
: build-vect ( sd.name -- )
  \ It creates three words named "of-{sd.name}", "set-{sd.name}", and "{sd.name}"
  2>r [: true abort" vect is not initialized" ;] align here swap ,
  dup ['] @     2r@ s" of-"  <#-#>  build-colon-partial1
  dup ['] !     2r@ s" set-" <#-#>  build-colon-partial1
  dup [: lit,  postpone @  postpone execute ;]
                2r@                 build-colon-with
  drop 2rdrop
;

: (tt-build-for-input) ( any xt "ccc <rparen>" -- any )
  [: ( any xt sd -- any xt ) rot >r tt-slit r@ tt-xt r> ;] for-input-lexeme-till-rparen drop
;
: slot(   ( "ccc <right-paren>" -- ) ['] build-slot  (tt-build-for-input) ; immediate
: slot2(  ( "ccc <right-paren>" -- ) ['] build-slot2 (tt-build-for-input) ; immediate
: vect(   ( "ccc <right-paren>" -- ) ['] build-vect  (tt-build-for-input) ; immediate

: find-xt-slot-setter ( sd.name -- xt|0 )
  s" set-" <#-#> find-xt
;
: set(    ( "ccc <right-paren>" -- )
  parse-lexeme-till-rparen dup 0= if 2drop exit then
  find-xt-slot-setter ?found >r recurse r> tt-xt
; immediate

This gist repository can be cloned into a directory slot.gist (in the current directory) by a command:

git clone https://gist.github.com/ruv/438d57d0af6a38e616efb59b43795e1b slot.gist