Commit ec52ea5f authored by bp's avatar bp

Added nested picture number stuff

git-svn-id: https://forth-ev.de/repos/bigforth@1716 3b8d8251-53f3-0310-8f3b-fd1cb8370982
parent 90a171f1
This diff is collapsed.
......@@ -5,7 +5,7 @@ Variable click# click# off
X" There have been no clicks yet" text-label new
dup F bind click-label
^ S[ 1 click# +!
click# @ 0 <# #S s" Number of clicks: " holds #>
click-label assign ]S X" Click me" button new
click# @ 0 <<# #s s" Number of clicks: " holds #>
click-label assign #>> ]S X" Click me" button new
&2 vabox new panel s" Clicks" assign show endwith ;
click-win
This diff is collapsed.
......@@ -239,7 +239,7 @@ stredit implements
IF [defined] filename [IF] filename >len scratch$ $+!
[ELSE] drop [THEN] THEN
S" Line # " scratch$ $+! base push decimal
line#@ 0 <# bl hold # # # #S #> scratch$ $+!
line#@ 0 <<# bl hold # # # #S #> scratch$ $+! #>>
update$ scratch$ $+! scratch$ $@ ;
: maketitle edifile @ 0= ?EXIT
title$ dpy get-dpy window with title! endwith
......
......@@ -108,7 +108,7 @@ scredit implements
: title$ ( -- addr u )
base push decimal
S" Scr # " scratch$ $!
scr# @ 0 <# bl hold # # #S #> scratch$ $+!
scr# @ 0 <<# bl hold # # #S #> scratch$ $+! #>>
scratch$ $@ ;
[ELSE]
: updated? ( -- f ) 'start 4- @ $14 + wx@ 0< ;
......@@ -117,7 +117,7 @@ scredit implements
: title$ ( -- addr u )
base push decimal
edifile @ filename >len scratch$ $!
S" Scr # " scratch$ $+! scr# @ 0 <# bl hold # # #S #> scratch$ $+!
S" Scr # " scratch$ $+! scr# @ 0 <<# bl hold # # #S #> scratch$ $+! #>>
update$ scratch$ $+!
scratch$ $@ ;
[THEN]
......
This diff is collapsed.
This diff is collapsed.
......@@ -2,7 +2,7 @@
: 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
DO spaces I 2 type 7 2 +LOOP drop ;
| : .regs ( -- ) dumped 8 cells +
......@@ -38,8 +38,8 @@
: in_which? ( addr -- len nfa count/false ) cell swap dup @
[ ' push 5 + @ ] ALiteral =
IF swap 3 * swap cell+ 2@ swap
0 <# #S drop bl hold #S
s" push " 1- FOR dup I + c@ hold NEXT drop #> EXIT THEN
0 <<# #S drop bl hold #s
s" push " 1- FOR dup I + c@ hold NEXT drop #> #>> EXIT THEN
@ context @ over noop in_voc?
dup IF nip count $1F and EXIT THEN drop voc-link
BEGIN @ dup WHILE 2dup 8 - swap in_voc? dup
......@@ -48,7 +48,7 @@
| : "name ( nfa count / 0 -- ) ?dup
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 !
S" Level: " $add backtrace 8 cells bounds
?DO I in_which? dup 0= IF I @ swap THEN "name
......
This source diff could not be displayed because it is too large. You can view the blob instead.
This diff is collapsed.
This diff is collapsed.
No preview for this file type
......@@ -464,7 +464,7 @@ struct{
cell hc_wavetable
} gsl_fft_precomputes
| 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 ;
| : (cache-fft) ( n -- addr )
sizeof gsl_fft_precomputes allocate throw >r
......
......@@ -517,16 +517,16 @@ synonym VT[ noop-i
\ number input field 27apr98py
edit-action class number-action
public: cell var nbase
how: : ># ( d -- addr u ) base push nbase @ base ! tuck dabs
<# #S nbase @ $10 = IF '$' hold THEN
nbase @ %10 = IF '%' hold THEN rot sign #> ;
how: : #>text ( d -- addr u ) base push nbase @ base ! tuck dabs
<<# #s nbase @ $10 = IF '$' hold THEN
nbase @ %10 = IF '%' hold THEN rot sign #> #>> ;
: key ( key sh -- ) drop base push nbase @ base !
dup shift-keys? IF drop EXIT THEN dup find-key dup
IF cell+ @ caller send drop
ELSE drop dup digit? nip 0= ?EXIT
sp@ 1 edit with ins drop 1 c drop endwith
THEN stroke @ called send ;
: store ( d -- ) ># edit assign ;
: store ( d -- ) #>text edit assign ;
: fetch ( -- d ) edit get base push decimal s>number ;
: init ( o addr -- ) #10 nbase ! super init ;
class;
......@@ -852,9 +852,9 @@ public: method #>text \ early scalekey
\ new scaler 03dec06py
how: : #>text ( n -- addr u ) base push decimal
text/ @ m* tuck dabs <#
text/ @ m* tuck dabs <<#
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>
fnt select fnt self fnt ' display dpy drawer ;
: get ( -- steps step pos ) super get 0 swap ;
......@@ -938,9 +938,9 @@ public: method #>text \ early scalekey
\ new scaler 08mar07py
how: : #>text ( n -- addr u ) base push decimal
text/ @ m* tuck dabs <#
text/ @ m* tuck dabs <<#
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>
fnt select fnt self fnt ' display dpy drawer ;
: get ( -- steps step pos ) super get 0 swap ;
......
......@@ -826,7 +826,7 @@ how: \ 6 colors defocuscol !
: assign ( size time attr addr len -- ) base push
super assign attr ! time ! size ! ;
: !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" 00:00:00" 0 textsize drop wtime ! ;
[defined] x11 [IF] : dir@ attr @ $C >> ; [THEN]
......@@ -846,8 +846,8 @@ how: \ 6 colors defocuscol !
w @ wdate @ - 6 - 0 p+
time @ >date 2over cc .text
m wtime @ + 0 p- time @ >time 2over cc .text
m wsize @ + 0 p- size @ 0 <# #S #>
2swap cc .text ;
m wsize @ + 0 p- size @ 0 <<# #s #>
2swap cc .text #>> ;
\ file widget 10apr04py
: hglue ( -- glue ) super hglue xM 3 *
......
......@@ -119,7 +119,7 @@ Variable list$
IF cr ." depends " over .id .list ELSE drop THEN
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
cr ." resource " dup resource id $@ type space
......@@ -138,7 +138,7 @@ Variable list$
\ print globals 21apr01py
: .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 ;
: .files ( addr n suffix n type n -- ) { suffix n1 typ n2 }
......
......@@ -107,7 +107,7 @@ s" foofoofoo" ?foos1
s// \( \d \d \) ` : \( \d \d \) ` : \( \d \d \)
\1 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 45296s fasel 117s" str= 0= [IF] .( failed) [THEN]
......
......@@ -460,7 +460,7 @@ minos
Variable ?showpath ?showpath on
| : 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
dup count here count ?showpath @
......
\ 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 ;
\ No newline at end of file
\ 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
......@@ -88,7 +88,7 @@ database implements
swap dup +in +! move ;
: >$ ( addr u -- ) +in off $+ ;
: >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 ;
\ basic operations 01apr98py
......
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
This diff is collapsed.
......@@ -21,7 +21,7 @@ screen self menu-window : win0
0 ' noop edit-action new s" " s" Text:" infotextfield : tfield0
\ 0 edit-action new s" " (textfield : tfield0
: .button button text @ @+ swap tfield0 assign ;
: .pos base push decimal dup 0 <# #s #> tfield0 assign ;
: .pos base push decimal dup 0 <<# #s #> tfield0 assign #>> ;
0 :noname s" Test 0" tfield0 assign ; simple new s" Menu 0" menu-entry : menu0
0 :noname s" Test 1" tfield0 assign ; simple new s" Menu 1" menu-entry : menu1
......
......@@ -81,7 +81,7 @@ descriptors implements
ELSE
set-var @ IF nvar @ number ! 1 nvar +! THEN
." (" item self >class" lctype ." -" number @ 0
<# # # #> type ." )"
<<# # # #> type #>> ." )"
THEN ;
: dump-class ( -- )
item self >class" lctype ;
......
......@@ -51,8 +51,7 @@ ficon: minos-win icons/minos1+"
Variable comp#
: anonymous-component ( -- addr u ) base push hex
comp# @ 0 <# 3 0 ?DO # LOOP #S
S" pmoc" bounds ?DO I c@ hold LOOP #>
comp# @ 0 <<# 3 0 ?DO # LOOP #s s" comp" holds #> #>>
1 comp# +! ;
: new-code ( addr u content -- o )
......@@ -1414,7 +1413,7 @@ Variable $acc
s" .#" +$
cur file-name @ IF cur file-name $@ 2dup '/' -scan nip safe/string +$ THEN
base push hex cur self dup $10 >> + $FFFF and dup $8 >> + $FF and
0 <# '#' hold #S '-' hold #> +$ ;
0 <<# '#' hold #S '-' hold #> +$ #>> ;
: auto-save-name ( -- addr u )
s" " $acc $! auto-save-add
$acc $@ ;
......
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -69,7 +69,7 @@ how:
base @ 8 =
IF 8 umin S" 01ZXLHWU-----D" rot /string 1 min
ELSE base @ 2 = IF 0 tuck ELSE extend tuck dabs THEN
<# bl hold #S rot sign bl hold #> THEN text ;
<<# bl hold #S rot sign bl hold #> #>> THEN text ;
: draw-normal ( path xi addr' addr -- )
?DO 0. rot I @ extend rot extend d- dto
1 0 to
......
......@@ -35,7 +35,7 @@ Constant message
: .16 ( u[d] -- )
[ cell 8 = ] [IF] 0 [THEN]
base @ >r hex <# 16 0 DO # LOOP #> type r> base ! ;
base @ >r hex <<# 16 0 DO # LOOP #> type #>> r> base ! ;
: .state ( -- ) 8 0 DO wurst-state I 64s + 64@ .16 LOOP ;
: .source ( -- ) 8 0 DO wurst-source I 64s + 64@ .16 LOOP ;
......@@ -270,45 +270,45 @@ s" gforth" environment? [IF] 2drop
\ %> a<% r@ 7 and 0 .r %> ^=ROL(rnds[states[<% 0 .r %> ]^(0xff&(t>><% $7 and 8 * 0 .r %> ))],<% r> 7 r@ - 0 .r %> );<% \c, ;
: mix2bytes_ind, ( index n k i -- index n ) >r
>r over r@ 64 +
<#
<<#
s" );" holds r> 7 r@ - 0 #s 2drop >r
s" ))]," holds $7 and 8 * 0 #s 2drop
s" ]^(0xff&(t>>" holds 0 #s 2drop
s" ^=ROL(rnds[states[" holds r@ 7 and 0 #s 2drop
s" a" holds 0. #> \c,
s" a" holds 0. #> \c, #>>
rdrop rdrop ;
: round_ind, ( n -- )
<# s" _ind(unsigned char * states, uint64_t * rnds) {" holds dup 0 # s" static inline void round" holds #> \c,
<<# s" _ind(unsigned char * states, uint64_t * rnds) {" holds dup 0 # s" static inline void round" holds #> \c, #>>
s" uint64_t a0, a1, a2, a3, a4, a5, a6, a7, t;" \c,
round# dup 1- swap 8 0 DO
<#
<<#
s" )),8);" holds I permut# 8 + 64s 0 #S 2drop
s" =ROL(*((uint64_t*)(states+" holds I 0 #S
s" a" holds #> \c,
s" a" holds #> \c, #>
LOOP
8 0 DO
s\" asm volatile(\"# line break\" : : \"g\" (a0), \"g\" (a1), \"g\" (a2), \"g\" (a3), \"g\" (a4), \"g\" (a5), \"g\" (a6), \"g\" (a7));" \c,
<#
<<#
s" ));" holds I 8 * 64 + 0 #s
s" t=*((uint64_t*)(states+" holds #> \c,
s" t=*((uint64_t*)(states+" holds #> \c, #>>
8 0 DO I J 8 * + J mix2bytes_ind,
dup >r 8 * + $3F and r>
LOOP dup >r + $3F and r>
LOOP
2drop
8 0 DO
<#
<<#
s" ;" holds I 0 #s 2drop
s" )) = a" holds I 16 + 64s 0 #s
s" *((uint64_t *)(states+" holds
#> \c,
#> \c, #>>
LOOP
8 0 DO
<#
<<#
s" ));" holds I 8 + 64s 0 #s 2drop
s" )) ^= *((uint64_t *)(states+" holds I 64s 0 #s
s" *((uint64_t *)(states+" holds
#> \c,
#> \c, #>>
LOOP
s" memcpy(states+64, states+128, 64); }" \c, ;
......@@ -533,7 +533,7 @@ Create 'round-flags
: read-first32 ( flags -- n ) wurst-size32 >reads >r
message state#32 r> * 2 2* /string wurst-in read-file throw 2 2* + ;
: .4h ( u -- )
0 base @ >r hex <# # # # # #> type r> base ! ;
0 base @ >r hex <<# # # # # #> type #>> r> base ! ;
: .source32 ( -- ) 2 0 DO wurst-source I 2* + w@ .4h LOOP ;
: .state32 ( -- ) 2 0 DO wurst-state I 2* + w@ .4h LOOP ;
......
Markdown is supported
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