-
-
Save ruv/438d57d0af6a38e616efb59b43795e1b to your computer and use it in GitHub Desktop.
Defining words to create the getter and setter for a slot at once
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
\ 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 ) | |
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 ) 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 ( i*x xt -- j*x ) 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] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
\ 2023-10-25 | |
[undefined] find-xt-slot-setter [if] | |
include ./slot.fth | |
[then] | |
: v: ( "name" -- ) | |
['] :noname execute-balance 1- roll | |
parse-name find-xt-slot-setter ?found execute | |
; | |
vect( foo bar baz ) | |
v: foo ( -- ) ." (foo)" bar ; | |
v: bar ( -- ) ." (bar)" baz ; | |
v: baz ( -- ) ." (baz)" cr ; | |
foo \ "(foo)(bar)(baz)" |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
\ 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 ( -- x x )" and "set-foo ( x x -- )" | |
\ "vect( foo )" creates the words "set-foo ( xt -- )", "of-foo ( -- xt )", and "foo ( i*x -- j*x )" | |
\ | |
\ 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: | |
\ x1 x2 ... xN set( name1 name2 ... nameN ) | |
\ is equivalent to the phrase: | |
\ x1 x2 ... xN set-nameN ... set-name2 set-name-1 | |
[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 ( i*x xt -- j*x ) | |
>r begin parse-lexeme-till-rparen dup while r@ execute repeat 2drop rdrop | |
; | |
: execute-under-auto ( i*x xt2 k*x xt1 n.k -- j*x ) | |
>r execute-balance r> + n>r execute nr> drop | |
; | |
: :name ( sd.name -- colon-sys ) | |
['] : execute-parsing | |
; | |
: build-noname-with ( i*x xt.builder -- j*x xt.new ) \ xt.builder ( i*x -- j*x ) | |
['] :noname 0 execute-under-auto postpone ; | |
; | |
: build-colon-with ( i*x xt.builder sd.name -- j*x ) \ xt.builder ( i*x -- j*x ) | |
['] :name 2 execute-under-auto postpone ; | |
; | |
: partial1 ( x xt1 -- xt2 ) [: swap lit, compile, ;] build-noname-with ; | |
: 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 -- ) | |
2>r align here 0 , | |
dup ['] ! 2r@ s" set-" <#-#> build-colon-partial1 | |
dup ['] @ 2r@ build-colon-partial1 | |
drop 2rdrop | |
; | |
: build-slot2 ( 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 -- ) | |
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) ( i*x xt "ccc <rparen>" -- j*x ) | |
[: ( i*x xt sd -- j*x 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 | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
This gist repository can be cloned into a directory
slot.gist
(in the current directory) by a command: