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
\\ Ach ja, die leidigen Benchmarks. 30jan93pyAlle Benchmarks auer der auf Block 6 sind iterativ. Da FORTH konzeptionell weder eine Ausdrucksverwertung machen mu noch kann, gibt das natrlich im Vergleich mit Assembler ineffektivenCode. Als Beispiel habe ich die Iteration von "Wundersam" aus Hofstadters "Gdel, Escher, Bach" und den Byte-Benchmark "Sieb des Erathostenes" auch in Assembler geschrieben, ersterer bietet hier einen Zeitvorteil um den Faktor 4. Wer nun neidisch nach Turbo-C schielt (weil das fast den selben Code produziert wie ich von Hand), dem sei gesagt: Ein Programm besteht ja auch zu einem nicht geringen Teil aus Subroutine- Calls, und die sind in unserem FORTH nunmal konzeptionell schneller, weil wir berhaupt keine Register sichern mssen und keine Stack-Frames brauchen. tsch! Denn ganz um diesen unnti- gen Krampf wird Turbo-C auch nicht 'rumkommen. FORTH ist nunmal Subroutinen-optimiert, das kann niemand schneller. \ Benchmarks 19aug92py VARIABLE TOFFSET : .TIME BASE @ DECIMAL TIMER@ TIME @ - TOFFSET @ - 0 <# # # # $2C HOLD #S #> TYPE ." sec " BASE ! ; : TEST0 TOFFSET OFF !TIME $FFFFF 0 DO LOOP TIMER@ TIME @ - .TIME TOFFSET ! ; : TEST1 !TIME 0 $FFFFF 0 DO NEGATE LOOP DROP .TIME ; : TEST2 !TIME 0 $FFFFF 0 DO 1 + LOOP DROP .TIME ; : TEST3 !TIME 0 $FFFFF 0 DO $12345678 + LOOP DROP .TIME ; : TEST4 !TIME 0 $FFFFF 0 DO DUP DROP LOOP DROP .TIME ; : TEST5 !TIME 0 $FFFFF 0 DO I DROP LOOP DROP .TIME ; : TEST6 !TIME 0 $FFFFF 0 DO I NIP LOOP DROP .TIME ; : TEST7 !TIME $FFFFF 0 DO 5000 @ 5000 ! LOOP .TIME ; : TEST8 PAD PAD ! PAD !TIME $FFFFF 0 DO @ LOOP DROP .TIME ; \ Wundersam 25jul88py: wundersam ( n -- n trial# ) dup 0 BEGIN over 1- WHILE 1+ under 0> WHILE dup 1 and IF dup dup + + 1+ ELSE 2/ THEN swap REPEAT THEN nip ; : .wundersam ( n -- ) wundersam swap . ." ist " dup 0< IF ." nicht " THEN ." 'wundersam'. (" . ." Versuche)" ; : seltsam ( start -- ) 0 >r BEGIN wundersam r> 2dup > IF drop 2dup >r cr &10 .r ." :" &5 .r ELSE >r drop THEN 1+ stop? UNTIL rdrop drop ; \\ Eine Zahl ist seltsam, wenn zur Ableitung ihrer Wundersamkeit mehr Schritte bentigt werden, als zur Ableitung derer aller vorhergehenden Zahlen (wenn alle Zahlen wundersam sind...). \ Wundersam 25jul88py Code wundersam ( n -- n trial# ) SP ) D0 move 0 D1 moveq BEGIN 1 # D0 lsr cs IF 0= IF D1 SP -) move Next THEN D0 D0 addx D0 D2 move D2 D0 add D2 D0 add 1 D0 addq THEN 1 D1 addq cs UNTIL -1 D1 moveq D1 SP -) move Next end-code \\ R: Eine gerade Zahl n ist wundersam, wenn n/2 wundersam ist. R: Eine ungerade Zahl n ist wundersam, wenn 3n+1 wundersam ist. Axiom: 1 ist wundersam. Nach: Theo Schildkrte aus Hofstadters "Gdel, Escher, Bach" Wundersam in Assembler ist ungefhr 4* so schnell, wie in FORTH \ Primes (Erathostenes, wie immer) 16jan00py$1FFE CONSTANT 8190 CREATE FLAGS 8190 ALLOT \ ^ die grte Zahl, die auch der bldste Compiler noch packt. : PRIMZAHLEN FLAGS 8190 1 FILL 0 8190 0 DO FLAGS I + C@ IF I DUP + 3+ DUP I + BEGIN DUP 8190 < WHILE 0 OVER FLAGS + C! OVER + REPEAT 2DROP 1+ THEN LOOP 1899 - ABORT" Fehler!" ; : BENCHMARK !TIME 100 0 DO PRIMZAHLEN LOOP .TIME ; \ So geht's schneller (optimiertes FORTH): 25jan04py$1FFE CONSTANT 8190 CREATE FLAGS 8190 ALLOT \ ^ die grte Zahl, die auch der bldste Compiler noch packt. : PRIMZAHLEN FLAGS 8190 1 FILL 0 3 FLAGS 8190 + FLAGS DO I C@ IF DUP I + DUP [ 8190 FLAGS + ] ALITERAL < IF [ 8190 FLAGS + ] ALITERAL OVER DO 0 I C! OVER +LOOP THEN DROP SWAP 1+ SWAP THEN 2+ LOOP DROP ; : BENCHMARK !TIME &100 0 DO PRIMZAHLEN &1899 - abort" Error!" LOOP .TIME ; \ Primes: Zum Vergleich in Assembler 16jan00py$1FFE CONSTANT 8190 CREATE FLAGS 8190 ALLOT \ ^ die grte Zahl, die auch der bldste Compiler noch packt. : PRIMZAHLEN DUP FLAGS 8190 1 FILL >c: pusha Flags A# SI mov SI DI mov Flags 8190 + 1- A# BX mov AX AX xor DX DX xor 8190 # CX mov 3 # BP mov .align DO .b 0 # SI ) cmp 0<> IF SI DI mov DX inc AHEAD .align BEGIN AL DI ) mov BUT THEN BP DI add BX DI cmp >= UNTIL THEN SI inc 2 # BP add LOOP DX $1C SP D) mov popa ;c: ; : BENCHMARK !TIME &100 0 DO PRIMZAHLEN DROP LOOP .TIME ; \ Und hier noch 'n paar rekursive Benchmarks 12jul98py: fib ( n -- fib[n] ) recursive 2- dup 0<= IF drop 1 exit THEN dup 1+ fib swap fib + ; : fibi ( iterative version von FIB ) 2- dup 0> 0= IF drop 1 exit THEN 1 1 rot 0 ?DO over + swap LOOP drop ; \ Ach ja: Die Rekursive Version hat ein unmgliches Zeitverhal- \ ten, jeder nchste Wert braucht ~(1+5)/2 mal solange! ( x=1+1/x , Zeit der letzten plus Zeit der vorletzen Zahl ) : x=1+1/x ( -- ) base push decimal 0 &1000000000 BEGIN &1000000000 dup dup 3 pick */ + rot drop 2dup - abs 2 < UNTIL 0 <# # # # bl hold # # # bl hold # # # ', hold #S #> type space drop ; \ Ostertermine 16jan92py Create Dfeld &200 cells allot : func ( n -- func ) dup &19 qmod dup 7 q* 1+ &19 q/ swap &11 q* 4+ swap - &29 qmod over 4/ rot + &31 + over - 7 qmod &25 swap - swap - ; : ostern &200 0 DO i func i cells dfeld + ! LOOP ; : .2 0 <# # # #> type ; : .ostern cr ." Ostertermine:" cr base push decimal &200 0 DO i cells dfeld + @ dup 0> IF .2 ." apr" ELSE &31 + .2 ." mar" THEN i .2 2 spaces ?cr LOOP ; \ Ackermann 13apr93py: .a compile BEGIN drop ; immediate restrict : ack ( m n -- ack ) recursive over 0= IF 1+ nip exit THEN dup 0= IF drop 1- 1 ack exit THEN >r 1- dup 1+ r> 1- ack ack ; : ackf ( m n -- ack ) recursive \ ?ack over 3 = IF 3 + >r 1 r> << 3 - nip exit THEN over 2 = IF 2* 3 + nip exit THEN over 1 = IF 2+ nip exit THEN over 0= IF 1+ nip exit THEN dup 0= IF drop 1- 1 ackf ELSE >r 1- dup 1+ r> 1- ackf ackf THEN ; : acki ( m n -- ack ) recursive \ ?ack \ <--fr Speed weglassen! BEGIN BEGIN over 0= IF 1+ nip exit .a THEN dup 0= WHILE drop 1- 1 AGAIN .a THEN >r 1- dup 1+ r> 1- acki AGAIN ; \ falcon speed test 04mar08pyalso memory $1000000 Constant memsz : .kbs ( b/sec -- ) &10 rshift &1000000 timer@ time @ - >us drop */ . ." KBytes/sec " ; ( $4E714E71) $BA constant $code : memtest cr base push decimal memsz 2+ NewPtr >r r@ memsz 5 / 5 * $code fill $C3 r@ memsz 5 / 5 * + c! ." Code: " !time r@ $7F FOR dup execute NEXT drop $80 memsz * .kbs ." (P55-200 121594/486DX50 82397/386DX33 21801/ST 3775)" cr ." Fill: " !time r@ $7F FOR dup memsz erase NEXT drop $80 memsz * .kbs ." (P55-200 82522/486DX50 47440/386DX33 25761/ST 2864)" cr ." Move: " !time r@ $7F FOR dup dup memsz 2/ + swap memsz 2/ move NEXT drop $80 memsz 2/ * .kbs r> DisposPtr ." (P55-200 45189/486DX50 24561/386DX33 14160/ST 1360)" ; toss\ falcon speed test 12mar00py $A load 5 load 9 load cr \ ." Load: " null \ !time include ans.str standardi/o .time cr close bench.scr \ ." (486DX50 1,485/ST 33,716 sec)" cr \ ." Forget: " !time forget ans.str .time cr \ ." (486DX50 0,056/ST 1,315 sec)" cr : test !time FOR 3 6 ack drop NEXT .time ; ." Primes: " benchmark ." (P55-200 0,109/486DX50 1,281/386DX33 3,069/ST 28,375)" cr ." recurse: " 9 test ." (P55-200 0,173/486DX50 1,466/386DX33 3,611/ST 34,770)" memtest forget .kbs clear \ Terminal test 15mar00py : char/sec ( n -- ) base push decimal page timer@ over 0 ?DO '# emit LOOP timer@ swap - >us drop swap &1000 * &10000000 rot */ 0 <# # # # # ', hold #S #> type ; \ Rafael Delianos EC-Benchmark 02dec93py 5 Constant five Variable bvar : bench $100 0 DO 1 BEGIN dup swap tuck swap drop 1 and IF five + ELSE 1- THEN bvar ! bvar @ dup $100 and UNTIL drop LOOP ; \ taskswitch time 10jan94py : subtask ( n -- ) 1 $200 $200 NewTask pass 0 ?DO pause LOOP ; : maintask ( n -- ) dup subtask 0 ?DO pause LOOP ; : .3 ( u -- ) 0 <# # # # ', hold #S #> type ; : /task ( n -- ) !time dup maintask 2* timer@ time @ - ( gives ms ) over cr . ." task switchs in " dup .3 ." seconds " 2dup / . ." task switchs/ms " &1000000 rot */ .3 ." us/task switch" ;
\ No newline at end of file
\\ Ach ja, die leidigen Benchmarks. 30jan93pyAlle Benchmarks auer der auf Block 6 sind iterativ. Da FORTH konzeptionell weder eine Ausdrucksverwertung machen mu noch kann, gibt das natrlich im Vergleich mit Assembler ineffektivenCode. Als Beispiel habe ich die Iteration von "Wundersam" aus Hofstadters "Gdel, Escher, Bach" und den Byte-Benchmark "Sieb des Erathostenes" auch in Assembler geschrieben, ersterer bietet hier einen Zeitvorteil um den Faktor 4. Wer nun neidisch nach Turbo-C schielt (weil das fast den selben Code produziert wie ich von Hand), dem sei gesagt: Ein Programm besteht ja auch zu einem nicht geringen Teil aus Subroutine- Calls, und die sind in unserem FORTH nunmal konzeptionell schneller, weil wir berhaupt keine Register sichern mssen und keine Stack-Frames brauchen. tsch! Denn ganz um diesen unnti- gen Krampf wird Turbo-C auch nicht 'rumkommen. FORTH ist nunmal Subroutinen-optimiert, das kann niemand schneller. \ Benchmarks 07aug10py VARIABLE TOFFSET : .TIME BASE @ DECIMAL TIMER@ TIME @ - TOFFSET @ - 0 <<# # # # $2C HOLD #S #> TYPE #>> ." sec " BASE ! ; : TEST0 TOFFSET OFF !TIME $FFFFF 0 DO LOOP TIMER@ TIME @ - .TIME TOFFSET ! ; : TEST1 !TIME 0 $FFFFF 0 DO NEGATE LOOP DROP .TIME ; : TEST2 !TIME 0 $FFFFF 0 DO 1 + LOOP DROP .TIME ; : TEST3 !TIME 0 $FFFFF 0 DO $12345678 + LOOP DROP .TIME ; : TEST4 !TIME 0 $FFFFF 0 DO DUP DROP LOOP DROP .TIME ; : TEST5 !TIME 0 $FFFFF 0 DO I DROP LOOP DROP .TIME ; : TEST6 !TIME 0 $FFFFF 0 DO I NIP LOOP DROP .TIME ; : TEST7 !TIME $FFFFF 0 DO 5000 @ 5000 ! LOOP .TIME ; : TEST8 PAD PAD ! PAD !TIME $FFFFF 0 DO @ LOOP DROP .TIME ; \ Wundersam 25jul88py: wundersam ( n -- n trial# ) dup 0 BEGIN over 1- WHILE 1+ under 0> WHILE dup 1 and IF dup dup + + 1+ ELSE 2/ THEN swap REPEAT THEN nip ; : .wundersam ( n -- ) wundersam swap . ." ist " dup 0< IF ." nicht " THEN ." 'wundersam'. (" . ." Versuche)" ; : seltsam ( start -- ) 0 >r BEGIN wundersam r> 2dup > IF drop 2dup >r cr &10 .r ." :" &5 .r ELSE >r drop THEN 1+ stop? UNTIL rdrop drop ; \\ Eine Zahl ist seltsam, wenn zur Ableitung ihrer Wundersamkeit mehr Schritte bentigt werden, als zur Ableitung derer aller vorhergehenden Zahlen (wenn alle Zahlen wundersam sind...). \ Wundersam 25jul88py Code wundersam ( n -- n trial# ) SP ) D0 move 0 D1 moveq BEGIN 1 # D0 lsr cs IF 0= IF D1 SP -) move Next THEN D0 D0 addx D0 D2 move D2 D0 add D2 D0 add 1 D0 addq THEN 1 D1 addq cs UNTIL -1 D1 moveq D1 SP -) move Next end-code \\ R: Eine gerade Zahl n ist wundersam, wenn n/2 wundersam ist. R: Eine ungerade Zahl n ist wundersam, wenn 3n+1 wundersam ist. Axiom: 1 ist wundersam. Nach: Theo Schildkrte aus Hofstadters "Gdel, Escher, Bach" Wundersam in Assembler ist ungefhr 4* so schnell, wie in FORTH \ Primes (Erathostenes, wie immer) 16jan00py$1FFE CONSTANT 8190 CREATE FLAGS 8190 ALLOT \ ^ die grte Zahl, die auch der bldste Compiler noch packt. : PRIMZAHLEN FLAGS 8190 1 FILL 0 8190 0 DO FLAGS I + C@ IF I DUP + 3+ DUP I + BEGIN DUP 8190 < WHILE 0 OVER FLAGS + C! OVER + REPEAT 2DROP 1+ THEN LOOP 1899 - ABORT" Fehler!" ; : BENCHMARK !TIME 100 0 DO PRIMZAHLEN LOOP .TIME ; \ So geht's schneller (optimiertes FORTH): 25jan04py$1FFE CONSTANT 8190 CREATE FLAGS 8190 ALLOT \ ^ die grte Zahl, die auch der bldste Compiler noch packt. : PRIMZAHLEN FLAGS 8190 1 FILL 0 3 FLAGS 8190 + FLAGS DO I C@ IF DUP I + DUP [ 8190 FLAGS + ] ALITERAL < IF [ 8190 FLAGS + ] ALITERAL OVER DO 0 I C! OVER +LOOP THEN DROP SWAP 1+ SWAP THEN 2+ LOOP DROP ; : BENCHMARK !TIME &100 0 DO PRIMZAHLEN &1899 - abort" Error!" LOOP .TIME ; \ Primes: Zum Vergleich in Assembler 16jan00py$1FFE CONSTANT 8190 CREATE FLAGS 8190 ALLOT \ ^ die grte Zahl, die auch der bldste Compiler noch packt. : PRIMZAHLEN DUP FLAGS 8190 1 FILL >c: pusha Flags A# SI mov SI DI mov Flags 8190 + 1- A# BX mov AX AX xor DX DX xor 8190 # CX mov 3 # BP mov .align DO .b 0 # SI ) cmp 0<> IF SI DI mov DX inc AHEAD .align BEGIN AL DI ) mov BUT THEN BP DI add BX DI cmp >= UNTIL THEN SI inc 2 # BP add LOOP DX $1C SP D) mov popa ;c: ; : BENCHMARK !TIME &100 0 DO PRIMZAHLEN DROP LOOP .TIME ; \ Und hier noch 'n paar rekursive Benchmarks 07aug10py: fib ( n -- fib[n] ) recursive 2- dup 0<= IF drop 1 exit THEN dup 1+ fib swap fib + ; : fibi ( iterative version von FIB ) 2- dup 0> 0= IF drop 1 exit THEN 1 1 rot 0 ?DO over + swap LOOP drop ; \ Ach ja: Die Rekursive Version hat ein unmgliches Zeitverhal- \ ten, jeder nchste Wert braucht ~(1+5)/2 mal solange! ( x=1+1/x , Zeit der letzten plus Zeit der vorletzen Zahl ) : x=1+1/x ( -- ) base push decimal 0 &1000000000 BEGIN &1000000000 dup dup 3 pick */ + rot drop 2dup - abs 2 < UNTIL 0 <<# # # # bl hold # # # bl hold # # # ', hold #S #> type #>> space drop ; \ Ostertermine 07aug10py Create Dfeld &200 cells allot : func ( n -- func ) dup &19 qmod dup 7 q* 1+ &19 q/ swap &11 q* 4+ swap - &29 qmod over 4/ rot + &31 + over - 7 qmod &25 swap - swap - ; : ostern &200 0 DO i func i cells dfeld + ! LOOP ; : .2 0 <<# # # #> type #>> ; : .ostern cr ." Ostertermine:" cr base push decimal &200 0 DO i cells dfeld + @ dup 0> IF .2 ." apr" ELSE &31 + .2 ." mar" THEN i .2 2 spaces ?cr LOOP ; \ Ackermann 13apr93py: .a compile BEGIN drop ; immediate restrict : ack ( m n -- ack ) recursive over 0= IF 1+ nip exit THEN dup 0= IF drop 1- 1 ack exit THEN >r 1- dup 1+ r> 1- ack ack ; : ackf ( m n -- ack ) recursive \ ?ack over 3 = IF 3 + >r 1 r> << 3 - nip exit THEN over 2 = IF 2* 3 + nip exit THEN over 1 = IF 2+ nip exit THEN over 0= IF 1+ nip exit THEN dup 0= IF drop 1- 1 ackf ELSE >r 1- dup 1+ r> 1- ackf ackf THEN ; : acki ( m n -- ack ) recursive \ ?ack \ <--fr Speed weglassen! BEGIN BEGIN over 0= IF 1+ nip exit .a THEN dup 0= WHILE drop 1- 1 AGAIN .a THEN >r 1- dup 1+ r> 1- acki AGAIN ; \ falcon speed test 04mar08pyalso memory $1000000 Constant memsz : .kbs ( b/sec -- ) &10 rshift &1000000 timer@ time @ - >us drop */ . ." KBytes/sec " ; ( $4E714E71) $BA constant $code : memtest cr base push decimal memsz 2+ NewPtr >r r@ memsz 5 / 5 * $code fill $C3 r@ memsz 5 / 5 * + c! ." Code: " !time r@ $7F FOR dup execute NEXT drop $80 memsz * .kbs ." (P55-200 121594/486DX50 82397/386DX33 21801/ST 3775)" cr ." Fill: " !time r@ $7F FOR dup memsz erase NEXT drop $80 memsz * .kbs ." (P55-200 82522/486DX50 47440/386DX33 25761/ST 2864)" cr ." Move: " !time r@ $7F FOR dup dup memsz 2/ + swap memsz 2/ move NEXT drop $80 memsz 2/ * .kbs r> DisposPtr ." (P55-200 45189/486DX50 24561/386DX33 14160/ST 1360)" ; toss\ falcon speed test 12mar00py $A load 5 load 9 load cr \ ." Load: " null \ !time include ans.str standardi/o .time cr close bench.scr \ ." (486DX50 1,485/ST 33,716 sec)" cr \ ." Forget: " !time forget ans.str .time cr \ ." (486DX50 0,056/ST 1,315 sec)" cr : test !time FOR 3 6 ack drop NEXT .time ; ." Primes: " benchmark ." (P55-200 0,109/486DX50 1,281/386DX33 3,069/ST 28,375)" cr ." recurse: " 9 test ." (P55-200 0,173/486DX50 1,466/386DX33 3,611/ST 34,770)" memtest forget .kbs clear \ Terminal test 07aug10py : char/sec ( n -- ) base push decimal page timer@ over 0 ?DO '# emit LOOP timer@ swap - >us drop swap &1000 * &10000000 rot */ 0 <<# # # # # ', hold #S #> type #>> ; \ Rafael Delianos EC-Benchmark 02dec93py 5 Constant five Variable bvar : bench $100 0 DO 1 BEGIN dup swap tuck swap drop 1 and IF five + ELSE 1- THEN bvar ! bvar @ dup $100 and UNTIL drop LOOP ; \ taskswitch time 07aug10py : subtask ( n -- ) 1 $200 $200 NewTask pass 0 ?DO pause LOOP ; : maintask ( n -- ) dup subtask 0 ?DO pause LOOP ; : .3 ( u -- ) 0 <<# # # # ', hold #S #> type #>> ; : /task ( n -- ) !time dup maintask 2* timer@ time @ - ( gives ms ) over cr . ." task switchs in " dup .3 ." seconds " 2dup / . ." task switchs/ms " &1000000 rot */ .3 ." us/task switch" ;
\ No newline at end of file
......@@ -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
\\ *** Disassembler for the i486 *** 08nov92py \ i486 disassembler loadscreen 19may97py Module Disass base @ $8 base ! Variable cp? 1 ?head ! \ alle Disassembler-Worte headerless 1 capacity 2- +thru export dis disw disline .86 .386 ; base ! Module; \ long words and presigns 31dec92py : .# '# emit ; : .$ '$ emit ; : ., ', emit ; : .+ '+ emit ; : .- '- emit ; : .. '. emit ; : .: ': emit ; : .[ '[ emit ; : .] '] emit ; : cr? col IF cr THEN ; \ signed / unsigned byte, word and long output 25dec93py : .lformat ( addr -- ) $8 u.r ." :" ; : .du ( n -- ) 0 <# #s #> type ; : .$du ( n -- ) .$ .du ; : .$ds ( n -- ) dup 0< IF .- negate THEN .$du ; : .by ( 8b -- ) 0 <# # # #> type ; : .$bu ( 8b -- ) .$ .by ; : .$bs ( 8b -- ) $FF and dup $7F > IF .- $100 swap - THEN .$bu ; : .dump ( addr len -- ) bounds DO i c@ .by LOOP ; \ Variables and tabs 16nov97py Variable opcode Variable mode Variable length Variable alength Variable .length Variable .alength Variable seg: seg: on &36 constant bytfld : tab row swap at ; &10 constant mnefld &18 constant addrfld : tab1 addrfld col - 1 max spaces ; : l! .length @ length ! .alength @ alength ! seg: on ; : t, swap c, c, ' A, '" parse here $A allot place ; \ Strings 07feb93pyCreate "regs ," AXCXDXBXSPBPSIDIALCLDLBLAHCHDHBH" Create "16ri ," BX+SIBX+DIBP+SIBP+DISI DI BP BX " Create "ptrs ," DWORDWORD BYTE " Create "idx ," *2*4*8" Create "seg ," ESCSSSDSFSGS" Create "seg1 ," escsssdsfsgs" Create "jmp ," o b z bes p l le" Create grp1 ," addor adcsbbandsubxorcmprolrorrclrcrshlshrsalsar"Create grp3 ," testtestnot neg mul imuldiv idiv" Create grp4 ," inc dec call callfjmp jmpf push g4?? " Create grp6 ," sldtstr lldtltr verrverwg6??g6??sgdtsidtlgdtlidtsmswg7??lmswg7??" Create grp8 ," ???? src" 2 "regs c! 5 "16ri c! 5 "ptrs c! 2 "idx c! 2 "seg c! 2 "seg1 c! 2 "jmp c! 3 grp1 c! 4 grp3 c! 5 grp4 c! 4 grp6 c! 1 grp8 c! \ Register display 05dec92py : *." ( n addr -- ) count >r swap r@ * + r> -trailing type ; : .(reg ( n l -- ) dup 0= IF drop 'E emit ELSE 2 = IF 8+ THEN THEN "regs *." ; : .reg ( n -- ) length @ .(reg ; : .ereg ( n -- ) 'E emit "regs *." ; : .seg ( n -- ) "seg *." ; : mod@ ( addr -- addr' r/m reg ) count dup 70 and 3 >> swap 307 and swap ; : .8b ( addr -- addr' ) count .$bs ; : .32b ( addr -- addr' ) dup @ .$ds 4+ ; : .32u ( addr -- addr' ) dup @ .$du 4+ ; \ Register display 05dec92py Table: .disp noop .8b .32b [ : .sib ( addr mod -- addr' ) >r count dup 7 and 5 = r@ 0= and IF rdrop >r .32b r> ELSE swap r> cells .disp + perform swap dup 7 and .[ .ereg .] THEN 3 >> dup 7 and 4 = 0= IF .[ dup 7 and .ereg 3 >> "idx *." .] ELSE drop THEN ; : .32a ( addr r/m -- addr' ) dup 7 and >r 6 >> dup 3 = IF drop r> .reg exit THEN dup 0= r@ 5 = and IF drop rdrop .[ .32u .] exit THEN r@ 4 = IF rdrop .sib exit THEN cells .disp + perform r> .[ .ereg .] ; \ Register display 29may10py : wcount ( addr -- addr' w ) w@+ swap ; : wxcount ( addr -- addr' w ) wx@+ swap ; : +8b ( addr -- addr' ) count .$bs ; : +16b ( addr -- addr' ) wcount .$ds ; Table: .16disp noop +8b +16b [ : .16r ( reg -- ) .[ "16ri *." .] ; : .16a ( addr r/m -- addr' ) 307 and dup 006 = IF drop wcount .[ .$du .] exit THEN dup 7 and >r 6 >> dup 3 = IF drop r> .reg exit THEN cells .16disp + perform r> .16r ; \ Register display 01jan93py : .addr ( addr r/m -- addr' ) seg: @ 0< 0= IF seg: @ .seg ': emit THEN alength @ IF .16a ELSE .32a THEN ; : .ptr ( addr r/m -- addr' ) dup 300 < IF length @ "ptrs *." ." PTR " THEN .addr ; : .mod ( addr -- addr' ) mod@ .reg ., .addr ; : .rmod ( addr -- addr' ) mod@ >r .addr r> ., .reg ; : .imm ( addr -- addr' ) length @ dup 0= IF drop dup @ .$ds 4+ exit THEN 1 = IF wcount .$ds exit THEN count .$bs ; \ .ari 07feb93py forward .code : .b? ( -- ) opcode @ 1 and 0= IF 2 length ! THEN ; : .ari .b? tab1 opcode @ dup 4 and IF drop 0 .reg ., .imm exit THEN 2 and IF .mod ELSE .rmod THEN ; : .modt tab1 .mod ; : .gr tab1 opcode @ 7 and .reg ; : .igrv .gr ., .imm ; : .igrb 2 length ! .igrv ; : .igr .b? .igrv ; : .modb .b? tab1 .rmod ; : .xcha .gr ., 0 .reg ; \ .conds modifier 29may10py : .cond ( -- ) opcode @ 17 and dup 1 and IF Ascii n emit THEN 2/ "jmp *." ; : .jb tab1 count dup $80 and IF -$80 or THEN over + .$du ; : .jv tab1 alength @ IF wxcount over ELSE dup @ swap 4+ under THEN + .$du ; : .js .cond .jb ; : .jl .cond .jv ; : .set .cond tab1 mod@ drop 2 length ! .ptr ; : asize alength @ invert alength ! .code ; : osize length @ 1 xor length ! .code ; : .seg: opcode @ 3 >> 3 and seg: ! .code ; : .segx opcode @ 1 and 4+ seg: ! .code ; : .pseg tab1 opcode @ 3 >> 7 and .seg ; \ .grp1 .grp4 .adj .arpl 05dec92py: .grp1 .b? mod@ grp1 *." tab1 .ptr ., opcode @ 3 and 3 = IF 2 length ! THEN .imm ; : .grp2 .b? mod@ 8+ grp1 *." tab1 .ptr ., opcode @ 2 and IF ." CL" ELSE ." 1" THEN ; : .grp3 .b? mod@ dup >r grp3 *." tab1 r@ 3 > IF 0 .reg ., THEN r@ 2 4 within IF .ptr ELSE .addr THEN r> 2 < IF ., .imm THEN ; : .grp4 .b? mod@ dup grp4 *." tab1 2+ 7 and 4 < IF .ptr ELSE .addr THEN ; : .adj opcode @ dup $10 and IF Ascii a ELSE Ascii d THEN emit Ascii a emit $8 and IF Ascii s ELSE Ascii a THEN emit ; : .seg# .[ dup alength @ 2* 4+ + wcount .$du .: swap alength @ IF wcount .$du ELSE .32u THEN .] drop ; \ .movo .movx .str 23jan93py: .movo tab1 .b? opcode @ 2 and 0= IF 0 .reg ., THEN $05 alength @ - .addr opcode @ 2 and IF ., 0 .reg THEN ; : .movx tab1 mod@ .reg ., 1 length ! .b? .ptr ; : .movi .b? tab1 mod@ drop .ptr ., .imm ; : .movs tab1 mod@ opcode @ 2 and IF .seg ., .addr ELSE >r .addr ., r> .seg THEN ; : .str .b? " dwb" 1+ length @ + c@ emit ; : .far tab1 .seg# ; : .modiv .modt ., .imm ; : .modib .modt ., 2 length ! .imm ; : .iv tab1 .imm ; : .ib 2 length ! .iv ; : .ev tab1 mod@ drop .ptr ; : .arpl tab1 1 length ! .rmod ; \ .mne 16nov97py : .io tab1 .b? 0 .reg ., 1 length ! 2 .reg ; : .io# tab1 .b? 0 .reg ., count .$bu ; : .ret opcode @ 1 and 0= IF tab1 wcount .$du THEN ; : .enter tab1 wcount .$du ., count .$bu ; : .stcl opcode @ 1 and IF ." st" ELSE ." cl" THEN " cid " 1+ opcode @ 2/ 3 and + c@ emit ; : .mne ( addr field -- addr' ) >r count dup opcode ! r> BEGIN 2dup c@ and over 1+ c@ = 0= WHILE $10 + REPEAT nip dup 6+ count type 2+ perform l! ; forward mntbl : .code mntbl .mne ; \ .grp6 .grp7 06sep97py : .grp6 1 length ! mod@ opcode @ 4* 2* + grp6 *." tab1 .addr ; : .grp2i .b? mod@ 8+ grp1 *." tab1 .ptr ., 2 length ! .imm ; : .grp8 mod@ grp8 *." tab1 .addr ., 2 length ! .imm ; : .bt opcode @ 3 >> 7 and grp8 *." tab1 .rmod ; Create lbswap 0 c, 3 c, 3 c, 0 c, : .movrx tab1 opcode @ dup 3 and lbswap + c@ xor 7 and >r mod@ r@ 1 and IF swap 7 and .reg ., THEN r@ 2/ " CDT?" + 1+ c@ swap 0 <# # 'R hold rot hold #> type r> 1 and 0= IF ., 7 and .reg THEN ; : .lxs opcode @ 7 and "seg1 *." .modt ; : .shd tab1 .rmod ., 2 length ! opcode @ 1 and IF 1 .reg ELSE .imm THEN ; \ .esc 22may93py: flt, c, bl parse here over 1+ allot place ; Create fop1table hex 80 flt, chs 81 flt, abs 84 flt, tst 85 flt, xam 08 flt, ld1 09 flt, ldl2t 0A flt, ldl2e 0B flt, ldpi 0C flt, ldlg2 0D flt, ldln2 0E flt, ldz 90 flt, 2xm1 D1 flt, yl2x 92 flt, ptan D3 flt, patan 94 flt, xtract D5 flt, prem1 16 flt, decstp 17 flt, incstp D8 flt, prem D9 flt, yl2xp1 9A flt, sqrt 9B flt, sincos 9C flt, rndint DD flt, scale 9E flt, sin 9F flt, cos : .st ." ST" ?dup IF ." (" 1 .r ." )" THEN ; : .st? dup 40 and IF 1 .st ., THEN 80 and IF 0 .st THEN ; : .fop1 ( IP opcode -- IP ) 1F and >r fop1table BEGIN count 1F and r@ < WHILE count + REPEAT dup 1- c@ dup 1F and r> = IF swap count type tab1 .st? ELSE ." ??" 2drop THEN ; \ .esc 18dec93pyCreate fopbtable 00 flt, add 01 flt, mul 02 flt, com 03 flt, comp 04 flt, sub 05 flt, subr 06 flt, div 07 flt, divr 08 flt, ld 09 flt, xch 0A flt, st 0B flt, stp Create "fptrs ," SFLOATDWORD DFLOATWORD " 6 "fptrs c! : .modst count type dup 200 and IF ." p" THEN tab1 dup 400 and IF dup 7 and .st ., THEN 0 .st dup 400 and 0= IF dup 7 and ., .st THEN drop ; : .fmodm over 9 >> dup >r 1 and IF ." i" THEN count type tab1 r> "fptrs *." ." PTR " FF and .addr ; : .modfb ( IP opcode -- IP' ) 1D0 case? IF ." nop" exit THEN dup 7F8 and 5C0 = IF ." free" tab1 7 and .st exit THEN dup dup 38 and 3 >> swap 100 and 5 >> or >r fopbtable BEGIN count 1F and r@ < WHILE count + REPEAT rdrop over C0 and C0 = IF .modst ELSE .fmodm THEN ; \ .esc 22may93pyCreate fopatable 00 flt, ldenv 01 flt, ldcw 02 flt, stenv 03 flt, stcw 05 flt, ld 07 flt, stp 08 flt, rstor 0A flt, save 0B flt, stsw 0C flt, bld 0D flt, ild 0E flt, bstp 0F flt, istp : .modfa ( IP opcode -- IP' ) 7E0 case? IF ." stsw" tab1 ." AX" exit THEN dup 600 and 7 >> over 18 and 3 >> or >r fopatable BEGIN count 1F and r@ < WHILE count + REPEAT dup 1- c@ r> = 0= IF drop " ??" THEN count type tab1 FF and .addr ; \ .esc 02mar97py : .fop2 1F and 2 case? IF ." clex" exit THEN 3 case? IF ." init" exit THEN ." ??" . ; : .esc ( ip -- ip' ) count opcode @ 7 and 8 << or dup 7E0 and 1E0 = IF .fop1 exit THEN dup 7E0 and 3E0 = IF .fop2 exit THEN dup 120 and 120 = IF .modfa exit THEN .modfb ; \ .mmi 02mar97py : .mmr ( reg -- ) ." MM" 7 and 0 .r ; : .mma ( r/m -- ) dup $C0 < IF ." QUAD PTR " .addr ELSE .mmr THEN ; : .mmq ( ip -- ip' ) tab1 mod@ .mmr ., .mma ; : .mms ( -- ) opcode @ 3 and s" bwdq" drop + c@ emit ; : .mmx ( ip -- ip' ) .mms .mmq ; : .mmi ( ip -- ip' ) mod@ 2/ 3 and s" ??rlrall" drop swap 2* + 2 type .mms tab1 .mmr ., .8b ; \ 0Ffld 16nov97pyCreate 0Ftbl FE 00 t, .grp6 " FF 02 t, .modt lar" FF 03 t, .modt lsl" FF 06 t, noop clts" F8 20 t, .movrx mov" FF 08 t, noop invd" FF 09 t, noop wbinvd" F0 80 t, .jl j" F0 90 t, .set set" F7 A0 t, .pseg push" F7 A1 t, .pseg pop" FE A4 t, .shd shld" FE AC t, .shd shrd" E7 A3 t, .bt bt" FE A6 t, .modb cmpxchg" FE B6 t, .movx movzx" FF BA t, .grp8 bt" F8 B0 t, .lxs l" FE BE t, .movx movsx" FE C0 t, .modb xadd" F8 C8 t, .gr bswap" FF AF t, .modt imul" FF BC t, .modt bsf" FF BD t, .modt bsr" FF C7 t, .ev cmpxchg8b" \ 0Ffld 12apr98py FC 70 t, .mmi ps" FF 30 t, noop wrmsr" FF 32 t, noop rdmsr" FF D5 t, .mmq pmullw" FF E5 t, .mmq pmulhw" FF F5 t, .mmq pmaddwd" FF DB t, .mmq pand" FF $DF t, .mmq pandn" FF EB t, .mmq por" FF EF t, .mmq pxor" FC D0 t, .mmx psrl" FC D8 t, .mmx psubu" FC E0 t, .mmx psra" FC E8 t, .mmx psubs" FC F0 t, .mmx psll" FC F8 t, .mmx psub" FC DC t, .mmx paddu" FC EC t, .mmx padds" FC FC t, .mmx padd" 00 00 t, noop 0F???" : .0f 0Ftbl .mne ; \ disassembler table 22may93pyCreate mntbl FF 0F t, .0f " E7 06 t, .pseg push" E7 07 t, .pseg pop" F8 00 t, .ari add" F8 08 t, .ari or" F8 10 t, .ari adc" F8 18 t, .ari sbb" E7 26 t, .seg: " E7 27 t, .adj " F8 20 t, .ari and" F8 28 t, .ari sub" F8 30 t, .ari xor" F8 38 t, .ari cmp" F8 40 t, .gr inc" F8 48 t, .gr dec" F8 50 t, .gr push" F8 58 t, .gr pop" FF 60 t, noop pusha" FF 61 t, noop popa" FF 62 t, .modt bound" FF 63 t, .arpl arpl" FE 64 t, .segx " FF 66 t, osize " FF 67 t, asize " \ disassembler table 21may94py FF 68 t, .iv push" FF 69 t, .modiv imul" FF 6A t, .ib push" FF 6B t, .modib imul" FE 6C t, .str ins" FE 6E t, .str outs" F0 70 t, .js j" FF 82 t, noop ???" FC 80 t, .grp1 " FE 84 t, .modb test" FE 86 t, .modb xchg" FC 88 t, .ari mov" FD 8C t, .movs mov" FF 8D t, .modt lea" FF 8F t, .ev pop" FF 90 t, noop nop" F8 90 t, .xcha xchg" FF 98 t, noop cbw" FF 99 t, noop cwd" FF 9A t, .far callf" FF 9B t, noop wait" FF 9C t, noop pushf" FF 9D t, noop popf" FF 9E t, noop sahf" FF 9F t, noop lahf" \ disassembler table 22may93py FC A0 t, .movo mov" FE A4 t, .str movs" FE A6 t, .str cmps" FE A8 t, .igr test" FE AA t, .str stos" FE AC t, .str lods" FE AE t, .str scas" F8 B0 t, .igrb mov" F8 B8 t, .igrv mov" FE C0 t, .grp2i " FE C2 t, .ret ret" FF C4 t, .modt les" FF C5 t, .modt lds" FE C6 t, .movi mov" FF C8 t, .enter enter" FF C9 t, noop leave" FE CA t, .ret retf" FF CC t, noop int3" FF 0CD t, .ib int" FF CE t, noop into" FF CF t, noop iret" \ disassembler table 12aug00pyFC D0 t, .grp2 " FF D4 t, noop aam" FF D5 t, noop aad" FF D6 t, noop salc" FF D7 t, noop xlat" F8 D8 t, .esc f" FF E0 t, .jb loopne" FF E1 t, .jb loope" FF E2 t, .jb loop" FF E3 t, .jb jcxz" FE E4 t, .io# in" FE E6 t, .io# out" FF E8 t, .jv call" FF E9 t, .jv jmp" FF EA t, .far jmpf" FF EB t, .jb jmp" FE EC t, .io in" FE EE t, .io out" FF F0 t, .code lock " FF F2 t, .code rep " FF F3 t, .code repe " FF F4 t, noop hlt" FF F5 t, noop cmc" FE F6 t, .grp3 " FE FE t, .grp4 " F8 F8 t, .stcl " 00 00 t, noop ???" \ addr! dis disw disline 13may95py: disline base push hex dup .lformat mnefld tab dup .code col bytfld < 0= IF cr THEN bytfld tab swap 2dup - .dump ; ?head off : dis &20 BEGIN cr? more? dup 0< 0= WHILE >r disline r> REPEAT cr? 2drop ; : disw ' dup ." Adresse : " u. cr? &20 BEGIN BEGIN cr? more? dup 0< 0= WHILE >r disline r> opcode @ $C3 = UNTIL THEN drop &20 key $FF and #esc = UNTIL cr? 2drop ; : disline ( addr -- addr' ) base push hex .code at? &48 max at ; : .86 1 .length ! .alength on l! ; : .386 .length off .alength off l! ;
\ No newline at end of file
\\ *** Disassembler for the i486 *** 08nov92py \ i486 disassembler loadscreen 19may97py Module Disass base @ $8 base ! Variable cp? 1 ?head ! \ alle Disassembler-Worte headerless 1 capacity 2- +thru export dis disw disline .86 .386 ; base ! Module; \ long words and presigns 31dec92py : .# '# emit ; : .$ '$ emit ; : ., ', emit ; : .+ '+ emit ; : .- '- emit ; : .. '. emit ; : .: ': emit ; : .[ '[ emit ; : .] '] emit ; : cr? col IF cr THEN ; \ signed / unsigned byte, word and long output 07aug10py : .lformat ( addr -- ) $8 u.r ." :" ; : .du ( n -- ) 0 <<# #s #> type #>> ; : .$du ( n -- ) .$ .du ; : .$ds ( n -- ) dup 0< IF .- negate THEN .$du ; : .by ( 8b -- ) 0 <<# # # #> type #>> ; : .$bu ( 8b -- ) .$ .by ; : .$bs ( 8b -- ) $FF and dup $7F > IF .- $100 swap - THEN .$bu ; : .dump ( addr len -- ) bounds DO i c@ .by LOOP ; \ Variables and tabs 16nov97py Variable opcode Variable mode Variable length Variable alength Variable .length Variable .alength Variable seg: seg: on &36 constant bytfld : tab row swap at ; &10 constant mnefld &18 constant addrfld : tab1 addrfld col - 1 max spaces ; : l! .length @ length ! .alength @ alength ! seg: on ; : t, swap c, c, ' A, '" parse here $A allot place ; \ Strings 07feb93pyCreate "regs ," AXCXDXBXSPBPSIDIALCLDLBLAHCHDHBH" Create "16ri ," BX+SIBX+DIBP+SIBP+DISI DI BP BX " Create "ptrs ," DWORDWORD BYTE " Create "idx ," *2*4*8" Create "seg ," ESCSSSDSFSGS" Create "seg1 ," escsssdsfsgs" Create "jmp ," o b z bes p l le" Create grp1 ," addor adcsbbandsubxorcmprolrorrclrcrshlshrsalsar"Create grp3 ," testtestnot neg mul imuldiv idiv" Create grp4 ," inc dec call callfjmp jmpf push g4?? " Create grp6 ," sldtstr lldtltr verrverwg6??g6??sgdtsidtlgdtlidtsmswg7??lmswg7??" Create grp8 ," ???? src" 2 "regs c! 5 "16ri c! 5 "ptrs c! 2 "idx c! 2 "seg c! 2 "seg1 c! 2 "jmp c! 3 grp1 c! 4 grp3 c! 5 grp4 c! 4 grp6 c! 1 grp8 c! \ Register display 05dec92py : *." ( n addr -- ) count >r swap r@ * + r> -trailing type ; : .(reg ( n l -- ) dup 0= IF drop 'E emit ELSE 2 = IF 8+ THEN THEN "regs *." ; : .reg ( n -- ) length @ .(reg ; : .ereg ( n -- ) 'E emit "regs *." ; : .seg ( n -- ) "seg *." ; : mod@ ( addr -- addr' r/m reg ) count dup 70 and 3 >> swap 307 and swap ; : .8b ( addr -- addr' ) count .$bs ; : .32b ( addr -- addr' ) dup @ .$ds 4+ ; : .32u ( addr -- addr' ) dup @ .$du 4+ ; \ Register display 05dec92py Table: .disp noop .8b .32b [ : .sib ( addr mod -- addr' ) >r count dup 7 and 5 = r@ 0= and IF rdrop >r .32b r> ELSE swap r> cells .disp + perform swap dup 7 and .[ .ereg .] THEN 3 >> dup 7 and 4 = 0= IF .[ dup 7 and .ereg 3 >> "idx *." .] ELSE drop THEN ; : .32a ( addr r/m -- addr' ) dup 7 and >r 6 >> dup 3 = IF drop r> .reg exit THEN dup 0= r@ 5 = and IF drop rdrop .[ .32u .] exit THEN r@ 4 = IF rdrop .sib exit THEN cells .disp + perform r> .[ .ereg .] ; \ Register display 29may10py : wcount ( addr -- addr' w ) w@+ swap ; : wxcount ( addr -- addr' w ) wx@+ swap ; : +8b ( addr -- addr' ) count .$bs ; : +16b ( addr -- addr' ) wcount .$ds ; Table: .16disp noop +8b +16b [ : .16r ( reg -- ) .[ "16ri *." .] ; : .16a ( addr r/m -- addr' ) 307 and dup 006 = IF drop wcount .[ .$du .] exit THEN dup 7 and >r 6 >> dup 3 = IF drop r> .reg exit THEN cells .16disp + perform r> .16r ; \ Register display 01jan93py : .addr ( addr r/m -- addr' ) seg: @ 0< 0= IF seg: @ .seg ': emit THEN alength @ IF .16a ELSE .32a THEN ; : .ptr ( addr r/m -- addr' ) dup 300 < IF length @ "ptrs *." ." PTR " THEN .addr ; : .mod ( addr -- addr' ) mod@ .reg ., .addr ; : .rmod ( addr -- addr' ) mod@ >r .addr r> ., .reg ; : .imm ( addr -- addr' ) length @ dup 0= IF drop dup @ .$ds 4+ exit THEN 1 = IF wcount .$ds exit THEN count .$bs ; \ .ari 07feb93py forward .code : .b? ( -- ) opcode @ 1 and 0= IF 2 length ! THEN ; : .ari .b? tab1 opcode @ dup 4 and IF drop 0 .reg ., .imm exit THEN 2 and IF .mod ELSE .rmod THEN ; : .modt tab1 .mod ; : .gr tab1 opcode @ 7 and .reg ; : .igrv .gr ., .imm ; : .igrb 2 length ! .igrv ; : .igr .b? .igrv ; : .modb .b? tab1 .rmod ; : .xcha .gr ., 0 .reg ; \ .conds modifier 29may10py : .cond ( -- ) opcode @ 17 and dup 1 and IF Ascii n emit THEN 2/ "jmp *." ; : .jb tab1 count dup $80 and IF -$80 or THEN over + .$du ; : .jv tab1 alength @ IF wxcount over ELSE dup @ swap 4+ under THEN + .$du ; : .js .cond .jb ; : .jl .cond .jv ; : .set .cond tab1 mod@ drop 2 length ! .ptr ; : asize alength @ invert alength ! .code ; : osize length @ 1 xor length ! .code ; : .seg: opcode @ 3 >> 3 and seg: ! .code ; : .segx opcode @ 1 and 4+ seg: ! .code ; : .pseg tab1 opcode @ 3 >> 7 and .seg ; \ .grp1 .grp4 .adj .arpl 05dec92py: .grp1 .b? mod@ grp1 *." tab1 .ptr ., opcode @ 3 and 3 = IF 2 length ! THEN .imm ; : .grp2 .b? mod@ 8+ grp1 *." tab1 .ptr ., opcode @ 2 and IF ." CL" ELSE ." 1" THEN ; : .grp3 .b? mod@ dup >r grp3 *." tab1 r@ 3 > IF 0 .reg ., THEN r@ 2 4 within IF .ptr ELSE .addr THEN r> 2 < IF ., .imm THEN ; : .grp4 .b? mod@ dup grp4 *." tab1 2+ 7 and 4 < IF .ptr ELSE .addr THEN ; : .adj opcode @ dup $10 and IF Ascii a ELSE Ascii d THEN emit Ascii a emit $8 and IF Ascii s ELSE Ascii a THEN emit ; : .seg# .[ dup alength @ 2* 4+ + wcount .$du .: swap alength @ IF wcount .$du ELSE .32u THEN .] drop ; \ .movo .movx .str 23jan93py: .movo tab1 .b? opcode @ 2 and 0= IF 0 .reg ., THEN $05 alength @ - .addr opcode @ 2 and IF ., 0 .reg THEN ; : .movx tab1 mod@ .reg ., 1 length ! .b? .ptr ; : .movi .b? tab1 mod@ drop .ptr ., .imm ; : .movs tab1 mod@ opcode @ 2 and IF .seg ., .addr ELSE >r .addr ., r> .seg THEN ; : .str .b? " dwb" 1+ length @ + c@ emit ; : .far tab1 .seg# ; : .modiv .modt ., .imm ; : .modib .modt ., 2 length ! .imm ; : .iv tab1 .imm ; : .ib 2 length ! .iv ; : .ev tab1 mod@ drop .ptr ; : .arpl tab1 1 length ! .rmod ; \ .mne 16nov97py : .io tab1 .b? 0 .reg ., 1 length ! 2 .reg ; : .io# tab1 .b? 0 .reg ., count .$bu ; : .ret opcode @ 1 and 0= IF tab1 wcount .$du THEN ; : .enter tab1 wcount .$du ., count .$bu ; : .stcl opcode @ 1 and IF ." st" ELSE ." cl" THEN " cid " 1+ opcode @ 2/ 3 and + c@ emit ; : .mne ( addr field -- addr' ) >r count dup opcode ! r> BEGIN 2dup c@ and over 1+ c@ = 0= WHILE $10 + REPEAT nip dup 6+ count type 2+ perform l! ; forward mntbl : .code mntbl .mne ; \ .grp6 .grp7 07aug10py : .grp6 1 length ! mod@ opcode @ 4* 2* + grp6 *." tab1 .addr ; : .grp2i .b? mod@ 8+ grp1 *." tab1 .ptr ., 2 length ! .imm ; : .grp8 mod@ grp8 *." tab1 .addr ., 2 length ! .imm ; : .bt opcode @ 3 >> 7 and grp8 *." tab1 .rmod ; Create lbswap 0 c, 3 c, 3 c, 0 c, : .movrx tab1 opcode @ dup 3 and lbswap + c@ xor 7 and >r mod@ r@ 1 and IF swap 7 and .reg ., THEN r@ 2/ " CDT?" + 1+ c@ swap 0 <<# # 'R hold rot hold #> type #>> r> 1 and 0= IF ., 7 and .reg THEN ; : .lxs opcode @ 7 and "seg1 *." .modt ; : .shd tab1 .rmod ., 2 length ! opcode @ 1 and IF 1 .reg ELSE .imm THEN ; \ .esc 22may93py: flt, c, bl parse here over 1+ allot place ; Create fop1table hex 80 flt, chs 81 flt, abs 84 flt, tst 85 flt, xam 08 flt, ld1 09 flt, ldl2t 0A flt, ldl2e 0B flt, ldpi 0C flt, ldlg2 0D flt, ldln2 0E flt, ldz 90 flt, 2xm1 D1 flt, yl2x 92 flt, ptan D3 flt, patan 94 flt, xtract D5 flt, prem1 16 flt, decstp 17 flt, incstp D8 flt, prem D9 flt, yl2xp1 9A flt, sqrt 9B flt, sincos 9C flt, rndint DD flt, scale 9E flt, sin 9F flt, cos : .st ." ST" ?dup IF ." (" 1 .r ." )" THEN ; : .st? dup 40 and IF 1 .st ., THEN 80 and IF 0 .st THEN ; : .fop1 ( IP opcode -- IP ) 1F and >r fop1table BEGIN count 1F and r@ < WHILE count + REPEAT dup 1- c@ dup 1F and r> = IF swap count type tab1 .st? ELSE ." ??" 2drop THEN ; \ .esc 18dec93pyCreate fopbtable 00 flt, add 01 flt, mul 02 flt, com 03 flt, comp 04 flt, sub 05 flt, subr 06 flt, div 07 flt, divr 08 flt, ld 09 flt, xch 0A flt, st 0B flt, stp Create "fptrs ," SFLOATDWORD DFLOATWORD " 6 "fptrs c! : .modst count type dup 200 and IF ." p" THEN tab1 dup 400 and IF dup 7 and .st ., THEN 0 .st dup 400 and 0= IF dup 7 and ., .st THEN drop ; : .fmodm over 9 >> dup >r 1 and IF ." i" THEN count type tab1 r> "fptrs *." ." PTR " FF and .addr ; : .modfb ( IP opcode -- IP' ) 1D0 case? IF ." nop" exit THEN dup 7F8 and 5C0 = IF ." free" tab1 7 and .st exit THEN dup dup 38 and 3 >> swap 100 and 5 >> or >r fopbtable BEGIN count 1F and r@ < WHILE count + REPEAT rdrop over C0 and C0 = IF .modst ELSE .fmodm THEN ; \ .esc 22may93pyCreate fopatable 00 flt, ldenv 01 flt, ldcw 02 flt, stenv 03 flt, stcw 05 flt, ld 07 flt, stp 08 flt, rstor 0A flt, save 0B flt, stsw 0C flt, bld 0D flt, ild 0E flt, bstp 0F flt, istp : .modfa ( IP opcode -- IP' ) 7E0 case? IF ." stsw" tab1 ." AX" exit THEN dup 600 and 7 >> over 18 and 3 >> or >r fopatable BEGIN count 1F and r@ < WHILE count + REPEAT dup 1- c@ r> = 0= IF drop " ??" THEN count type tab1 FF and .addr ; \ .esc 02mar97py : .fop2 1F and 2 case? IF ." clex" exit THEN 3 case? IF ." init" exit THEN ." ??" . ; : .esc ( ip -- ip' ) count opcode @ 7 and 8 << or dup 7E0 and 1E0 = IF .fop1 exit THEN dup 7E0 and 3E0 = IF .fop2 exit THEN dup 120 and 120 = IF .modfa exit THEN .modfb ; \ .mmi 02mar97py : .mmr ( reg -- ) ." MM" 7 and 0 .r ; : .mma ( r/m -- ) dup $C0 < IF ." QUAD PTR " .addr ELSE .mmr THEN ; : .mmq ( ip -- ip' ) tab1 mod@ .mmr ., .mma ; : .mms ( -- ) opcode @ 3 and s" bwdq" drop + c@ emit ; : .mmx ( ip -- ip' ) .mms .mmq ; : .mmi ( ip -- ip' ) mod@ 2/ 3 and s" ??rlrall" drop swap 2* + 2 type .mms tab1 .mmr ., .8b ; \ 0Ffld 16nov97pyCreate 0Ftbl FE 00 t, .grp6 " FF 02 t, .modt lar" FF 03 t, .modt lsl" FF 06 t, noop clts" F8 20 t, .movrx mov" FF 08 t, noop invd" FF 09 t, noop wbinvd" F0 80 t, .jl j" F0 90 t, .set set" F7 A0 t, .pseg push" F7 A1 t, .pseg pop" FE A4 t, .shd shld" FE AC t, .shd shrd" E7 A3 t, .bt bt" FE A6 t, .modb cmpxchg" FE B6 t, .movx movzx" FF BA t, .grp8 bt" F8 B0 t, .lxs l" FE BE t, .movx movsx" FE C0 t, .modb xadd" F8 C8 t, .gr bswap" FF AF t, .modt imul" FF BC t, .modt bsf" FF BD t, .modt bsr" FF C7 t, .ev cmpxchg8b" \ 0Ffld 12apr98py FC 70 t, .mmi ps" FF 30 t, noop wrmsr" FF 32 t, noop rdmsr" FF D5 t, .mmq pmullw" FF E5 t, .mmq pmulhw" FF F5 t, .mmq pmaddwd" FF DB t, .mmq pand" FF $DF t, .mmq pandn" FF EB t, .mmq por" FF EF t, .mmq pxor" FC D0 t, .mmx psrl" FC D8 t, .mmx psubu" FC E0 t, .mmx psra" FC E8 t, .mmx psubs" FC F0 t, .mmx psll" FC F8 t, .mmx psub" FC DC t, .mmx paddu" FC EC t, .mmx padds" FC FC t, .mmx padd" 00 00 t, noop 0F???" : .0f 0Ftbl .mne ; \ disassembler table 22may93pyCreate mntbl FF 0F t, .0f " E7 06 t, .pseg push" E7 07 t, .pseg pop" F8 00 t, .ari add" F8 08 t, .ari or" F8 10 t, .ari adc" F8 18 t, .ari sbb" E7 26 t, .seg: " E7 27 t, .adj " F8 20 t, .ari and" F8 28 t, .ari sub" F8 30 t, .ari xor" F8 38 t, .ari cmp" F8 40 t, .gr inc" F8 48 t, .gr dec" F8 50 t, .gr push" F8 58 t, .gr pop" FF 60 t, noop pusha" FF 61 t, noop popa" FF 62 t, .modt bound" FF 63 t, .arpl arpl" FE 64 t, .segx " FF 66 t, osize " FF 67 t, asize " \ disassembler table 21may94py FF 68 t, .iv push" FF 69 t, .modiv imul" FF 6A t, .ib push" FF 6B t, .modib imul" FE 6C t, .str ins" FE 6E t, .str outs" F0 70 t, .js j" FF 82 t, noop ???" FC 80 t, .grp1 " FE 84 t, .modb test" FE 86 t, .modb xchg" FC 88 t, .ari mov" FD 8C t, .movs mov" FF 8D t, .modt lea" FF 8F t, .ev pop" FF 90 t, noop nop" F8 90 t, .xcha xchg" FF 98 t, noop cbw" FF 99 t, noop cwd" FF 9A t, .far callf" FF 9B t, noop wait" FF 9C t, noop pushf" FF 9D t, noop popf" FF 9E t, noop sahf" FF 9F t, noop lahf" \ disassembler table 22may93py FC A0 t, .movo mov" FE A4 t, .str movs" FE A6 t, .str cmps" FE A8 t, .igr test" FE AA t, .str stos" FE AC t, .str lods" FE AE t, .str scas" F8 B0 t, .igrb mov" F8 B8 t, .igrv mov" FE C0 t, .grp2i " FE C2 t, .ret ret" FF C4 t, .modt les" FF C5 t, .modt lds" FE C6 t, .movi mov" FF C8 t, .enter enter" FF C9 t, noop leave" FE CA t, .ret retf" FF CC t, noop int3" FF 0CD t, .ib int" FF CE t, noop into" FF CF t, noop iret" \ disassembler table 12aug00pyFC D0 t, .grp2 " FF D4 t, noop aam" FF D5 t, noop aad" FF D6 t, noop salc" FF D7 t, noop xlat" F8 D8 t, .esc f" FF E0 t, .jb loopne" FF E1 t, .jb loope" FF E2 t, .jb loop" FF E3 t, .jb jcxz" FE E4 t, .io# in" FE E6 t, .io# out" FF E8 t, .jv call" FF E9 t, .jv jmp" FF EA t, .far jmpf" FF EB t, .jb jmp" FE EC t, .io in" FE EE t, .io out" FF F0 t, .code lock " FF F2 t, .code rep " FF F3 t, .code repe " FF F4 t, noop hlt" FF F5 t, noop cmc" FE F6 t, .grp3 " FE FE t, .grp4 " F8 F8 t, .stcl " 00 00 t, noop ???" \ addr! dis disw disline 13may95py: disline base push hex dup .lformat mnefld tab dup .code col bytfld < 0= IF cr THEN bytfld tab swap 2dup - .dump ; ?head off : dis &20 BEGIN cr? more? dup 0< 0= WHILE >r disline r> REPEAT cr? 2drop ; : disw ' dup ." Adresse : " u. cr? &20 BEGIN BEGIN cr? more? dup 0< 0= WHILE >r disline r> opcode @ $C3 = UNTIL THEN drop &20 key $FF and #esc = UNTIL cr? 2drop ; : disline ( addr -- addr' ) base push hex .code at? &48 max at ; : .86 1 .length ! .alength on l! ; : .386 .length off .alength off l! ;
\ No newline at end of file
......@@ -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]
......
\ 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 ;
\ No newline at end of file
\ 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
\ 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 ;
\ No newline at end of file
\ 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
......@@ -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
......
\\ *** File Interface *** 32b 07may97py This file contains the rest of the file interface. The basic part of the file interface is already in the kernel, therefore this file contains only the higher level parts, as file lists (ls, files), path search and friends. Geschrieben von Bernd Pennemann An 32bit angepasst von georg rehfeld PC-Version von Bernd Paysan \ File interface load and patch block 32b 16jan05py \needs >len : >len ( addr -- a l ) dup $100 0 scan drop over - ; $35 +load \ Load structs for interpreter \ Load additional File Interface DOS joined Module DOS 1 $30 +thru Module; \ Load additional Memory Management \ Memory joined Module Memory $31 $33 +thru Module; \ disk errors 32b 09mar97py defined? go32 defined? win32 or [IF] : >diskerror ( -n -- string ) "error push $400 - >error "error @ ; : .diskerror ( -n -- ) >diskerror count type ; : ?diskabort ( -n -- ) dup 0< IF $400 - dup lasterr ! throw THEN drop ; : (diskerr ( error# string -- ) pushi/o standardi/o >r .diskerror r> throw ; ' (diskerr IS diskerr [THEN] \ disk errors 17oct99py[IFDEF] unix libc strerror int (int) strerror Create errorstring $40 allot : >diskerror ( -n -- string ) negate strerror >len errorstring place errorstring ; : .diskerror ( -n -- ) >diskerror count type ; : ?diskabort ( -n -- ) dup 0< IF dup $400 - lasterr ! >diskerror >r 'abort r> "error ! lasterr @ throw THEN drop ; : (diskerr ( error# string -- ) pushi/o standardi/o >r .diskerror r> throw ; ' (diskerr IS diskerr [THEN] \ create and search for files 32b 09mar97py[IFDEF] go32 Create dta &46 allot \needs go32 -2 allot : fsfirst ( C$ attr -- ior ) $60814E00 ms-dos ; : fsnext ( -- ior ) $00814F00 ms-dos ; : dcreate ( C$ -- ior ) $20813900 ms-dos ; : ddelete ( C$ -- ior ) $20813A00 ms-dos ; : dsetpath ( C$ -- ior ) $20813B00 ms-dos ; : fdelete ( C$ -- ior ) $20814100 ms-dos ; : fsetdta ( addr -- ) $20001A00 ms-dos drop ; : dgetpath ( buffer drive -- ior ) $22814700 ms-dos ; : frename ( C$old C$new -- ior ) swap $21815600 ms-dos ; : dfree ( drive+1 -- total_units free_units b/unit ) $20703600 ms-dos rot Q* >r $FFFF and swap $FFFF and r> ; \ : pexec ( name parameter -- ior ) $30814B00 ms-dos ; [THEN] \ create and search for files 32b 22jan10py[IFDEF] unix [DEFINED] glibc [DEFINED] bsd or [IF] Variable dent-basep libc getdirentries [ 4 ] ints (int) getdirentries : getdents dent-basep getdirentries dup 0= IF dent-basep off THEN ; [IFDEF] bsd libc lstat <rev> [ 2 ] ints (int) lstat libc stat <rev> [ 2 ] ints (int) stat [ELSE] libc lxstat <rev> [ 3 ] ints (int) __lxstat libc xstat <rev> [ 3 ] ints (int) __xstat : lstat 1 lxstat ; ( buf name -- r ) : stat 1 xstat ; ( buf name -- r ) [THEN] libc wcwidth int (int) wcwidth ( u -- n ) \ libc wcswidth ptr int (int) wcswidth ( addr u -- n ) \ non-glibc part 14dec08py [ELSE] legacy on 3 libc (getdents getdents ( count dirp fd -- n ) : getdents swap rot (getdents ; 2 libc lstat lstat ( buf name -- r ) 2 libc stat stat ( buf name -- r ) legacy off libc wcwidth int (int) wcwidth ( u -- n ) [THEN] \ create and search for files 32b 19dec04pylibc fnmatch <rev> [ 3 ] ints (int) fnmatch ( fs strs pat -- f )libc mkdir <rev> int int (int) mkdir ( mode pathname -- r ) libc rmdir int (int) rmdir ( pathname -- r ) libc chdir int (int) chdir ( pathname -- r ) libc unlink int (int) unlink ( pathname -- r ) libc getcwd <rev> int int (int) getcwd ( size buf -- buf ) libc rename <rev> int int (int) rename ( newpath oldpath -- r ) libc statfs <rev> int int (int) statfs ( buf path -- r ) libc ftruncate <rev> int int (int) ftruncate ( fd length -- r ) libc execve <rev> [ 3 ] ints (int) execve ( envp argv file -- r)libc fork (int) fork ( -- pid ) libc mmap <rev> [ 6 ] ints (int) mmap ( offset fd flags prot u addr -- addr ) libc munmap <rev> int int (int) munmap ( u addr -- n ) libc setlocale int ptr (ptr) setlocale ( locale addr -- addr ) \ create and search for files 32b 22jan10py Variable dirbuf dirbuf off Variable dirpath Variable direndp Create dta $50 allot [IFDEF] bsd $100 allot [THEN] Create pattern $80 allot | dta 1 cells + AConstant diroff | dta 2 cells + AConstant dirsize | dta 3 cells + AConstant dirfd : dirstat ( -- 0/ior ) dta @ >len 1+ direndp @ swap move dta $10 + dirpath @ 2dup stat IF lstat ELSE 2drop 0 THEN ; : ?allot ( n addr -- ) dup @ IF 2drop EXIT THEN [ also Memory ] Handle! [ previous ] ; \ create and search for files 32b 22jan10py forward makec$ : fsend ( -- ) dirfd @ ?dup IF _close drop THEN dirfd off ; : fsnext ( -- ior ) BEGIN diroff @ dirsize @ = IF diroff off dirfd @ dirbuf @ $400 getdents dup 0 max dirsize ! /ior dup 0<= IF fsend dup 0= or EXIT THEN drop THEN 0 diroff @ dirbuf @ + [IFDEF] bsd 4+ [ELSE] 8+ [THEN] dup w@ diroff +! [IFDEF] glibc 3 + [ELSE] [IFDEF] bsd 4+ [ELSE] 2+ [THEN] [THEN] dup dta ! pattern fnmatch 0= UNTIL dirstat ; \ create and search for files 32b 17oct99py : fsfirst ( C$ attr -- ior ) drop >len makec$ dup dirpath ! diroff off dirsize off $400 dirbuf ?allot >len '/ -scan over + dup >r >len 1+ pattern swap move '. r@ c! 0 r@ 1+ c! r> direndp ! 0 0 _open dup dirfd ! dup /ior swap -1 = ?EXIT drop fsnext ; \ open-dir read-dir close-dir filename-match 15jul01py libc opendir int (int) opendir libc readdir int (int) readdir libc closedir int (int) closedir : open-dir ( addr u -- wdirid wior ) makec$ opendir dup 0= /ior ; : close-dir ( wdirid -- wior ) closedir /ior ; : read-dir ( addr u1 wdirid -- u2 flag wior ) readdir dup 0= IF drop 2drop 0 0 0 EXIT THEN swap >r $B + >len dup r@ > IF r> min -$424 >r ELSE rdrop 0 >r THEN dup >r rot swap move r> true r> ; : filename-match ( c-addr1 u1 c-addr2 u2 -- flag ) pattern swap 2dup + >r move 0 r> c! makec$ 0 swap pattern fnmatch 0= ; \ create and search for files 32b 15jul01py Create statbuf 15 cells allot : dcreate ( C$ -- ior ) mkdir ; : ddelete ( C$ -- ior ) rmdir ; : dsetpath ( C$ -- ior ) chdir ; : fdelete ( C$ -- ior ) unlink ; : fsetdta ( addr -- ) drop ; : dgetpath ( buffer drive -- ior ) drop $100 swap getcwd 0= ; : frename ( C$old C$new -- ior ) swap rename ; : dfree ( C$ -- total_units free_units b/unit ) statbuf swap statfs drop statbuf 2 cells + 2@ swap statbuf cell+ @ ; [THEN] \ Win32 file links 16may00py[IFDEF] win32 legacy on 1 kernel32 DeleteFile DeleteFileA 1 kernel32 RemoveDirectory RemoveDirectoryA 1 kernel32 CreateDirectory CreateDirectoryA 1 kernel32 SetCurrentDirectory SetCurrentDirectoryA 2 kernel32 GetCurrentDirectory GetCurrentDirectoryA 2 kernel32 MoveFile MoveFileA 2 kernel32 FindFirstFile FindFirstFileA 2 kernel32 FindNextFile FindNextFileA 1 kernel32 FindClose FindClose create DTA &11 cells &260 + &14 + allot $20 allot | Variable find-handle \ create and search for files 32b 09mar97py: fsnext ( -- ior ) dta find-handle @ FindNextFile 0= dup IF find-handle @ FindClose drop THEN ; : fsfirst ( C$ attr -- ior ) drop dta swap FindFirstFile dup find-handle ! 0< ; : dcreate ( C$ -- ior ) CreateDirectory ; : ddelete ( C$ -- ior ) RemoveDirectory ; : dsetpath ( C$ -- ior ) SetCurrentDirectory ; : fdelete ( C$ -- ior ) DeleteFile ; : fsetdta ( dta -- ) drop ; : dgetpath ( buffer drive -- ior ) drop $100 GetCurrentDirectory ; : frename ( C$old C$new -- ior ) swap MoveFile ; : dfree ( drive+1 -- total_units free_units b/unit ) drop $1000 $800 $400 ; [THEN] \ sh 11jul99py : PC>sh cr curon r> execute curoff ; Defer >sh ' PC>sh IS >sh [IFDEF] go32 : system ( addr count -- ret ) >sh pad swap 2dup + 0 swap c! move pad $1000FF07 ms-dos ; : sh '# parse system drop ; [ELSE] [IFDEF] unix libc system int (int) system ( C$ -- r ) : sh '# parse tuck pad swap move pad + 0 swap c! pad system drop ; \ sh 23oct99py [ELSE] [IFDEF] win32 \ library msvcrt msvcrt.dll 0 msvcrt system system Variable app-win library shell32 shell32.dll 6 shell32 ShellExecute ShellExecuteA | Create "open S" open" here over allot swap move 0 c, | Create fnbuf $100 allot : system ( addr -- r ) >len 2dup bl scan tuck bl skip drop >r - 0 over fnbuf + c! fnbuf swap move 1 0 r> >len 0<> and fnbuf "open app-win @ ShellExecute ; : sh '# parse tuck pad swap move pad + 0 swap c! pad system drop ; [ELSE] : sh '# parse 2drop ; [THEN] [THEN] [THEN] \ env$ 05apr09py | : env@ mroot $20 + @ ; : env$ ( addr count -- addr' count' ) env@ BEGIN BEGIN >r 2dup r@ @ -text WHILE r> cell+ dup @ 0= UNTIL 2drop drop 0 0 exit THEN r> cell+ 2dup cell- @ + c@ '= = UNTIL cell- @ + 1+ nip >len ; : .env ( -- ) env@ BEGIN dup @ WHILE cr dup @ >len type cell+ stop? UNTIL THEN cr drop ; \ position into files 32b 05feb95py : position ( offset handle -- false/-error ) 0 fseek dup 0< ?exit drop false ; : position? ( handle -- offset ) 0 swap 1 fseek dup ?diskabort ; \ twiggling the file variables 32b 11aug86re : ?fcb ( fcb/ff -- fcb ) ?dup 0= abort" not for direct access !" dup assign? ; : .fcb ( fcb -- ) cell+ ?fcb \ print filename dup filehandle @ 2 .r space dup filesize @ 6 .r space dup .file filename >len type ; \ PATHes 32b 22jun98py [IFDEF] unix ': [ELSE] '; [THEN] Constant pathsep Create pathes $80 allot \ counted string of pathes pathes off : .pathes ( -- ) \ print the pathes cr 3 spaces pathes count type ; : setpath ( addr len -- ) \ set's the list of pathes under pathes count + swap move pathes c@ + pathes c! pathsep pathes count + c! pathes c@ 1+ pathes c! ; \\ PATH : see elsewhere in this file \ search for files 32b 09dec01pyalso Memory | $400 NewPtr Value workspace previous [IFDEF] unix : try.path ( addr len filename attr -- f ) \ true if found drop -rot workspace swap 2dup + >r move '/ r@ c! >len 1+ r> 1+ swap move workspace DTA $10 + swap stat 0= ; [ELSE] : try.path ( addr len filename attr -- f ) \ true if found >r -rot workspace swap 2dup + >r move '\ r@ c! >len 1+ r> 1+ swap move dta fsetdta workspace r> fsfirst 0= ; [THEN] : makec$ ( addr len -- c$ ) \ make addr len to a c$ workspace swap 2dup + >r move \ in "workspace" r> 0 swap c! ( make a c$ ) workspace ; \ search for files 32b 09dec01py | 7 Constant defaultattr \ find all filetypes | : path.file? ( filename -- ff/ C$ tf ) >r pathes count over 0 BEGIN r@ defaultattr try.path IF 2drop rdrop workspace true exit THEN pathsep skip dup WHILE 2dup pathsep scan 2swap 2 pick - REPEAT rdrop nip ; | : (>path.file dup path.file? IF nip THEN ; ' (>path.file IS >path.file : (searchfile ( fcb -- ff/ C$ tf ) \ search for file in path ?fcb filename path.file? ; \ and in act. directory : searchfile ( fcb -- C$ ) \ file was found in path (searchfile 0= abort" File not found" ; \ Dateidatum und -uhrzeit ausgeben 00jan80py [IFDEF] go32 : @time dta &22 + w@ dta &24 + w@ $10 lshift or ; : @attr dta &21 + c@ ; : @length dta &28 + @ ; : dtaname dta $20 + ; : >hms $FFFF and 2* $40 /mod $40 /mod $1F and swap 1- rot ; : >ymd $10 rshift $20 /mod $10 /mod &1980 + swap 1- swap ; [THEN] \ Dateidatum und -uhrzeit ausgeben 22jan10py [IFDEF] unix \ 1 libc localtime localtime ( &time_t -- tm ) : @time dta [IFDEF] bsd $30 [ELSE] $38 [THEN] + @ ; : @attr dta $18 + w@ ; : @length dta [IFDEF] bsd $40 [ELSE] $24 [THEN] + @ ; : dtaname dta @ ; : !dtaname ( addr u -- ) makec$ dta ! ; : >hms sp@ localtime nip @+ @+ @ swap rot ; : >ymd sp@ localtime nip $C + @+ @+ @ ; [THEN] \ Dateidatum und -uhrzeit ausgeben 06dec03py[IFDEF] win32 3 kernel32 FileTimeToDosDateTime FileTimeToDosDateTime | Variable FatDate | Variable FatTime | : (@time ( -- ) FatTime FatDate dta cell+ FileTimeToDosDateTime drop ; : @time (@time FatTime @ FatDate @ $10 lshift or ; : @attr dta @ ; : @length dta 8 cells + @ ; : dtaname dta &11 cells + ; : !dtaname ( addr u -- ) tuck dtaname swap move 0 swap dtaname + c! ; : >hms $FFFF and 2* $40 /mod $40 /mod $1F and swap 1- rot ; : >ymd $10 rshift $20 /mod $10 /mod &1980 + swap 1- swap ; [THEN] \ Dateidatum und -uhrzeit ausgeben 06dec03pyVariable #col : >time ( time -- addr count ) base push decimal >hms 0 <# # # ': hold drop # # ': hold drop # # #> ; | : .dtatime ( time -- ) >time type ; : >date ( date -- string len ) base push decimal >ymd 0 <# # # 2drop >r S" janfebmaraprmayjunjulaugsepoctnovdec" r> 0 max &11 min dup dup + + /string 3 min over + 1- DO I c@ hold -1 +LOOP 0 # # #> ; | : .dtadate ( date -- ) >date type ; | : .dtaname ( C$ -- ) \ C$ is addr of name >len under type negate $10 + 1 max spaces ; [IFDEF] unix | : .dtalname ( C$ -- ) \ C$ is addr of name >len under type negate $28 + #col @ - 1 max spaces ; [THEN] \ print dta and directory 32b 06dec03py Variable dir" | Variable -opt | Variable +opt : -opt? ( Char -- flag ) $1F and -opt swap Bit@ ; : -opt! ( Char -- flag ) $1F and -opt swap +Bit ; : +opt! ( Char -- flag ) $1F and +opt swap +Bit ; | : +cr cr #col @ spaces ; \ print dta and directory 32b 29jan00pydefined? go32 defined? win32 or [IF] : .dta 'L -opt? 0= IF dtaname >len under type @attr $10 and IF ." /" 1+ THEN @attr 8 and IF ." :" 1+ THEN negate $E + spaces col cols $F - u> IF +cr THEN ELSE 0 0 <# @attr S" RHSVDA" bounds DO dup 1 and IF i c@ hold THEN 2/ LOOP drop #> 6 over - spaces type space dtaname .dtaname @length 8 .r 2 spaces @time .dtatime 2 spaces @time .dtadate +cr THEN ; [IFDEF] win32 &11 cells &260 + &14 + [ELSE] &44 [THEN] Constant denlen '\ Constant dirsep | : <path dirsep -scan over 1+ c@ ': = IF 2 max THEN ; | : ?dir $10 and ; hmacro | : all-files s" *.*" ; [THEN] \ print dta and directory 32b 13mar99py[IFDEF] unix : .dta 'L -opt? 0= IF dtaname >len under type S" | / @ = " drop @attr $C >> + c@ emit 1+ negate $E + spaces col cols $F - u> IF +cr THEN ELSE 0 0 <# @attr S" xwrxwrxwr" bounds DO dup 1 and IF i c@ ELSE '- THEN hold 2/ LOOP 3 >> s" -pc-d-b---l-s---" drop + c@ hold #> &10 over - spaces type space dtaname .dtalname @length 8 .r 2 spaces @time .dtatime 2 spaces @time .dtadate +cr THEN ; '/ constant dirsep $4C Constant denlen | : <path dirsep -scan ; | : ?dir $4000 and ; hmacro | : all-files s" *" ; [THEN] \ print dta and directory 32b 06dec03py: .dta? @attr $20 and 0<> 'N -opt? invert or 'O -opt? xor IF .dta THEN ; : ((dir ( addr attr -- flag ) fsfirst BEGIN 0= WHILE stop? IF true exit THEN .dta? fsnext REPEAT false ; | : insdir ( addr u addr -- ) >len <path + >r r@ >len >r 2dup + 1+ r> 1+ move r> swap 2dup + >r move dirsep r> c! ; | : deldir ( addr -- ) >len <path 2dup + >r 1- <path + r> >len 1+ rot swap move ; | : +path ( path addr u -- ) rot swap 2dup + >r move 0 r> c! ; | : ?break IF 2drop 2drop true rdrop r> dir" ! THEN ; | : ?+cr 'L -opt? 0= IF +cr THEN ; : +dta dtaname >len tuck s" .." drop -text swap 2 > or IF dtaname >len dir" @ place dir" @ c@ 1+ dir" +! THEN ; \ ((hir (dir 06dec03py: get-dirs over >len <path + all-files +path over $10 fsfirst BEGIN 0= WHILE stop? ?break @attr ?dir IF +dta THEN fsnext REPEAT ; : ((hir ( addr count addr attr -- flag ) recursive dir" @ >r get-dirs 2over 2over drop >len <path + -rot +path 2dup ((dir drop dir" @ r@ ?DO I count type ." :" 4 #col +! +cr over I count rot insdir 2over 2over ((hir -4 #col +! IF 2drop 2drop true r> dir" ! unloop exit THEN over deldir col #col @ 4+ = IF at? 4- at ELSE +cr THEN I c@ 1+ +LOOP r> dir" ! 2drop 2drop false ; : (dir ( attr addr len -- ) cr dta fsetdta pad dir" ! 'R -opt? IF 0 #col ! rot >r 2dup makec$ >r 2dup <path nip /string r> r> ((hir ELSE #col off makec$ swap ((dir THEN drop ; \ primitives for fcb's 32b 10oct99py : forthfiles ( -- ) \ print a list of : file-link LIST> \ forthword,filename,handle,len cr .fcb stop? IF unlist THEN ; \ Next Words are for export : path ( -- ) \ this is a smart word ! \ name count /parse dup 0= IF 2drop .pathes exit THEN over c@ pathsep = IF pathes off 1 /string THEN setpath ; \ Killfile 09mar09py : scanopt ( -- addr count ) +opt @ -opt ! +opt off BEGIN /parse dup WHILE over c@ '- = WHILE 1 /string bounds ?DO i c@ -opt! LOOP REPEAT THEN ; | : dir$ ( -- addr ) scanopt makec$ ; : free? [IFDEF] unix s" ." makec$ [ELSE] 0 [THEN] dfree >r cr dgetdrv 'A + emit ." : Von " over . ." Units (" swap r@ m* d. ." Bytes) sind " dup . ." (" r> m* d. ." Bytes) frei." ; \ Killfile 17may99py [IFDEF] unix : killfile dir$ 'A -opt? $80 and 'D -opt? $100 and or fsfirst ?diskabort 0 BEGIN 0= WHILE cr ." Kill? " .dta 'Y -opt? ?dup 0= IF key $FF and capital 'J over = swap 'Y = or THEN IF dtaname fdelete ?diskabort ." killed" THEN fsnext REPEAT ; : files scanopt dup 0= IF 2drop S" *" THEN 'A -opt? $80 and 'D -opt? $100 and or -rot (dir ; [THEN] \ Killfile 09mar97py defined? go32 defined? win32 or [IF] : killfile dta fsetdta dir$ dup 'A -opt? IF $F ELSE 0 THEN fsfirst ?diskabort >len '\ -scan over 1+ c@ ': = IF 2 max THEN 0 BEGIN 0= WHILE cr ." Kill? " .dta 'Y -opt? ?dup 0= IF key $FF and capital 'J over = swap 'Y = or THEN IF 2dup + >r dtaname r> &14 move over fdelete ?diskabort ." killed" THEN fsnext REPEAT 2drop ; : files scanopt dup 0= IF 2drop S" *.*" THEN $10 'A -opt? $F and + -rot (dir ; [THEN] \ File Interface User words 32b 21jun01py : makefile dir$ 0 fcreate dup ?diskabort fclose ?diskabort ; : rename dir$ bl word count over + 0 swap c! frename ?diskabort ; : from isfile push use ; \ sets only fromfile : "use ( addr count -- ) dup 0= abort" missing filename!" ">tib USE ; : eof ( -- f ) \ end of file ? isfile@ dup filehandle @ position? swap filesize @ = ; \ extend files mod 25may03py | : addblock ( n -- ) \ add block n to file buffer dup b/blk bl fill update b/blk isfile@ filesize +! Backup ; : (more ( n -- ) capacity swap bounds ?DO I addblock LOOP ; : more ( n -- ) open (more close ; \ moving blocks mod 03nov91py | : fromblock ( blk -- addr ) fromfile @ (block ; | : (copy ( from to -- ) dup isfile@ core? IF prev @ emptybuf THEN swap >r isfile@ [ memory ] >Purge r> fromblock GetMP dup >r HNoPurge r> HPurge Update ; dos | : blkmove ( from to quan --) save-buffers >r over r@ + over u> >r 2dup u< r> and IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP THEN save-buffers 2drop ; : copy ( from to -- ) 1 blkmove ; : convey ( [blk1 blk2] [to.blk -- ) swap 1+ 2 pick - dup 0> 0= abort" No Sir" blkmove ; \ Allocating buffers index 03nov91py | : range ( from to -- to+1 from ) capacity 1- umin swap capacity 1- umin 2dup > IF swap THEN 1+ swap ; : index ( from to -- ) range DO cr I 4 .r space I block c/l type stop? ?LEAVE LOOP ; \ make, kill and set directories 32b 09mar97py: killdir dir$ ddelete ?diskabort ; : makedir dir$ dcreate ?diskabort ; : pwd here dgetdrv over 0 dgetpath ?diskabort [IFDEF] go32 abs 'A + emit ." :/" [ELSE] drop [THEN] >len type ; : cd dir$ dup c@ 0= IF drop pwd exit THEN dup 1+ c@ ': = \ Laufwerk als Kopf? IF dup c@ capital 'A - dsetdrv drop THEN dsetpath ?diskabort ; \ Die allseits geforderten Unix-like-Aliases: ' files Alias dir ' files Alias ls ' rename Alias mv ' killfile Alias rm \ ' free? Alias df : ll 'L +opt! ls ; \ words for VIEWing 32b 19oct98py | $400 Constant viewoffset \ max. &512 Kbyte lange Files : (view ( %ffffffbbbbbbbbbb -- blk' ) dup 0= ?exit viewoffset u/mod file-link BEGIN @ dup WHILE 2dup cell+ fileno w@ = UNTIL THEN dup IF cell+ dup assign? dup searchfile drop THEN !files drop ; also memory | : ~file ( fid -- ) dup unlink-file DisposHandle ; previous \ missing ANS file words 05aug01py: file-status ( c-addr u -- x ior ) !fid dup >r filename $1F fsfirst dta swap ior [IFDEF] fsend fsend [THEN] r> ~file ; : delete-file ( addr count -- ior ) !fid >r r@ filename fdelete ior r> ~file ; : load-file ( u fileid -- ) isfile push isfile ! load ; : flush-file ( fid -- ior ) isfile push isfile ! ['] close! catch dup 0= IF drop ['] open catch THEN ; : resize-file ( ud fileid -- ior ) >r over r@ filesize ! r@ reposition-file drop r@ ?pos dup IF rdrop EXIT THEN drop [IFDEF] unix r@ filesize @ r> filehandle @ ftruncate ior [ELSE] -1 0 r> write-file [THEN] ; : rename-file ( addr1 u1 addr2 u2 -- ior ) !fid >r !fid dup filename r@ filename frename ior swap ~file r> ~file ; \ Init path at boot time for Linux 31may02pyalso Memory [IFDEF] unix | : ?path ( addr u -- ) over IF setpath ELSE 2drop THEN ; cold: pathes off $400 NewPtr to workspace s" HOME" env$ ?path s" BIGFORTH_PATH" env$ ?path [ s" LIBDIR" env$ 2dup d0= [IF] 2drop s" /usr/local/lib/bigforth" [THEN] ] SLiteral setpath [ s" SRCDIR" env$ 2dup d0= [IF] 2drop s" /usr/local/lib/bigforth/src" [THEN] ] SLiteral setpath ; [ELSE] cold: $400 NewPtr to workspace ; [THEN] previous \\ direct access diskchange? mod 03jan93py \ DOS primitives | Variable (drv | Variable (r/w $10000000 | Constant b/dev b/dev b/blk / | Constant blk/dev Code mediach ( drive -- flag ) \ false = no change SP ) A7 -) move .w 9 # A7 ) move $D trap .l 4 A7 addq D0 ext D0 SP ) move Next end-code Code getbpb ( drive -- bpb ) SP ) A7 -) move .w 7 # A7 ) move $D trap .l 4 A7 addq D0 SP ) move Next end-code \\ blk/drv getblocks 03jan93py | : R/Werr ( err# -- ) (r/w @ IF " write " ELSE " read " THEN diskerr ; | : ?R/Werr ( err# -- ) dup 0< IF R/Werr THEN drop ; Create bpbs $10 cells allot | : bpb ( -- addr ) bpbs (drv @ cells + ; | : getblocks (drv @ getbpb bpb ! ; : b/drv ( -- n ) 0 drv? (drv ! bpb @ >r (drv @ mediach dup ?R/Werr r@ 0= or IF getblocks rdrop bpb @ >r THEN r@ 4+ w@ r> $E + w@ Q* ; : blk/drv ( -- n ) isfile@ 0= IF b/drv b/blk / ELSE defers capacity THEN ; ' blk/drv IS capacity \\ readsector writesector mod 03jan93py Code rwabs ( drv begsec #sec lbuf r/w -- flag ) SP )+ $001F # movem A7 USP move $FFFE # D3 cmpi > IF D3 A7 -) move -1 D3 moveq THEN .w D4 A7 -) move \ Drive D3 A7 -) move \ Startsektor D2 A7 -) move \ Anzahl Sektoren .l D1 A7 -) move \ Buffer .w D0 A7 -) move \ r/w-Flag 4 # A7 -) move \ Funktionsnummer $0D trap .l USP A7 move .l D0 SP -) move \ Fehlerflag Next end-code \\ (drvinit 03jan93py also Memory Variable R/Wbuffer $200 , | : drvinit bpbs $40 erase dgetdrv drive R/Wbuffer @ 0= IF R/Wbuffer 4+ @ $04810001 gemdos R/Wbuffer ! THEN ; drvinit cold: drvinit ; | : R/Walloc ( buflen -- ) dup R/Wbuffer 4+ @ > IF dup R/Wbuffer 4+ ! R/Wbuffer @ $04910001 gemdos R/Werr $04810001 gemdos R/Wbuffer ! exit THEN drop ; toss bye: r> R/Wbuffer dup push off >r ; \\ FileR/W 03jan93py | : R/Wsec ( r/w pos bpb -- ) rot >r >r (drv @ swap r@ w@ / r> $C + w@ + 1 R/Wbuffer @ r> rwabs ?R/Werr ; | : R/Wrest ( addr pos1 len1 bpb -- addr pos2 len2 ) >r over r@ w@ 1- and 0= over r@ w@ > and over 0= or IF rdrop exit THEN r@ w@ R/Walloc 0 2 pick r@ R/Wsec dup 2over r@ w@ under 1- and under - >r R/Wbuffer @ + rot r> min (r/w @ 0= IF >r swap r> THEN move (r/w @ IF 1 2 pick r@ R/Wsec THEN r> w@ 2 pick over 1- and - dup >r /string rot r> + -rot ; | : R/Wmid ( addr pos1 len1 bpb -- addr pos2 len2 ) >r dup r@ w@ < IF rdrop exit THEN (drv @ 2 pick r@ w@ / r@ $C + w@ + 2 pick r@ w@ / 5 pick (r/w @ rwabs ?R/Werr dup r> w@ under / * dup >r /string rot r> + -rot ; \ stdin stdout stderr (linux) 07jul01py [IFDEF] unix : set-file ( fd fcb -- ) >r 0 over 2 fseek dup $7FFFFFFF umin r@ filesize ! 0 max r@ fileOSpos ! r> filehandle ! ; file-link @ File stdin DOES> cell+ dup @ ?EXIT >r s" stdin" r@ assign 0 r@ set-file r> ; File stdout DOES> cell+ dup @ ?EXIT >r s" stdout" r@ assign 1 r@ set-file r> ; File stderr DOES> cell+ dup @ ?EXIT >r s" stderr" r@ assign 2 r@ set-file r> ; file-link ! \ these three aren't real files [THEN] \ exports 08aug08py[IFDEF] win32 export DOS app-win time&date source-id open-file create-file close-file delete-file r/o r/w w/o bin read-file write-file flush-file file-position reposition-file file-size resize-file path killfile free? makefile rename from "use eof files (more more copy convey index killdir makedir pwd dir CD free? LS LL MV RM (view sh ; [ELSE] export DOS time&date source-id stdin stdout stderr open-file create-file close-file delete-file open-dir close-dir read-dir filename-match r/o r/w w/o bin read-file write-file flush-file file-position reposition-file file-size resize-file path killfile free? makefile rename from "use eof files (more more copy convey index killdir makedir pwd dir CD free? LS LL MV RM (view sh ; [THEN] \ HandToHand PtrToHand PtrToXHand 18apr91py DOS also : HandToHand ( MP1 -- MP2 ) dup GetHandleSize under NewHandle >r @ r@ @ rot move r> ; : PtrToHand ( addr -- MP ) dup GetPtrSize under NewHandle >r @ r@ @ rot move r> ; : PtrToXHand ( addr MP -- ) dup >r over GetPtrSize SetHandleSize r> @ over GetPtrSize move ; \ HandAndHand PtrAndHand 11jun88py : HandAndHand ( MP1 MP2 -- ) dup >r over GetHandleSize over GetHandleSize + SetHandleSize dup @ swap GetHandleSize r@ @ r> GetHandleSize + swap >r r@ - r> move ; : PtrAndHand ( Addr MP -- ) dup >r over GetPtrSize over GetHandleSize + SetHandleSize dup GetPtrSize r@ @ r> GetHandleSize + swap >r r@ - r> move ; \ .Heap 11oct91py: .Heap ( -- ) HeapStart base push HeapSem lock BEGIN cr dup @ WHILE hex dup 8+ 6 u.r ': emit dup @ $C - 7 u.r dup NextBlock 4- @ $C - 7 u.r dup Full? ?dup IF dup >r 1+ ?dup IF ." <- " 1- abs 2dup @ 8 - = IF 6 u.r ELSE 4+ @ dup 6 u.r dup Purge@ rot space .File swap 6 .r ': emit . @ 4- @ abs $14 + wx@ 0< IF ." x" THEN THEN THEN r> 0< IF ." locked " THEN ELSE ." Frei " THEN [IFDEF] Pool dup Pool @ = IF ." Pool" THEN dup Pool 2 cells + @ = IF ." First" THEN dup Pool 3 cells + @ = IF ." Shift" THEN [THEN] NextBlock stop? UNTIL THEN drop HeapSem unlock ; \ .blocks 29oct91py : .blocks ( -- ) prev BEGIN @ dup WHILE cr dup dup 4+ @ @ 6 .r 8+ ." Block : " 4+ dup @ over 4+ @ / 4 .r ." File : " dup 4- @ .file 8+ w@ IF ." updated " THEN stop? UNTIL THEN drop ; toss export Memory ; \ Interpretative Structuren 14sep09py| Variable #I | Variable countif Vocabulary [struct] [struct] also definitions : [IF] 1 countif +! ; : [THEN] -1 countif +! ; : [ELSE] [THEN] r> execute [IF] ; ' [IF] alias [IFDEF] ' [IF] alias [IFUNDEF] ' [IF] alias [BEGIN] ' [IF] alias [WHILE] ' [THEN] alias [UNTIL] ' [THEN] alias [AGAIN] ' [IF] alias [DO] ' [IF] alias [?DO] ' [THEN] alias [LOOP] ' [THEN] alias [+LOOP] : [REPEAT] [AGAIN] [THEN] ; ' [THEN] alias [ENDIF] ' ( alias ( ' (* alias (* ' /* alias /* ' \* alias \* ' \ alias \ ' \\ alias \\ ' \\\ alias \\\ --> \ Interpretative Structuren 14sep09py| Variable parser' | : scanIF [ context @ ] ALiteral (find IF name> execute countif @ 0< IF parser' @ IS parser THEN ELSE drop THEN ; Forth definitions : defined? name find nip 0<> ; : [defined] defined? ; immediate : [undefined] defined? 0= ; immediate : [IF] what's parser parser' ! 0= IF countif off ['] scanIF IS parser THEN ; immediate : [IFDEF] defined? compile [IF] ; immediate : [IFUNDEF] defined? 0= compile [IF] ; immediate : [ELSE] 0 compile [IF] ; immediate : [THEN] ; immediate : [ENDIF] ; immediate Onlyforth --> \ Structs for interpreter 11mar00py: [DO] ( start end -- ) #I push >in @ -rot DO I #I ! dup >r >in ! interpret r> swap +LOOP drop ; immediate : [?DO] 2dup = IF 2drop compile [ELSE] ELSE compile [DO] THEN ; immediate : [+LOOP] ( n -- ) rdrop rdrop ; immediate : [LOOP] ( -- ) 1 rdrop rdrop ; immediate : [FOR] ( n -- ) 0 swap compile [DO] ; immediate : [NEXT] ( n -- ) -1 rdrop rdrop ; immediate : [I] ( -- index ) #I @ ?lit, ; immediate : [BEGIN] >in @ >r BEGIN r@ >in ! interpret UNTIL rdrop ; immediate ' [+LOOP] alias [UNTIL] immediate : [REPEAT] ( -- ) false rdrop rdrop ; immediate ' [REPEAT] alias [AGAIN] immediate : [WHILE] 0= IF compile [ELSE] true rdrop rdrop 1 countif +! THEN ; immediate
\ No newline at end of file
\\ *** File Interface *** 32b 07may97py This file contains the rest of the file interface. The basic part of the file interface is already in the kernel, therefore this file contains only the higher level parts, as file lists (ls, files), path search and friends. Geschrieben von Bernd Pennemann An 32bit angepasst von georg rehfeld PC-Version von Bernd Paysan \ File interface load and patch block 32b 16jan05py \needs >len : >len ( addr -- a l ) dup $100 0 scan drop over - ; $35 +load \ Load structs for interpreter \ Load additional File Interface DOS joined Module DOS 1 $30 +thru Module; \ Load additional Memory Management \ Memory joined Module Memory $31 $33 +thru Module; \ disk errors 32b 09mar97py defined? go32 defined? win32 or [IF] : >diskerror ( -n -- string ) "error push $400 - >error "error @ ; : .diskerror ( -n -- ) >diskerror count type ; : ?diskabort ( -n -- ) dup 0< IF $400 - dup lasterr ! throw THEN drop ; : (diskerr ( error# string -- ) pushi/o standardi/o >r .diskerror r> throw ; ' (diskerr IS diskerr [THEN] \ disk errors 17oct99py[IFDEF] unix libc strerror int (int) strerror Create errorstring $40 allot : >diskerror ( -n -- string ) negate strerror >len errorstring place errorstring ; : .diskerror ( -n -- ) >diskerror count type ; : ?diskabort ( -n -- ) dup 0< IF dup $400 - lasterr ! >diskerror >r 'abort r> "error ! lasterr @ throw THEN drop ; : (diskerr ( error# string -- ) pushi/o standardi/o >r .diskerror r> throw ; ' (diskerr IS diskerr [THEN] \ create and search for files 32b 09mar97py[IFDEF] go32 Create dta &46 allot \needs go32 -2 allot : fsfirst ( C$ attr -- ior ) $60814E00 ms-dos ; : fsnext ( -- ior ) $00814F00 ms-dos ; : dcreate ( C$ -- ior ) $20813900 ms-dos ; : ddelete ( C$ -- ior ) $20813A00 ms-dos ; : dsetpath ( C$ -- ior ) $20813B00 ms-dos ; : fdelete ( C$ -- ior ) $20814100 ms-dos ; : fsetdta ( addr -- ) $20001A00 ms-dos drop ; : dgetpath ( buffer drive -- ior ) $22814700 ms-dos ; : frename ( C$old C$new -- ior ) swap $21815600 ms-dos ; : dfree ( drive+1 -- total_units free_units b/unit ) $20703600 ms-dos rot Q* >r $FFFF and swap $FFFF and r> ; \ : pexec ( name parameter -- ior ) $30814B00 ms-dos ; [THEN] \ create and search for files 32b 22jan10py[IFDEF] unix [DEFINED] glibc [DEFINED] bsd or [IF] Variable dent-basep libc getdirentries [ 4 ] ints (int) getdirentries : getdents dent-basep getdirentries dup 0= IF dent-basep off THEN ; [IFDEF] bsd libc lstat <rev> [ 2 ] ints (int) lstat libc stat <rev> [ 2 ] ints (int) stat [ELSE] libc lxstat <rev> [ 3 ] ints (int) __lxstat libc xstat <rev> [ 3 ] ints (int) __xstat : lstat 1 lxstat ; ( buf name -- r ) : stat 1 xstat ; ( buf name -- r ) [THEN] libc wcwidth int (int) wcwidth ( u -- n ) \ libc wcswidth ptr int (int) wcswidth ( addr u -- n ) \ non-glibc part 14dec08py [ELSE] legacy on 3 libc (getdents getdents ( count dirp fd -- n ) : getdents swap rot (getdents ; 2 libc lstat lstat ( buf name -- r ) 2 libc stat stat ( buf name -- r ) legacy off libc wcwidth int (int) wcwidth ( u -- n ) [THEN] \ create and search for files 32b 19dec04pylibc fnmatch <rev> [ 3 ] ints (int) fnmatch ( fs strs pat -- f )libc mkdir <rev> int int (int) mkdir ( mode pathname -- r ) libc rmdir int (int) rmdir ( pathname -- r ) libc chdir int (int) chdir ( pathname -- r ) libc unlink int (int) unlink ( pathname -- r ) libc getcwd <rev> int int (int) getcwd ( size buf -- buf ) libc rename <rev> int int (int) rename ( newpath oldpath -- r ) libc statfs <rev> int int (int) statfs ( buf path -- r ) libc ftruncate <rev> int int (int) ftruncate ( fd length -- r ) libc execve <rev> [ 3 ] ints (int) execve ( envp argv file -- r)libc fork (int) fork ( -- pid ) libc mmap <rev> [ 6 ] ints (int) mmap ( offset fd flags prot u addr -- addr ) libc munmap <rev> int int (int) munmap ( u addr -- n ) libc setlocale int ptr (ptr) setlocale ( locale addr -- addr ) \ create and search for files 32b 22jan10py Variable dirbuf dirbuf off Variable dirpath Variable direndp Create dta $50 allot [IFDEF] bsd $100 allot [THEN] Create pattern $80 allot | dta 1 cells + AConstant diroff | dta 2 cells + AConstant dirsize | dta 3 cells + AConstant dirfd : dirstat ( -- 0/ior ) dta @ >len 1+ direndp @ swap move dta $10 + dirpath @ 2dup stat IF lstat ELSE 2drop 0 THEN ; : ?allot ( n addr -- ) dup @ IF 2drop EXIT THEN [ also Memory ] Handle! [ previous ] ; \ create and search for files 32b 22jan10py forward makec$ : fsend ( -- ) dirfd @ ?dup IF _close drop THEN dirfd off ; : fsnext ( -- ior ) BEGIN diroff @ dirsize @ = IF diroff off dirfd @ dirbuf @ $400 getdents dup 0 max dirsize ! /ior dup 0<= IF fsend dup 0= or EXIT THEN drop THEN 0 diroff @ dirbuf @ + [IFDEF] bsd 4+ [ELSE] 8+ [THEN] dup w@ diroff +! [IFDEF] glibc 3 + [ELSE] [IFDEF] bsd 4+ [ELSE] 2+ [THEN] [THEN] dup dta ! pattern fnmatch 0= UNTIL dirstat ; \ create and search for files 32b 17oct99py : fsfirst ( C$ attr -- ior ) drop >len makec$ dup dirpath ! diroff off dirsize off $400 dirbuf ?allot >len '/ -scan over + dup >r >len 1+ pattern swap move '. r@ c! 0 r@ 1+ c! r> direndp ! 0 0 _open dup dirfd ! dup /ior swap -1 = ?EXIT drop fsnext ; \ open-dir read-dir close-dir filename-match 15jul01py libc opendir int (int) opendir libc readdir int (int) readdir libc closedir int (int) closedir : open-dir ( addr u -- wdirid wior ) makec$ opendir dup 0= /ior ; : close-dir ( wdirid -- wior ) closedir /ior ; : read-dir ( addr u1 wdirid -- u2 flag wior ) readdir dup 0= IF drop 2drop 0 0 0 EXIT THEN swap >r $B + >len dup r@ > IF r> min -$424 >r ELSE rdrop 0 >r THEN dup >r rot swap move r> true r> ; : filename-match ( c-addr1 u1 c-addr2 u2 -- flag ) pattern swap 2dup + >r move 0 r> c! makec$ 0 swap pattern fnmatch 0= ; \ create and search for files 32b 15jul01py Create statbuf 15 cells allot : dcreate ( C$ -- ior ) mkdir ; : ddelete ( C$ -- ior ) rmdir ; : dsetpath ( C$ -- ior ) chdir ; : fdelete ( C$ -- ior ) unlink ; : fsetdta ( addr -- ) drop ; : dgetpath ( buffer drive -- ior ) drop $100 swap getcwd 0= ; : frename ( C$old C$new -- ior ) swap rename ; : dfree ( C$ -- total_units free_units b/unit ) statbuf swap statfs drop statbuf 2 cells + 2@ swap statbuf cell+ @ ; [THEN] \ Win32 file links 16may00py[IFDEF] win32 legacy on 1 kernel32 DeleteFile DeleteFileA 1 kernel32 RemoveDirectory RemoveDirectoryA 1 kernel32 CreateDirectory CreateDirectoryA 1 kernel32 SetCurrentDirectory SetCurrentDirectoryA 2 kernel32 GetCurrentDirectory GetCurrentDirectoryA 2 kernel32 MoveFile MoveFileA 2 kernel32 FindFirstFile FindFirstFileA 2 kernel32 FindNextFile FindNextFileA 1 kernel32 FindClose FindClose create DTA &11 cells &260 + &14 + allot $20 allot | Variable find-handle \ create and search for files 32b 09mar97py: fsnext ( -- ior ) dta find-handle @ FindNextFile 0= dup IF find-handle @ FindClose drop THEN ; : fsfirst ( C$ attr -- ior ) drop dta swap FindFirstFile dup find-handle ! 0< ; : dcreate ( C$ -- ior ) CreateDirectory ; : ddelete ( C$ -- ior ) RemoveDirectory ; : dsetpath ( C$ -- ior ) SetCurrentDirectory ; : fdelete ( C$ -- ior ) DeleteFile ; : fsetdta ( dta -- ) drop ; : dgetpath ( buffer drive -- ior ) drop $100 GetCurrentDirectory ; : frename ( C$old C$new -- ior ) swap MoveFile ; : dfree ( drive+1 -- total_units free_units b/unit ) drop $1000 $800 $400 ; [THEN] \ sh 11jul99py : PC>sh cr curon r> execute curoff ; Defer >sh ' PC>sh IS >sh [IFDEF] go32 : system ( addr count -- ret ) >sh pad swap 2dup + 0 swap c! move pad $1000FF07 ms-dos ; : sh '# parse system drop ; [ELSE] [IFDEF] unix libc system int (int) system ( C$ -- r ) : sh '# parse tuck pad swap move pad + 0 swap c! pad system drop ; \ sh 23oct99py [ELSE] [IFDEF] win32 \ library msvcrt msvcrt.dll 0 msvcrt system system Variable app-win library shell32 shell32.dll 6 shell32 ShellExecute ShellExecuteA | Create "open S" open" here over allot swap move 0 c, | Create fnbuf $100 allot : system ( addr -- r ) >len 2dup bl scan tuck bl skip drop >r - 0 over fnbuf + c! fnbuf swap move 1 0 r> >len 0<> and fnbuf "open app-win @ ShellExecute ; : sh '# parse tuck pad swap move pad + 0 swap c! pad system drop ; [ELSE] : sh '# parse 2drop ; [THEN] [THEN] [THEN] \ env$ 05apr09py | : env@ mroot $20 + @ ; : env$ ( addr count -- addr' count' ) env@ BEGIN BEGIN >r 2dup r@ @ -text WHILE r> cell+ dup @ 0= UNTIL 2drop drop 0 0 exit THEN r> cell+ 2dup cell- @ + c@ '= = UNTIL cell- @ + 1+ nip >len ; : .env ( -- ) env@ BEGIN dup @ WHILE cr dup @ >len type cell+ stop? UNTIL THEN cr drop ; \ position into files 32b 05feb95py : position ( offset handle -- false/-error ) 0 fseek dup 0< ?exit drop false ; : position? ( handle -- offset ) 0 swap 1 fseek dup ?diskabort ; \ twiggling the file variables 32b 11aug86re : ?fcb ( fcb/ff -- fcb ) ?dup 0= abort" not for direct access !" dup assign? ; : .fcb ( fcb -- ) cell+ ?fcb \ print filename dup filehandle @ 2 .r space dup filesize @ 6 .r space dup .file filename >len type ; \ PATHes 32b 22jun98py [IFDEF] unix ': [ELSE] '; [THEN] Constant pathsep Create pathes $80 allot \ counted string of pathes pathes off : .pathes ( -- ) \ print the pathes cr 3 spaces pathes count type ; : setpath ( addr len -- ) \ set's the list of pathes under pathes count + swap move pathes c@ + pathes c! pathsep pathes count + c! pathes c@ 1+ pathes c! ; \\ PATH : see elsewhere in this file \ search for files 32b 09dec01pyalso Memory | $400 NewPtr Value workspace previous [IFDEF] unix : try.path ( addr len filename attr -- f ) \ true if found drop -rot workspace swap 2dup + >r move '/ r@ c! >len 1+ r> 1+ swap move workspace DTA $10 + swap stat 0= ; [ELSE] : try.path ( addr len filename attr -- f ) \ true if found >r -rot workspace swap 2dup + >r move '\ r@ c! >len 1+ r> 1+ swap move dta fsetdta workspace r> fsfirst 0= ; [THEN] : makec$ ( addr len -- c$ ) \ make addr len to a c$ workspace swap 2dup + >r move \ in "workspace" r> 0 swap c! ( make a c$ ) workspace ; \ search for files 32b 09dec01py | 7 Constant defaultattr \ find all filetypes | : path.file? ( filename -- ff/ C$ tf ) >r pathes count over 0 BEGIN r@ defaultattr try.path IF 2drop rdrop workspace true exit THEN pathsep skip dup WHILE 2dup pathsep scan 2swap 2 pick - REPEAT rdrop nip ; | : (>path.file dup path.file? IF nip THEN ; ' (>path.file IS >path.file : (searchfile ( fcb -- ff/ C$ tf ) \ search for file in path ?fcb filename path.file? ; \ and in act. directory : searchfile ( fcb -- C$ ) \ file was found in path (searchfile 0= abort" File not found" ; \ Dateidatum und -uhrzeit ausgeben 00jan80py [IFDEF] go32 : @time dta &22 + w@ dta &24 + w@ $10 lshift or ; : @attr dta &21 + c@ ; : @length dta &28 + @ ; : dtaname dta $20 + ; : >hms $FFFF and 2* $40 /mod $40 /mod $1F and swap 1- rot ; : >ymd $10 rshift $20 /mod $10 /mod &1980 + swap 1- swap ; [THEN] \ Dateidatum und -uhrzeit ausgeben 22jan10py [IFDEF] unix \ 1 libc localtime localtime ( &time_t -- tm ) : @time dta [IFDEF] bsd $30 [ELSE] $38 [THEN] + @ ; : @attr dta $18 + w@ ; : @length dta [IFDEF] bsd $40 [ELSE] $24 [THEN] + @ ; : dtaname dta @ ; : !dtaname ( addr u -- ) makec$ dta ! ; : >hms sp@ localtime nip @+ @+ @ swap rot ; : >ymd sp@ localtime nip $C + @+ @+ @ ; [THEN] \ Dateidatum und -uhrzeit ausgeben 06dec03py[IFDEF] win32 3 kernel32 FileTimeToDosDateTime FileTimeToDosDateTime | Variable FatDate | Variable FatTime | : (@time ( -- ) FatTime FatDate dta cell+ FileTimeToDosDateTime drop ; : @time (@time FatTime @ FatDate @ $10 lshift or ; : @attr dta @ ; : @length dta 8 cells + @ ; : dtaname dta &11 cells + ; : !dtaname ( addr u -- ) tuck dtaname swap move 0 swap dtaname + c! ; : >hms $FFFF and 2* $40 /mod $40 /mod $1F and swap 1- rot ; : >ymd $10 rshift $20 /mod $10 /mod &1980 + swap 1- swap ; [THEN] \ Dateidatum und -uhrzeit ausgeben 07aug10pyVariable #col : >time ( time -- addr count ) base push decimal >hms 0 <<# # # ': hold drop # # ': hold drop # # #> #>> ; | : .dtatime ( time -- ) >time type ; : >date ( date -- string len ) base push decimal >ymd 0 <<# # # 2drop >r S" janfebmaraprmayjunjulaugsepoctnovdec" r> 0 max &11 min dup dup + + /string 3 min over + 1- DO I c@ hold -1 +LOOP 0 # # #> #>> ; | : .dtadate ( date -- ) >date type ; | : .dtaname ( C$ -- ) \ C$ is addr of name >len under type negate $10 + 1 max spaces ; [IFDEF] unix | : .dtalname ( C$ -- ) \ C$ is addr of name >len under type negate $28 + #col @ - 1 max spaces ; [THEN] \ print dta and directory 32b 06dec03py Variable dir" | Variable -opt | Variable +opt : -opt? ( Char -- flag ) $1F and -opt swap Bit@ ; : -opt! ( Char -- flag ) $1F and -opt swap +Bit ; : +opt! ( Char -- flag ) $1F and +opt swap +Bit ; | : +cr cr #col @ spaces ; \ print dta and directory 32b 07aug10pydefined? go32 defined? win32 or [IF] : .dta 'L -opt? 0= IF dtaname >len under type @attr $10 and IF ." /" 1+ THEN @attr 8 and IF ." :" 1+ THEN negate $E + spaces col cols $F - u> IF +cr THEN ELSE 0 0 <<# @attr S" RHSVDA" bounds DO dup 1 and IF i c@ hold THEN 2/ LOOP drop #> 6 over - spaces type #>> space dtaname .dtaname @length 8 .r 2 spaces @time .dtatime 2 spaces @time .dtadate +cr THEN ; [IFDEF] win32 &11 cells &260 + &14 + [ELSE] &44 [THEN] Constant denlen '\ Constant dirsep | : <path dirsep -scan over 1+ c@ ': = IF 2 max THEN ; | : ?dir $10 and ; hmacro | : all-files s" *.*" ; [THEN] \ print dta and directory 32b 07aug10py[IFDEF] unix : .dta 'L -opt? 0= IF dtaname >len under type S" | / @ = " drop @attr $C >> + c@ emit 1+ negate $E + spaces col cols $F - u> IF +cr THEN ELSE 0 0 <<# @attr S" xwrxwrxwr" bounds DO dup 1 and IF i c@ ELSE '- THEN hold 2/ LOOP 3 >> s" -pc-d-b---l-s---" drop + c@ hold #> &10 over - spaces type #>> space dtaname .dtalname @length 8 .r 2 spaces @time .dtatime 2 spaces @time .dtadate +cr THEN ; '/ constant dirsep $4C Constant denlen | : <path dirsep -scan ; | : ?dir $4000 and ; hmacro | : all-files s" *" ; [THEN] \ print dta and directory 32b 06dec03py: .dta? @attr $20 and 0<> 'N -opt? invert or 'O -opt? xor IF .dta THEN ; : ((dir ( addr attr -- flag ) fsfirst BEGIN 0= WHILE stop? IF true exit THEN .dta? fsnext REPEAT false ; | : insdir ( addr u addr -- ) >len <path + >r r@ >len >r 2dup + 1+ r> 1+ move r> swap 2dup + >r move dirsep r> c! ; | : deldir ( addr -- ) >len <path 2dup + >r 1- <path + r> >len 1+ rot swap move ; | : +path ( path addr u -- ) rot swap 2dup + >r move 0 r> c! ; | : ?break IF 2drop 2drop true rdrop r> dir" ! THEN ; | : ?+cr 'L -opt? 0= IF +cr THEN ; : +dta dtaname >len tuck s" .." drop -text swap 2 > or IF dtaname >len dir" @ place dir" @ c@ 1+ dir" +! THEN ; \ ((hir (dir 06dec03py: get-dirs over >len <path + all-files +path over $10 fsfirst BEGIN 0= WHILE stop? ?break @attr ?dir IF +dta THEN fsnext REPEAT ; : ((hir ( addr count addr attr -- flag ) recursive dir" @ >r get-dirs 2over 2over drop >len <path + -rot +path 2dup ((dir drop dir" @ r@ ?DO I count type ." :" 4 #col +! +cr over I count rot insdir 2over 2over ((hir -4 #col +! IF 2drop 2drop true r> dir" ! unloop exit THEN over deldir col #col @ 4+ = IF at? 4- at ELSE +cr THEN I c@ 1+ +LOOP r> dir" ! 2drop 2drop false ; : (dir ( attr addr len -- ) cr dta fsetdta pad dir" ! 'R -opt? IF 0 #col ! rot >r 2dup makec$ >r 2dup <path nip /string r> r> ((hir ELSE #col off makec$ swap ((dir THEN drop ; \ primitives for fcb's 32b 10oct99py : forthfiles ( -- ) \ print a list of : file-link LIST> \ forthword,filename,handle,len cr .fcb stop? IF unlist THEN ; \ Next Words are for export : path ( -- ) \ this is a smart word ! \ name count /parse dup 0= IF 2drop .pathes exit THEN over c@ pathsep = IF pathes off 1 /string THEN setpath ; \ Killfile 09mar09py : scanopt ( -- addr count ) +opt @ -opt ! +opt off BEGIN /parse dup WHILE over c@ '- = WHILE 1 /string bounds ?DO i c@ -opt! LOOP REPEAT THEN ; | : dir$ ( -- addr ) scanopt makec$ ; : free? [IFDEF] unix s" ." makec$ [ELSE] 0 [THEN] dfree >r cr dgetdrv 'A + emit ." : Von " over . ." Units (" swap r@ m* d. ." Bytes) sind " dup . ." (" r> m* d. ." Bytes) frei." ; \ Killfile 17may99py [IFDEF] unix : killfile dir$ 'A -opt? $80 and 'D -opt? $100 and or fsfirst ?diskabort 0 BEGIN 0= WHILE cr ." Kill? " .dta 'Y -opt? ?dup 0= IF key $FF and capital 'J over = swap 'Y = or THEN IF dtaname fdelete ?diskabort ." killed" THEN fsnext REPEAT ; : files scanopt dup 0= IF 2drop S" *" THEN 'A -opt? $80 and 'D -opt? $100 and or -rot (dir ; [THEN] \ Killfile 09mar97py defined? go32 defined? win32 or [IF] : killfile dta fsetdta dir$ dup 'A -opt? IF $F ELSE 0 THEN fsfirst ?diskabort >len '\ -scan over 1+ c@ ': = IF 2 max THEN 0 BEGIN 0= WHILE cr ." Kill? " .dta 'Y -opt? ?dup 0= IF key $FF and capital 'J over = swap 'Y = or THEN IF 2dup + >r dtaname r> &14 move over fdelete ?diskabort ." killed" THEN fsnext REPEAT 2drop ; : files scanopt dup 0= IF 2drop S" *.*" THEN $10 'A -opt? $F and + -rot (dir ; [THEN] \ File Interface User words 32b 21jun01py : makefile dir$ 0 fcreate dup ?diskabort fclose ?diskabort ; : rename dir$ bl word count over + 0 swap c! frename ?diskabort ; : from isfile push use ; \ sets only fromfile : "use ( addr count -- ) dup 0= abort" missing filename!" ">tib USE ; : eof ( -- f ) \ end of file ? isfile@ dup filehandle @ position? swap filesize @ = ; \ extend files mod 25may03py | : addblock ( n -- ) \ add block n to file buffer dup b/blk bl fill update b/blk isfile@ filesize +! Backup ; : (more ( n -- ) capacity swap bounds ?DO I addblock LOOP ; : more ( n -- ) open (more close ; \ moving blocks mod 03nov91py | : fromblock ( blk -- addr ) fromfile @ (block ; | : (copy ( from to -- ) dup isfile@ core? IF prev @ emptybuf THEN swap >r isfile@ [ memory ] >Purge r> fromblock GetMP dup >r HNoPurge r> HPurge Update ; dos | : blkmove ( from to quan --) save-buffers >r over r@ + over u> >r 2dup u< r> and IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP THEN save-buffers 2drop ; : copy ( from to -- ) 1 blkmove ; : convey ( [blk1 blk2] [to.blk -- ) swap 1+ 2 pick - dup 0> 0= abort" No Sir" blkmove ; \ Allocating buffers index 03nov91py | : range ( from to -- to+1 from ) capacity 1- umin swap capacity 1- umin 2dup > IF swap THEN 1+ swap ; : index ( from to -- ) range DO cr I 4 .r space I block c/l type stop? ?LEAVE LOOP ; \ make, kill and set directories 32b 09mar97py: killdir dir$ ddelete ?diskabort ; : makedir dir$ dcreate ?diskabort ; : pwd here dgetdrv over 0 dgetpath ?diskabort [IFDEF] go32 abs 'A + emit ." :/" [ELSE] drop [THEN] >len type ; : cd dir$ dup c@ 0= IF drop pwd exit THEN dup 1+ c@ ': = \ Laufwerk als Kopf? IF dup c@ capital 'A - dsetdrv drop THEN dsetpath ?diskabort ; \ Die allseits geforderten Unix-like-Aliases: ' files Alias dir ' files Alias ls ' rename Alias mv ' killfile Alias rm \ ' free? Alias df : ll 'L +opt! ls ; \ words for VIEWing 32b 19oct98py | $400 Constant viewoffset \ max. &512 Kbyte lange Files : (view ( %ffffffbbbbbbbbbb -- blk' ) dup 0= ?exit viewoffset u/mod file-link BEGIN @ dup WHILE 2dup cell+ fileno w@ = UNTIL THEN dup IF cell+ dup assign? dup searchfile drop THEN !files drop ; also memory | : ~file ( fid -- ) dup unlink-file DisposHandle ; previous \ missing ANS file words 05aug01py: file-status ( c-addr u -- x ior ) !fid dup >r filename $1F fsfirst dta swap ior [IFDEF] fsend fsend [THEN] r> ~file ; : delete-file ( addr count -- ior ) !fid >r r@ filename fdelete ior r> ~file ; : load-file ( u fileid -- ) isfile push isfile ! load ; : flush-file ( fid -- ior ) isfile push isfile ! ['] close! catch dup 0= IF drop ['] open catch THEN ; : resize-file ( ud fileid -- ior ) >r over r@ filesize ! r@ reposition-file drop r@ ?pos dup IF rdrop EXIT THEN drop [IFDEF] unix r@ filesize @ r> filehandle @ ftruncate ior [ELSE] -1 0 r> write-file [THEN] ; : rename-file ( addr1 u1 addr2 u2 -- ior ) !fid >r !fid dup filename r@ filename frename ior swap ~file r> ~file ; \ Init path at boot time for Linux 31may02pyalso Memory [IFDEF] unix | : ?path ( addr u -- ) over IF setpath ELSE 2drop THEN ; cold: pathes off $400 NewPtr to workspace s" HOME" env$ ?path s" BIGFORTH_PATH" env$ ?path [ s" LIBDIR" env$ 2dup d0= [IF] 2drop s" /usr/local/lib/bigforth" [THEN] ] SLiteral setpath [ s" SRCDIR" env$ 2dup d0= [IF] 2drop s" /usr/local/lib/bigforth/src" [THEN] ] SLiteral setpath ; [ELSE] cold: $400 NewPtr to workspace ; [THEN] previous \\ direct access diskchange? mod 03jan93py \ DOS primitives | Variable (drv | Variable (r/w $10000000 | Constant b/dev b/dev b/blk / | Constant blk/dev Code mediach ( drive -- flag ) \ false = no change SP ) A7 -) move .w 9 # A7 ) move $D trap .l 4 A7 addq D0 ext D0 SP ) move Next end-code Code getbpb ( drive -- bpb ) SP ) A7 -) move .w 7 # A7 ) move $D trap .l 4 A7 addq D0 SP ) move Next end-code \\ blk/drv getblocks 03jan93py | : R/Werr ( err# -- ) (r/w @ IF " write " ELSE " read " THEN diskerr ; | : ?R/Werr ( err# -- ) dup 0< IF R/Werr THEN drop ; Create bpbs $10 cells allot | : bpb ( -- addr ) bpbs (drv @ cells + ; | : getblocks (drv @ getbpb bpb ! ; : b/drv ( -- n ) 0 drv? (drv ! bpb @ >r (drv @ mediach dup ?R/Werr r@ 0= or IF getblocks rdrop bpb @ >r THEN r@ 4+ w@ r> $E + w@ Q* ; : blk/drv ( -- n ) isfile@ 0= IF b/drv b/blk / ELSE defers capacity THEN ; ' blk/drv IS capacity \\ readsector writesector mod 03jan93py Code rwabs ( drv begsec #sec lbuf r/w -- flag ) SP )+ $001F # movem A7 USP move $FFFE # D3 cmpi > IF D3 A7 -) move -1 D3 moveq THEN .w D4 A7 -) move \ Drive D3 A7 -) move \ Startsektor D2 A7 -) move \ Anzahl Sektoren .l D1 A7 -) move \ Buffer .w D0 A7 -) move \ r/w-Flag 4 # A7 -) move \ Funktionsnummer $0D trap .l USP A7 move .l D0 SP -) move \ Fehlerflag Next end-code \\ (drvinit 03jan93py also Memory Variable R/Wbuffer $200 , | : drvinit bpbs $40 erase dgetdrv drive R/Wbuffer @ 0= IF R/Wbuffer 4+ @ $04810001 gemdos R/Wbuffer ! THEN ; drvinit cold: drvinit ; | : R/Walloc ( buflen -- ) dup R/Wbuffer 4+ @ > IF dup R/Wbuffer 4+ ! R/Wbuffer @ $04910001 gemdos R/Werr $04810001 gemdos R/Wbuffer ! exit THEN drop ; toss bye: r> R/Wbuffer dup push off >r ; \\ FileR/W 03jan93py | : R/Wsec ( r/w pos bpb -- ) rot >r >r (drv @ swap r@ w@ / r> $C + w@ + 1 R/Wbuffer @ r> rwabs ?R/Werr ; | : R/Wrest ( addr pos1 len1 bpb -- addr pos2 len2 ) >r over r@ w@ 1- and 0= over r@ w@ > and over 0= or IF rdrop exit THEN r@ w@ R/Walloc 0 2 pick r@ R/Wsec dup 2over r@ w@ under 1- and under - >r R/Wbuffer @ + rot r> min (r/w @ 0= IF >r swap r> THEN move (r/w @ IF 1 2 pick r@ R/Wsec THEN r> w@ 2 pick over 1- and - dup >r /string rot r> + -rot ; | : R/Wmid ( addr pos1 len1 bpb -- addr pos2 len2 ) >r dup r@ w@ < IF rdrop exit THEN (drv @ 2 pick r@ w@ / r@ $C + w@ + 2 pick r@ w@ / 5 pick (r/w @ rwabs ?R/Werr dup r> w@ under / * dup >r /string rot r> + -rot ; \ stdin stdout stderr (linux) 07jul01py [IFDEF] unix : set-file ( fd fcb -- ) >r 0 over 2 fseek dup $7FFFFFFF umin r@ filesize ! 0 max r@ fileOSpos ! r> filehandle ! ; file-link @ File stdin DOES> cell+ dup @ ?EXIT >r s" stdin" r@ assign 0 r@ set-file r> ; File stdout DOES> cell+ dup @ ?EXIT >r s" stdout" r@ assign 1 r@ set-file r> ; File stderr DOES> cell+ dup @ ?EXIT >r s" stderr" r@ assign 2 r@ set-file r> ; file-link ! \ these three aren't real files [THEN] \ exports 08aug08py[IFDEF] win32 export DOS app-win time&date source-id open-file create-file close-file delete-file r/o r/w w/o bin read-file write-file flush-file file-position reposition-file file-size resize-file path killfile free? makefile rename from "use eof files (more more copy convey index killdir makedir pwd dir CD free? LS LL MV RM (view sh ; [ELSE] export DOS time&date source-id stdin stdout stderr open-file create-file close-file delete-file open-dir close-dir read-dir filename-match r/o r/w w/o bin read-file write-file flush-file file-position reposition-file file-size resize-file path killfile free? makefile rename from "use eof files (more more copy convey index killdir makedir pwd dir CD free? LS LL MV RM (view sh ; [THEN] \ HandToHand PtrToHand PtrToXHand 18apr91py DOS also : HandToHand ( MP1 -- MP2 ) dup GetHandleSize under NewHandle >r @ r@ @ rot move r> ; : PtrToHand ( addr -- MP ) dup GetPtrSize under NewHandle >r @ r@ @ rot move r> ; : PtrToXHand ( addr MP -- ) dup >r over GetPtrSize SetHandleSize r> @ over GetPtrSize move ; \ HandAndHand PtrAndHand 11jun88py : HandAndHand ( MP1 MP2 -- ) dup >r over GetHandleSize over GetHandleSize + SetHandleSize dup @ swap GetHandleSize r@ @ r> GetHandleSize + swap >r r@ - r> move ; : PtrAndHand ( Addr MP -- ) dup >r over GetPtrSize over GetHandleSize + SetHandleSize dup GetPtrSize r@ @ r> GetHandleSize + swap >r r@ - r> move ; \ .Heap 11oct91py: .Heap ( -- ) HeapStart base push HeapSem lock BEGIN cr dup @ WHILE hex dup 8+ 6 u.r ': emit dup @ $C - 7 u.r dup NextBlock 4- @ $C - 7 u.r dup Full? ?dup IF dup >r 1+ ?dup IF ." <- " 1- abs 2dup @ 8 - = IF 6 u.r ELSE 4+ @ dup 6 u.r dup Purge@ rot space .File swap 6 .r ': emit . @ 4- @ abs $14 + wx@ 0< IF ." x" THEN THEN THEN r> 0< IF ." locked " THEN ELSE ." Frei " THEN [IFDEF] Pool dup Pool @ = IF ." Pool" THEN dup Pool 2 cells + @ = IF ." First" THEN dup Pool 3 cells + @ = IF ." Shift" THEN [THEN] NextBlock stop? UNTIL THEN drop HeapSem unlock ; \ .blocks 29oct91py : .blocks ( -- ) prev BEGIN @ dup WHILE cr dup dup 4+ @ @ 6 .r 8+ ." Block : " 4+ dup @ over 4+ @ / 4 .r ." File : " dup 4- @ .file 8+ w@ IF ." updated " THEN stop? UNTIL THEN drop ; toss export Memory ; \ Interpretative Structuren 14sep09py| Variable #I | Variable countif Vocabulary [struct] [struct] also definitions : [IF] 1 countif +! ; : [THEN] -1 countif +! ; : [ELSE] [THEN] r> execute [IF] ; ' [IF] alias [IFDEF] ' [IF] alias [IFUNDEF] ' [IF] alias [BEGIN] ' [IF] alias [WHILE] ' [THEN] alias [UNTIL] ' [THEN] alias [AGAIN] ' [IF] alias [DO] ' [IF] alias [?DO] ' [THEN] alias [LOOP] ' [THEN] alias [+LOOP] : [REPEAT] [AGAIN] [THEN] ; ' [THEN] alias [ENDIF] ' ( alias ( ' (* alias (* ' /* alias /* ' \* alias \* ' \ alias \ ' \\ alias \\ ' \\\ alias \\\ --> \ Interpretative Structuren 14sep09py| Variable parser' | : scanIF [ context @ ] ALiteral (find IF name> execute countif @ 0< IF parser' @ IS parser THEN ELSE drop THEN ; Forth definitions : defined? name find nip 0<> ; : [defined] defined? ; immediate : [undefined] defined? 0= ; immediate : [IF] what's parser parser' ! 0= IF countif off ['] scanIF IS parser THEN ; immediate : [IFDEF] defined? compile [IF] ; immediate : [IFUNDEF] defined? 0= compile [IF] ; immediate : [ELSE] 0 compile [IF] ; immediate : [THEN] ; immediate : [ENDIF] ; immediate Onlyforth --> \ Structs for interpreter 11mar00py: [DO] ( start end -- ) #I push >in @ -rot DO I #I ! dup >r >in ! interpret r> swap +LOOP drop ; immediate : [?DO] 2dup = IF 2drop compile [ELSE] ELSE compile [DO] THEN ; immediate : [+LOOP] ( n -- ) rdrop rdrop ; immediate : [LOOP] ( -- ) 1 rdrop rdrop ; immediate : [FOR] ( n -- ) 0 swap compile [DO] ; immediate : [NEXT] ( n -- ) -1 rdrop rdrop ; immediate : [I] ( -- index ) #I @ ?lit, ; immediate : [BEGIN] >in @ >r BEGIN r@ >in ! interpret UNTIL rdrop ; immediate ' [+LOOP] alias [UNTIL] immediate : [REPEAT] ( -- ) false rdrop rdrop ; immediate ' [REPEAT] alias [AGAIN] immediate : [WHILE] 0= IF compile [ELSE] true rdrop rdrop 1 countif +! THEN ; immediate
\ No newline at end of file
\\ *** Floating Point Bindings *** 02may95py Unlike for the ST, I provide a native floating point binding for the 387 and compatible, because it's likely for a FP user to have a coprocessor. If not, (s)he can use emu387 from DJ Delorie. This binding uses the 8 items depth stack of the 80387, so be carefully not to exceed this stack depth. This prohibits recursive algorithms without using a second stack for results, but speeds things up very much. Notice, that ASCII output of FP numbers will not work with a full stack, it needs 2 items free over the TOS! \ Fliekommaarithmetik Loadscreen double pres. 09jul00py Module Float $A Constant Fcell -$A Constant -Fcell : Float+ Fcell + ; macro 0 :#+ T&P Code Floats AX AX add AX AX *4 I) AX lea Next end-code macro 1 capacity 4 - +thru [IFDEF] environment environment definitions true to floating true to floating-ext !$7.FFFFFFFFFFFFFFF8'FFF f2* fconstant max-float [THEN] Module; \ floating error handling status code 17aug93py Variable fpstat fpstat off \ errorcode | -&42 Constant FPdiv0 | -&43 Constant FPoverflow | -&44 Constant FPstackfull | -&45 Constant FPstackempty | -&46 Constant FPwrongarg ' align Alias falign ' aligned Alias faligned ' align Alias sfalign ' aligned Alias sfaligned ' align Alias dfalign ' aligned Alias dfaligned ' cells Alias sfloats ' cell+ Alias sfloat+ : dfloats 2* cells ; macro : dfloat+ cell+ cell+ ; macro \ floating error handler 23mar09pyhere negate 3 and allot Label :f0 $073F w, $033F w, $0F3F w, Code FClearStack finit :f0 2+ A#) fldcw Next end-code FClearStack Code FClex fnclex Next end-code macro ' FClearStack Alias fpu-init : truncate $0F3F :f0 4+ w! ; \ default : nearest $033F :f0 4+ w! ; : down $073F :f0 4+ w! ; : up $0B3F :f0 4+ w! ; | : -fak ( flag -- ) IF FPwrongarg throw THEN ; Label fexp# $40 c, -$2C c, $01 c, -$14 c, $10 c, -$2B c, $08 c, -$2B c, $04 c, -$2A c, $02 c, -$2E c, $20 c, -$29 c, $00 c, -$01 c, What's 'catch Alias old-catch \ floating point exception handling 02may95py Label fp-recover pusha dumped A# DI mov SP SI mov $B # CX mov rep movs popa 3 cells # SP add 'UP A#) UP mov AX fstsw fnclex SP RP cmp u> IF :S R: THEN user' s0 UP D) SI cmp u> IF user' s0 UP D) SI mov THEN user' s^ UP D) SI cmp u<= IF user' s0 UP D) SI mov THEN fexp# A# CX mov BEGIN .w CX ) DX mov DL AL test 0= WHILE 2 # CX add DL DL test 0= UNTIL THEN -$2C # DH cmp 0= IF $47 # AH and $41 # AH cmp 0= IF -$2D # DH mov THEN THEN DH AX movsx A:: ' throw rel) jmp end-code \ Stack operations 02may95py Code Fdepth ( -- n ) AX push fxam ( fwait ) AX fstsw $FD # AH and $41 # AH cmp 0= IF AX AX xor ELSE $B # AX shr 7 # AX and 7 # AX xor AX inc THEN Next end-code Label taskpause :R pushf BX push DI push AX push SI push fxam ( fwait ) AX fstsw $FD # AH and $41 # AH cmp 0= IF 0 # push ELSE $B # AX shr 7 # AX and 7 # AX xor AX DX mov BEGIN $C # SP sub .fx SP ) fstp ( fwait) AX dec 0< UNTIL DX inc DX push THEN CX call CX pop ?DO .fx SP ) fld $C # SP add LOOP THEN \ -$6C # SP add SP ) fsave CX call SP ) frstor $6C # SP add SI pop AX pop DI pop BX pop popf ret end-code \ Fnegate Fabs F0= F0< F0> 27feb99py Code D>F ( d -- f ) DX pop AX push DX push .fq SP ) fld 8 # SP add AX pop Next end-code macro :dx :ax T&P Code S>F ( n -- f ) AX push .fd SP ) fld AX pop AX pop Next end-code macro :ax :ax T&P Code Fnegate ( f -- -f ) fchs Next end-code macro Code Fabs ( f -- |f| ) fabs Next end-code macro Code F2* ( f -- f*2 ) 0 ST fadd Next end-code macro | Create .5 $3F000000 , Code F2/ ( f -- f/2 ) .fs .5 A#) fmul Next end-code macro \ Fnegate Fabs F0= F0< F0> 25oct93py Code F0= AX push ftst ( fwait ) AX fstsw 0 ST fstp sahf AL 0<> setIF 1 # AX and AX dec Next end-code macro :ax :f T&P Code F0< AX push ftst ( fwait ) AX fstsw 0 ST fstp sahf AL u>= setIF 1 # AX and AX dec Next end-code macro :ax :f T&P Code F0> AX push ftst ( fwait ) AX fstsw 0 ST fstp sahf AL u<= setIF 1 # AX and AX dec Next end-code macro :ax :f T&P : F0>= F0< 0= ; macro : F0<= F0> 0= ; macro : F0<> F0= 0= ; macro \ Fdrop Fdup Fswap Fover F>r Fr@ Fr> Frot F-rot 12jun00pyCode Fdrop ( f -- ) 0 ST fstp Next end-code macro Code Fdup ( f -- f f ) 0 ST fld Next end-code macro Code Fswap ( f1 f2 -- f2 f1 ) 1 ST fxch Next end-code macro Code Fover ( f1 f2 -- f1 f2 f1 ) 1 ST fld Next end-code macro Code Fover2 ( f3 -- f3 f1 ) 2 ST fld Next end-code macro Code Fover3 ( f3 -- f3 f1 ) 3 ST fld Next end-code macro : Funder ( f1 f2 -- f2 f1 f2 ) fswap fover ; macro Code F>r ( f -- ) $C # RP sub .fx RP ) fstp \ fwait Next end-code macro Code Fr@ ( f -- ) .fx RP ) fld Next end-code macro Code Fr> ( f -- ) .fx RP ) fld $C # RP add Next end-code macro Code Frot ( f1 f2 f3 -- f2 f3 f1 ) 1 ST fxch 2 ST fxch Next end-code macro Code F-rot ( f1 f2 f3 -- f3 f1 f2 ) 2 ST fxch 1 ST fxch Next end-code macro \ Fpick Fpin Fnip 04oct99py Code Fpick ( n -- fn ) 7 # AX and AL AH xchg $C0D9 # AX add .w AX here 8+ A#) mov AHEAD THEN 0 ST fld AX pop Next end-code Code Fpin ( f n -- ) AX inc 7 # AX and AL AH xchg $D8DD # AX add .w AX here 8+ A#) mov AHEAD THEN 1 ST fstp AX pop Next end-code Code Fnip ( f1 f2 -- f2 ) 1 ST fstp Next end-code macro | Code 22fpick ( f1 f2 f3 -- f1 f2 f3 f1 f2 ) 1 ST fld 3 ST fld Next end-code macro Code Flit1 AHEAD Fcell allot THEN Next end-code macro Code Flit2 .fx 0 A#) fld Next end-code macro \ F@ F! Fvariable Fconstant 04oct99pyCode F@ ( addr -- f ) .fx AX ) fld AX pop Next end-code macro 0 :ax T&P Code F! ( f addr -- ) .fx AX ) fstp ( fwait) AX pop Next end-code macro 0 :ax T&P : F, ( f -- ) here Fcell allot f! ; : Fvariable Create Fcell allot ; : Fconstant Create F, Does> F@ ; \ Code Flit ( addr -- f ) R: DX pop .fx DX ) fld \ Fcell # DX add DX jmp Next end-code \ : Fliteral state @ 0= ?EXIT \ compile Flit f, ; immediate restrict : Fliteral state @ 0= ?EXIT compile Flit1 here Fcell - 2- dup f! compile Flit2 here 6 - ! ; immediate restrict \ f>d f>s F* F/ F+ f- 12jun00pyCode ff>d ( f -- d ) AX push :f0 A#) fldcw 8 # SP sub .fq SP ) fstp :f0 2+ A#) fldcw DX pop AX pop DX push Next end-code \ macro :ax :dx T&P Code ff>s ( f -- n ) AX push :f0 A#) fldcw .fd SP ) fstp ( fclex ) :f0 2+ A#) fldcw AX SP ) xchg Next end-code \ macro :ax 0 T&P Code f>d ( f -- d ) AX push :f0 4+ A#) fldcw 8 # SP sub .fq SP ) fstp :f0 2+ A#) fldcw DX pop AX pop DX push Next end-code \ macro :ax :dx T&P Code f>s ( f -- n ) AX push :f0 4+ A#) fldcw .fd SP ) fstp ( fclex ) :f0 2+ A#) fldcw AX SP ) xchg Next end-code \ macro :ax 0 T&P \ f>fd f>fs fd>f fs>f 28may00py Code f* ( f1 f2 -- f ) 1 STP fmul Next end-code macro Code f/ ( f1 f2 -- f ) 1 STP fdivr Next end-code macro Code F+ ( f1 f2 -- f ) 1 STP fadd Next end-code macro Code F- ( f1 f2 -- f ) 1 STP fsubr Next end-code macro Code f>fd ( f -- fd ) AX push 8 # SP sub .fl SP ) fstp AX pop Next end-code macro :ax :ax T&P Code f>fs ( f -- fs ) AX push 4 # SP sub .fs SP ) fstp AX pop Next end-code macro :ax :ax T&P Code fd>f ( fd -- f ) AX push .fl SP ) fld 8 # SP add AX pop Next end-code macro :ax :ax T&P Code fs>f ( fs -- f ) AX push .fs SP ) fld 4 # SP add AX pop Next end-code macro :ax :ax T&P \ fm* fm/ fm*/ 20apr09pyCode !0 ( -- 0 ) fldz Next end-code macro Code !1 ( -- 1 ) fld1 Next end-code macro Code 1/f ( f -- 1/f ) fld1 1 STP fdiv Next end-code macro Code Fm* ( f u32b -- f*u32b ) AX push .fd SP ) fmul ( fwait) AX pop AX pop Next end-code macro :ax :ax T&P Code Fm/ ( f u32b -- f/u32b ) AX push SP ) fdiv ( fwait) AX pop AX pop Next end-code macro :ax :ax T&P Code Fm*/ ( f u32b1 u32b2 -- f*u32b1/u32b2 ) SP ) fmul ( fwait) AX SP ) mov SP ) fdiv ( fwait) AX pop AX pop Next end-code macro 0 :ax T&P | Create 2fs !0 f, !0 f, : Fequal ( f1 f2 -- f1-f2=0 ) 2fs f! 2fs float+ f! 2fs 1 floats 2fs float+ over str= ; \ floor frac frnd 20apr09pyCode floor ( f -- fs ) :f0 A#) fldcw frndint :f0 2+ A#) fldcw Next end-code macro : frac ( f -- f ) fdup floor f- ; Code Fsign ( f -- -1:0< ; 0:0= ; 1:0> ) AX push ftst ( fwait) AX fstsw 0 ST fstp sahf AL 0<> setIF u< IF AL neg THEN AL AX movsx Next end-code Code Fcomp ( f1 f2 -- -1:0< ; 0:0= ; 1:0> ) AX push 1 STP fcomp ( fwait ) AX fstsw 0 ST fstp sahf AL 0<> setIF u> IF AL neg THEN AL AX movsx Next end-code Code F= ( f1 f2 -- flag ) AX push fcompp ( fwait ) AX fstsw sahf AL 0<> setIF 1 # AX and AX dec Next end-code macro :ax :f T&P \ Fsign Fcomp F> F< Fmin Fmax F= 04feb01pyCode F< ( f1 f2 -- flag ) AX push fcompp ( fwait ) AX fstsw sahf AL u<= setIF 1 # AX and AX dec Next end-code macro :ax :f T&P Code F> ( f1 f2 -- flag ) AX push fcompp ( fwait ) AX fstsw sahf AL u>= setIF 1 # AX and AX dec Next end-code macro :ax :f T&P : F<= ( f1 f2 -- f1<f2 ) F> 0= ; macro : F>= ( f1 f2 -- f1>f2 ) F< 0= ; macro : F<> ( f1 f2 -- f2<>f2 ) F= 0= ; macro Code Fmax AX push 1 ST fcom AX fstsw sahf u<= IF 0 ST fstp ELSE 1 ST fstp THEN AX pop Next end-code macro :ax :ax T&P Code Fmin AX push 1 ST fcom AX fstsw sahf u>= IF 0 ST fstp ELSE 1 ST fstp THEN AX pop Next end-code macro :ax :ax T&P \ Tabellen 23dec02py| : !! 1 max >r !1 r> 1+ 2 ?DO i fm* LOOP ; | : tab: here dup >r | : swap compile ALiteral swap compile Literal compile ; hmacro r> dp ! ; &07 tab: teta' !1 &156 fm/ f, &691 s>f &360360 s>f f/ f, !1 &1188 fm/ f, !1 &1680 fm/ f, !1 &1260 fm/ f, !1 &360 fm/ f, !1 &12 fm/ f, \\ &07 dup tab: sin' 1 swap 2* 1- [DO] [I] !! 1/f f, -2 [+LOOP] &10 dup tab: cos' 0 swap 1- 2* [DO] [I] !! 1/f f, -2 [+LOOP] &16 dup tab: exp' 2- [FOR] [I] 1+ !! 1/f f, [NEXT] !0 f, &06 dup tab: ln' 1 swap 2* 1- [DO] !1 [I] fm/ f, -2 [+LOOP] &24 dup tab: atan' 1 swap 2* 1- [DO] !1 [I] fm/ f, -2 [+LOOP] &28 dup tab: asin' 3 swap 2* 1- [DO] !1 [I] 1 [?DO] [I] [I] 1+ fm*/ 2 [+LOOP] [I] fm/ f, -2 [+LOOP] !1 f, \ sf@ df@ sf! df! 07mar09pyCode sf@ ( addr -- f ) .fs AX ) fld AX pop Next end-code macro 0 :ax T&P Code df@ ( addr -- f ) .fl AX ) fld AX pop Next end-code macro 0 :ax T&P Code sf! ( f addr -- ) .fs AX ) fstp ( fwait) AX pop Next end-code macro 0 :ax T&P Code df! ( f addr -- ) .fl AX ) fstp ( fwait) AX pop Next end-code macro 0 :ax T&P : sf, here sf! 1 sfloats allot ; : df, here df! 1 dfloats allot ; Variable fseed timer@ fseed ! | $10450405 Constant rnd# | : rnd fseed @ rnd# * 1+ dup fseed ! ; : Frnd ( -- ramdom ) $3fff >r rnd $80000000 or >r rnd >r fr> !1 f- ; \ sf@+ df@+ sf!+ df!+ 17oct99py Code sf@+ ( addr -- f ) .fs AX ) fld 1 sfloats AX D) AX lea Next end-code macro Code df@+ ( addr -- f ) .fl AX ) fld 1 dfloats AX D) AX lea Next end-code macro Code sf!+ ( f addr -- ) .fs AX ) fstp 1 sfloats AX D) AX lea Next end-code macro Code df!+ ( f addr -- ) .fl AX ) fstp 1 dfloats AX D) AX lea Next end-code macro \ horner fln fsqrt fexp fexpm1 flnp1 23dec02py : horner ( f addr n -- f ) !0 Floats bounds DO fover f* I f@ f+ fcell +LOOP fnip ; Code fsqrt ( f -- sqrt[f] ) fsqrt Next end-code macro Code fscale ( f1 f2 -- f ) 1 ST fxch fscale 1 ST fstp Next end-code macro Code fxtract ( f -- f n ) fxtract AX push AX push 1 ST fxch .fd SP ) fstp ( fwait) AX pop Next end-code Code pi fldpi Next end-code macro Code ln2 fldln2 Next end-code macro \ f~ f>s round ceiling fmod 03sep09py : f~ ( f1 f2 f3 -- flag ) fdup f0= IF fdrop fequal EXIT THEN fdup f0> IF f>r f- fabs fr> ELSE fnegate f>r fover fabs fover fabs f+ f>r f- fabs fr> fr> f* THEN f< ; Code fround ( f -- round[f] ) frndint Next end-code : ceiling ( f -- ceiling[f] ) fnegate floor fnegate ; Code ftrunc ( f -- fs ) :f0 4+ A#) fldcw frndint :f0 2+ A#) fldcw Next end-code macro : fmod ( f1 f2 -- f1modf2 ) funder f/ frac f* ; \ horner fln 29mar95py Code fln ( f -- ln[f] ) fldln2 1 ST fxch fyl2x ( fwait) Next end-code macro Code flog ( f -- ln[f] ) fldlg2 1 ST fxch fyl2x ( fwait) Next end-code macro Code flb ( f -- ln[f] ) fld1 1 ST fxch fyl2x ( fwait) Next end-code macro Code flogb ( fx fb -- logb[x] ) fld1 1 ST fxch fyl2x ( fwait) fld1 1 STP fdiv 1 ST fxch fyl2x Next end-code | Code (lnp1 ( f -- ln[f+1] ) fldl2e 1 ST fxch fyl2xp1 Next end-code macro : flnp1 ( f -- ln[f+1] ) fdup f0= ?EXIT fdup [ 2 s>f fsqrt f2/ !1 f- ] FLiteral f> IF fdup [ 2 s>f fsqrt !1 f- ] FLiteral f< IF (lnp1 EXIT THEN THEN !1 f+ fln ; \ fexp 14jul98py Code fexp ( f1 -- f2 ) fldl2e 1 STP fmul 0 ST fld frndint 1 <ST fsubr 1 ST fxch f2xm1 fld1 1 STP fadd fscale 1 ST fstp Next end-code macro Code fexpm1 ( f1 -- f2 ) AX push fldl2e 1 STP fmul 0 ST fld frndint 1 <ST fsubr 1 ST fxch f2xm1 fincstp ftst ( fwait ) fdecstp AX fstsw sahf 0= IF AX pop 1 ST fstp Next THEN fld1 1 STP fadd fscale 1 ST fstp fld1 1 STP fsubr AX pop Next end-code \ fatan fasin 15dec02py [IFDEF] ownatan $25 $26 thru | : fpatan f/ fatan ; [ELSE] Code fatan fld1 fpatan Next end-code macro Code fasin 0 ST fld 0 ST fmul fld1 1 STP fsub fsqrt fpatan Next end-code Code fatan2 fpatan Next end-code macro [THEN] \ fsin fcos fsincos 18apr93py Code fsin ( f -- sin[f] ) fsin Next end-code macro Code fcos ( f -- cos[f] ) fcos Next end-code macro Code fsincos ( f -- sin[f] cos[f] ) fsincos Next end-code macro \ fm^ f^ fine^ grad>rad rad>grad r,phi>xy 25may09py Code f**2 ( fx -- fx**2 ) 0 ST fmul Next end-code macro : fm** ( f n -- f**n ) dup >r abs >r !1 fswap BEGIN r@ 1 and IF funder f* fswap THEN r> 2/ dup WHILE >r f**2 REPEAT drop fdrop r> 0< IF 1/f THEN ; : f** ( fx fy -- fx**y ) ( fdup frac f0= IF f>s fm** ELSE ) fswap fln f* fexp ( THEN ) ; : falog ( f -- 10^f ) [ &10 s>f fln ] FLiteral f* fexp ; : grad>rad ( fgrad -- frad ) [ pi &180 fm/ ] Fliteral f* ; : rad>grad ( frad -- fgrad ) [ &180 s>f pi f/ ] Fliteral f* ; Code r,phi>xy ( r phi -- x y ) fsincos 2 ST fmul 2 ST fxch 1 STP fmul Next end-code macro \ Fakultt und Stirlingsche Nherung 18apr93py | : teta ( exp n -- exp+teta[n] ) 1/f fdup f**2 fnegate teta' horner f* f+ ; : stirling ( f -- f! ) fdup [ !1 f2/ ] FLiteral f+ fover fln f* fover f- [ pi f2* fln f2/ ] FLiteral f+ fswap teta fexp ; : fak ( f -- f! ) fdup fround fabs funder f= invert -fak fdup [ &200 s>f ] Fliteral f> IF stirling ELSE ff>s !! THEN ; \ Trigonometrische Funktionen 15dec02py: fsec ( f -- sec[f] ) fsin 1/f ; macro : fcosec ( f -- sec[f] ) fcos 1/f ; macro Code ftan ( f -- tan[f] ) fptan 0 ST fstp Next end-code macro : fcot ( f -- cot[f] ) fsincos fswap f/ ; macro : facos ( f -- arccos[f] ) fasin fnegate [ pi f2/ ] FLiteral f+ ; : facot ( f -- arccot[f] ) fdup f0= IF fdrop [ pi f2/ ] FLiteral EXIT THEN 1/f fatan fdup f0< IF pi f+ THEN ; [IFUNDEF] fatan2 : fatan2 ( sin cos -- angle ) fover f0= IF fdup f0< ELSE fover f0< THEN >r fdup f0= IF fdrop fdrop pi f2/ ELSE fpatan fdup f0< IF pi f+ THEN THEN r> IF pi f- THEN ; [THEN] \ Hyperbel- und Areafunktionen 17apr09py : fsinh fexpm1 fdup fdup !1 f+ f/ f+ f2/ ; : fcosh fexp fdup 1/f f+ f2/ ; : fsech fsinh 1/f ; : fcosech fcosh 1/f ; : ftanh f2* fexpm1 fdup [ 2 s>f ] FLiteral f+ f/ ; : fcoth f2* fexpm1 fdup [ 2 s>f ] FLiteral f+ fswap f/ ; : fatanh fdup f0< >r fabs !1 fover f- f/ f2* flnp1 f2/ r> IF fnegate THEN ; : facoth fdup f0< >r fabs !1 f- 1/f f2* flnp1 f2/ r> IF fnegate THEN ; : fasinh fdup fdup f* !1 f+ fsqrt f+ fln ; : facosh fdup fdup f* !1 f- fsqrt f+ fln ; \ Statistikfunktionen 28may00py: frandom ( n -- 0/n-1) frnd f* floor ; : fchoose ( n k -- k_choose_n ) fdup frac f0<> -fak fdup f0<= IF fnip f0= IF !1 ELSE !0 THEN EXIT THEN fover frac f0<> IF ff>s >r fdup r> 1+ 2 ?DO !1 f- funder f* i fm/ fswap LOOP fdrop EXIT THEN fover fover f< IF fdrop fdrop !0 EXIT THEN fdup fak f>r fover [ &400 s>f ] FLiteral f> IF fover fak f-rot f- fak f/ ELSE ff>s >r ff>s 1+ dup r> - >r >r !1 r> r> ?DO i fm* LOOP THEN fr> f/ fround ; : bernoulli ( n k p -- b[n,k,p] ) fdup f>r fover f** f-rot fover fover f- !1 fr> f- fswap f** f-rot fchoose f* f* ; \ Zahlen ausgeben 20apr09py : fextract ( f -- dmant nexp sign ) fdup f0= IF 0. 0 !0 fequal 0= EXIT THEN \ zero is trivial fdup fxtract f0< >r 1+ fabs \ |f| exp+1 r: sign ln2 base @ s>f fln f/ \ |f| fln(2)/fln(base) exp+1 fdup fm* ff>s >r \ .. r: sign exponent[base] [ &64 s>f ] Fliteral f* ff>s 1- \ representable digits r> over >r dup >r - base @ s>f fm** f* \ fmant r: sg rd exb !1 f+ f2/ ff>d 2dup d+ base @ \ d(round(f)) base base BEGIN dup r@ abs 4/ 2/ < WHILE base @ * r> 1+ >r REPEAT dup >r ud/mod \ mod dquot r: sg rd exb rot r> 2/ > IF 1. d+ THEN \ round adjusted number r> r> - 1+ r> ; \ dmant exb-rd+1 sign : esign base @ &10 = IF sign 'e hold ELSE 0< IF '- ELSE '+ THEN hold THEN ; \ represent 03oct06py: fadjust ( dmant nexp n -- dmant' nexp' ) swap >r 1. rot 0 ?DO 2dup base @ 0 d* 2over 2over d< IF 2swap THEN 2drop LOOP 2swap 0 >r BEGIN 2over 2over d< WHILE base @ ud/mod rot dup 0= over base @ 2/ = or r> 0<> and - r> 1+ >r >r REPEAT r> base @ 2/ 3 pick 1 and IF >= ELSE > THEN IF 1. d+ THEN 2swap 2drop r> ; : represent ( f addr u -- n flag1 flag2 ) 2>r fextract r@ swap >r fadjust r> 2r> 2swap >r >r 2swap <# #S #> r> over + >r 2swap 2over 2over rot min move rot /string '0 fill drop r> r> true ; | User (precision : precision (precision @ ; : set-precision (precision ! ; \ Zahlen ausgeben 19aug07py| : fscratch ( -- addr u ) pad precision - $20 - cell- precision ; | : fscratch' ( -- addr u ) fscratch '0 -skip ; | : f$ ( f -- n sign ) fscratch represent drop ; \needs 3* | : 3* ( n -- n*3 ) dup 2* + ; hmacro | : zeros ( n -- ) 0 ?DO '0 hold LOOP ; | : .fexp ( n -- ) extend under dabs <# #S 2drop esign ; | : finish ( sign -- addr u ) sign 0. #> ; | : .$# ( addr u -- ) dup 0= IF 2drop EXIT THEN bounds swap 1- DO I c@ hold -1 +LOOP ; | : 0.f ( sign -- addr u ) s" 0." .$# finish ; | : .. ( addr n -- ) dup IF .$# '. hold ELSE 2drop THEN ; | : $#.f ( addr u sign -- addr u ) >r .$# r> finish ; | : $0.f ( addr u sign -- addr u ) >r .$# r> 0.f ; \ Zahlen ausgeben 09jan05py : fs$ ( f -- addr u ) f$ >r .fexp fscratch r> $0.f ; : fe$ ( f -- addr u ) f$ >r 1- 3 /mod 3* .fexp 1+ >r fscratch over r@ 2swap r> /string .$# '. hold .$# r> finish ; : fx$ ( f -- addr u ) fdup f0= IF fdrop s" 0" EXIT THEN f$ >r >r fscratch' r@ 1- -3 u> IF <# .$# r> negate zeros r> 0.f EXIT THEN dup r@ u>= IF <# over r@ 2swap r> /string .. r> $#.f EXIT THEN r@ precision 3 + u<= IF <# r> over - zeros r> $#.f EXIT THEN r> 1- .fexp 2dup 1 /string .. drop c@ hold r> finish ; \ Zahlen ausgeben 09jul00py : ff$ ( f -- addr u ) f$ >r >r fscratch' r@ abs $40 > IF r> .fexp r> $0.f EXIT THEN r@ 0> IF <# 2dup r@ min 2swap r@ over - 0 max r> swap >r /string .$# '. hold r> zeros .$# r> finish EXIT THEN <# .$# r> negate zeros r> 0.f ; : fs. ( f -- ) fs$ type space ; : fx. ( f -- ) fx$ type space ; : fe. ( f -- ) fe$ type space ; : ff. ( f -- ) ff$ type space ; ' ff. alias f. ' ff$ alias f$ \ fdump f.s fe.s 09jul00py| : .flit ( IP -- IP' ) drop dup f@ '! emit fx. float+ ; Tools ' Flit1 ' .flit bind-see Float : fdump ( -- ) base @ fdepth 0 ?DO hex cr i fpick pad Fcell - f! pad Fcell - 2@ swap pad [ Fcell 8 - ] Literal - w@ 0 <# 3 FOR # NEXT #> type <# 7 FOR # # bl hold NEXT #> type dup base ! 2 spaces i fpick fx. stop? ?LEAVE LOOP drop ; : f.s fdepth 0 ?DO i fpick fswap f>r fx. fr> LOOP ; : fe.s fdepth 0 ?DO cr i fpick fswap f>r fe. fr> LOOP ; \\ : f.all ( f -- ) fdup floor fx. curleft frac fdup f0= 0= IF ." ." THEN BEGIN fdup f0= 0= WHILE base @ fm* fdup ff>s 0 u.r frac REPEAT fdrop ; \ fdpl fsign? fbase? exp# 31aug07py| Variable fdpl fdpl on | : fsign? ( addr count -- addr count sign ) over c@ Ascii - case? IF 1 /string true EXIT THEN Ascii + case? IF 1 /string false EXIT THEN drop 0 ; here $10 c, %10 c, &10 c, | : fbase? ( addr count -- addr count ) over c@ Ascii $ - dup 3 u< IF [ rot ] ALiteral + c@ base ! 1 /string EXIT THEN drop ; | : >esign ( addr u -- addr' u' ) 2dup bounds ?DO s" dDeE'+-" base @ &10 > 4 and /string I c@ scan nip IF 2drop I I' over - unloop EXIT THEN LOOP + 0 ; | : exp# ( addr count -- exp t / f ) fsign? >r 0. 2swap >number >r 2drop r> IF drop 0 EXIT THEN r> IF negate THEN true ; \ >float 31aug07py: >float ( addr count -- f t / f ) base push bl skip -trailing fsign? >r fbase? Ascii 0 skip 2dup 2dup >esign nip - bounds fdpl on >r >r !0 r> r> ?DO i c@ digit? IF ?dup 0= IF base @ fm* ELSE >r fdup f0= 0= IF base @ fm* r> s>f f+ ELSE fdrop r> s>f THEN THEN ELSE i c@ $FD and ', = 0= fdpl @ i' 1+ i - = or IF fdrop 2drop UNLOOP rdrop false EXIT THEN i' i - fdpl ! THEN LOOP r> IF fnegate THEN f>r >esign over c@ '- <> negate /string dup 0= IF nip ELSE exp# 0= IF fr> fdrop false EXIT THEN THEN >r base @ s>f r> fdpl @ 1- 0 max - dup >r abs fm** r> fr> 0< IF fswap f/ ELSE f* THEN true ; \ fnumber 19aug07py| What's notfound alias oldnotfound \ [IFDEF] ANS : f# ( addr -- f ) >r r@ count over c@ '! = IF 1 /string THEN >float IF rdrop state @ IF compile Fliteral THEN EXIT THEN r> oldnotfound ; \ [ELSE] : f# ( addr -- f ) dup 1+ c@ '! = \ IF >r r@ count 1 /string >float \ IF rdrop state @ IF compile Fliteral THEN EXIT THEN\ r> THEN oldnotfound ; ( [THEN]) ' f# IS notfound \ export: bye: 14mar10py: f-catch Fclex fdepth >r defers 'catch r@ 8 0 within IF rdrop FClearStack EXIT THEN r> fdepth - dup 0< IF negate 0 ?DO fdrop LOOP ELSE 0 ?DO !0 LOOP THEN ; bye: lasterr @ 0> ?EXIT FClearStack [ except' $10 cells + dup @ ] ALiteral ALiteral ! [ ' multitask 4+ dup @ ] ALiteral ALiteral ! multitask ['] old-catch IS 'catch ['] oldnotfound IS notfound ; : f-init ['] f-catch IS 'catch ['] f# IS notfound ; also environment cold: fp-recover except' $10 cells + ! FClearStack ; export: drop taskpause [ ' multitask 4+ ] ALiteral ! multitask true to floating true to floating-ext &18 set-precision f-init \ export list 14mar10pyexport float fcell -fcell float+ floats fpstat falign faligned sfalign sfaligned dfalign dfaligned sfloats sfloat+ dfloats dfloat+ fclearstack fclex truncate nearest down up fdepth d>f s>f fnegate fabs f2* f2/ f0= f0< f0> f0>= f0<= f0<> fdrop fdup fswap fover fover2 fover3 funder f>r fr@ fr> frot f-rot fpick fpin fnip f@ f! f, fvariable fconstant fliteral ff>d ff>s f>d f>s f* f/ f+ f- f>fd f>fs fd>f fs>f !0 !1 1/f fm* fm/ fm*/ fequal floor frac fsign fcomp f= f< f> f<= f>= f<> fmax fmin sf@ df@ sf! df! sf, df, fseed frnd sf@+ df@+ sf!+ df!+ horner fsqrt fscale fxtract pi ln2 f~ fround ceiling ftrunc fmod fln flog flb flogb flnp1 fexp fexpm1 fatan fasin fatan2 fsin fcos fsincos f**2 fm** f** falog grad>rad rad>grad r,phi>xy stirling fak fsec fcosec ftanh fcoth fatanh facoth fasinh facosh frandom fchoose bernoulli represent precision set-precision fs$ f$ fx$ ff$ fs. fx. fe. ff. f. f$ fdump f.s fe.s >float f# f-catch f-init ; toss \ (arctan (arcsin 20apr93py &24 dup tab: atan' 1 swap 2* 1- [DO] !1 [I] fm/ f, -2 [+LOOP] &28 dup tab: asin' 3 swap 2* 1- [DO] !1 [I] 1 [?DO] [I] [I] 1+ fm*/ 2 [+LOOP] [I] fm/ f, -2 [+LOOP] !1 f, | : (arctan ( f -- arctan[f] ) fdup f0= ?EXIT fdup fdup f* fnegate atan' horner f* ; | : (arcsin ( f -- arcsin[f] ) fdup f0= ?EXIT fdup fdup f* asin' horner f* ; \\ Both fasin and fatan are very inaccurate with emu387; so I replace them by my original versions (which is quite accurate) \ arctan arcsin 20apr93py : fatan ( f -- arctan[f] ) fdup f0< >r fabs fdup !1 f> dup >r IF !1 fswap f/ THEN fdup [ !1 f2* fsqrt !1 f- ] Fliteral f> IF !1 fover f- fswap !1 f+ f/ (arctan fnegate [ pi f2/ f2/ ] Fliteral f+ ELSE (arctan THEN r> IF fnegate [ pi f2/ ] Fliteral f+ THEN r> IF fnegate THEN ; : fasin ( f -- arcsin[f] ) fdup f0< >r fabs fdup !1 f> IF FPwrongarg throw THEN fdup [ !1 f2/ ] Fliteral f> IF !1 fover fdup f* f- fsqrt fswap f/ fatan fnegate [ pi f2/ ] Fliteral f+ ELSE (arcsin THEN r> IF fnegate THEN ;
\ No newline at end of file
\\ *** Floating Point Bindings *** 02may95py Unlike for the ST, I provide a native floating point binding for the 387 and compatible, because it's likely for a FP user to have a coprocessor. If not, (s)he can use emu387 from DJ Delorie. This binding uses the 8 items depth stack of the 80387, so be carefully not to exceed this stack depth. This prohibits recursive algorithms without using a second stack for results, but speeds things up very much. Notice, that ASCII output of FP numbers will not work with a full stack, it needs 2 items free over the TOS! \ Fliekommaarithmetik Loadscreen double pres. 09jul00py Module Float $A Constant Fcell -$A Constant -Fcell : Float+ Fcell + ; macro 0 :#+ T&P Code Floats AX AX add AX AX *4 I) AX lea Next end-code macro 1 capacity 4 - +thru [IFDEF] environment environment definitions true to floating true to floating-ext !$7.FFFFFFFFFFFFFFF8'FFF f2* fconstant max-float [THEN] Module; \ floating error handling status code 17aug93py Variable fpstat fpstat off \ errorcode | -&42 Constant FPdiv0 | -&43 Constant FPoverflow | -&44 Constant FPstackfull | -&45 Constant FPstackempty | -&46 Constant FPwrongarg ' align Alias falign ' aligned Alias faligned ' align Alias sfalign ' aligned Alias sfaligned ' align Alias dfalign ' aligned Alias dfaligned ' cells Alias sfloats ' cell+ Alias sfloat+ : dfloats 2* cells ; macro : dfloat+ cell+ cell+ ; macro \ floating error handler 23mar09pyhere negate 3 and allot Label :f0 $073F w, $033F w, $0F3F w, Code FClearStack finit :f0 2+ A#) fldcw Next end-code FClearStack Code FClex fnclex Next end-code macro ' FClearStack Alias fpu-init : truncate $0F3F :f0 4+ w! ; \ default : nearest $033F :f0 4+ w! ; : down $073F :f0 4+ w! ; : up $0B3F :f0 4+ w! ; | : -fak ( flag -- ) IF FPwrongarg throw THEN ; Label fexp# $40 c, -$2C c, $01 c, -$14 c, $10 c, -$2B c, $08 c, -$2B c, $04 c, -$2A c, $02 c, -$2E c, $20 c, -$29 c, $00 c, -$01 c, What's 'catch Alias old-catch \ floating point exception handling 02may95py Label fp-recover pusha dumped A# DI mov SP SI mov $B # CX mov rep movs popa 3 cells # SP add 'UP A#) UP mov AX fstsw fnclex SP RP cmp u> IF :S R: THEN user' s0 UP D) SI cmp u> IF user' s0 UP D) SI mov THEN user' s^ UP D) SI cmp u<= IF user' s0 UP D) SI mov THEN fexp# A# CX mov BEGIN .w CX ) DX mov DL AL test 0= WHILE 2 # CX add DL DL test 0= UNTIL THEN -$2C # DH cmp 0= IF $47 # AH and $41 # AH cmp 0= IF -$2D # DH mov THEN THEN DH AX movsx A:: ' throw rel) jmp end-code \ Stack operations 02may95py Code Fdepth ( -- n ) AX push fxam ( fwait ) AX fstsw $FD # AH and $41 # AH cmp 0= IF AX AX xor ELSE $B # AX shr 7 # AX and 7 # AX xor AX inc THEN Next end-code Label taskpause :R pushf BX push DI push AX push SI push fxam ( fwait ) AX fstsw $FD # AH and $41 # AH cmp 0= IF 0 # push ELSE $B # AX shr 7 # AX and 7 # AX xor AX DX mov BEGIN $C # SP sub .fx SP ) fstp ( fwait) AX dec 0< UNTIL DX inc DX push THEN CX call CX pop ?DO .fx SP ) fld $C # SP add LOOP THEN \ -$6C # SP add SP ) fsave CX call SP ) frstor $6C # SP add SI pop AX pop DI pop BX pop popf ret end-code \ Fnegate Fabs F0= F0< F0> 27feb99py Code D>F ( d -- f ) DX pop AX push DX push .fq SP ) fld 8 # SP add AX pop Next end-code macro :dx :ax T&P Code S>F ( n -- f ) AX push .fd SP ) fld AX pop AX pop Next end-code macro :ax :ax T&P Code Fnegate ( f -- -f ) fchs Next end-code macro Code Fabs ( f -- |f| ) fabs Next end-code macro Code F2* ( f -- f*2 ) 0 ST fadd Next end-code macro | Create .5 $3F000000 , Code F2/ ( f -- f/2 ) .fs .5 A#) fmul Next end-code macro \ Fnegate Fabs F0= F0< F0> 25oct93py Code F0= AX push ftst ( fwait ) AX fstsw 0 ST fstp sahf AL 0<> setIF 1 # AX and AX dec Next end-code macro :ax :f T&P Code F0< AX push ftst ( fwait ) AX fstsw 0 ST fstp sahf AL u>= setIF 1 # AX and AX dec Next end-code macro :ax :f T&P Code F0> AX push ftst ( fwait ) AX fstsw 0 ST fstp sahf AL u<= setIF 1 # AX and AX dec Next end-code macro :ax :f T&P : F0>= F0< 0= ; macro : F0<= F0> 0= ; macro : F0<> F0= 0= ; macro \ Fdrop Fdup Fswap Fover F>r Fr@ Fr> Frot F-rot 12jun00pyCode Fdrop ( f -- ) 0 ST fstp Next end-code macro Code Fdup ( f -- f f ) 0 ST fld Next end-code macro Code Fswap ( f1 f2 -- f2 f1 ) 1 ST fxch Next end-code macro Code Fover ( f1 f2 -- f1 f2 f1 ) 1 ST fld Next end-code macro Code Fover2 ( f3 -- f3 f1 ) 2 ST fld Next end-code macro Code Fover3 ( f3 -- f3 f1 ) 3 ST fld Next end-code macro : Funder ( f1 f2 -- f2 f1 f2 ) fswap fover ; macro Code F>r ( f -- ) $C # RP sub .fx RP ) fstp \ fwait Next end-code macro Code Fr@ ( f -- ) .fx RP ) fld Next end-code macro Code Fr> ( f -- ) .fx RP ) fld $C # RP add Next end-code macro Code Frot ( f1 f2 f3 -- f2 f3 f1 ) 1 ST fxch 2 ST fxch Next end-code macro Code F-rot ( f1 f2 f3 -- f3 f1 f2 ) 2 ST fxch 1 ST fxch Next end-code macro \ Fpick Fpin Fnip 04oct99py Code Fpick ( n -- fn ) 7 # AX and AL AH xchg $C0D9 # AX add .w AX here 8+ A#) mov AHEAD THEN 0 ST fld AX pop Next end-code Code Fpin ( f n -- ) AX inc 7 # AX and AL AH xchg $D8DD # AX add .w AX here 8+ A#) mov AHEAD THEN 1 ST fstp AX pop Next end-code Code Fnip ( f1 f2 -- f2 ) 1 ST fstp Next end-code macro | Code 22fpick ( f1 f2 f3 -- f1 f2 f3 f1 f2 ) 1 ST fld 3 ST fld Next end-code macro Code Flit1 AHEAD Fcell allot THEN Next end-code macro Code Flit2 .fx 0 A#) fld Next end-code macro \ F@ F! Fvariable Fconstant 04oct99pyCode F@ ( addr -- f ) .fx AX ) fld AX pop Next end-code macro 0 :ax T&P Code F! ( f addr -- ) .fx AX ) fstp ( fwait) AX pop Next end-code macro 0 :ax T&P : F, ( f -- ) here Fcell allot f! ; : Fvariable Create Fcell allot ; : Fconstant Create F, Does> F@ ; \ Code Flit ( addr -- f ) R: DX pop .fx DX ) fld \ Fcell # DX add DX jmp Next end-code \ : Fliteral state @ 0= ?EXIT \ compile Flit f, ; immediate restrict : Fliteral state @ 0= ?EXIT compile Flit1 here Fcell - 2- dup f! compile Flit2 here 6 - ! ; immediate restrict \ f>d f>s F* F/ F+ f- 12jun00pyCode ff>d ( f -- d ) AX push :f0 A#) fldcw 8 # SP sub .fq SP ) fstp :f0 2+ A#) fldcw DX pop AX pop DX push Next end-code \ macro :ax :dx T&P Code ff>s ( f -- n ) AX push :f0 A#) fldcw .fd SP ) fstp ( fclex ) :f0 2+ A#) fldcw AX SP ) xchg Next end-code \ macro :ax 0 T&P Code f>d ( f -- d ) AX push :f0 4+ A#) fldcw 8 # SP sub .fq SP ) fstp :f0 2+ A#) fldcw DX pop AX pop DX push Next end-code \ macro :ax :dx T&P Code f>s ( f -- n ) AX push :f0 4+ A#) fldcw .fd SP ) fstp ( fclex ) :f0 2+ A#) fldcw AX SP ) xchg Next end-code \ macro :ax 0 T&P \ f>fd f>fs fd>f fs>f 28may00py Code f* ( f1 f2 -- f ) 1 STP fmul Next end-code macro Code f/ ( f1 f2 -- f ) 1 STP fdivr Next end-code macro Code F+ ( f1 f2 -- f ) 1 STP fadd Next end-code macro Code F- ( f1 f2 -- f ) 1 STP fsubr Next end-code macro Code f>fd ( f -- fd ) AX push 8 # SP sub .fl SP ) fstp AX pop Next end-code macro :ax :ax T&P Code f>fs ( f -- fs ) AX push 4 # SP sub .fs SP ) fstp AX pop Next end-code macro :ax :ax T&P Code fd>f ( fd -- f ) AX push .fl SP ) fld 8 # SP add AX pop Next end-code macro :ax :ax T&P Code fs>f ( fs -- f ) AX push .fs SP ) fld 4 # SP add AX pop Next end-code macro :ax :ax T&P \ fm* fm/ fm*/ 20apr09pyCode !0 ( -- 0 ) fldz Next end-code macro Code !1 ( -- 1 ) fld1 Next end-code macro Code 1/f ( f -- 1/f ) fld1 1 STP fdiv Next end-code macro Code Fm* ( f u32b -- f*u32b ) AX push .fd SP ) fmul ( fwait) AX pop AX pop Next end-code macro :ax :ax T&P Code Fm/ ( f u32b -- f/u32b ) AX push SP ) fdiv ( fwait) AX pop AX pop Next end-code macro :ax :ax T&P Code Fm*/ ( f u32b1 u32b2 -- f*u32b1/u32b2 ) SP ) fmul ( fwait) AX SP ) mov SP ) fdiv ( fwait) AX pop AX pop Next end-code macro 0 :ax T&P | Create 2fs !0 f, !0 f, : Fequal ( f1 f2 -- f1-f2=0 ) 2fs f! 2fs float+ f! 2fs 1 floats 2fs float+ over str= ; \ floor frac frnd 20apr09pyCode floor ( f -- fs ) :f0 A#) fldcw frndint :f0 2+ A#) fldcw Next end-code macro : frac ( f -- f ) fdup floor f- ; Code Fsign ( f -- -1:0< ; 0:0= ; 1:0> ) AX push ftst ( fwait) AX fstsw 0 ST fstp sahf AL 0<> setIF u< IF AL neg THEN AL AX movsx Next end-code Code Fcomp ( f1 f2 -- -1:0< ; 0:0= ; 1:0> ) AX push 1 STP fcomp ( fwait ) AX fstsw 0 ST fstp sahf AL 0<> setIF u> IF AL neg THEN AL AX movsx Next end-code Code F= ( f1 f2 -- flag ) AX push fcompp ( fwait ) AX fstsw sahf AL 0<> setIF 1 # AX and AX dec Next end-code macro :ax :f T&P \ Fsign Fcomp F> F< Fmin Fmax F= 04feb01pyCode F< ( f1 f2 -- flag ) AX push fcompp ( fwait ) AX fstsw sahf AL u<= setIF 1 # AX and AX dec Next end-code macro :ax :f T&P Code F> ( f1 f2 -- flag ) AX push fcompp ( fwait ) AX fstsw sahf AL u>= setIF 1 # AX and AX dec Next end-code macro :ax :f T&P : F<= ( f1 f2 -- f1<f2 ) F> 0= ; macro : F>= ( f1 f2 -- f1>f2 ) F< 0= ; macro : F<> ( f1 f2 -- f2<>f2 ) F= 0= ; macro Code Fmax AX push 1 ST fcom AX fstsw sahf u<= IF 0 ST fstp ELSE 1 ST fstp THEN AX pop Next end-code macro :ax :ax T&P Code Fmin AX push 1 ST fcom AX fstsw sahf u>= IF 0 ST fstp ELSE 1 ST fstp THEN AX pop Next end-code macro :ax :ax T&P \ Tabellen 23dec02py| : !! 1 max >r !1 r> 1+ 2 ?DO i fm* LOOP ; | : tab: here dup >r | : swap compile ALiteral swap compile Literal compile ; hmacro r> dp ! ; &07 tab: teta' !1 &156 fm/ f, &691 s>f &360360 s>f f/ f, !1 &1188 fm/ f, !1 &1680 fm/ f, !1 &1260 fm/ f, !1 &360 fm/ f, !1 &12 fm/ f, \\ &07 dup tab: sin' 1 swap 2* 1- [DO] [I] !! 1/f f, -2 [+LOOP] &10 dup tab: cos' 0 swap 1- 2* [DO] [I] !! 1/f f, -2 [+LOOP] &16 dup tab: exp' 2- [FOR] [I] 1+ !! 1/f f, [NEXT] !0 f, &06 dup tab: ln' 1 swap 2* 1- [DO] !1 [I] fm/ f, -2 [+LOOP] &24 dup tab: atan' 1 swap 2* 1- [DO] !1 [I] fm/ f, -2 [+LOOP] &28 dup tab: asin' 3 swap 2* 1- [DO] !1 [I] 1 [?DO] [I] [I] 1+ fm*/ 2 [+LOOP] [I] fm/ f, -2 [+LOOP] !1 f, \ sf@ df@ sf! df! 07mar09pyCode sf@ ( addr -- f ) .fs AX ) fld AX pop Next end-code macro 0 :ax T&P Code df@ ( addr -- f ) .fl AX ) fld AX pop Next end-code macro 0 :ax T&P Code sf! ( f addr -- ) .fs AX ) fstp ( fwait) AX pop Next end-code macro 0 :ax T&P Code df! ( f addr -- ) .fl AX ) fstp ( fwait) AX pop Next end-code macro 0 :ax T&P : sf, here sf! 1 sfloats allot ; : df, here df! 1 dfloats allot ; Variable fseed timer@ fseed ! | $10450405 Constant rnd# | : rnd fseed @ rnd# * 1+ dup fseed ! ; : Frnd ( -- ramdom ) $3fff >r rnd $80000000 or >r rnd >r fr> !1 f- ; \ sf@+ df@+ sf!+ df!+ 17oct99py Code sf@+ ( addr -- f ) .fs AX ) fld 1 sfloats AX D) AX lea Next end-code macro Code df@+ ( addr -- f ) .fl AX ) fld 1 dfloats AX D) AX lea Next end-code macro Code sf!+ ( f addr -- ) .fs AX ) fstp 1 sfloats AX D) AX lea Next end-code macro Code df!+ ( f addr -- ) .fl AX ) fstp 1 dfloats AX D) AX lea Next end-code macro \ horner fln fsqrt fexp fexpm1 flnp1 23dec02py : horner ( f addr n -- f ) !0 Floats bounds DO fover f* I f@ f+ fcell +LOOP fnip ; Code fsqrt ( f -- sqrt[f] ) fsqrt Next end-code macro Code fscale ( f1 f2 -- f ) 1 ST fxch fscale 1 ST fstp Next end-code macro Code fxtract ( f -- f n ) fxtract AX push AX push 1 ST fxch .fd SP ) fstp ( fwait) AX pop Next end-code Code pi fldpi Next end-code macro Code ln2 fldln2 Next end-code macro \ f~ f>s round ceiling fmod 03sep09py : f~ ( f1 f2 f3 -- flag ) fdup f0= IF fdrop fequal EXIT THEN fdup f0> IF f>r f- fabs fr> ELSE fnegate f>r fover fabs fover fabs f+ f>r f- fabs fr> fr> f* THEN f< ; Code fround ( f -- round[f] ) frndint Next end-code : ceiling ( f -- ceiling[f] ) fnegate floor fnegate ; Code ftrunc ( f -- fs ) :f0 4+ A#) fldcw frndint :f0 2+ A#) fldcw Next end-code macro : fmod ( f1 f2 -- f1modf2 ) funder f/ frac f* ; \ horner fln 29mar95py Code fln ( f -- ln[f] ) fldln2 1 ST fxch fyl2x ( fwait) Next end-code macro Code flog ( f -- ln[f] ) fldlg2 1 ST fxch fyl2x ( fwait) Next end-code macro Code flb ( f -- ln[f] ) fld1 1 ST fxch fyl2x ( fwait) Next end-code macro Code flogb ( fx fb -- logb[x] ) fld1 1 ST fxch fyl2x ( fwait) fld1 1 STP fdiv 1 ST fxch fyl2x Next end-code | Code (lnp1 ( f -- ln[f+1] ) fldl2e 1 ST fxch fyl2xp1 Next end-code macro : flnp1 ( f -- ln[f+1] ) fdup f0= ?EXIT fdup [ 2 s>f fsqrt f2/ !1 f- ] FLiteral f> IF fdup [ 2 s>f fsqrt !1 f- ] FLiteral f< IF (lnp1 EXIT THEN THEN !1 f+ fln ; \ fexp 14jul98py Code fexp ( f1 -- f2 ) fldl2e 1 STP fmul 0 ST fld frndint 1 <ST fsubr 1 ST fxch f2xm1 fld1 1 STP fadd fscale 1 ST fstp Next end-code macro Code fexpm1 ( f1 -- f2 ) AX push fldl2e 1 STP fmul 0 ST fld frndint 1 <ST fsubr 1 ST fxch f2xm1 fincstp ftst ( fwait ) fdecstp AX fstsw sahf 0= IF AX pop 1 ST fstp Next THEN fld1 1 STP fadd fscale 1 ST fstp fld1 1 STP fsubr AX pop Next end-code \ fatan fasin 15dec02py [IFDEF] ownatan $25 $26 thru | : fpatan f/ fatan ; [ELSE] Code fatan fld1 fpatan Next end-code macro Code fasin 0 ST fld 0 ST fmul fld1 1 STP fsub fsqrt fpatan Next end-code Code fatan2 fpatan Next end-code macro [THEN] \ fsin fcos fsincos 18apr93py Code fsin ( f -- sin[f] ) fsin Next end-code macro Code fcos ( f -- cos[f] ) fcos Next end-code macro Code fsincos ( f -- sin[f] cos[f] ) fsincos Next end-code macro \ fm^ f^ fine^ grad>rad rad>grad r,phi>xy 25may09py Code f**2 ( fx -- fx**2 ) 0 ST fmul Next end-code macro : fm** ( f n -- f**n ) dup >r abs >r !1 fswap BEGIN r@ 1 and IF funder f* fswap THEN r> 2/ dup WHILE >r f**2 REPEAT drop fdrop r> 0< IF 1/f THEN ; : f** ( fx fy -- fx**y ) ( fdup frac f0= IF f>s fm** ELSE ) fswap fln f* fexp ( THEN ) ; : falog ( f -- 10^f ) [ &10 s>f fln ] FLiteral f* fexp ; : grad>rad ( fgrad -- frad ) [ pi &180 fm/ ] Fliteral f* ; : rad>grad ( frad -- fgrad ) [ &180 s>f pi f/ ] Fliteral f* ; Code r,phi>xy ( r phi -- x y ) fsincos 2 ST fmul 2 ST fxch 1 STP fmul Next end-code macro \ Fakultt und Stirlingsche Nherung 18apr93py | : teta ( exp n -- exp+teta[n] ) 1/f fdup f**2 fnegate teta' horner f* f+ ; : stirling ( f -- f! ) fdup [ !1 f2/ ] FLiteral f+ fover fln f* fover f- [ pi f2* fln f2/ ] FLiteral f+ fswap teta fexp ; : fak ( f -- f! ) fdup fround fabs funder f= invert -fak fdup [ &200 s>f ] Fliteral f> IF stirling ELSE ff>s !! THEN ; \ Trigonometrische Funktionen 15dec02py: fsec ( f -- sec[f] ) fsin 1/f ; macro : fcosec ( f -- sec[f] ) fcos 1/f ; macro Code ftan ( f -- tan[f] ) fptan 0 ST fstp Next end-code macro : fcot ( f -- cot[f] ) fsincos fswap f/ ; macro : facos ( f -- arccos[f] ) fasin fnegate [ pi f2/ ] FLiteral f+ ; : facot ( f -- arccot[f] ) fdup f0= IF fdrop [ pi f2/ ] FLiteral EXIT THEN 1/f fatan fdup f0< IF pi f+ THEN ; [IFUNDEF] fatan2 : fatan2 ( sin cos -- angle ) fover f0= IF fdup f0< ELSE fover f0< THEN >r fdup f0= IF fdrop fdrop pi f2/ ELSE fpatan fdup f0< IF pi f+ THEN THEN r> IF pi f- THEN ; [THEN] \ Hyperbel- und Areafunktionen 17apr09py : fsinh fexpm1 fdup fdup !1 f+ f/ f+ f2/ ; : fcosh fexp fdup 1/f f+ f2/ ; : fsech fsinh 1/f ; : fcosech fcosh 1/f ; : ftanh f2* fexpm1 fdup [ 2 s>f ] FLiteral f+ f/ ; : fcoth f2* fexpm1 fdup [ 2 s>f ] FLiteral f+ fswap f/ ; : fatanh fdup f0< >r fabs !1 fover f- f/ f2* flnp1 f2/ r> IF fnegate THEN ; : facoth fdup f0< >r fabs !1 f- 1/f f2* flnp1 f2/ r> IF fnegate THEN ; : fasinh fdup fdup f* !1 f+ fsqrt f+ fln ; : facosh fdup fdup f* !1 f- fsqrt f+ fln ; \ Statistikfunktionen 28may00py: frandom ( n -- 0/n-1) frnd f* floor ; : fchoose ( n k -- k_choose_n ) fdup frac f0<> -fak fdup f0<= IF fnip f0= IF !1 ELSE !0 THEN EXIT THEN fover frac f0<> IF ff>s >r fdup r> 1+ 2 ?DO !1 f- funder f* i fm/ fswap LOOP fdrop EXIT THEN fover fover f< IF fdrop fdrop !0 EXIT THEN fdup fak f>r fover [ &400 s>f ] FLiteral f> IF fover fak f-rot f- fak f/ ELSE ff>s >r ff>s 1+ dup r> - >r >r !1 r> r> ?DO i fm* LOOP THEN fr> f/ fround ; : bernoulli ( n k p -- b[n,k,p] ) fdup f>r fover f** f-rot fover fover f- !1 fr> f- fswap f** f-rot fchoose f* f* ; \ Zahlen ausgeben 20apr09py : fextract ( f -- dmant nexp sign ) fdup f0= IF 0. 0 !0 fequal 0= EXIT THEN \ zero is trivial fdup fxtract f0< >r 1+ fabs \ |f| exp+1 r: sign ln2 base @ s>f fln f/ \ |f| fln(2)/fln(base) exp+1 fdup fm* ff>s >r \ .. r: sign exponent[base] [ &64 s>f ] Fliteral f* ff>s 1- \ representable digits r> over >r dup >r - base @ s>f fm** f* \ fmant r: sg rd exb !1 f+ f2/ ff>d 2dup d+ base @ \ d(round(f)) base base BEGIN dup r@ abs 4/ 2/ < WHILE base @ * r> 1+ >r REPEAT dup >r ud/mod \ mod dquot r: sg rd exb rot r> 2/ > IF 1. d+ THEN \ round adjusted number r> r> - 1+ r> ; \ dmant exb-rd+1 sign : esign base @ &10 = IF sign 'e hold ELSE 0< IF '- ELSE '+ THEN hold THEN ; \ represent 07aug10py: fadjust ( dmant nexp n -- dmant' nexp' ) swap >r 1. rot 0 ?DO 2dup base @ 0 d* 2over 2over d< IF 2swap THEN 2drop LOOP 2swap 0 >r BEGIN 2over 2over d< WHILE base @ ud/mod rot dup 0= over base @ 2/ = or r> 0<> and - r> 1+ >r >r REPEAT r> base @ 2/ 3 pick 1 and IF >= ELSE > THEN IF 1. d+ THEN 2swap 2drop r> ; : represent ( f addr u -- n flag1 flag2 ) 2>r fextract r@ swap >r fadjust r> 2r> 2swap >r >r 2swap <<# #s #> r> over + >r 2swap 2over 2over rot min move rot /string '0 fill drop r> r> true #>> ; | User (precision : precision (precision @ ; : set-precision (precision ! ; \ Zahlen ausgeben 07aug10py| : fscratch ( -- addr u ) pad precision - $20 - cell- precision ; | : fscratch' ( -- addr u ) fscratch '0 -skip ; | : f$ ( f -- n sign ) fscratch represent drop ; \needs 3* | : 3* ( n -- n*3 ) dup 2* + ; hmacro | : zeros ( n -- ) 0 ?DO '0 hold LOOP ; | : .fexp ( n -- ) extend under dabs <<# #s 2drop esign ; | : finish ( sign -- addr u ) sign 0. #> #>> ; | : .$# ( addr u -- ) dup 0= IF 2drop EXIT THEN bounds swap 1- DO I c@ hold -1 +LOOP ; | : 0.f ( sign -- addr u ) s" 0." .$# finish ; | : .. ( addr n -- ) dup IF .$# '. hold ELSE 2drop THEN ; | : $#.f ( addr u sign -- addr u ) >r .$# r> finish ; | : $0.f ( addr u sign -- addr u ) >r .$# r> 0.f ; \ Zahlen ausgeben 07aug10py : fs$ ( f -- addr u ) f$ >r .fexp fscratch r> $0.f ; : fe$ ( f -- addr u ) f$ >r 1- 3 /mod 3* .fexp 1+ >r fscratch over r@ 2swap r> /string .$# '. hold .$# r> finish ; : fx$ ( f -- addr u ) fdup f0= IF fdrop s" 0" EXIT THEN f$ >r >r fscratch' r@ 1- -3 u> IF <<# .$# r> negate zeros r> 0.f EXIT THEN dup r@ u>= IF <<# over r@ 2swap r> /string .. r> $#.f EXIT THEN r@ precision 3 + u<= IF <<# r> over - zeros r> $#.f EXIT THEN r> 1- .fexp 2dup 1 /string .. drop c@ hold r> finish ; \ Zahlen ausgeben 07aug10py : ff$ ( f -- addr u ) f$ >r >r fscratch' r@ abs $40 > IF r> .fexp r> $0.f EXIT THEN r@ 0> IF <<# 2dup r@ min 2swap r@ over - 0 max r> swap >r /string .$# '. hold r> zeros .$# r> finish EXIT THEN <<# .$# r> negate zeros r> 0.f ; : fs. ( f -- ) fs$ type space ; : fx. ( f -- ) fx$ type space ; : fe. ( f -- ) fe$ type space ; : ff. ( f -- ) ff$ type space ; ' ff. alias f. ' ff$ alias f$ \ fdump f.s fe.s 07aug10py| : .flit ( IP -- IP' ) drop dup f@ '! emit fx. float+ ; Tools ' Flit1 ' .flit bind-see Float : fdump ( -- ) base @ fdepth 0 ?DO hex cr i fpick pad Fcell - f! pad Fcell - 2@ swap pad Fcell 8 - - w@ 0 <<# 3 FOR # NEXT #> type #>> <<# 7 FOR # # bl hold NEXT #> type #>> dup base ! 2 spaces i fpick fx. stop? ?LEAVE LOOP drop ; : f.s fdepth 0 ?DO i fpick fswap f>r fx. fr> LOOP ; : fe.s fdepth 0 ?DO cr i fpick fswap f>r fe. fr> LOOP ; \\ : f.all ( f -- ) fdup floor fx. curleft frac fdup f0= 0= IF ." ." THEN BEGIN fdup f0= 0= WHILE base @ fm* fdup ff>s 0 u.r frac REPEAT fdrop ; \ fdpl fsign? fbase? exp# 31aug07py| Variable fdpl fdpl on | : fsign? ( addr count -- addr count sign ) over c@ Ascii - case? IF 1 /string true EXIT THEN Ascii + case? IF 1 /string false EXIT THEN drop 0 ; here $10 c, %10 c, &10 c, | : fbase? ( addr count -- addr count ) over c@ Ascii $ - dup 3 u< IF [ rot ] ALiteral + c@ base ! 1 /string EXIT THEN drop ; | : >esign ( addr u -- addr' u' ) 2dup bounds ?DO s" dDeE'+-" base @ &10 > 4 and /string I c@ scan nip IF 2drop I I' over - unloop EXIT THEN LOOP + 0 ; | : exp# ( addr count -- exp t / f ) fsign? >r 0. 2swap >number >r 2drop r> IF drop 0 EXIT THEN r> IF negate THEN true ; \ >float 31aug07py: >float ( addr count -- f t / f ) base push bl skip -trailing fsign? >r fbase? Ascii 0 skip 2dup 2dup >esign nip - bounds fdpl on >r >r !0 r> r> ?DO i c@ digit? IF ?dup 0= IF base @ fm* ELSE >r fdup f0= 0= IF base @ fm* r> s>f f+ ELSE fdrop r> s>f THEN THEN ELSE i c@ $FD and ', = 0= fdpl @ i' 1+ i - = or IF fdrop 2drop UNLOOP rdrop false EXIT THEN i' i - fdpl ! THEN LOOP r> IF fnegate THEN f>r >esign over c@ '- <> negate /string dup 0= IF nip ELSE exp# 0= IF fr> fdrop false EXIT THEN THEN >r base @ s>f r> fdpl @ 1- 0 max - dup >r abs fm** r> fr> 0< IF fswap f/ ELSE f* THEN true ; \ fnumber 19aug07py| What's notfound alias oldnotfound \ [IFDEF] ANS : f# ( addr -- f ) >r r@ count over c@ '! = IF 1 /string THEN >float IF rdrop state @ IF compile Fliteral THEN EXIT THEN r> oldnotfound ; \ [ELSE] : f# ( addr -- f ) dup 1+ c@ '! = \ IF >r r@ count 1 /string >float \ IF rdrop state @ IF compile Fliteral THEN EXIT THEN\ r> THEN oldnotfound ; ( [THEN]) ' f# IS notfound \ export: bye: 14mar10py: f-catch Fclex fdepth >r defers 'catch r@ 8 0 within IF rdrop FClearStack EXIT THEN r> fdepth - dup 0< IF negate 0 ?DO fdrop LOOP ELSE 0 ?DO !0 LOOP THEN ; bye: lasterr @ 0> ?EXIT FClearStack [ except' $10 cells + dup @ ] ALiteral ALiteral ! [ ' multitask 4+ dup @ ] ALiteral ALiteral ! multitask ['] old-catch IS 'catch ['] oldnotfound IS notfound ; : f-init ['] f-catch IS 'catch ['] f# IS notfound ; also environment cold: fp-recover except' $10 cells + ! FClearStack ; export: drop taskpause [ ' multitask 4+ ] ALiteral ! multitask true to floating true to floating-ext &18 set-precision f-init \ export list 14mar10pyexport float fcell -fcell float+ floats fpstat falign faligned sfalign sfaligned dfalign dfaligned sfloats sfloat+ dfloats dfloat+ fclearstack fclex truncate nearest down up fdepth d>f s>f fnegate fabs f2* f2/ f0= f0< f0> f0>= f0<= f0<> fdrop fdup fswap fover fover2 fover3 funder f>r fr@ fr> frot f-rot fpick fpin fnip f@ f! f, fvariable fconstant fliteral ff>d ff>s f>d f>s f* f/ f+ f- f>fd f>fs fd>f fs>f !0 !1 1/f fm* fm/ fm*/ fequal floor frac fsign fcomp f= f< f> f<= f>= f<> fmax fmin sf@ df@ sf! df! sf, df, fseed frnd sf@+ df@+ sf!+ df!+ horner fsqrt fscale fxtract pi ln2 f~ fround ceiling ftrunc fmod fln flog flb flogb flnp1 fexp fexpm1 fatan fasin fatan2 fsin fcos fsincos f**2 fm** f** falog grad>rad rad>grad r,phi>xy stirling fak fsec fcosec ftanh fcoth fatanh facoth fasinh facosh frandom fchoose bernoulli represent precision set-precision fs$ f$ fx$ ff$ fs. fx. fe. ff. f. f$ fdump f.s fe.s >float f# f-catch f-init ; toss \ (arctan (arcsin 20apr93py &24 dup tab: atan' 1 swap 2* 1- [DO] !1 [I] fm/ f, -2 [+LOOP] &28 dup tab: asin' 3 swap 2* 1- [DO] !1 [I] 1 [?DO] [I] [I] 1+ fm*/ 2 [+LOOP] [I] fm/ f, -2 [+LOOP] !1 f, | : (arctan ( f -- arctan[f] ) fdup f0= ?EXIT fdup fdup f* fnegate atan' horner f* ; | : (arcsin ( f -- arcsin[f] ) fdup f0= ?EXIT fdup fdup f* asin' horner f* ; \\ Both fasin and fatan are very inaccurate with emu387; so I replace them by my original versions (which is quite accurate) \ arctan arcsin 20apr93py : fatan ( f -- arctan[f] ) fdup f0< >r fabs fdup !1 f> dup >r IF !1 fswap f/ THEN fdup [ !1 f2* fsqrt !1 f- ] Fliteral f> IF !1 fover f- fswap !1 f+ f/ (arctan fnegate [ pi f2/ f2/ ] Fliteral f+ ELSE (arctan THEN r> IF fnegate [ pi f2/ ] Fliteral f+ THEN r> IF fnegate THEN ; : fasin ( f -- arcsin[f] ) fdup f0< >r fabs fdup !1 f> IF FPwrongarg throw THEN fdup [ !1 f2/ ] Fliteral f> IF !1 fover fdup f* f- fsqrt fswap f/ fatan fnegate [ pi f2/ ] Fliteral f+ ELSE (arcsin THEN r> IF fnegate THEN ;
\ No newline at end of file
No preview for this file type
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
......
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