Skip to content
GitLab
Commit ec52ea5f authored by bp's avatar bp
Browse files

Added nested picture number stuff 

git-svn-id: https://forth-ev.de/repos/bigforth@1716 3b8d8251-53f3-0310-8f3b-fd1cb8370982
parent 90a171f1
Expand all Hide whitespace changes
Inline Side-by-side
bench.fb
View file @ ec52ea5f
This diff is collapsed.
clicks.fs
View file @ ec52ea5f
...@@ -5,7 +5,7 @@ Variable click# click# off ...@@ -5,7 +5,7 @@ Variable click# click# off
X" There have been no clicks yet" text-label new X" There have been no clicks yet" text-label new
dup F bind click-label dup F bind click-label
^ S[ 1 click# +! ^ S[ 1 click# +!
click# @ 0 <# #S s" Number of clicks: " holds #> click# @ 0 <<# #s s" Number of clicks: " holds #>
click-label assign ]S X" Click me" button new click-label assign #>> ]S X" Click me" button new
&2 vabox new panel s" Clicks" assign show endwith ; &2 vabox new panel s" Clicks" assign show endwith ;
click-win click-win
disass.fb
View file @ ec52ea5f
This diff is collapsed.
edit.fs
View file @ ec52ea5f
...@@ -239,7 +239,7 @@ stredit implements ...@@ -239,7 +239,7 @@ stredit implements
IF [defined] filename [IF] filename >len scratch$ $+! IF [defined] filename [IF] filename >len scratch$ $+!
[ELSE] drop [THEN] THEN [ELSE] drop [THEN] THEN
S" Line # " scratch$ $+! base push decimal S" Line # " scratch$ $+! base push decimal
line#@ 0 <# bl hold # # # #S #> scratch$ $+! line#@ 0 <<# bl hold # # # #S #> scratch$ $+! #>>
update$ scratch$ $+! scratch$ $@ ; update$ scratch$ $+! scratch$ $@ ;
: maketitle edifile @ 0= ?EXIT : maketitle edifile @ 0= ?EXIT
title$ dpy get-dpy window with title! endwith title$ dpy get-dpy window with title! endwith
......
ediwind.fs
View file @ ec52ea5f
...@@ -108,7 +108,7 @@ scredit implements ...@@ -108,7 +108,7 @@ scredit implements
: title$ ( -- addr u ) : title$ ( -- addr u )
base push decimal base push decimal
S" Scr # " scratch$ $! S" Scr # " scratch$ $!
scr# @ 0 <# bl hold # # #S #> scratch$ $+! scr# @ 0 <<# bl hold # # #S #> scratch$ $+! #>>
scratch$ $@ ; scratch$ $@ ;
[ELSE] [ELSE]
: updated? ( -- f ) 'start 4- @ $14 + wx@ 0< ; : updated? ( -- f ) 'start 4- @ $14 + wx@ 0< ;
...@@ -117,7 +117,7 @@ scredit implements ...@@ -117,7 +117,7 @@ scredit implements
: title$ ( -- addr u ) : title$ ( -- addr u )
base push decimal base push decimal
edifile @ filename >len scratch$ $! edifile @ filename >len scratch$ $!
S" Scr # " scratch$ $+! scr# @ 0 <# bl hold # # #S #> scratch$ $+! S" Scr # " scratch$ $+! scr# @ 0 <<# bl hold # # #S #> scratch$ $+! #>>
update$ scratch$ $+! update$ scratch$ $+!
scratch$ $@ ; scratch$ $@ ;
[THEN] [THEN]
......
etikette.fb
View file @ ec52ea5f
\ Etiketten drucken (zweispaltig) 01jan10pyCreate (name" $20 allot Create (film $20 allot \ Variable date dos dattime $4000000 / &80 + date ! forth : name" ascii " parse (name" place ; name" Frank Paysan" : film bl word count (film place ; film F9101AC \ F9101AC/36 : .archivnummer ( n -- ) base push decimal (film count 2dup type + 1- c@ 'D' = IF ." /img_" 0 <# # # # # #> type ." .jpg" ELSE ." /" 0 <# # # #> type THEN ; : tab 9 emit ; : .name (name" count type ; : .copyright ." Copyright (c) 20" base push decimal (film 2+ 2 type ." by" ; --> \ Init 17may09py include fileop.fb also fileop : init s" /dev/usblp0" r/w output-file +buffer #esc emit 'A emit 5 emit \ Halber Vorschub #esc emit 'D emit &16 emit 0 emit \ Tabulator #esc emit 'A emit 5 emit \ Halber Vorschub #esc emit 'S emit 0 emit \ Hochstellen #esc emit 'p emit 1 emit \ Proportionalschrift ; : fcr ( #cr emit ) cr ; --> \ Etiketten drucken (zweispaltig) 26may08py : .etikette ( #1 #2 -- ) init swap .copyright tab .copyright fcr .name tab .name fcr ." Stockmannstr. 14" tab ." Stockmannstr. 14" fcr ." 81477 Mnchen" tab ." 81477 Mnchen" fcr ." Archivnummer:" tab ." Archivnummer:" fcr .archivnummer tab .archivnummer fcr fcr fcr fcr fcr fcr fcr eot ; : .etiketten ( end start -- ) ?DO i i 1+ .etikette stop? ?LEAVE 2 +LOOP ; --> \ Etiketten drucken (Liste) 18apr89py: .elist ( n1 n2 n3 .. nx x -- ) >r r@ init 0 ?DO i' i - 1- pick 1 > IF i dup .etikette i' i - 1- >r r@ pick 2- r@ pin r> pick 0= negate ELSE i' i - 1- pick 0<> IF i' i - 1 = IF i 0 .etikette 1 ELSE 1 BEGIN i' i - over - pick 0= WHILE 1+ REPEAT i 2dup + .etikette i' i - over - >r r@ pick 1- r@ pin r@ 1+ pick 1- r> 1+ pin THEN ELSE 1 THEN THEN stop? IF drop leave THEN +LOOP r> 0 ?DO drop LOOP eot ; \ Etiketten drucken (zweispaltig) 07aug10pyCreate (name" $20 allot Create (film $20 allot \ Variable date dos dattime $4000000 / &80 + date ! forth : name" ascii " parse (name" place ; name" Frank Paysan" : film bl word count (film place ; film F9101AC \ F9101AC/36 : .archivnummer ( n -- ) base push decimal (film count 2dup type + 1- c@ 'D' = IF ." /img_" 0 <<# # # # # #> type #>> ." .jpg" ELSE ." /" 0 <<# # # #> type #>> THEN ; : tab 9 emit ; : .name (name" count type ; : .copyright ." Copyright (c) 20" base push decimal (film 2+ 2 type ." by" ; --> \ Init 17may09py include fileop.fb also fileop : init s" /dev/usblp0" r/w output-file +buffer #esc emit 'A emit 5 emit \ Halber Vorschub #esc emit 'D emit &16 emit 0 emit \ Tabulator #esc emit 'A emit 5 emit \ Halber Vorschub #esc emit 'S emit 0 emit \ Hochstellen #esc emit 'p emit 1 emit \ Proportionalschrift ; : fcr ( #cr emit ) cr ; --> \ Etiketten drucken (zweispaltig) 26may08py : .etikette ( #1 #2 -- ) init swap .copyright tab .copyright fcr .name tab .name fcr ." Stockmannstr. 14" tab ." Stockmannstr. 14" fcr ." 81477 Mnchen" tab ." 81477 Mnchen" fcr ." Archivnummer:" tab ." Archivnummer:" fcr .archivnummer tab .archivnummer fcr fcr fcr fcr fcr fcr fcr eot ; : .etiketten ( end start -- ) ?DO i i 1+ .etikette stop? ?LEAVE 2 +LOOP ; --> \ Etiketten drucken (Liste) 18apr89py: .elist ( n1 n2 n3 .. nx x -- ) >r r@ init 0 ?DO i' i - 1- pick 1 > IF i dup .etikette i' i - 1- >r r@ pick 2- r@ pin r> pick 0= negate ELSE i' i - 1- pick 0<> IF i' i - 1 = IF i 0 .etikette 1 ELSE 1 BEGIN i' i - over - pick 0= WHILE 1+ REPEAT i 2dup + .etikette i' i - over - >r r@ pick 1- r@ pin r@ 1+ pick 1- r> 1+ pin THEN ELSE 1 THEN THEN stop? IF drop leave THEN +LOOP r> 0 ?DO drop LOOP eot ;
\ No newline at end of file \ No newline at end of file
etikette2.fb
View file @ ec52ea5f
\ Etiketten drucken (zweispaltig) 30nov09pyCreate (name" $20 allot Create (film $20 allot \ Variable date dos dattime $4000000 / &80 + date ! forth : name" ascii " parse (name" place ; name" Frank Paysan" : film bl word count (film place ; film F0911AD \ F9101AC/36 : .archivnummer ( n -- ) base push decimal (film count 2dup type + 1- c@ 'D' = IF ." /img_" 0 <# # # # # #> type ." .jpg" ELSE ." /" 0 <# # # #> type THEN ; : tab 9 emit ; : .name (name" count type ; : .copyright ." Copyright (c) 20" base push decimal (film 2+ 2 type ." by" ; --> \ Init 30nov09py \needs fileop include fileop.fb also fileop : init s" /dev/usblp0" r/w output-file +buffer \ #esc emit 'A emit 5 emit \ Halber Vorschub #esc emit 'D emit &16 emit 0 emit \ Tabulator \ #esc emit 'A emit 5 emit \ Halber Vorschub \ #esc emit 'S emit 0 emit \ Hochstellen #esc emit 'p emit 1 emit \ Proportionalschrift ; : fcr ( #cr emit ) cr ; --> \ Etiketten drucken (zweispaltig) 01jan10py : leer 3 spaces ; : (.etikette ( #1 -- ) leer ." (c) " .name ." 20" (film 2+ 2 type fcr leer ." Stockmannstr. 14" fcr leer ." 81477 Mnchen" fcr leer ." Archivnummer:" fcr leer .archivnummer fcr 11 0 DO fcr LOOP ; : .etikette ( #1 -- ) init (.etikette eot ; : .etiketten ( end start -- ) init ?DO i (.etikette stop? ?LEAVE LOOP eot ; --> \ Etiketten drucken (Liste) 30nov09py : .elist ( n1 n2 n3 .. nx x -- ) >r r@ init 0 ?DO I' I - 1- pick (.etikette stop? ?LEAVE LOOP eot r> 0 ?DO drop LOOP ; \ Etiketten drucken (zweispaltig) 07aug10pyCreate (name" $20 allot Create (film $20 allot \ Variable date dos dattime $4000000 / &80 + date ! forth : name" ascii " parse (name" place ; name" Frank Paysan" : film bl word count (film place ; film F0911AD \ F9101AC/36 : .archivnummer ( n -- ) base push decimal (film count 2dup type + 1- c@ 'D' = IF ." /img_" 0 <<# # # # # #> type #>> ." .jpg" ELSE ." /" 0 <<# # # #> type #>> THEN ; : tab 9 emit ; : .name (name" count type ; : .copyright ." Copyright (c) 20" base push decimal (film 2+ 2 type ." by" ; --> \ Init 30nov09py \needs fileop include fileop.fb also fileop : init s" /dev/usblp0" r/w output-file +buffer \ #esc emit 'A emit 5 emit \ Halber Vorschub #esc emit 'D emit &16 emit 0 emit \ Tabulator \ #esc emit 'A emit 5 emit \ Halber Vorschub \ #esc emit 'S emit 0 emit \ Hochstellen #esc emit 'p emit 1 emit \ Proportionalschrift ; : fcr ( #cr emit ) cr ; --> \ Etiketten drucken (zweispaltig) 01jan10py : leer 3 spaces ; : (.etikette ( #1 -- ) leer ." (c) " .name ." 20" (film 2+ 2 type fcr leer ." Stockmannstr. 14" fcr leer ." 81477 Mnchen" fcr leer ." Archivnummer:" fcr leer .archivnummer fcr 11 0 DO fcr LOOP ; : .etikette ( #1 -- ) init (.etikette eot ; : .etiketten ( end start -- ) init ?DO i (.etikette stop? ?LEAVE LOOP eot ; --> \ Etiketten drucken (Liste) 30nov09py : .elist ( n1 n2 n3 .. nx x -- ) >r r@ init 0 ?DO I' I - 1- pick (.etikette stop? ?LEAVE LOOP eot r> 0 ?DO drop LOOP ;
\ No newline at end of file \ No newline at end of file
except.fs
View file @ ec52ea5f
...@@ -2,7 +2,7 @@ ...@@ -2,7 +2,7 @@
: dumped ftab 8 cells + @ cell+ ; : dumped ftab 8 cells + @ cell+ ;
| : 0.r 0 swap <# 0 ?DO # LOOP #> type ; | : 0.r 0 swap <<# 0 ?DO # LOOP #> type #>> ;
| : .header ( -- ) 3 S" AXCXDXBXSPBPSIDI" bounds | : .header ( -- ) 3 S" AXCXDXBXSPBPSIDI" bounds
DO spaces I 2 type 7 2 +LOOP drop ; DO spaces I 2 type 7 2 +LOOP drop ;
| : .regs ( -- ) dumped 8 cells + | : .regs ( -- ) dumped 8 cells +
...@@ -38,8 +38,8 @@ ...@@ -38,8 +38,8 @@
: in_which? ( addr -- len nfa count/false ) cell swap dup @ : in_which? ( addr -- len nfa count/false ) cell swap dup @
[ ' push 5 + @ ] ALiteral = [ ' push 5 + @ ] ALiteral =
IF swap 3 * swap cell+ 2@ swap IF swap 3 * swap cell+ 2@ swap
0 <# #S drop bl hold #S 0 <<# #S drop bl hold #s
s" push " 1- FOR dup I + c@ hold NEXT drop #> EXIT THEN s" push " 1- FOR dup I + c@ hold NEXT drop #> #>> EXIT THEN
@ context @ over noop in_voc? @ context @ over noop in_voc?
dup IF nip count $1F and EXIT THEN drop voc-link dup IF nip count $1F and EXIT THEN drop voc-link
BEGIN @ dup WHILE 2dup 8 - swap in_voc? dup BEGIN @ dup WHILE 2dup 8 - swap in_voc? dup
...@@ -48,7 +48,7 @@ ...@@ -48,7 +48,7 @@
| : "name ( nfa count / 0 -- ) ?dup | : "name ( nfa count / 0 -- ) ?dup
IF $add S" " $add IF $add S" " $add
ELSE 0 <# bl hold #S '$ hold #> $add THEN ; ELSE 0 <<# bl hold #S '$ hold #> $add #>> THEN ;
: "back ( addr -- addr len ) base push hex dup off $sum ! : "back ( addr -- addr len ) base push hex dup off $sum !
S" Level: " $add backtrace 8 cells bounds S" Level: " $add backtrace 8 cells bounds
?DO I in_which? dup 0= IF I @ swap THEN "name ?DO I in_which? dup 0= IF I @ swap THEN "name
......
fileint.fb
View file @ ec52ea5f
This diff is collapsed.
float.fb
View file @ ec52ea5f
This diff is collapsed.
forth.fb
View file @ ec52ea5f
This diff is collapsed.
forthker-linux.fi
View file @ ec52ea5f
No preview for this file type
gsl.fs
View file @ ec52ea5f
...@@ -464,7 +464,7 @@ struct{ ...@@ -464,7 +464,7 @@ struct{
cell hc_wavetable cell hc_wavetable
} gsl_fft_precomputes } gsl_fft_precomputes
| create $buf 255 allot | create $buf 255 allot
| : 2str dup >r abs s>d <# #s r> sign #> $buf 0place ; | : 2str dup >r abs s>d <<# #s r> sign #> $buf 0place #>> ;
| : s>hash ( n -- key ) 2str $buf hash ; | : s>hash ( n -- key ) 2str $buf hash ;
| : (cache-fft) ( n -- addr ) | : (cache-fft) ( n -- addr )
sizeof gsl_fft_precomputes allocate throw >r sizeof gsl_fft_precomputes allocate throw >r
......
minos-buttons.fs
View file @ ec52ea5f
...@@ -517,16 +517,16 @@ synonym VT[ noop-i ...@@ -517,16 +517,16 @@ synonym VT[ noop-i
\ number input field 27apr98py \ number input field 27apr98py
edit-action class number-action edit-action class number-action
public: cell var nbase public: cell var nbase
how: : ># ( d -- addr u ) base push nbase @ base ! tuck dabs how: : #>text ( d -- addr u ) base push nbase @ base ! tuck dabs
<# #S nbase @ $10 = IF '$' hold THEN <<# #s nbase @ $10 = IF '$' hold THEN
nbase @ %10 = IF '%' hold THEN rot sign #> ; nbase @ %10 = IF '%' hold THEN rot sign #> #>> ;
: key ( key sh -- ) drop base push nbase @ base ! : key ( key sh -- ) drop base push nbase @ base !
dup shift-keys? IF drop EXIT THEN dup find-key dup dup shift-keys? IF drop EXIT THEN dup find-key dup
IF cell+ @ caller send drop IF cell+ @ caller send drop
ELSE drop dup digit? nip 0= ?EXIT ELSE drop dup digit? nip 0= ?EXIT
sp@ 1 edit with ins drop 1 c drop endwith sp@ 1 edit with ins drop 1 c drop endwith
THEN stroke @ called send ; THEN stroke @ called send ;
: store ( d -- ) ># edit assign ; : store ( d -- ) #>text edit assign ;
: fetch ( -- d ) edit get base push decimal s>number ; : fetch ( -- d ) edit get base push decimal s>number ;
: init ( o addr -- ) #10 nbase ! super init ; : init ( o addr -- ) #10 nbase ! super init ;
class; class;
...@@ -852,9 +852,9 @@ public: method #>text \ early scalekey ...@@ -852,9 +852,9 @@ public: method #>text \ early scalekey
\ new scaler 03dec06py \ new scaler 03dec06py
how: : #>text ( n -- addr u ) base push decimal how: : #>text ( n -- addr u ) base push decimal
text/ @ m* tuck dabs <# text/ @ m* tuck dabs <<#
text*/ @ 1 ?DO # I 9 * +LOOP text*/ @ 1 ?DO # I 9 * +LOOP
text*/ @ 1 > IF '.' hold THEN #S rot sign #> ; text*/ @ 1 > IF '.' hold THEN #S rot sign #> #>> ;
: .text ( addr u x y c -- ) >r 2swap r> : .text ( addr u x y c -- ) >r 2swap r>
fnt select fnt self fnt ' display dpy drawer ; fnt select fnt self fnt ' display dpy drawer ;
: get ( -- steps step pos ) super get 0 swap ; : get ( -- steps step pos ) super get 0 swap ;
...@@ -938,9 +938,9 @@ public: method #>text \ early scalekey ...@@ -938,9 +938,9 @@ public: method #>text \ early scalekey
\ new scaler 08mar07py \ new scaler 08mar07py
how: : #>text ( n -- addr u ) base push decimal how: : #>text ( n -- addr u ) base push decimal
text/ @ m* tuck dabs <# text/ @ m* tuck dabs <<#
text*/ @ 1 ?DO # I 9 * +LOOP text*/ @ 1 ?DO # I 9 * +LOOP
text*/ @ 1 > IF '.' hold THEN #S rot sign #> ; text*/ @ 1 > IF '.' hold THEN #S rot sign #> #>> ;
: .text ( addr u x y c -- ) >r 2swap r> : .text ( addr u x y c -- ) >r 2swap r>
fnt select fnt self fnt ' display dpy drawer ; fnt select fnt self fnt ' display dpy drawer ;
: get ( -- steps step pos ) super get 0 swap ; : get ( -- steps step pos ) super get 0 swap ;
......
minos-complex.fs
View file @ ec52ea5f
...@@ -826,7 +826,7 @@ how: \ 6 colors defocuscol ! ...@@ -826,7 +826,7 @@ how: \ 6 colors defocuscol !
: assign ( size time attr addr len -- ) base push : assign ( size time attr addr len -- ) base push
super assign attr ! time ! size ! ; super assign attr ! time ! size ! ;
: !resized super !resized decimal : !resized super !resized decimal
size @ 0 <# #S #> 0 textsize drop wsize ! size @ 0 <<# #s #> 0 textsize drop wsize ! #>>
S" 00may99" 0 textsize drop wdate ! S" 00may99" 0 textsize drop wdate !
S" 00:00:00" 0 textsize drop wtime ! ; S" 00:00:00" 0 textsize drop wtime ! ;
[defined] x11 [IF] : dir@ attr @ $C >> ; [THEN] [defined] x11 [IF] : dir@ attr @ $C >> ; [THEN]
...@@ -846,8 +846,8 @@ how: \ 6 colors defocuscol ! ...@@ -846,8 +846,8 @@ how: \ 6 colors defocuscol !
w @ wdate @ - 6 - 0 p+ w @ wdate @ - 6 - 0 p+
time @ >date 2over cc .text time @ >date 2over cc .text
m wtime @ + 0 p- time @ >time 2over cc .text m wtime @ + 0 p- time @ >time 2over cc .text
m wsize @ + 0 p- size @ 0 <# #S #> m wsize @ + 0 p- size @ 0 <<# #s #>
2swap cc .text ; 2swap cc .text #>> ;
\ file widget 10apr04py \ file widget 10apr04py
: hglue ( -- glue ) super hglue xM 3 * : hglue ( -- glue ) super hglue xM 3 *
......
opensched-types.fs
View file @ ec52ea5f
...@@ -119,7 +119,7 @@ Variable list$ ...@@ -119,7 +119,7 @@ Variable list$
IF cr ." depends " over .id .list ELSE drop THEN IF cr ." depends " over .id .list ELSE drop THEN
cr drop ; cr drop ;
: d.2 ( n -- ) base push decimal 0 <# # # '. hold #s #> type ; : d.2 ( n -- ) base push decimal 0 <<# # # '. hold #s #> type #>> ;
: .resource ( addr -- ) base push decimal : .resource ( addr -- ) base push decimal
cr ." resource " dup resource id $@ type space cr ." resource " dup resource id $@ type space
...@@ -138,7 +138,7 @@ Variable list$ ...@@ -138,7 +138,7 @@ Variable list$
\ print globals 21apr01py \ print globals 21apr01py
: .iso-date ( n char -- ) base push decimal >r : .iso-date ( n char -- ) base push decimal >r
0 <# # # r@ hold # # r> hold #s #> type ; 0 <<# # # r@ hold # # r> hold #s #> type #>> ;
: .prefix ( addr -- ) global prefix $@ type ; : .prefix ( addr -- ) global prefix $@ type ;
: .files ( addr n suffix n type n -- ) { suffix n1 typ n2 } : .files ( addr n suffix n type n -- ) { suffix n1 typ n2 }
......
regexp-test.fs
View file @ ec52ea5f
...@@ -107,7 +107,7 @@ s" foofoofoo" ?foos1 ...@@ -107,7 +107,7 @@ s" foofoofoo" ?foos1
s// \( \d \d \) ` : \( \d \d \) ` : \( \d \d \) s// \( \d \d \) ` : \( \d \d \) ` : \( \d \d \)
\1 s>number drop 60 * \1 s>number drop 60 *
\2 s>number drop + 60 * \2 s>number drop + 60 *
\3 s>number drop + 0 <# 's' hold #s #> //g ; \3 s>number drop + 0 <<# 's' hold #s #> #>> //g ;
s" bla 12:34:56 fasel 00:01:57 blubber" hms>s s" bla 12:34:56 fasel 00:01:57 blubber" hms>s
s" bla 45296s fasel 117s" str= 0= [IF] .( failed) [THEN] s" bla 45296s fasel 117s" str= 0= [IF] .( failed) [THEN]
......
resources.fs
View file @ ec52ea5f
...@@ -460,7 +460,7 @@ minos ...@@ -460,7 +460,7 @@ minos
Variable ?showpath ?showpath on Variable ?showpath ?showpath on
| : scr# ( -- addr len ) scr @ abs extend | : scr# ( -- addr len ) scr @ abs extend
<# #S s" klB" bounds DO I c@ hold LOOP #> ; <<# #s s" klB" bounds DO I c@ hold LOOP #> #>> ;
: boxhandler ( addr -- ) tflush : boxhandler ( addr -- ) tflush
dup count here count ?showpath @ dup count here count ?showpath @
......
roman.fb
View file @ ec52ea5f
\ inspired by Thinking Forth 31oct04py \ roman numbers 31oct04py Variable column# : symbol ( off -- ) column# @ + s" IVXLCDM " drop + c@ hold ; : oner ( -- ) 0 symbol ; : fiver ( -- ) 1 symbol ; : almost ( q -- ) 1+ symbol oner ; : oners ( n -- ) 0 ?DO oner LOOP ; : digit ( digit -- ) 5 /mod over 4 = IF almost drop ELSE swap oners IF fiver THEN THEN ; : #r ( digit -- digit' ) 10 /mod swap digit 2 column# +! ; : roman ( number -- ) column# off <# #r #r #r #r 0 #> type ; \ inspired by Thinking Forth 31oct04py \ roman numbers 07aug10py Variable column# : symbol ( off -- ) column# @ + s" IVXLCDM " drop + c@ hold ; : oner ( -- ) 0 symbol ; : fiver ( -- ) 1 symbol ; : almost ( q -- ) 1+ symbol oner ; : oners ( n -- ) 0 ?DO oner LOOP ; : digit ( digit -- ) 5 /mod over 4 = IF almost drop ELSE swap oners IF fiver THEN THEN ; : #r ( digit -- digit' ) 10 /mod swap digit 2 column# +! ; : roman ( number -- ) column# off <<# #r #r #r #r 0 #> type #>> ;
\ No newline at end of file \ No newline at end of file
sql.fs
View file @ ec52ea5f
...@@ -88,7 +88,7 @@ database implements ...@@ -88,7 +88,7 @@ database implements
swap dup +in +! move ; swap dup +in +! move ;
: >$ ( addr u -- ) +in off $+ ; : >$ ( addr u -- ) +in off $+ ;
: >0" ( addr u -- addr ) >$ tmpbuf @ ; : >0" ( addr u -- addr ) >$ tmpbuf @ ;
: #+ ( n -- ) extend under dabs <# #S rot sign #> $+ ; : #+ ( n -- ) extend under dabs <<# #S rot sign #> $+ #>> ;
: ,+ ( -- ) state @ IF s" , " $+ THEN state on ; : ,+ ( -- ) state @ IF s" , " $+ THEN state on ;
\ basic operations 01apr98py \ basic operations 01apr98py
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment