Stack effect comments are not permitted inside word definitions
slava
parent
733ab3c5ac
commit
4e351ee5b7
|
|
@ -305,7 +305,7 @@ TUPLE: tagged-message data from tag ;
|
|||
#! 'send-synchronous' call. It will send 'message' back to the process
|
||||
#! that originally sent the tagged message, and will have the same tag
|
||||
#! as that in 'tagged-message'.
|
||||
swap >tagged-message< rot drop ( message from tag )
|
||||
swap >tagged-message< rot drop ! message from tag
|
||||
swap >r >r self r> <tagged-message> r> send ;
|
||||
|
||||
: forever ( quot -- )
|
||||
|
|
@ -353,11 +353,11 @@ SYMBOL: quit-cc
|
|||
#! The result of that call will be sent back to the
|
||||
#! messages original caller with the same tag as the
|
||||
#! original message.
|
||||
>r >r >tagged-message< rot ( from tag data r: quot pred )
|
||||
dup r> call [ ( from tag data r: quot )
|
||||
r> call ( from tag result )
|
||||
self ( from tag result self )
|
||||
rot ( from self tag result )
|
||||
>r >r >tagged-message< rot ! from tag data r: quot pred )
|
||||
dup r> call [ ! from tag data r: quot
|
||||
r> call ! from tag result
|
||||
self ! from tag result self
|
||||
rot ! from self tag result
|
||||
<tagged-message> swap send
|
||||
] [
|
||||
r> drop 3drop
|
||||
|
|
@ -366,12 +366,12 @@ SYMBOL: quit-cc
|
|||
: maybe-send-reply ( message pred quot -- )
|
||||
#! Same as !result but if false is returned from
|
||||
#! quot then nothing is sent back to the caller.
|
||||
>r >r >tagged-message< rot ( from tag data r: quot pred )
|
||||
dup r> call [ ( from tag data r: quot )
|
||||
r> call ( from tag result )
|
||||
>r >r >tagged-message< rot ! from tag data r: quot pred )
|
||||
dup r> call [ ! from tag data r: quot
|
||||
r> call ! from tag result
|
||||
[
|
||||
self ( from tag result self )
|
||||
rot ( from self tag result )
|
||||
self ! from tag result self
|
||||
rot ! from self tag result
|
||||
<tagged-message> swap send
|
||||
] [
|
||||
2drop
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ SYMBOL: current-show
|
|||
[ ( 0 1 -- )
|
||||
current-show set ( 0 -- )
|
||||
continue
|
||||
] callcc1 ( 0 [ ] == )
|
||||
] callcc1 ! 0 [ ] ==
|
||||
nip
|
||||
restore-request
|
||||
call
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@ TUPLE: parse-result parsed unparsed ;
|
|||
#! successfully parsed character on the stack. The result
|
||||
#! of that call is returned as the result portion of the
|
||||
#! successfull parse lazy list.
|
||||
-rot over first swap call [ ( quot inp -- )
|
||||
-rot over first swap call [
|
||||
h:t >r swap call r> <parse-result> lunit
|
||||
] [
|
||||
2drop nil
|
||||
|
|
@ -115,7 +115,7 @@ TUPLE: parse-result parsed unparsed ;
|
|||
: <&>-do-parser3 ( <parse-result> x -- result )
|
||||
#! Called by <&>-do-parser2 on each result of the
|
||||
#! parse from parser2.
|
||||
>r dup parse-result-unparsed swap parse-result-parsed r> ( x1 xs2 x )
|
||||
>r dup parse-result-unparsed swap parse-result-parsed r>
|
||||
swap 2array swap <parse-result> ;
|
||||
|
||||
: <&>-do-parser2 ( <parse-result> parser2 -- result )
|
||||
|
|
@ -125,8 +125,8 @@ TUPLE: parse-result parsed unparsed ;
|
|||
#! input. This word will parser2 on the remaining input
|
||||
#! returning a new cons cell containing the combined
|
||||
#! parse result.
|
||||
>r dup parse-result-parsed swap parse-result-unparsed r> ( x xs parser2 )
|
||||
call swap ( llist x )
|
||||
>r dup parse-result-parsed swap parse-result-unparsed r>
|
||||
call swap
|
||||
[ <&>-do-parser3 ] curry lmap ;
|
||||
|
||||
: <&>-parser ( input parser1 parser2 -- llist )
|
||||
|
|
@ -134,7 +134,7 @@ TUPLE: parse-result parsed unparsed ;
|
|||
#! two parsers. First parser1 is applied to the
|
||||
#! input then parser2 is applied to the rest of
|
||||
#! the input strings from the first parser.
|
||||
>r call r> ( <parse-result> p2 -- result )
|
||||
>r call r>
|
||||
[ <&>-do-parser2 ] curry lmap lappend* ;
|
||||
|
||||
: <&> ( parser1 parser2 -- parser )
|
||||
|
|
@ -193,9 +193,9 @@ TUPLE: parse-result parsed unparsed ;
|
|||
#! The result of that quotation then becomes the new parse result.
|
||||
#! This allows modification of parse tree results (like
|
||||
#! converting strings to integers, etc).
|
||||
-rot call dup nil? [ ( quot nil -- )
|
||||
-rot call dup nil? [
|
||||
nip
|
||||
] [ ( quot result -- )
|
||||
] [
|
||||
[ (<@-parser-replace) ] rot swap curry lmap
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -42,11 +42,11 @@ USING: kernel io math prettyprint inspector lists arrays sequences namespaces ;
|
|||
[ 1array swap keep first continue-with ] callcc1 nip ;
|
||||
|
||||
: (bshift) ( v r k -- )
|
||||
>r dup first -rot r> ( old-rc v r k )
|
||||
[ ( old-rc v r k kstar )
|
||||
rot 0 swap set-nth ( old-rc v k )
|
||||
>r dup first -rot r>
|
||||
[
|
||||
rot 0 swap set-nth
|
||||
continue-with
|
||||
] callcc1 ( old-rc v r k v2 )
|
||||
] callcc1
|
||||
>r drop nip 0 swap set-nth r> ;
|
||||
|
||||
: bshift ( r quot -- )
|
||||
|
|
@ -58,9 +58,9 @@ USING: kernel io math prettyprint inspector lists arrays sequences namespaces ;
|
|||
#! discards items on the stack, the stack will be restored to
|
||||
#! the way it was before it is called (which is true of callcc
|
||||
#! usage in general).
|
||||
[ ( r quot k )
|
||||
[ (bshift) ] cons pick swons swap ( r bshift quot )
|
||||
rot >r call ( v )
|
||||
[ ! r quot k
|
||||
[ (bshift) ] cons pick swons swap
|
||||
rot >r call
|
||||
r> first continue-with
|
||||
] callcc1 2nip ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,13 +4,13 @@ IN: rss
|
|||
USING: kernel http-client sequences namespaces math errors io ;
|
||||
|
||||
: (replace) ( str1 str2 string -- )
|
||||
pick over ( str1 str2 string str1 string )
|
||||
start dup -1 = [ ( str1 str2 string n )
|
||||
pick over ! str1 str2 string str1 string
|
||||
start dup -1 = [ ! str1 str2 string n
|
||||
drop % 2drop
|
||||
] [
|
||||
dup ( str1 str2 string n n-1 )
|
||||
pick swap head % ( str1 str2 string n )
|
||||
>r pick length r> + tail ( str1 str2 tail )
|
||||
dup ! str1 str2 string n n-1
|
||||
pick swap head % ! str1 str2 string n )
|
||||
>r pick length r> + tail ! str1 str2 tail
|
||||
over % (replace)
|
||||
] if ;
|
||||
|
||||
|
|
@ -21,7 +21,7 @@ USING: kernel http-client sequences namespaces math errors io ;
|
|||
: find-start-tag ( tag seq -- n )
|
||||
#! Find the start XML tag in the sequence. Return f if not found.
|
||||
#! If found return the index of the start of the contents of that tag.
|
||||
dup rot "<" swap append swap start dup 0 >= [ ( seq index )
|
||||
dup rot "<" swap append swap start dup 0 >= [ ! seq index
|
||||
">" -rot start* dup 0 >= [ 1 + ] [ drop f ] if
|
||||
] [
|
||||
drop f
|
||||
|
|
@ -47,11 +47,11 @@ USING: kernel http-client sequences namespaces math errors io ;
|
|||
[ find-start-tag ] 2keep find-end-tag 2dup and ;
|
||||
|
||||
: (child-tags) ( list tag seq -- list )
|
||||
2dup between-tags-index ( list tag seq start end bool )
|
||||
2dup between-tags-index ! list tag seq start end bool )
|
||||
[
|
||||
dup 1 + >r ( list tag seq start end r: end )
|
||||
pick subseq ( list tag seq item r: end )
|
||||
-rot >r >r over push r> r> r> ( list tag seq end )
|
||||
dup 1 + >r ! list tag seq start end r: end
|
||||
pick subseq ! list tag seq item r: end
|
||||
-rot >r >r over push r> r> r> ! list tag seq end
|
||||
over length rot subseq (child-tags)
|
||||
] [
|
||||
drop drop drop drop drop
|
||||
|
|
|
|||
|
|
@ -262,7 +262,7 @@ M: cpu write-port ( value port cpu -- )
|
|||
|
||||
: add-byte ( lhs rhs cpu -- result )
|
||||
#! Add rhs to lhs
|
||||
>r 2dup + r> ( lhs rhs result cpu )
|
||||
>r 2dup + r> ! lhs rhs result cpu
|
||||
[ update-flags ] 2keep
|
||||
[ update-half-carry-flag ] 2keep
|
||||
drop HEX: FF bitand ;
|
||||
|
|
@ -273,7 +273,7 @@ M: cpu write-port ( value port cpu -- )
|
|||
|
||||
: add-byte-with-carry ( lhs rhs cpu -- result )
|
||||
#! Add rhs to lhs plus carry.
|
||||
>r 2dup + r> ( lhs rhs result cpu )
|
||||
>r 2dup + r> ! lhs rhs result cpu
|
||||
[ add-carry ] keep
|
||||
[ update-flags ] 2keep
|
||||
[ update-half-carry-flag ] 2keep
|
||||
|
|
@ -301,7 +301,7 @@ M: cpu write-port ( value port cpu -- )
|
|||
: inc-byte ( byte cpu -- result )
|
||||
#! Increment byte by one. Note that carry flag is not affected
|
||||
#! by this operation.
|
||||
>r 1 2dup + r> ( lhs rhs result cpu )
|
||||
>r 1 2dup + r> ! lhs rhs result cpu
|
||||
[ update-flags-no-carry ] 2keep
|
||||
[ update-half-carry-flag ] 2keep
|
||||
drop HEX: FF bitand ;
|
||||
|
|
@ -309,7 +309,7 @@ M: cpu write-port ( value port cpu -- )
|
|||
: dec-byte ( byte cpu -- result )
|
||||
#! Decrement byte by one. Note that carry flag is not affected
|
||||
#! by this operation.
|
||||
>r 1 2dup - r> ( lhs rhs result cpu )
|
||||
>r 1 2dup - r> ! lhs rhs result cpu
|
||||
[ update-flags-no-carry ] 2keep
|
||||
[ update-half-carry-flag ] 2keep
|
||||
drop HEX: FF bitand ;
|
||||
|
|
@ -336,7 +336,7 @@ M: cpu write-port ( value port cpu -- )
|
|||
: and-byte ( lhs rhs cpu -- result )
|
||||
#! Logically and rhs to lhs. The carry flag is cleared and
|
||||
#! the half carry is set to the ORing of bits 3 of the operands.
|
||||
[ drop bit3or ] 3keep ( bit3or lhs rhs cpu )
|
||||
[ drop bit3or ] 3keep ! bit3or lhs rhs cpu
|
||||
>r bitand r> [ update-flags ] 2keep
|
||||
[ carry-flag clear-flag ] keep
|
||||
rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
|
||||
|
|
@ -364,8 +364,8 @@ M: cpu write-port ( value port cpu -- )
|
|||
|
||||
: save-pc ( cpu -- )
|
||||
#! Save the value of the PC on the stack.
|
||||
[ cpu-pc ] keep ( pc cpu )
|
||||
[ cpu-sp ] keep ( pc sp cpu )
|
||||
[ cpu-pc ] keep ! pc cpu
|
||||
[ cpu-sp ] keep ! pc sp cpu
|
||||
write-word ;
|
||||
|
||||
: push-pc ( cpu -- )
|
||||
|
|
@ -469,7 +469,7 @@ C: cpu ( cpu -- cpu )
|
|||
[ reset ] keep ;
|
||||
|
||||
: (load-rom) ( n ram -- )
|
||||
read1 [ ( n ram ch )
|
||||
read1 [ ! n ram ch
|
||||
-rot [ set-nth ] 2keep >r 1 + r> (load-rom)
|
||||
] [
|
||||
2drop
|
||||
|
|
@ -494,7 +494,7 @@ C: cpu ( cpu -- cpu )
|
|||
: read-instruction ( cpu -- word )
|
||||
#! Read the next instruction from the cpu's program
|
||||
#! counter, and increment the program counter.
|
||||
[ cpu-pc ] keep ( pc cpu )
|
||||
[ cpu-pc ] keep ! pc cpu
|
||||
[ over 1 + swap set-cpu-pc ] keep
|
||||
read-byte ;
|
||||
|
||||
|
|
@ -523,7 +523,7 @@ C: cpu ( cpu -- cpu )
|
|||
|
||||
: step ( cpu -- )
|
||||
#! Run a single 8080 instruction
|
||||
[ read-instruction ] keep ( n cpu )
|
||||
[ read-instruction ] keep ! n cpu
|
||||
over get-cycles over inc-cycles
|
||||
[ swap instructions dispatch ] keep
|
||||
[ cpu-pc HEX: FFFF bitand ] keep
|
||||
|
|
@ -619,11 +619,11 @@ SYMBOL: $4
|
|||
#! Copy the tree, replacing each occurence of
|
||||
#! $1, $2, etc with the relevant item from the
|
||||
#! given index.
|
||||
dup quotation? over [ ] = not and [ ( vector tree )
|
||||
dup first swap 1 tail ( vector car cdr )
|
||||
>r dupd replace-patterns ( vector v R: cdr )
|
||||
dup quotation? over [ ] = not and [ ! vector tree
|
||||
dup first swap 1 tail ! vector car cdr
|
||||
>r dupd replace-patterns ! vector v R: cdr
|
||||
swap r> replace-patterns >r unit r> append
|
||||
] [ ( vector value )
|
||||
] [ ! vector value
|
||||
dup $1 = [ drop 0 over nth ] when
|
||||
dup $2 = [ drop 1 over nth ] when
|
||||
dup $3 = [ drop 2 over nth ] when
|
||||
|
|
@ -636,19 +636,19 @@ SYMBOL: $4
|
|||
|
||||
: (emulate-RST) ( n cpu -- )
|
||||
#! RST nn
|
||||
[ cpu-sp 2 - dup ] keep ( sp sp cpu )
|
||||
[ set-cpu-sp ] keep ( sp cpu )
|
||||
[ cpu-pc ] keep ( sp pc cpu )
|
||||
swapd [ write-word ] keep ( cpu )
|
||||
[ cpu-sp 2 - dup ] keep ! sp sp cpu
|
||||
[ set-cpu-sp ] keep ! sp cpu
|
||||
[ cpu-pc ] keep ! sp pc cpu
|
||||
swapd [ write-word ] keep ! cpu
|
||||
>r 8 * r> set-cpu-pc ;
|
||||
|
||||
: (emulate-CALL) ( cpu -- )
|
||||
#! 205 - CALL nn
|
||||
[ next-word HEX: FFFF bitand ] keep ( addr cpu )
|
||||
[ cpu-sp 2 - dup ] keep ( addr sp sp cpu )
|
||||
[ set-cpu-sp ] keep ( addr sp cpu )
|
||||
[ cpu-pc ] keep ( addr sp pc cpu )
|
||||
swapd [ write-word ] keep ( addr cpu )
|
||||
[ next-word HEX: FFFF bitand ] keep ! addr cpu
|
||||
[ cpu-sp 2 - dup ] keep ! addr sp sp cpu
|
||||
[ set-cpu-sp ] keep ! addr sp cpu
|
||||
[ cpu-pc ] keep ! addr sp pc cpu
|
||||
swapd [ write-word ] keep ! addr cpu
|
||||
set-cpu-pc ;
|
||||
|
||||
: (emulate-RLCA) ( cpu -- )
|
||||
|
|
@ -1603,7 +1603,7 @@ INSTRUCTION: CP n ; opcode FE cycles 07
|
|||
INSTRUCTION: RST 38H ; opcode FF cycles 11
|
||||
|
||||
: each-8bit ( n quot -- )
|
||||
8 [ ( n quot bit )
|
||||
8 [ ! n quot bit
|
||||
pick over -1 * shift 1 bitand pick call
|
||||
] repeat 2drop ;
|
||||
|
||||
|
|
@ -1615,7 +1615,7 @@ INSTRUCTION: RST 38H ; opcode FF cycles 11
|
|||
"1" print
|
||||
224 [ ( cpu h -- h )
|
||||
32 [ ( cpu h w -- w )
|
||||
over 32 * over + HEX: 2400 + ( cpu h w addr )
|
||||
over 32 * over + HEX: 2400 + ! cpu h w addr
|
||||
>r pick r> swap cpu-ram nth [
|
||||
0 = [
|
||||
" 0 0 0" write
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap ;
|
|||
|
||||
: set-bitmap-pixel ( color point array -- )
|
||||
#! 'color' is a {r g b}. Point is {x y}.
|
||||
[ bitmap-index ] dip ( color index array )
|
||||
[ bitmap-index ] dip ! color index array
|
||||
[ [ first ] dipd set-uchar-nth ] 3keep
|
||||
[ [ second ] dipd [ 1 + ] dip set-uchar-nth ] 3keep
|
||||
[ third ] dipd [ 2 + ] dip set-uchar-nth ;
|
||||
|
|
@ -153,7 +153,7 @@ M: space-invaders reset ( cpu -- )
|
|||
0 swap set-space-invaders-port5o ;
|
||||
|
||||
: gui-step ( cpu -- )
|
||||
[ read-instruction ] keep ( n cpu )
|
||||
[ read-instruction ] keep ! n cpu
|
||||
over get-cycles over inc-cycles
|
||||
[ swap instructions dispatch ] keep
|
||||
[ cpu-pc HEX: FFFF bitand ] keep
|
||||
|
|
@ -162,7 +162,7 @@ M: space-invaders reset ( cpu -- )
|
|||
: gui-frame/2 ( cpu -- )
|
||||
[ gui-step ] keep
|
||||
[ cpu-cycles ] keep
|
||||
over 16667 < [ ( cycles cpu )
|
||||
over 16667 < [ ! cycles cpu
|
||||
nip gui-frame/2
|
||||
] [
|
||||
[ >r 16667 - r> set-cpu-cycles ] keep
|
||||
|
|
@ -251,15 +251,15 @@ M: invaders-gadget draw-gadget* ( gadget -- )
|
|||
|
||||
: addr>xy ( addr -- point )
|
||||
#! Convert video RAM address to base X Y value. point is a {x y}.
|
||||
HEX: 2400 - ( n )
|
||||
dup HEX: 1f bitand 8 * 255 swap - ( n y )
|
||||
HEX: 2400 - ! n
|
||||
dup HEX: 1f bitand 8 * 255 swap - ! n y
|
||||
swap -5 shift swap 2array ;
|
||||
|
||||
: plot-bitmap-pixel ( bitmap point color -- )
|
||||
#! point is a {x y}. color is a {r g b}.
|
||||
swap rot set-bitmap-pixel ;
|
||||
|
||||
: within ( n a b - bool )
|
||||
: within ( n a b -- bool )
|
||||
#! n >= a and n <= b
|
||||
rot tuck swap <= >r swap >= r> and ;
|
||||
|
||||
|
|
@ -301,7 +301,8 @@ M: space-invaders update-video ( value addr cpu -- )
|
|||
|
||||
: sync-frame ( millis -- millis )
|
||||
#! Sleep until the time for the next frame arrives.
|
||||
1000 60 / >fixnum + millis - dup 0 > [ sleep ] [ drop ] if millis ;
|
||||
1000 60 / >fixnum + millis - dup 0 >
|
||||
[ sleep ] [ drop yield ] if millis ;
|
||||
|
||||
: invaders-process ( millis gadget -- )
|
||||
#! Run a space invaders gadget inside a
|
||||
|
|
|
|||
|
|
@ -163,8 +163,8 @@ M: mapping select-sql ( tuple mapping -- select )
|
|||
#! will select based on only the filled in fields of the tuple (ie. all non-f).
|
||||
[
|
||||
"select ROWID,* from " % dup mapping-table %
|
||||
mapping-fields [ ( tuple field )
|
||||
swap over db-field-slot slot ( field value )
|
||||
mapping-fields [ ! tuple field
|
||||
swap over db-field-slot slot ! field value
|
||||
[
|
||||
[ dup db-field-name % "=" % db-field-bind-name % ] "" make
|
||||
] [
|
||||
|
|
@ -195,19 +195,19 @@ M: mapping select-sql ( tuple mapping -- select )
|
|||
: bind-for-insert ( statement tuple -- )
|
||||
#! Bind the fields in the tuple to the fields in the
|
||||
#! prepared insert statement.
|
||||
dup class get-mapping mapping-fields [ ( statement tuple field )
|
||||
[ db-field-slot slot ] keep ( statement value field )
|
||||
db-field-bind-name swap ( statement name value )
|
||||
dup class get-mapping mapping-fields [ ! statement tuple field
|
||||
[ db-field-slot slot ] keep ! statement value field
|
||||
db-field-bind-name swap ! statement name value
|
||||
>r dupd r> sqlite-bind-text-by-name
|
||||
] each-with drop ;
|
||||
|
||||
: bind-for-select ( statement tuple -- )
|
||||
#! Bind the fields in the tuple to the fields in the
|
||||
#! prepared select statement.
|
||||
dup class get-mapping mapping-fields [ ( statement tuple field )
|
||||
[ db-field-slot slot ] keep ( statement value field )
|
||||
dup class get-mapping mapping-fields [ ! statement tuple field
|
||||
[ db-field-slot slot ] keep ! statement value field
|
||||
over [
|
||||
db-field-bind-name swap ( statement name value )
|
||||
db-field-bind-name swap ! statement name value
|
||||
>r dupd r> sqlite-bind-text-by-name
|
||||
] [
|
||||
2drop
|
||||
|
|
@ -229,9 +229,9 @@ M: mapping select-sql ( tuple mapping -- select )
|
|||
#! Insert this tuple instance into the database. Note that
|
||||
#! it inserts only this instance, and not any one-to-one or
|
||||
#! one-to-many fields.
|
||||
dup class get-mapping insert-sql ( db tuple sql )
|
||||
swapd sqlite-prepare swap ( statement tuple )
|
||||
dupd bind-for-insert ( statement )
|
||||
dup class get-mapping insert-sql ! db tuple sql
|
||||
swapd sqlite-prepare swap ! statement tuple
|
||||
dupd bind-for-insert ! statement
|
||||
dup [ drop ] sqlite-each
|
||||
sqlite-finalize ;
|
||||
|
||||
|
|
@ -244,9 +244,9 @@ M: mapping select-sql ( tuple mapping -- select )
|
|||
: update-tuple ( db tuple -- )
|
||||
#! Update this tuple instance in the database. The tuple should have
|
||||
#! a delegate of 'persistent' with the key field set.
|
||||
dup class get-mapping update-sql ( db tuple sql )
|
||||
swapd sqlite-prepare swap ( statement tuple )
|
||||
dupd bind-for-update ( statement )
|
||||
dup class get-mapping update-sql ! db tuple sql
|
||||
swapd sqlite-prepare swap ! statement tuple
|
||||
dupd bind-for-update ! statement
|
||||
dup [ drop ] sqlite-each
|
||||
sqlite-finalize ;
|
||||
|
||||
|
|
@ -258,9 +258,9 @@ M: mapping select-sql ( tuple mapping -- select )
|
|||
: delete-tuple ( db tuple -- )
|
||||
#! Delete this tuple instance from the database. The tuple should have
|
||||
#! a delegate of 'persistent' with the key field set.
|
||||
dup class get-mapping delete-sql ( db tuple sql )
|
||||
swapd sqlite-prepare swap ( statement tuple )
|
||||
dupd bind-for-delete ( statement )
|
||||
dup class get-mapping delete-sql ! db tuple sql
|
||||
swapd sqlite-prepare swap ! statement tuple
|
||||
dupd bind-for-delete ! statement
|
||||
dup [ drop ] sqlite-each
|
||||
sqlite-finalize ;
|
||||
|
||||
|
|
@ -269,12 +269,12 @@ M: mapping select-sql ( tuple mapping -- select )
|
|||
#! return the clone with fields set to the values from the
|
||||
#! database.
|
||||
clone dup class get-mapping mapping-fields 1 swap
|
||||
[ ( statement tuple index field )
|
||||
over 1+ >r ( statement tuple index field r: index+1 )
|
||||
db-field-slot >r ( statement tuple index r: index+1 slot )
|
||||
pick swap column-text ( statement tuple value r: index+1 slot )
|
||||
over r> set-slot r> ( statement tuple index+1 )
|
||||
] each ( statement tuple index )
|
||||
[ ! statement tuple index field )
|
||||
over 1+ >r ! statement tuple index field r: index+1
|
||||
db-field-slot >r ! statement tuple index r: index+1 slot
|
||||
pick swap column-text ! statement tuple value r: index+1 slot
|
||||
over r> set-slot r> ! statement tuple index+1
|
||||
] each ! statement tuple index
|
||||
drop make-persistent swap 0 column-text swap [ set-persistent-key ] keep ;
|
||||
|
||||
: find-tuples ( db tuple -- seq )
|
||||
|
|
@ -282,14 +282,14 @@ M: mapping select-sql ( tuple mapping -- select )
|
|||
#! match the tuple provided as a template. All fields in the
|
||||
#! tuple must match the entries in the database, except for
|
||||
#! those set to 'f'.
|
||||
dup class get-mapping dupd select-sql ( db tuple sql )
|
||||
swapd sqlite-prepare swap ( statement tuple )
|
||||
2dup bind-for-select ( statement tuple )
|
||||
dup class get-mapping dupd select-sql ! db tuple sql
|
||||
swapd sqlite-prepare swap ! statement tuple
|
||||
2dup bind-for-select ! statement tuple )
|
||||
[
|
||||
over [ ( tuple statement )
|
||||
over [ ! tuple statement
|
||||
over restore-tuple ,
|
||||
] sqlite-each
|
||||
] [ ] make nip ( statement tuple accum )
|
||||
] [ ] make nip ! statement tuple accum
|
||||
swap sqlite-finalize ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -287,7 +287,7 @@ swap XConfigureEvent-position swap set-pwindow-last-position ;
|
|||
: call-move-action ( event obj -- ? )
|
||||
swap XConfigureEvent-position swap dup pwindow-move-action call ;
|
||||
|
||||
: maybe-handle-move ( event obj )
|
||||
: maybe-handle-move ! event obj
|
||||
2dup position-changed?
|
||||
[ 2dup update-last-position call-move-action ] [ 2drop ] if ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue