Skip to content

gforth
gforth
Verified Commit 9c2a55a8 authored by Bernd Paysan's avatar Bernd Paysan
Browse files
Options

Coding style change: No code after stack comment for multi-line definitions... 

Coding style change: No code after stack comment for multi-line definitions (not completely through; some code will stay in the original format, like the one-screen codes
parent 87e737e7
Hide whitespace changes
Inline Side-by-side
Showing with 408 additions and 522 deletions
Makefile.in
View file @ 9c2a55a8
......@@ -172,9 +172,7 @@ KERN_SRC = \
kernel/aliases0.fs \
kernel/aliases.fs \
kernel/args.fs \
kernel/cloop.fs \
kernel/cond.fs \
kernel/cond-old.fs \
cross.fs \
kernel/errore.fs \
kernel/files.fs \
......
ansi.fs
View file @ 9c2a55a8
......@@ -75,16 +75,18 @@ decimal
User Attr $660 Attr !
: (Attr!) ( attr -- ) dup Attr @ = IF drop EXIT THEN
dup Attr !
ESC[ 0 pn
dup FG> ?dup IF $F xor 30 + ;pn THEN
dup BG> ?dup IF $F xor 40 + ;pn THEN
dup Bold and IF 1 ;pn THEN
dup Underline and IF 4 ;pn THEN
dup Blink and IF 5 ;pn THEN
Invers and IF 7 ;pn THEN
[char] m emit ;
: (Attr!) ( attr -- )
\G set attribute
dup Attr @ = IF drop EXIT THEN
dup Attr !
ESC[ 0 pn
dup FG> ?dup IF $F xor 30 + ;pn THEN
dup BG> ?dup IF $F xor 40 + ;pn THEN
dup Bold and IF 1 ;pn THEN
dup Underline and IF 4 ;pn THEN
dup Blink and IF 5 ;pn THEN
Invers and IF 7 ;pn THEN
[char] m emit ;
' (Attr!) IS Attr!
......@@ -96,7 +98,8 @@ User Attr $660 Attr !
default-out op-vector !
[THEN]
: BlackSpace Attr @ dup BG> Black =
IF drop space
ELSE 0 attr! space attr! THEN ;
: BlackSpace ( -- )
Attr @ dup BG> Black =
IF drop space
ELSE 0 attr! space attr! THEN ;
assert.fs
View file @ 9c2a55a8
......@@ -71,11 +71,12 @@ variable assert-level ( -- a-addr ) \ gforth
: debug-does> DOES> @
IF ['] noop assert-canary ELSE postpone ( THEN ;
: debug: ( -- ) Create false ,
debug-does>
: debug: ( -- )
Create false , debug-does>
comp: >body
]] Literal @ IF [[ [: ]] THEN [[ ;] assert-canary ;
: )else( ]] ) ( [[ ; \ )
: )else( ( --)
]] ) ( [[ ; \ )
comp: drop 2>r ]] ELSE [[ 2r> ;
: else( ['] noop assert-canary ; immediate
......@@ -85,8 +86,8 @@ comp: drop 2>r ]] ELSE [[ 2r> ;
Variable debug-eval
: +-? ( addr u -- flag ) 0= IF drop false EXIT THEN
c@ ',' - abs 1 = ; \ ',' is in the middle between '+' and '-'
: +-? ( addr u -- flag )
0<> swap c@ ',' - abs 1 = and ; \ ',' is in the middle between '+' and '-'
: +debug ( -- )
BEGIN argc @ 1 > WHILE
......@@ -127,7 +128,8 @@ Variable timer-list
: !time ( -- ) ntime timer-tick 2! ;
: @time ( -- delta-f ) ntime timer-tick 2@ d- d>f 1n f* ;
: .time ( -- ) @time
: .time ( -- )
@time
fdup 1e f>= IF 13 9 0 f.rdp ." s " EXIT THEN 1000 fm*
fdup 1e f>= IF 10 6 0 f.rdp ." ms " EXIT THEN 1000 fm*
fdup 1e f>= IF 7 3 0 f.rdp ." µs " EXIT THEN 1000 fm*
......
complex.fs
View file @ 9c2a55a8
......@@ -110,15 +110,17 @@ previous
: zln ( z -- ln[z] ) >polar fswap fln fswap ;
: z0= ( z -- flag ) f0= >r f0= r> and ;
: zsqrt ( z -- sqrt[z] ) zdup z0= 0= IF
fdup f0= IF fdrop fsqrt 0e EXIT THEN
zln z2/ zexp THEN ;
: zsqrt ( z -- sqrt[z] )
zdup z0= 0= IF
fdup f0= IF fdrop fsqrt 0e EXIT THEN
zln z2/ zexp THEN ;
: z** ( z1 z2 -- z1**z2 ) zswap zln z* zexp ;
\ Test: Fibonacci-Zahlen
1e 5e fsqrt f+ f2/ fconstant g 1e g f- fconstant -h
: zfib ( z1 -- fib[z1] ) zdup z>r g 0e zswap z**
zr> zswap z>r -h 0e zswap z** znegate zr> z+
[ g -h f- 1/f ] FLiteral zscale ;
: zfib ( z1 -- fib[z1] )
zdup z>r g 0e zswap z**
zr> zswap z>r -h 0e zswap z** znegate zr> z+
[ g -h f- 1/f ] FLiteral zscale ;
\ complexe Operationen 02mar05py
......@@ -139,8 +141,8 @@ previous
\ complexe Operationen 02mar05py
: zasinh ( z -- asinh[z] ) zdup 1e f+ zover 1e f- z* zsqrt z+ pln ;
: zacosh ( z -- acosh[z] ) zdup 1e x- z2/ zsqrt zswap 1e x+ z2/ zsqrt z+
pln z2* ;
: zacosh ( z -- acosh[z] )
zdup 1e x- z2/ zsqrt zswap 1e x+ z2/ zsqrt z+ pln z2* ;
: zatanh ( z -- atanh[z] ) zdup 1e x+ zln zswap 1e x- znegate pln z- z2/ ;
: zacoth ( z -- acoth[z] ) znegate zdup 1e x- pln zswap 1e x+ pln z- z2/ ;
......
cross.fs
View file @ 9c2a55a8
......@@ -1553,23 +1553,31 @@ variable constflag constflag off
bigendian
[IF]
: DS! ( d addr -- ) tcell bounds swap 1-
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
: DS@ ( addr -- d ) >r 0 0 r> tcell bounds
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP ;
: Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1-
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
: DS! ( d addr -- )
tcell bounds swap 1-
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
: DS@ ( addr -- d )
>r 0 0 r> tcell bounds
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP ;
: Sc! ( n addr -- )
>r s>d r> tchar bounds swap 1-
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
: Sc@ ( addr -- n )
>r 0 0 r> tchar bounds
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
[ELSE]
: DS! ( d addr -- ) tcell bounds
DO maxbyte ud/mod rot I c! LOOP 2drop ;
: DS@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1-
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP ;
: Sc! ( n addr -- ) >r s>d r> tchar bounds
DO maxbyte ud/mod rot I c! LOOP 2drop ;
: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1-
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
: DS! ( d addr -- )
tcell bounds
DO maxbyte ud/mod rot I c! LOOP 2drop ;
: DS@ ( addr -- n )
>r 0 0 r> tcell bounds swap 1-
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP ;
: Sc! ( n addr -- )
>r s>d r> tchar bounds
DO maxbyte ud/mod rot I c! LOOP 2drop ;
: Sc@ ( addr -- n )
>r 0 0 r> tchar bounds swap 1-
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
[THEN]
: S! ( n addr -- ) >r s>d r> DS! ;
......@@ -2010,8 +2018,7 @@ variable ResolveFlag
\ ?touched 11may93jaw
: ?touched ( ghost -- flag ) dup forward? swap >link @
0 <> and ;
: ?touched ( ghost -- flag ) dup forward? swap >link @ 0<> and ;
: .forwarddefs ( ghost -- )
." appeared in:"
......@@ -2106,9 +2113,10 @@ $20 constant restrict-mask
>TARGET
X has? f83headerstring [IF]
: name, ( "name" -- ) bl word count ht-header, X cfalign ;
: name, ( "name" -- ) bl word count ht-header, X cfalign ;
[ELSE]
: name, ( "name" -- ) bl word count
: name, ( "name" -- )
bl word count
dup T cell+ cfoddalign H ht-nlstring, X cfalign ;
[THEN]
: view, ( -- ) ( dummy ) ;
......@@ -2906,7 +2914,8 @@ Cond: DOES>
Ghost do:ghost!
:noname postpone gdoes> ;
: vtghost: ( ghost -- ) Ghost >r
: vtghost: ( ghost -- )
Ghost >r
:noname r> postpone Literal postpone addr, postpone ;
built >do:ghost @ >exec2 ! ;
......@@ -3007,7 +3016,8 @@ End-Struct vtable-struct
I @ ,
cell +LOOP ;
:noname ( -- ) vttemplate @ 0= IF EXIT THEN
:noname ( -- )
vttemplate @ 0= IF EXIT THEN
gvtable-list
BEGIN @ dup WHILE
dup vttemplate vt= IF
......
date.fs
View file @ 9c2a55a8
......@@ -4,8 +4,7 @@
: /mod3 ( n1 n2 -- r q )
dup >r /mod dup 4 = IF drop r@ + 3 THEN rdrop ;
: day2dow ( day -- dow )
2 + 7 mod ;
: day2dow ( day -- dow ) 2 + 7 mod ;
\ julian calendar
......@@ -16,20 +15,21 @@
>r 2 + dup 12 > IF 12 - swap 1+ swap THEN
r> 1+ ;
: (ymd2day) ( y m d -- day year/4 ) 1- -rot
: (ymd2day) ( y m d -- day year/4 )
1- -rot
2 - dup 0<= IF 12 + swap 1- swap THEN
153 5 */ 31 - swap
4 /mod swap 365 * swap >r + + r> ;
: j-ymd2day ( y m d -- day ) (ymd2day)
1461 * + ;
: j-ymd2day ( y m d -- day ) (ymd2day) 1461 * + ;
\ gregorian calendar
1582 10 15 (ymd2day) 2Constant gregorian.
1582 10 5 j-ymd2day Constant gregorian
: day2ymd ( day -- y m d ) dup gregorian >= IF
: day2ymd ( day -- y m d )
dup gregorian >= IF
1 - 146097 /mod 400 * swap
36524 /mod3 100 * rot + swap
j-day2ymd 2>r + 2r>
......@@ -37,7 +37,8 @@
1 + j-day2ymd
THEN ;
: ymd2day ( y m d -- day ) (ymd2day)
: ymd2day ( y m d -- day )
(ymd2day)
2dup gregorian. d< 0= IF
25 /mod swap 1461 * swap
4 /mod swap 36524 * swap
......
debug.fs
View file @ 9c2a55a8
......@@ -48,7 +48,8 @@ get-current also see-voc definitions
: .n ( n -- ) 0 <# # # # # #S #> ctype bl cemit ;
: d.s ( .. -- .. ) ." [ " depth . ." ] "
: d.s ( .. -- .. )
." [ " depth . ." ] "
depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
: NoFine ( -- )
......
fft-bench.fs
View file @ 9c2a55a8
......@@ -9,7 +9,8 @@ require fft.fs
: main setup fft rfft normalize ;
Variable pass
: test ( -- ) main pass on
: test ( -- )
main pass on
#points 0 ?DO
i values z@ fround f>s fround f>s
I $aa and I $55 and d<> IF i . i values z@ z. cr pass off THEN
......
fft.fs
View file @ 9c2a55a8
......@@ -25,28 +25,33 @@ require complex.fs
Carray values
Carray expix
: r+ BEGIN 2dup xor -rot and dup WHILE 1 rshift REPEAT drop ;
: reverse ( n -- ) 2/ dup dup 2* 1
DO dup I < IF dup values I values 2dup z@ z@ z! z! THEN
over r+ LOOP 2drop ;
: r+ ( x1 x2 -- x3 )
BEGIN 2dup xor -rot and dup WHILE 1 rshift REPEAT drop ;
: reverse ( n -- )
2/ dup dup 2* 1
DO dup I < IF dup values I values 2dup z@ z@ z! z! THEN
over r+ LOOP 2drop ;
\ reverse carry add 23sep05py
8 Value #points
: realloc ( n addr -- )
dup @ IF dup @ free throw THEN swap allocate throw swap ! ;
: points ( n --- ) dup to #points dup complex' dup
['] values >body realloc 2/
['] expix >body realloc
dup 0 DO 0e 0e I values z! LOOP
1e 0e 0 expix z! 2/ dup 2/ dup 2/ dup 1+ 1
?DO pi I I' 1- 2* 2* fm*/ fsincos fswap I expix z! LOOP
?DO I' I - 1- expix z@ fswap I 1+ expix z! LOOP dup 2/
?DO I' I - expix z@ fswap fnegate fswap
I expix z! LOOP ;
: .values ( -- ) precision 4 set-precision
#points 0 DO I values z@ z. cr LOOP set-precision ;
: .expix ( -- ) precision 4 set-precision
#points 2/ 0 DO I expix z@ z. cr LOOP set-precision ;
: points ( n --- )
dup to #points dup complex' dup
['] values >body realloc 2/
['] expix >body realloc
dup 0 DO 0e 0e I values z! LOOP
1e 0e 0 expix z! 2/ dup 2/ dup 2/ dup 1+ 1
?DO pi I I' 1- 2* 2* fm*/ fsincos fswap I expix z! LOOP
?DO I' I - 1- expix z@ fswap I 1+ expix z! LOOP dup 2/
?DO I' I - expix z@ fswap fnegate fswap
I expix z! LOOP ;
: .values ( -- )
precision 4 set-precision
#points 0 DO I values z@ z. cr LOOP set-precision ;
: .expix ( -- )
precision 4 set-precision
#points 2/ 0 DO I expix z@ z. cr LOOP set-precision ;
' .values ALIAS .rvalues
\ FFT 23sep05py
......@@ -65,17 +70,19 @@ Carray expix
\ FFT 23sep05py
: (fft ( n flag -- ) swap dup reverse 1
BEGIN 2dup > WHILE dup 2* swap fft-step
REPEAT 2drop drop ;
: (fft ( n flag -- )
swap dup reverse 1
BEGIN 2dup > WHILE dup 2* swap fft-step
REPEAT 2drop drop ;
: fftscale ( r -- )
#points 0 DO I values dup z@ 2 fpick zscale z! LOOP fdrop ;
#points 0 DO I values dup z@ 2 fpick zscale z! LOOP fdrop ;
: normalize ( -- ) #points s>f 1/f fftscale ;
: fft ( -- ) #points true (fft ;
: rfft ( -- ) #points false (fft ;
: hamming ( -- ) #points 0 DO
: hamming ( -- )
#points 0 DO
I values dup z@ pi I #points fm*/ fsin f**2 f2* zscale z!
LOOP ;
\ No newline at end of file
fget.fs
View file @ 9c2a55a8
......@@ -49,15 +49,17 @@ wordlist Constant response-values
Variable response-string
Variable maxnum
: get-rest ( addr -- ) source >in @ /string dup >in +! rot $! ;
: get-rest ( addr -- )
source >in @ /string dup >in +! rot $! ;
: ?cr ( -- )
#tib @ 1 >= IF source 1- + c@ #cr = #tib +! THEN ;
: refill-loop ( -- flag ) base @ >r base off
BEGIN refill ?cr WHILE ['] interpret catch drop >in @ 0= UNTIL
true ELSE maxnum off false THEN r> base ! ;
: response: ( -- ) name
Forth definitions 2dup 1- nextname Variable
#tib @ 1 >= IF source 1- + c@ #cr = #tib +! THEN ;
: refill-loop ( -- flag )
base @ >r base off
BEGIN refill ?cr WHILE ['] interpret catch drop >in @ 0= UNTIL
true ELSE maxnum off false THEN r> base ! ;
: response: ( -- )
name Forth definitions 2dup 1- nextname Variable
response-values set-current nextname here cell - Create ,
DOES> @ get-rest ;
: >response response-values 1 set-order ;
......@@ -128,13 +130,15 @@ Variable data-buffer
: read-to-end ( fid -- )
>r BEGIN $1000 r@ add-chunk $1000 <> UNTIL rdrop ;
: read-chunked ( fid -- ) base @ >r hex >r
: read-chunked ( fid -- )
base @ >r hex >r
BEGIN pad $100 r@ read-line throw WHILE
pad swap s>number drop dup WHILE r@ add-chunk drop
pad 1 r@ read-line throw nip 0= UNTIL
ELSE drop THEN THEN rdrop r> base ! ;
: read-data ( fid -- ) clear-data >r
: read-data ( fid -- )
clear-data >r
Content-Length @ IF
Content-Length $@ s>number drop r> read-sized EXIT THEN
Transfer-Encoding @ IF
......
fi2c.fs
View file @ 9c2a55a8
......@@ -65,7 +65,8 @@ ENVIRON>
s" NULL" groups @ cell+ $!
: scan-ifs ( fd -- ) >r 1
: scan-ifs ( fd -- )
>r 1
BEGIN pad $100 r@ read-line throw WHILE
pad swap
2dup s" #ifdef HAS_" prefix? >r
......@@ -111,7 +112,8 @@ Variable au
THEN
dup 1 8 tcell @ * 1- lshift and negate or ;
: search-magic ( fd -- ) >r
: search-magic ( fd -- )
>r
BEGIN magicbuf 8 r@ read-file throw 8 = WHILE
magicbuf s" Gforth4" tuck str= UNTIL
ELSE true abort" No magic found" THEN
......@@ -134,11 +136,11 @@ Variable bitmap-chars
image-cells @ tcell @ * allocate throw to image
bitmap-chars @ allocate throw to bitmap ;
: read-dictionary ( fd -- ) >r
image image-cells @ tcell @ * r> read-file throw drop ;
: read-dictionary ( fd -- )
>r image image-cells @ tcell @ * r> read-file throw drop ;
: read-bitmap ( fd -- ) >r
bitmap bitmap-chars @ tchars @ * r> read-file throw drop ;
: read-bitmap ( fd -- )
>r bitmap bitmap-chars @ tchars @ * r> read-file throw drop ;
: .08x ( n -- ) 0 <# tcell @ 0 ?DO # # LOOP 'x hold '0 hold #> type ;
: .02x ( n -- ) 0 <# tchars @ 0 ?DO # # LOOP 'x hold '0 hold #> type ;
......@@ -196,8 +198,8 @@ Variable bitmap-chars
: .relocsize ( -- )
bitmap-chars @ .08x ;
: fi2c ( addr u -- ) base @ >r hex
read-image
: fi2c ( addr u -- )
base @ >r hex read-image
\ .\" const static __attribute__ ((__section__ (\".rodata\"))) void* image[" .imagesize ." ] = {" cr .image ." };" cr
.\" static void* image[" .imagesize ." ] = {" cr .image ." };" cr
." #ifdef USE_RELOC" cr
......
filedump.fs
View file @ 9c2a55a8
......@@ -21,14 +21,15 @@
Create buf $10 allot
: dumpline ( addr handle -- flag )
buf $10 rot read-file throw
dup /dump ! $10 <> swap 6 u.r ." : " buf .line cr ;
buf $10 rot read-file throw
dup /dump ! $10 <> swap 6 u.r ." : " buf .line cr ;
: init cr $10 base ! ;
: filedump ( addr count -- ) init r/o bin open-file throw >r
0 BEGIN $10 bounds r@ dumpline UNTIL drop
r> close-file throw ;
: filedump ( addr count -- )
init r/o bin open-file throw >r
0 BEGIN $10 bounds r@ dumpline UNTIL drop
r> close-file throw ;
script? [IF]
: alldump argc @ 1 ?DO I arg 2dup type ." :" filedump LOOP ;
......
fixpath.fs
View file @ 9c2a55a8
......@@ -23,7 +23,8 @@ Variable pathes$ 3 arg pathes$ $!
bounds ?DO I c@ '\' = IF '/' I c! THEN LOOP ;
: fixsemi ( addr u -- )
bounds ?DO I c@ ';' = IF ':' I c! THEN LOOP ;
: cygpath ( path -- ) >r
: cygpath ( path -- )
>r
BEGIN r@ $@ ':' scan WHILE
r@ $@ drop - { index }
r@ index 1 $del
......
float.fs
View file @ 9c2a55a8
......@@ -99,16 +99,17 @@ comp: drop >body postpone ALiteral postpone f! ;
: scratch ( -- addr len )
\G scratchpad for floating point - use space at the end of the user area
next-task udp @ + precision ;
next-task udp @ + precision ;
: zeros ( n -- ) 0 max 0 ?DO '0 emit LOOP ;
: -zeros ( addr u -- addr' u' )
BEGIN dup WHILE 1- 2dup + c@ '0 <> UNTIL 1+ THEN ;
BEGIN dup WHILE 1- 2dup + c@ '0 <> UNTIL 1+ THEN ;
: f$ ( f -- n ) scratch represent 0=
IF 2drop scratch 3 min type rdrop EXIT THEN
IF '- emit THEN ;
: f$ ( f -- n )
scratch represent 0=
IF 2drop scratch 3 min type rdrop EXIT THEN
IF '- emit THEN ;
: f. ( r -- ) \ float-ext f-dot
\G Display (the floating-point number) @i{r} without exponent,
......
fsl-util.fs
View file @ 9c2a55a8
......@@ -155,9 +155,8 @@ TRUE VALUE is-static? \ TRUE for statically allocated structs and arrays
\ | data_ptr | cell_size |
\ ------------------------
: DMARRAY ( cell_size -- ) CREATE 0 , ,
DOES>
@ CELL+
: DMARRAY ( cell_size -- )
CREATE 0 , , DOES> @ CELL+
;
\ Structures
......@@ -165,10 +164,10 @@ TRUE VALUE is-static? \ TRUE for statically allocated structs and arrays
\ | data_ptr | cell_size | id |
\ ----------------------------
: DSARRAY ( cell_size -- ) CREATE 0 , , TYPE-ID ,
DOES>
DUP [ 2 CELLS ] LITERAL + @ SWAP
@ CELL+
: DSARRAY ( cell_size -- )
CREATE 0 , , TYPE-ID ,
DOES> DUP [ 2 CELLS ] LITERAL + @ SWAP
@ CELL+
;
: DARRAY ( cell_size -- )
......@@ -313,8 +312,9 @@ VARIABLE print-width 6 print-width !
: |FRAME ( -- ) POSTPONE R> POSTPONE (unframe) ; IMMEDIATE
\ use a defining word to build locals cgm
: lcl ( n -- ) CREATE ,
DOES> @ FLOATS NEGATE HERE +
: lcl ( n -- )
CREATE ,
DOES> @ FLOATS NEGATE HERE +
;
8 lcl &a 7 lcl &b 6 lcl &c 5 lcl &d
......
gforthrc.fs
View file @ 9c2a55a8
......@@ -17,7 +17,9 @@
\ You should have received a copy of the GNU General Public License
\ along with this program. If not, see http://www.gnu.org/licenses/.
: load-rc ( -- ) s" ~/.gforthrc" open-fpath-file
: load-rc ( -- )
\G if available, load ~/.gforthrc
s" ~/.gforthrc" open-fpath-file
0= IF included1 ELSE drop THEN ;
:noname load-rc defers bootmessage ; is bootmessage
\ No newline at end of file
glocals.fs
View file @ 9c2a55a8
......@@ -792,38 +792,40 @@ colon-sys-xt-offset 3 + to colon-sys-xt-offset
then ;
[IFUNDEF] set-to
: (int-to) ( xt -- ) dup >definer
case
[ ' locals-wordlist ] literal >definer \ value
of >body ! endof
[ ' parse-name ] literal >definer \ defer
of defer! endof
-&32 throw
endcase ;
: (comp-to) ( xt -- ) dup >definer
case
[ ' locals-wordlist ] literal >definer \ value
OF >body POSTPONE Aliteral POSTPONE ! ENDOF
[ ' parse-name ] literal >definer \ defer
OF POSTPONE Aliteral POSTPONE defer! ENDOF
\ !! dependent on c: etc. being does>-defining words
\ this works, because >definer uses >does-code in this case,
\ which produces a relocatable address
[ comp' some-clocal drop ] literal >definer
OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
[ comp' some-wlocal drop ] literal >definer
OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
[ comp' some-dlocal drop ] literal >definer
OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF
[ comp' some-flocal drop ] literal >definer
OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
-&32 throw
endcase ;
: TO ( c|w|d|r "name" -- ) \ core-ext,local
' (int-to) ;
comp: drop comp' drop (comp-to) ;
: (int-to) ( xt -- )
dup >definer
case
[ ' locals-wordlist ] literal >definer \ value
of >body ! endof
[ ' parse-name ] literal >definer \ defer
of defer! endof
-&32 throw
endcase ;
: (comp-to) ( xt -- )
dup >definer
case
[ ' locals-wordlist ] literal >definer \ value
OF >body POSTPONE Aliteral POSTPONE ! ENDOF
[ ' parse-name ] literal >definer \ defer
OF POSTPONE Aliteral POSTPONE defer! ENDOF
\ !! dependent on c: etc. being does>-defining words
\ this works, because >definer uses >does-code in this case,
\ which produces a relocatable address
[ comp' some-clocal drop ] literal >definer
OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
[ comp' some-wlocal drop ] literal >definer
OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
[ comp' some-dlocal drop ] literal >definer
OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF
[ comp' some-flocal drop ] literal >definer
OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
-&32 throw
endcase ;
: TO ( c|w|d|r "name" -- ) \ core-ext,local
' (int-to) ;
comp: drop comp' drop (comp-to) ;
[THEN]
: locals| ( ... "name ..." -- ) \ local-ext locals-bar
......
gray.fs
View file @ 9c2a55a8
......@@ -40,11 +40,12 @@ s" address-unit-bits" environment? 0=
[THEN]
\ if your machine has more bits/au, this assumption wastes space
\ if your machine has fewer bits/au, gray will not work
: (bits/cell) ( -- n ) 1 0 invert dup 1 rshift xor
BEGIN dup 1 = 0= WHILE 1 rshift swap 1+ swap REPEAT drop ;
: (bits/cell) ( -- n )
1 0 invert dup 1 rshift xor
BEGIN dup 1 = 0= WHILE 1 rshift swap 1+ swap REPEAT drop ;
(bits/cell)
warnings @ [IF]
.( You seem to have ) dup 1 cells / . .( bits/address unit) cr
.( You seem to have ) dup 1 cells / . .( bits/address unit) cr
[THEN]
[ELSE]
cells
......
heartbleed.fs
View file @ 9c2a55a8
......@@ -31,7 +31,8 @@ here TLS-heartbleed - Constant heartbleed#
Variable buggy?
: get-heartbleed ( addr u port -- ) >r 2dup r> buggy? off
: get-heartbleed ( addr u port -- )
>r 2dup r> buggy? off
1000000 set-socket-timeout >random
open-socket >r
TLS-header header# r@ write-socket
......
history.fs
View file @ 9c2a55a8
......@@ -121,9 +121,10 @@ Variable setstring \ additional string at cursor for IME
hist-pos 2dup backward^ 2! end^ 2!
THEN r> (ret) ;
: extract-word ( addr len -- addr' len' ) dup >r
BEGIN 1- dup 0>= WHILE 2dup + c@ bl = UNTIL THEN 1+
tuck + r> rot - ;
: extract-word ( addr len -- addr' len' )
dup >r
BEGIN 1- dup 0>= WHILE 2dup + c@ bl = UNTIL THEN 1+
tuck + r> rot - ;
Create prefix-found 0 , 0 ,
......@@ -346,8 +347,8 @@ Variable vt100-modifier
: setcur ( max span addr pos1 -- max span addr pos2 0 )
drop over vt100-modifier @ umin .redraw 0 ;
: setsel ( max span addr pos1 -- max span addr pos2 0 ) >r
2dup swap r@ /string 2dup vt100-modifier @ umin setstring $!
: setsel ( max span addr pos1 -- max span addr pos2 0 )
>r 2dup swap r@ /string 2dup vt100-modifier @ umin setstring $!
vt100-modifier @ over umin >r r@ - over r@ + -rot move
swap r> - swap r> .redraw 0 ;
......
httpd.fs
View file @ 9c2a55a8
......@@ -60,15 +60,16 @@ Variable command?
wordlist constant values
wordlist constant commands
: value: ( -- ) name
Forth definitions 2dup 1- nextname Variable
: value: ( -- )
name Forth definitions 2dup 1- nextname Variable
values set-current nextname here cell - Create ,
DOES> @ get-rest ;
: >values values 1 set-order command? off ;
\ HTTP protocol commands 26mar00py
: rework-% ( add -- ) { url } base @ >r hex
: rework-% ( add -- )
{ url } base @ >r hex
0 url $@len 0 ?DO
url $@ drop I + c@ dup '% = IF
drop 0. url $@ I 1+ /string
......@@ -80,7 +81,8 @@ wordlist constant commands