more work on libs/sql
erg
parent
2f3db7b389
commit
fdbcf006d3
|
|
@ -1,10 +1,47 @@
|
|||
USING: kernel namespaces ;
|
||||
USING: errors generic kernel namespaces sql:utils ;
|
||||
IN: sql
|
||||
|
||||
GENERIC: execute-sql* ( string db -- )
|
||||
GENERIC: query-sql* ( string db -- seq )
|
||||
G: execute-sql* ( db string -- ) 1 standard-combination ;
|
||||
G: query-sql* ( db string -- seq ) 1 standard-combination ;
|
||||
|
||||
: execute-sql ( string -- ) db get execute-sql* ;
|
||||
: query-sql ( string -- ) db get query-sql* ;
|
||||
: execute-sql ( string -- ) >r db get r> execute-sql* ;
|
||||
: query-sql ( string -- ) >r db get r> query-sql* ;
|
||||
|
||||
G: create-table* ( db tuple -- ) 1 standard-combination ;
|
||||
G: drop-table* ( db tuple -- ) 1 standard-combination ;
|
||||
G: insert-tuple* ( db tuple -- ) 1 standard-combination ;
|
||||
G: delete-tuple* ( db tuple -- ) 1 standard-combination ;
|
||||
G: update-tuple* ( db tuple -- ) 1 standard-combination ;
|
||||
G: select-tuple* ( db tuple -- ) 1 standard-combination ;
|
||||
|
||||
TUPLE: persistent-error message ;
|
||||
|
||||
: create-table ( tuple -- ) >r db get r> create-table* ;
|
||||
: drop-table ( tuple -- ) >r db get r> drop-table* ;
|
||||
: insert-tuple ( tuple -- )
|
||||
dup bottom-delegate persistent?
|
||||
[
|
||||
"tuple is persistent, call update not insert"
|
||||
<persistent-error> throw
|
||||
] when
|
||||
>r db get r> insert-tuple* ;
|
||||
|
||||
: delete-tuple ( tuple -- )
|
||||
dup bottom-delegate persistent?
|
||||
[
|
||||
"tuple is not persistent, cannot delete"
|
||||
<persistent-error> throw
|
||||
] unless
|
||||
>r db get r> delete-tuple* ;
|
||||
|
||||
: update-tuple ( tuple -- )
|
||||
dup bottom-delegate persistent?
|
||||
[
|
||||
"tuple is not persistent, call insert not update"
|
||||
<persistent-error> throw
|
||||
] unless
|
||||
>r db get r> update-tuple* ;
|
||||
|
||||
: select-tuple ( tuple -- )
|
||||
>r db get r> select-tuple* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,52 +1,53 @@
|
|||
USING: generic kernel namespaces prettyprint sequences sql:utils ;
|
||||
USING: errors generic kernel namespaces prettyprint
|
||||
sequences sql:utils ;
|
||||
IN: sql
|
||||
|
||||
GENERIC: create-sql* ( tuple db -- string )
|
||||
GENERIC: drop-sql* ( tuple db -- string )
|
||||
GENERIC: insert-sql* ( tuple db -- string )
|
||||
GENERIC: delete-sql* ( tuple db -- string )
|
||||
GENERIC: update-sql* ( tuple db -- string )
|
||||
GENERIC: select-sql* ( tuple db -- string )
|
||||
G: create-sql* ( db tuple -- string ) 1 standard-combination ;
|
||||
G: drop-sql* ( db tuple -- string ) 1 standard-combination ;
|
||||
G: insert-sql* ( db tuple -- string ) 1 standard-combination ;
|
||||
G: delete-sql* ( db tuple -- string ) 1 standard-combination ;
|
||||
G: update-sql* ( db tuple -- string ) 1 standard-combination ;
|
||||
G: select-sql* ( db tuple -- string ) 1 standard-combination ;
|
||||
|
||||
: create-sql ( tuple -- string ) db get create-sql* ;
|
||||
: drop-sql ( tuple -- string ) db get drop-sql* ;
|
||||
: insert-sql ( tuple -- string ) db get insert-sql* ;
|
||||
: delete-sql ( tuple -- string ) db get delete-sql* ;
|
||||
: update-sql ( tuple -- string ) db get update-sql* ;
|
||||
: select-sql ( tuple -- string ) db get select-sql* ;
|
||||
: create-sql ( tuple -- string ) >r db get r> create-sql* ;
|
||||
: drop-sql ( tuple -- string ) >r db get r> drop-sql* ;
|
||||
: insert-sql ( tuple -- string ) >r db get r> insert-sql* ;
|
||||
: delete-sql ( tuple -- string ) >r db get r> delete-sql* ;
|
||||
: update-sql ( tuple -- string ) >r db get r> update-sql* ;
|
||||
: select-sql ( tuple -- string ) >r db get r> select-sql* ;
|
||||
|
||||
M: connection create-sql* ( tuple db -- string )
|
||||
drop [
|
||||
M: connection create-sql* ( db tuple -- string )
|
||||
nip [
|
||||
"create table " %
|
||||
dup class unparse % "(" %
|
||||
tuple>mapping%
|
||||
");" %
|
||||
] "" make ;
|
||||
|
||||
M: connection drop-sql* ( tuple db -- string )
|
||||
drop [ "drop table " % tuple>sql-name % ";" % ] "" make ;
|
||||
M: connection drop-sql* ( db tuple -- string )
|
||||
nip [ "drop table " % tuple>sql-name % ";" % ] "" make ;
|
||||
|
||||
M: connection insert-sql* ( tuple db -- string )
|
||||
drop [
|
||||
M: connection insert-sql* ( db tuple -- string )
|
||||
nip [
|
||||
"insert into " %
|
||||
dup tuple>sql-name %
|
||||
" (" % tuple>insert-parts dup first ", " join %
|
||||
! " (" % fulltuple>insert-all-parts dup first ", " join %
|
||||
") values(" %
|
||||
second [ escape-sql enquote ] map ", " join %
|
||||
");" %
|
||||
] "" make ;
|
||||
|
||||
M: connection delete-sql* ( tuple db -- string )
|
||||
drop [
|
||||
M: connection delete-sql* ( db tuples -- string )
|
||||
nip [
|
||||
! "delete from table " % unparse % ";" %
|
||||
] "" make ;
|
||||
|
||||
M: connection update-sql* ( tuples db -- string )
|
||||
drop [
|
||||
M: connection update-sql* ( db tuples -- string )
|
||||
nip [
|
||||
] "" make ;
|
||||
|
||||
M: connection select-sql* ( tuples db -- string )
|
||||
drop [
|
||||
M: connection select-sql* ( db tuples -- string )
|
||||
nip [
|
||||
] "" make ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@ IN: sql
|
|||
|
||||
SYMBOL: db
|
||||
TUPLE: connection handle ;
|
||||
TUPLE: persistent id ;
|
||||
|
||||
! TESTING
|
||||
"handle" <connection> db set-global
|
||||
|
|
|
|||
|
|
@ -1,7 +1,34 @@
|
|||
USING: kernel namespaces sql ;
|
||||
USING: kernel math namespaces sql sql:utils ;
|
||||
IN: sqlite
|
||||
|
||||
M: sqlite execute-sql* ( string db -- )
|
||||
connection-handle swap
|
||||
M: sqlite execute-sql* ( db string -- )
|
||||
>r connection-handle r>
|
||||
sqlite-prepare dup [ drop ] sqlite-each sqlite-finalize ;
|
||||
|
||||
M: sqlite create-table* ( db tuple -- )
|
||||
create-sql execute-sql* ;
|
||||
|
||||
M: sqlite drop-table* ( db tuple -- )
|
||||
drop-sql execute-sql* ;
|
||||
|
||||
M: sqlite insert-tuple* ( db tuple -- )
|
||||
2dup insert-sql* >r >r connection-handle r> over r>
|
||||
sqlite-prepare over bind-for-insert
|
||||
[ drop ] sqlite-each sqlite-finalize
|
||||
>r sqlite-last-insert-rowid number>string r> make-persistent ;
|
||||
|
||||
M: sqlite delete-tuple* ( db tuple -- )
|
||||
2dup delete-sql* >r >r connection-handle r> r>
|
||||
swapd sqlite-prepare over bind-for-delete
|
||||
[ drop ] sqlite-each sqlite-finalize remove-bottom-delegate ;
|
||||
|
||||
M: sqlite update-tuple* ( db tuple -- )
|
||||
2dup update-sql* >r >r connection-handle r> r>
|
||||
swapd sqlite-prepare swap bind-for-update
|
||||
[ drop ] sqlite-each sqlite-finalize drop ;
|
||||
|
||||
M: sqlite select-tuple* ( db tuple -- )
|
||||
2dup select-sql* >r >r connection-handle r> r>
|
||||
swapd sqlite-prepare over bind-for-select
|
||||
[ break [ break pick restore-tuple , ] sqlite-each ] { } make
|
||||
[ sqlite-finalize ] keep ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: generic kernel namespaces prettyprint sql sql:utils ;
|
||||
USING: generic kernel namespaces prettyprint sequences sql sql:utils ;
|
||||
IN: sqlite
|
||||
|
||||
TUPLE: sqlite ;
|
||||
|
|
@ -6,19 +6,59 @@ C: sqlite ( path -- db )
|
|||
>r sqlite-open <connection> r>
|
||||
[ set-delegate ] keep ;
|
||||
|
||||
! M: sqlite insert-sql* ( tuple db -- string )
|
||||
M: sqlite create-sql* ( db tuple -- string )
|
||||
nip [
|
||||
"create table " % dup tuple>sql-name %
|
||||
" (" % full-tuple>alist "id" alist-remove-key
|
||||
[ first sanitize ] map ", " join %
|
||||
");" %
|
||||
] "" make ;
|
||||
|
||||
M: sqlite insert-sql* ( db tuple -- string )
|
||||
#! Insert and fill in the ID column
|
||||
! ;
|
||||
nip [
|
||||
"insert into " %
|
||||
dup tuple>sql-name %
|
||||
" (" % tuple>insert-alist
|
||||
[ [ first ] map ", " join % ] keep
|
||||
") values(" %
|
||||
[ first field>sqlite-bind-name ] map ", " join %
|
||||
");" %
|
||||
] "" make ;
|
||||
|
||||
M: sqlite delete-sql* ( tuple db -- string )
|
||||
M: sqlite delete-sql* ( db tuple -- string )
|
||||
#! Delete based on the ID column
|
||||
;
|
||||
nip [
|
||||
"delete from " % tuple>sql-name %
|
||||
" where ROWID=:rowid;" %
|
||||
] "" make ;
|
||||
|
||||
M: sqlite update-sql* ( tuple db -- string )
|
||||
M: sqlite update-sql* ( db tuple -- string )
|
||||
#! Update based on the ID column
|
||||
;
|
||||
nip [
|
||||
"update " % dup tuple>sql-name%
|
||||
" set " % full-tuple>alist "id" alist-remove-key
|
||||
[
|
||||
[
|
||||
first [ sanitize % ] keep
|
||||
" = " % field>sqlite-bind-name %
|
||||
] "" make
|
||||
] map ", " join %
|
||||
" where ROWID = :rowid;" %
|
||||
] "" make ;
|
||||
|
||||
M: sqlite select-sql* ( tuple db -- string )
|
||||
;
|
||||
M: sqlite select-sql* ( db tuple -- string )
|
||||
nip [
|
||||
"select ROWID,* from " % dup tuple>sql-name %
|
||||
" where " % tuple>select-alist
|
||||
[
|
||||
[
|
||||
first dup %
|
||||
" = " %
|
||||
field>sqlite-bind-name %
|
||||
] "" make
|
||||
] map " and " join %
|
||||
";" %
|
||||
] "" make ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@
|
|||
! executing SQL calls and obtaining results.
|
||||
!
|
||||
IN: sqlite
|
||||
USING: alien compiler errors libsqlite kernel namespaces sequences sql strings ;
|
||||
USING: alien compiler errors generic libsqlite kernel math namespaces
|
||||
prettyprint sequences sql strings sql:utils ;
|
||||
|
||||
TUPLE: sqlite-error n message ;
|
||||
|
||||
|
|
@ -52,7 +53,7 @@ TUPLE: sqlite-error n message ;
|
|||
: sqlite-bind-parameter-index ( statement name -- index )
|
||||
sqlite3_bind_parameter_index ;
|
||||
|
||||
: sqlite-bind-text-by-name ( statement name text -- )
|
||||
: sqlite-bind-text-by-name ( statement name text -- )
|
||||
>r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
|
||||
|
||||
: sqlite-finalize ( statement -- )
|
||||
|
|
@ -124,3 +125,35 @@ DEFER: (sqlite-map)
|
|||
[ db get sqlite-close ] cleanup
|
||||
] with-scope ;
|
||||
|
||||
: bind-for-sql ( statement alist -- )
|
||||
[
|
||||
first2 >r field>sqlite-bind-name r>
|
||||
obj>string/f sqlite-bind-text-by-name
|
||||
] each-with ;
|
||||
|
||||
: bind-for-insert ( statement tuple -- )
|
||||
tuple>insert-alist dupd dupd bind-for-sql ;
|
||||
|
||||
: bind-for-update ( statement tuple -- )
|
||||
tuple>update-alist dupd dupd dupd bind-for-sql ;
|
||||
|
||||
: bind-for-delete ( statement tuple -- )
|
||||
tuple>delete-alist dupd dupd bind-for-sql ;
|
||||
|
||||
: bind-for-select ( statement tuple -- )
|
||||
tuple>select-alist dupd dupd bind-for-sql ;
|
||||
|
||||
: restore-tuple ( statement tuple -- tuple )
|
||||
break
|
||||
clone dup dup full-tuple>fields
|
||||
[
|
||||
2drop
|
||||
! over 1+ >r
|
||||
! db-field-slot >r
|
||||
! pick swap column-text
|
||||
! over r> set-slot r>
|
||||
] each-with
|
||||
! drop make-persistent swap 0 column-text swap
|
||||
! [ set-persistent-key ] keep
|
||||
;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
USING: kernel math sql:utils ;
|
||||
IN: sql
|
||||
|
||||
: save ( tuple -- )
|
||||
: save-tuple ( tuple -- )
|
||||
dup "id" tuple-slot [
|
||||
! update
|
||||
update-tuple
|
||||
] [
|
||||
! insert
|
||||
insert-tuple
|
||||
] if ;
|
||||
|
||||
: restore ( tuple -- )
|
||||
: restore-tuple ( tuple -- )
|
||||
;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,47 @@
|
|||
USING: arrays errors generic hashtables kernel math namespaces
|
||||
prettyprint sequences sql strings tools words ;
|
||||
USING: arrays errors generic hashtables kernel kernel-internals
|
||||
math namespaces parser prettyprint sequences sql
|
||||
strings tools words ;
|
||||
IN: sql:utils
|
||||
|
||||
! : 2seq>hash 2array flip alist>hash ;
|
||||
: sanitize ( string -- string )
|
||||
"_p" "-?" pick subst ;
|
||||
|
||||
: 2seq>hash ( seq seq -- hash )
|
||||
H{ } clone -rot [ pick set-hash ] 2each ;
|
||||
: obj>string/f ( obj -- string/f )
|
||||
dup [ dup string? [ unparse ] unless ] when ;
|
||||
|
||||
: bottom-delegate ( tuple -- tuple/f )
|
||||
dup delegate [ nip bottom-delegate ] when* ;
|
||||
|
||||
: set-bottom-delegate ( delegate tuple -- )
|
||||
bottom-delegate set-delegate ;
|
||||
|
||||
: make-persistent ( id tuple -- )
|
||||
>r <persistent> r> set-bottom-delegate ;
|
||||
|
||||
: remove-bottom-delegate ( tuple -- )
|
||||
dup delegate [
|
||||
delegate [
|
||||
delegate remove-bottom-delegate
|
||||
] [
|
||||
f swap set-delegate
|
||||
] if
|
||||
] [
|
||||
drop
|
||||
] if* ;
|
||||
|
||||
: make-empty-tuple ( string -- tuple )
|
||||
parse call dup tuple-size <tuple> ;
|
||||
|
||||
: field>sqlite-bind-name ( string -- string )
|
||||
>r ":" r> append sanitize ;
|
||||
|
||||
: tuple-slot ( string tuple -- ? obj )
|
||||
"slot-names" over class word-props hash
|
||||
pick [ = ] curry find over -1 = [
|
||||
2drop delegate dup [ tuple-slot ] [ 2drop f -1 ] if
|
||||
] [
|
||||
drop rot drop 2 + swap tuple>array nth >r t r>
|
||||
] if ;
|
||||
|
||||
: tuple-fields ( tuple -- seq )
|
||||
class "slot-names" word-prop ;
|
||||
|
|
@ -13,29 +49,61 @@ IN: sql:utils
|
|||
: tuple>parts ( tuple -- values names )
|
||||
[ tuple-slots ] keep tuple-fields ;
|
||||
|
||||
: tuple>hash ( tuple -- hash )
|
||||
tuple>parts 2seq>hash ;
|
||||
: tuple>alist ( tuple -- alist )
|
||||
tuple>parts [ swap 2array ] 2map ;
|
||||
|
||||
: tuple>all-slots
|
||||
delegates <reversed> V{ } clone
|
||||
[ tuple-slots dupd nappend ] reduce
|
||||
<reversed> prune <reversed> >array ;
|
||||
|
||||
: tuple>all-fields
|
||||
: full-tuple>fields ( tuple -- seq )
|
||||
delegates <reversed> V{ } clone
|
||||
[ tuple-fields dupd nappend ] reduce
|
||||
<reversed> prune <reversed> >array ;
|
||||
|
||||
: full-tuple>slots ( tuple -- seq )
|
||||
dup full-tuple>fields [ swap tuple-slot nip ] map-with ;
|
||||
|
||||
: full-tuple>parts ( tuple -- values names )
|
||||
[ full-tuple>slots ] keep full-tuple>fields ;
|
||||
|
||||
: full-tuple>alist ( tuple -- alist )
|
||||
full-tuple>parts [ swap 2array ] 2map ;
|
||||
|
||||
: alist-remove-key ( alist key -- seq )
|
||||
[ >r first r> = not ] curry subset ;
|
||||
|
||||
: alist-remove-value ( alist value -- seq )
|
||||
[ >r second r> = not ] curry subset ;
|
||||
|
||||
: alist-key-each ( alist quot -- )
|
||||
[ first ] swap append each ;
|
||||
|
||||
: tuple>insert-alist ( tuple -- alist )
|
||||
full-tuple>alist
|
||||
"id" alist-remove-key
|
||||
f alist-remove-value ;
|
||||
|
||||
: tuple>update-alist ( tuple -- alist )
|
||||
full-tuple>alist "id" over assoc
|
||||
>r "rowid" r> 2array 1array append
|
||||
"id" alist-remove-key ;
|
||||
|
||||
: tuple>delete-alist ( tuple -- alist )
|
||||
>r "rowid" r> "id" swap tuple-slot nip 2array 1array ;
|
||||
|
||||
: tuple>select-alist ( tuple -- alist )
|
||||
full-tuple>alist
|
||||
f alist-remove-value ;
|
||||
|
||||
! : 2seq>hash 2array flip alist>hash ;
|
||||
|
||||
: 2seq>hash ( seq seq -- hash )
|
||||
H{ } clone -rot [ pick set-hash ] 2each ;
|
||||
|
||||
|
||||
: tuple>hash ( tuple -- hash ) tuple>parts 2seq>hash ;
|
||||
|
||||
: full-tuple>hash ( tuple -- hash )
|
||||
delegates <reversed>
|
||||
H{ } clone [ tuple>hash hash-union ] reduce ;
|
||||
|
||||
: tuple>all-parts ( tuple -- values names )
|
||||
[
|
||||
[ full-tuple>hash ] keep tuple>all-fields
|
||||
[ swap hash ] map-with
|
||||
] keep tuple>all-fields ;
|
||||
|
||||
: maybe-unparse ( obj -- )
|
||||
dup string? [ unparse ] unless ;
|
||||
|
||||
|
|
@ -49,20 +117,23 @@ IN: sql:utils
|
|||
] { } make
|
||||
] keep like ;
|
||||
|
||||
GENERIC: escape-sql* ( string type db -- string )
|
||||
GENERIC: escape-sql* ( string db -- string )
|
||||
|
||||
M: connection escape-sql* ( string type db -- string )
|
||||
drop { "''" } "'" rot replace ;
|
||||
M: connection escape-sql* ( string db -- string )
|
||||
drop dup string? [
|
||||
{ "''" } "'" rot replace
|
||||
] when ;
|
||||
|
||||
: escape-sql ( string type -- string ) db get escape-sql* ;
|
||||
|
||||
: sanitize-name ( string -- string )
|
||||
"_p" "-?" pick subst ;
|
||||
: escape-sql ( string -- string ) db get escape-sql* ;
|
||||
|
||||
: tuple>sql-name ( tuple -- string )
|
||||
class unparse sanitize-name ;
|
||||
class unparse sanitize ;
|
||||
|
||||
: enquote% "'" % % "'" % ;
|
||||
: tuple>sql-name% ( tuple -- string )
|
||||
tuple>sql-name % ;
|
||||
|
||||
|
||||
: enquote% "'" % dup string? [ unparse ] unless % "'" % ;
|
||||
|
||||
: enquote ( string -- 'string' )
|
||||
[ enquote% ] "" make ;
|
||||
|
|
@ -78,7 +149,7 @@ M: connection escape-sql* ( string type db -- string )
|
|||
>r >r split-last r> each r> each ; inline
|
||||
|
||||
: each-last ( seq quot quot -- )
|
||||
>r dup clone r> append swap (each-last) ;
|
||||
>r dup clone r> append swap (each-last) ; inline
|
||||
|
||||
: (2each-last) ( seq seq quot quot -- )
|
||||
>r >r [ split-last ] 2apply swapd r> 2each r> 2each ; inline
|
||||
|
|
@ -86,7 +157,7 @@ M: connection escape-sql* ( string type db -- string )
|
|||
: 2each-last ( seq seq quot quot -- )
|
||||
#! apply first quotation on all but last elt of seq
|
||||
#! apply second quotation on last element
|
||||
>r dup clone r> append swap (2each-last) ;
|
||||
>r dup clone r> append swap (2each-last) ; inline
|
||||
|
||||
! <foo1> { integer string }
|
||||
! mapping: { integer { varchar(256) "not null" } }
|
||||
|
|
@ -104,48 +175,15 @@ H{ } clone mappings set-global
|
|||
|
||||
: tuple>mapping% ( obj -- seq )
|
||||
[ get-mapping ] keep tuple-fields
|
||||
[ sanitize-name % " " % % ] [ ", " % ] 2each-last ;
|
||||
[ sanitize % " " % % ] [ ", " % ] 2each-last ;
|
||||
|
||||
: tuple>mapping ( tuple -- string )
|
||||
[ tuple>mapping% ] "" make ;
|
||||
|
||||
: tuple>insert-parts ( tuple -- string )
|
||||
[
|
||||
tuple>parts
|
||||
[
|
||||
dup "id" = [
|
||||
2drop
|
||||
] [
|
||||
over [ swap 2array , ] [ 2drop ] if
|
||||
] if
|
||||
] 2each
|
||||
] { } make flip ;
|
||||
|
||||
: tuple>assignments% ( tuple -- string )
|
||||
[ tuple-slots [ maybe-unparse escape-sql ] map ] keep
|
||||
tuple-fields
|
||||
[ sanitize-name % " = " % enquote% ] [ ", " % ] 2each-last ;
|
||||
|
||||
: tuple>assignments% ( tuple -- string )
|
||||
tuple>parts dup [ "id" = ] find drop
|
||||
dup -1 = [ "tuple must have an id slot" throw ] when
|
||||
swap >r tuck >r remove-nth r> r> remove-nth
|
||||
>r [ maybe-unparse escape-sql ] map r>
|
||||
[ % " = " % enquote% ] [ ", " % ] 2each-last ;
|
||||
|
||||
: tuple>assignments ( tuple -- string )
|
||||
[ tuple>assignments% ] "" make ;
|
||||
|
||||
: tuple-slot ( string slot -- ? obj )
|
||||
"slot-names" over class word-props hash
|
||||
rot [ = ] curry find over -1 = [
|
||||
swap
|
||||
] [
|
||||
drop 2 + swap tuple>array nth >r t r>
|
||||
] if ;
|
||||
|
||||
: explode-tuple ( tuple -- )
|
||||
dup tuple-slots swap class "slot-names" word-prop
|
||||
[ set ] 2each ;
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue