├── .gitattributes ├── .gitignore ├── AUTHORS ├── F68KANS ├── APPFTH │ ├── AES.4 │ ├── APPINIT.4 │ ├── BGI.SI │ ├── BIOS.SI │ ├── DIS68K.4 │ ├── FINISH.4 │ ├── GRAF_ACS.4 │ ├── GRAF_BGI.4 │ ├── INITSI.4 │ ├── PLOTTER.SI │ ├── SAVESYS.4 │ └── VDI.4 ├── APP_ST │ ├── IFTEST.4 │ └── TIMER.4ST ├── ATARI │ ├── ACS │ │ ├── ACS.CFG │ │ ├── AM │ │ │ ├── DESKTOP.CFG │ │ │ ├── DIGI_UHR.AM │ │ │ ├── LUPE.AM │ │ │ ├── README.TXT │ │ │ └── RECHNER.AM │ │ ├── CEWS.EWS │ │ ├── DESKTOP.CFG │ │ ├── EDITOR.CFG │ │ ├── F68K81.PRJ │ │ ├── F68KACS.ACS │ │ ├── F68KACS.AH │ │ ├── F68KACS.C │ │ ├── F68KACS.H │ │ ├── F68KACS.PRJ │ │ └── PLOTTER.C │ ├── BGI.C │ ├── BIOS.C │ ├── BYE │ ├── CEWS.EWS │ ├── CLIB.C │ ├── DESKTOP.CFG │ ├── EDITOR.CFG │ ├── F68KACS.PRG │ ├── F68KANS.CFG │ ├── F68KANS.IMG │ ├── F68KANS.TTP │ ├── F68KKERN.PRJ │ ├── FLOAT.C │ ├── FONTS │ │ ├── BOLD.CHR │ │ ├── EURO.CHR │ │ ├── GOTH.CHR │ │ ├── LCOM.CHR │ │ ├── LITT.CHR │ │ ├── SANS.CHR │ │ ├── SCRI.CHR │ │ ├── SIMP.CHR │ │ ├── TRIP.CHR │ │ ├── TSCR.CHR │ │ └── VDI.BGI │ ├── KOPFWEG.PRJ │ ├── KOPFWEG.TOS │ ├── LOADER.C │ ├── LOADER.H │ ├── LOADER.PRJ │ ├── README.GER │ ├── README.TXT │ ├── SAVED.IMG │ ├── STARTUP.IN │ └── STREAM.IN ├── DOC │ ├── ERROR.GER │ ├── ERROR.TXT │ ├── PORTF68K.ENG │ ├── PORTIER.TXT │ └── SNCE1094.TXT ├── DOCREQ.TXT ├── KERNEL │ ├── CMACROS.S │ ├── CODE.S │ ├── COMMENTS.S │ ├── DMACROS.S │ ├── EQU.S │ ├── ERRMSG.S │ ├── F68KANS.S │ ├── HEADER.S │ ├── IMGHEAD.S │ ├── INIT.S │ ├── SYSVARS.S │ ├── USERVARS.S │ └── VOCSTACK.S ├── LICENSE.legacy ├── OS9 │ ├── Makefile │ ├── bios.a │ ├── bios.r │ ├── f68kans.cfg │ ├── f68kans.img │ ├── loader │ ├── loader.c │ ├── loader.h │ ├── loader.r │ ├── loader.stb │ └── readme ├── README.GER ├── README.TXT ├── SYSFTH │ ├── BLOCK.4 │ ├── CLIB.SI │ ├── CONTROL.4 │ ├── CORE.4 │ ├── DOUBLE.4 │ ├── FILE.4 │ ├── FLOAT.SI │ ├── LOCAL.4 │ ├── MEMORY.4 │ ├── MSS.4 │ ├── MULTASK.4 │ ├── PAUSE.S │ ├── REVOC.4 │ ├── REVOC.LST │ ├── SEARCH.4 │ ├── SI.4 │ ├── STRING.4 │ ├── SYSINIT.4 │ ├── TERMINAL.4 │ └── TOOLKIT.4 └── TST │ ├── BGI.TST │ ├── CLIB.TST │ ├── COMPCOND.TST │ ├── EXCPTION.TST │ ├── FLOAT.TST │ ├── MULTASK.TST │ ├── PLOT.TST │ └── VDI.TST ├── FTHSRC ├── AES.4 ├── ANSMEM.4 ├── APFEL.4 ├── ATARI.4 ├── COMPCOND.4 ├── CORE.FR ├── DEBUG.4 ├── DECOMP.4 ├── DIS68K.4 ├── OO.4 ├── POSTPONS.4 ├── POSTPONS.TXT ├── RANDOM.4 ├── SAVAGE.4 ├── SVARS.4 ├── SVARS.TXT ├── TESTER.FR ├── TESTSUIT.4TH ├── TST3D.4 ├── UUDECODE.4 ├── UUENCODE.4 └── WITHIN.4 ├── GRAY4.ANS ├── CALC.FS ├── CHANGES ├── COPYING ├── ELSE.FS ├── GRAY.DOC ├── GRAY.FS ├── GRAYCOND.FS ├── GRAYLIST.FS ├── MINI.FS ├── OBERON.FS ├── README ├── TEST.FS ├── TEST.MIN └── TEST.OUT ├── GRAY4.TXT ├── LICENSE └── README.TXT /.gitattributes: -------------------------------------------------------------------------------- 1 | *.4 linguist-language=Forth 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Joerg Plewe - original Author of the Atari ST/TT version 2 | Ed Gow - OS9 port 3 | -------------------------------------------------------------------------------- /F68KANS/APPFTH/APPINIT.4: -------------------------------------------------------------------------------- 1 | initBIOS 2 | initPBGI 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /F68KANS/APPFTH/BGI.SI: -------------------------------------------------------------------------------- 1 | ( Borland Graphic Interface ) 2 | ( JPS, 19apr93 ) 3 | 4 | 5 | systeminterface initPBGI PBGI 6 | GET-CURRENT local-wordlist SET-CURRENT \ change CURRENT 7 | SWAP CONSTANT PBGIBASE 8 | 9 | 10 | PBGIBASE 0 11 | 12 | _a _a _s SI: _initgraph nothing ( &driver &mode c-addr u -- ) 13 | SI: _graphresult outint ( -- ior ) 14 | _n SI: _grapherrormsg outstr ( errorcode -- c-addr u ) 15 | SI: _cleardevice nothing ( -- ) 16 | SI: _closegraph nothing ( -- ) 17 | _n _n _n SI: _putpixel nothing ( x y color -- ) 18 | _n _n SI: _getpixel outint ( x y -- color ) 19 | _n _n _n _n _n SI: _arc nothing ( x y st end r -- ) 20 | _n _n _n SI: _circle nothing ( x y r -- ) 21 | _n _a SI: _drawpoly nothing ( n !!int*!! -- ) 22 | _n _n _n _n _n _n SI: _ellipse nothing ( x y st end xr yr-- ) 23 | _a SI: _getarccoords nothing ( !!int*!! -- ) 24 | _a _a SI: _getaspectratio nothing ( *xasp *yasp -- ) 25 | _n _n SI: _setaspectratio nothing ( xasp yasp -- ) 26 | _a SI: _getlinesettings nothing ( !!int*!! -- ) 27 | _n _n _n _n SI: _line nothing ( x0 y0 x1 y1 -- ) 28 | _n _n SI: _lineto nothing ( x y -- ) 29 | _n _n SI: _linerel nothing ( dx dy -- ) 30 | _n _n SI: _moveto nothing ( x y -- ) 31 | _n _n SI: _moverel nothing ( dx dy -- ) 32 | _n _n _n _n SI: _rectangle nothing ( left top right bottom -- ) 33 | _n _n _n SI: _setlinestyle nothing ( style pattern thick -- ) 34 | _n SI: _setwritemode nothing ( mode -- ) 35 | _n _n _n _n SI: _bar nothing ( left top right bottom -- ) 36 | _n _n _n _n _n _n SI: _bar3d nothing ( left top right bottom depth topflag-- ) 37 | _n _n _n _n SI: _fillellipse nothing ( x y xr yr -- ) 38 | _n _a SI: _fillpoly nothing ( n !!int*!! -- ) 39 | 40 | _a SI: _getviewsettings nothing ( viewporttype* -- ) 41 | _n _n _n _n _n SI: _setviewport nothing ( left top right bottom clip -- ) 42 | SI: _clearviewport nothing ( -- ) 43 | 44 | _n _n SI: _setfillstyle nothing ( pattern color -- ) 45 | 46 | _a SI: _gettextsettings nothing ( textsettingstype* -- ) 47 | _s SI: _outtext nothing ( c-addr u -- ) 48 | _n _n _s SI: _outtextxy nothing ( x y c-addr u -- ) 49 | _n _n SI: _settextjustify nothing ( horiz vert -- ) 50 | _n _n _n SI: _settextstyle nothing ( font dir size -- ) 51 | _n _n _n _n SI: _setusercharsize nothing ( multx divx multy divy -- ) 52 | _s SI: _textheight outint ( c-addr u -- height ) 53 | _s SI: _textwidth outint ( c-addr u -- width ) 54 | 2DROP 55 | 56 | 57 | 58 | 0 CONSTANT DETECT 59 | 256 CONSTANT VDI 60 | 61 | 62 | ( Text ) 63 | 64 | 0 CONSTANT DEFAULT_FONT 65 | 1 CONSTANT TRIPLEX_FONT 66 | 2 CONSTANT SMALL_FONT 67 | 3 CONSTANT SANS_SERIF_FONT 68 | 4 CONSTANT GOTHIC_FONT 69 | 70 | 0 CONSTANT TEXT_HORIZ_DIR 71 | 1 CONSTANT TEXT_VERT_DIR 72 | 73 | ( struct viewporttype ) 74 | ( { ) 75 | ( int left; ) 76 | ( int top; ) 77 | ( int right; ) 78 | ( int bottom; ) 79 | ( int clip; ) 80 | ( }; ) 81 | 82 | 83 | DECIMAL 84 | 85 | 86 | : viewporttype ( -- ) 87 | CREATE 10 ALLOT ; 88 | 89 | : |create_viewporttype_offsets ( -- ) 90 | 5 0 DO 91 | : 92 | I 2* POSTPONE LITERAL POSTPONE + 93 | POSTPONE ; 94 | LOOP ; 95 | 96 | ( always use w@ to access ) 97 | 98 | |create_viewporttype_offsets >vp_left >vp_top >vp_right >vp_bottom >vp_clip 99 | 100 | 101 | SET-CURRENT ( restore ) 102 | 103 | -------------------------------------------------------------------------------- /F68KANS/APPFTH/BIOS.SI: -------------------------------------------------------------------------------- 1 | ( systeminterface for standard BIOS functions ) 2 | 3 | 4 | 5 | 6 | 7 | systeminterface initBIOS BIOS 8 | GET-CURRENT hidden-wordlist SET-CURRENT 9 | SWAP CONSTANT BIOSBASE 10 | ( initBIOS ) ( BIOS should always be available ) 11 | 12 | 13 | BIOSBASE 0 14 | SI: BIOSKEY outint 15 | SI: BIOSKEY? outint 16 | _n SI: BIOSEMIT nothing 17 | SI: BIOSEMIT? outint 18 | ( s1 n SI: BIOSTEST outstr ) 19 | 20 | 2DROP 21 | 22 | 23 | 24 | SET-CURRENT ( restore ) 25 | -------------------------------------------------------------------------------- /F68KANS/APPFTH/FINISH.4: -------------------------------------------------------------------------------- 1 | 2 | : 0!ORDER ( -- ) 3 | hidden-wordlist 4 | float-wordlist 5 | file-wordlist 6 | double-wordlist 7 | FORTH-WORDLIST 8 | 5 SET-ORDER ; 9 | 10 | 0!ORDER 11 | 12 | GET-CURRENT hidden-wordlist SET-CURRENT 13 | : .wl ( addr len -- ) 14 | 2DUP TYPE ." has wid " EVALUATE . CR ; 15 | SET-CURRENT 16 | 17 | 18 | : .wordlists 19 | CR 20 | S" FORTH-WORDLIST" .wl 21 | S" hidden-wordlist" .wl 22 | S" float-wordlist" .wl 23 | S" local-wordlist" .wl 24 | S" file-wordlist" .wl 25 | S" double-wordlist" .wl 26 | S" tasker-wordlist" .wl 27 | ; 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /F68KANS/APPFTH/GRAF_ACS.4: -------------------------------------------------------------------------------- 1 | \ 2 | \ Graphical interface 3 | \ using ACS plotter window 4 | \ 5 | \ JPS, 26jul93 6 | \ 7 | 8 | GET-CURRENT local-wordlist SET-CURRENT 9 | 10 | 11 | 12 | : OPEN-GRAPHICS ( wantx wanty -- xmax ymax #colors ) 13 | _w_plotsize 14 | _w_getMFDB 15 | CELL+ DUP w@ SWAP 16 | 2 + DUP w@ SWAP 17 | 6 + w@ 1 SWAP 1- LSHIFT 18 | ; 19 | 20 | 21 | 22 | : UPDATE-GRAPHICS ( -- ) 23 | _w_update 24 | ; 25 | 26 | : CLEAR-GRAPHICS ( -- ) 27 | _w_clr 28 | ; 29 | 30 | 31 | : CLOSE-GRAPHICS ( -- ) 32 | ; IMMEDIATE 33 | 34 | 35 | 36 | : SET-PIXEL ( x y -- ) 37 | 2DUP _w_draw 38 | ; 39 | 40 | 41 | : DRAW-LINE ( x1 y1 x2 y2 -- ) 42 | _w_draw 43 | ; 44 | 45 | 46 | CREATE pxy 5 CELLS ALLOT 47 | 48 | \ x y 49 | \ ------------------- 50 | \ lo: 0 2 51 | \ lu: 4 6 52 | \ ru: 8 10 53 | \ ro: 12 14 54 | \ lo': 16 18 55 | \ 56 | : DRAW-BOX ( x1 y1 x2 y2 -- ) 57 | DUP pxy 6 + w! 58 | pxy 10 + w! 59 | DUP pxy 8 + w! 60 | pxy 12 + w! 61 | DUP pxy 2 + w! 62 | DUP pxy 14 + w! 63 | pxy 18 + w! 64 | DUP pxy w! 65 | DUP pxy 16 + w! 66 | pxy 4 + w! 67 | 5 pxy _w_pline 68 | ; 69 | 70 | 71 | : DRAW-CIRCLE ( x y rad -- ) 72 | _w_circle 73 | ; 74 | 75 | 76 | SET-CURRENT ( restore ) 77 | 78 | 79 | 80 | 81 | 82 | 83 | -------------------------------------------------------------------------------- /F68KANS/APPFTH/GRAF_BGI.4: -------------------------------------------------------------------------------- 1 | \ 2 | \ Graphical interface 3 | \ using BGI 4 | \ 5 | \ JPS, 28jul93 6 | \ 7 | ( Variable ) 8 | 9 | VARIABLE GRAPHMODE 10 | VARIABLE GRAPHDRIVER 11 | 12 | VARIABLE GRAPH_IS_ON 13 | 0 GRAPH_IS_ON ! 14 | 15 | DETECT GRAPHDRIVER ! 16 | 17 | : PATHTODRIVER ( -- c-addr u ) 18 | S" .\fonts" ; 19 | 20 | viewporttype vp 21 | 22 | 23 | 24 | : OPEN-GRAPHICS ( wantx wanty -- xmax ymax #colors ) 25 | GRAPH_IS_ON @ 0= 26 | IF 27 | GRAPHDRIVER GRAPHMODE PATHTODRIVER _initgraph 28 | _cleardevice 29 | 30 | 0 0 2SWAP 1 _setviewport 31 | 32 | vp _getviewsettings 33 | vp >vp_left w@ . 34 | vp >vp_top w@ . 35 | vp >vp_right w@ . 36 | vp >vp_bottom w@ . 37 | vp >vp_clip w@ . 38 | vp >vp_right w@ vp >vp_left w@ - 39 | vp >vp_bottom w@ vp >vp_top w@ - 40 | 1 41 | THEN 42 | 1 GRAPH_IS_ON +! 43 | ; 44 | 45 | 46 | 47 | 48 | 49 | : UPDATE-GRAPHICS ( -- ) 50 | ; IMMEDIATE 51 | 52 | : CLEAR-GRAPHICS ( -- ) 53 | _clearviewport 54 | ; 55 | 56 | 57 | : CLOSE-GRAPHICS ( -- ) 58 | -1 GRAPH_IS_ON +! 59 | GRAPH_IS_ON @ 0= 60 | IF _closegraph THEN 61 | ; 62 | 63 | 64 | 65 | : SET-PIXEL ( x y -- ) 66 | 1 _putpixel 67 | ; 68 | 69 | 70 | : DRAW-LINE ( x1 y1 x2 y2 -- ) 71 | _line 72 | ; 73 | 74 | 75 | CREATE pxy 5 CELLS ALLOT 76 | 77 | \ x y 78 | \ ------------------- 79 | \ lo: 0 2 80 | \ lu: 4 6 81 | \ ru: 8 10 82 | \ ro: 12 14 83 | \ lo': 16 18 84 | \ 85 | : DRAW-BOX ( x1 y1 x2 y2 -- ) 86 | DUP pxy 6 + w! 87 | pxy 10 + w! 88 | DUP pxy 8 + w! 89 | pxy 12 + w! 90 | DUP pxy 2 + w! 91 | DUP pxy 14 + w! 92 | pxy 18 + w! 93 | DUP pxy w! 94 | DUP pxy 16 + w! 95 | pxy 4 + w! 96 | 5 pxy _drawpoly 97 | ; 98 | 99 | 100 | : DRAW-CIRCLE ( x y rad -- ) 101 | _circle 102 | ; 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /F68KANS/APPFTH/INITSI.4: -------------------------------------------------------------------------------- 1 | initBIOS 2 | initCLIB 3 | initFLOT 4 | initPLOT 5 | initPBGI 6 | -------------------------------------------------------------------------------- /F68KANS/APPFTH/PLOTTER.SI: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | systeminterface initPLOT PLOT 5 | GET-CURRENT local-wordlist SET-CURRENT \ change CURRENT 6 | SWAP CONSTANT PLOTBASE 7 | 8 | 9 | PLOTBASE 0 10 | 11 | _n _n _n _n _n SI: _w_arc nothing ( x y rad begang endang -- ) 12 | _n _n _n _n SI: _w_bar nothing ( x1 y1 x2 y2 -- ) 13 | _n _n _n SI: _w_circle nothing ( x y rad -- ) 14 | SI: _w_clr nothing ( -- ) 15 | _n _n _n SI: _w_contourfill nothing ( x y index -- ) 16 | _n _n _n _n SI: _w_draw nothing ( x1 y1 x2 y2 -- ) 17 | _n _n _n _n _n _n SI: _w_ellarc nothing ( x y xrad yrad begang endang -- ) 18 | _n _n _n _n SI: _w_ellipse nothing ( x y xrad yrad -- ) 19 | _n _n _n _n _n _n SI: _w_ellpie nothing ( x y xrad yrad begang endang -- ) 20 | _n _a SI: _w_fillarea nothing ( count addr -- ) 21 | _n _n _s SI: _w_gtext nothing ( x y c-addr u -- ) 22 | SI: _w_inv nothing ( -- ) 23 | _n _n _s _n _n _n SI: _w_justified nothing ( x y c-addr u len word_space char_space -- ) 24 | _n _n _n _n _n SI: _w_pieslice nothing ( x y rad begand endang -- ) 25 | _n _a SI: _w_pline nothing ( count addr -- ) 26 | _n _a SI: _w_pmarker nothing ( count addr -- ) 27 | _n _n _n _n SI: _w_rbox nothing ( x1 y1 x2 y2 -- ) 28 | _n _n _n _n SI: _w_rfbox nothing ( x1 y1 x2 y2 -- ) 29 | SI: _w_update nothing ( -- ) 30 | _n _n _n _n SI: _w_recfl nothing ( x1 y1 x2 y2 -- ) 31 | 32 | _n _n SI: _w_plotsize nothing ( w h -- ) 33 | SI: _w_getMFDB outptr ( -- MFDB ) 34 | 2DROP 35 | 36 | 37 | 38 | initPLOT 39 | 40 | SET-CURRENT ( restore ) 41 | 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /F68KANS/APPFTH/SAVESYS.4: -------------------------------------------------------------------------------- 1 | \ 2 | \ SAVE-SYSTEM Utility 3 | \ 4 | 5 | GET-CURRENT hidden-wordlist SET-CURRENT 6 | 7 | CREATE magic CHAR J C, CHAR P C, 8 | 9 | DECIMAL 10 | 11 | 12 | : write-header ( fileid -- ) 13 | >R 14 | cp @ code>data sysbot - PAD 2 + ! 15 | HERE PAD 6 + ! 16 | magic w@ PAD w! 17 | PAD 28 R> WRITE-FILE DROP ; 18 | 19 | : write-code ( fileid -- ) 20 | >R 21 | sysbot cp @ code>data sysbot - R@ WRITE-FILE DROP 22 | databot HERE R> WRITE-FILE DROP ; 23 | ( ^^^^ ) 24 | ( HERE as a relative address is the length! ) 25 | 26 | 27 | SET-CURRENT ( restore ) 28 | 29 | : SAVE-SYSTEM ( c-addr u -- ) 30 | W/O BIN CREATE-FILE ABORT" Cannot create file!" 31 | DUP write-header DUP write-code 32 | CLOSE-FILE DROP 33 | ; 34 | 35 | 36 | -------------------------------------------------------------------------------- /F68KANS/APP_ST/IFTEST.4: -------------------------------------------------------------------------------- 1 | C" *IFTEST*" FIND NIP INVERT [IF] MARKER *IFTEST* [THEN] 2 | 3 | *IFTEST* MARKER *IFTEST* 4 | 5 | INCLUDE ..\APP_ST\TIMER.4ST 6 | 7 | 8 | DECIMAL 9 | : T0 100000 0 DO LOOP ; 10 | : T1 100000 0 DO TRUE TRUE 2DROP LOOP ; 11 | : T2 100000 0 DO TRUE TRUE IF DROP THEN LOOP ; 12 | : T3 100000 0 DO 1 DROP LOOP ; 13 | : T4 100000 0 DO 1 TRUE 2DROP LOOP ; 14 | 15 | TIMER@ T0 TIMER@ SWAP - CONSTANT DOLOOP 16 | TIMER@ T2 TIMER@ SWAP - 17 | TIMER@ T1 TIMER@ SWAP - - CONSTANT IFTHEN 18 | TIMER@ T4 TIMER@ SWAP - 19 | TIMER@ T3 TIMER@ SWAP - - CONSTANT CONST 20 | 21 | 22 | 23 | CR 24 | .( DO ... LOOP: ) DOLOOP . CR 25 | .( IF ... THEN: ) IFTHEN . CR 26 | .( CONSTANT: ) CONST . CR 27 | 28 | 29 | \ NEW: 15674, 5978, 5130 30 | \ OLD: 15756, 16398, 13743 31 | 32 | 33 | 34 | -------------------------------------------------------------------------------- /F68KANS/APP_ST/TIMER.4ST: -------------------------------------------------------------------------------- 1 | \ TIMER@ nach Bernd Paysan, VD 2/94 2 | \ diesmal in high level fuer F68KANS auf Atari 3 | 4 | \ Code timer@ ( -- time ) 5 | \ BEGIN $C0 # D1 move $4BA #) D0 move 6 | \ .b $FFFFFA23 #) D1 sub .l $4BA #) D0 cmp 0= UNTIL 7 | \ 6 # D0 lsl D0 D1 add D0 D0 add D1 D0 add 8 | \ D0 SP -) move Next end-code 9 | 10 | m: 192* ( n1 -- 192*n1 ) 11 | 6 LSHIFT DUP 2* + ; 12 | 13 | HEX 14 | 4BA (abs) CONSTANT hz200 \ wird per Interrupt 15 | \ hochgezaehlt, wenn der 16 | \ rtc_ticker abgelaufen ist 17 | FFFFFA23 (abs) CONSTANT rtc_ticker \ aktueller Tickerwert 18 | C0 ( 192) CONSTANT max_ticker \ Initialwert des Tickers 19 | DECIMAL 20 | 21 | : TIMER@ 22 | hz200 @ 23 | rtc_ticker C@ 24 | OVER hz200 @ = \ Ueberlauf, waehrend rtc_ticker 25 | \ geholt wurde? 26 | IF max_ticker - SWAP 192* 27 | - NEGATE \ hz200*192 + (max-rtc) 28 | ELSE 2DROP RECURSE THEN \ nochmal das ganze 29 | ; 30 | 31 | \ TIMER@ braucht auf meiner Janus-Karte (68k/16Mhz) 42.98 Microsec. 32 | -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/ACS.CFG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/ACS/ACS.CFG -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/AM/DESKTOP.CFG: -------------------------------------------------------------------------------- 1 | E:\ACS.BSP\AM\DITHER.AM3 -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/AM/DIGI_UHR.AM: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/ACS/AM/DIGI_UHR.AM -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/AM/LUPE.AM: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/ACS/AM/LUPE.AM -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/AM/README.TXT: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/ACS/AM/README.TXT -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/AM/RECHNER.AM: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/ACS/AM/RECHNER.AM -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/CEWS.EWS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/ACS/CEWS.EWS -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/DESKTOP.CFG: -------------------------------------------------------------------------------- 1 | C:\DEVELOP\ACS\AM\EDIT.AM.AM\ACS\*.AM -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/EDITOR.CFG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/ACS/EDITOR.CFG -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/F68K81.PRJ: -------------------------------------------------------------------------------- 1 | ; ACS Example Program (c) 1991 Stefan Bachert 2 | ; 3 | ..\f68k81.prg ; name of executable program 4 | .C [ -8 ] 5 | = ; list of modules follows... 6 | PCSTART.O ; startup code 7 | 8 | plotter.c 9 | f68kacs.C (f68kacs.H) ; depends also upon surface definition 10 | 11 | 12 | ..\clib.c 13 | ..\float.c 14 | ..\bgi.c 15 | 16 | ACS.LIB ; ACS Library 17 | ACSPLUS.LIB ; ACS Plus Library 18 | 19 | PCBGILIB.LIB ; BGI library 20 | ;PCFLTLIB.LIB ; floating point library 21 | PC881LIB.LIB 22 | PCSTDLIB.LIB ; standard library 23 | 24 | PCEXTLIB.LIB ; extended library 25 | PCTOSLIB.LIB ; TOS library 26 | PCGEMLIB.LIB ; AES and VDI library 27 | PCLNALIB.LIB ; LINE-A library 28 | 29 | ; THIS IS THE END 30 | -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/F68KACS.ACS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/ACS/F68KACS.ACS -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/F68KACS.AH: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/ACS/F68KACS.AH -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/F68KACS.C: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/ACS/F68KACS.C -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/F68KACS.H: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | This file was created with ACS2.20 (c) Stefan Bachert 1991, 1992, 1993, 1994 4 | The contents is based on file: C:\F\F68KANS\ATARI\ACS\F68KACS.ACS 5 | compiled at: Wed Mar 01 22:36:12 1995 6 | */ 7 | 8 | 9 | /* PLATFORM */ 10 | #define ACS_ATARI 11 | 12 | 13 | /* STRINGS */ 14 | 15 | 16 | 17 | /* ICONS */ 18 | 19 | 20 | 21 | /* MENU TREES */ 22 | 23 | 24 | 25 | /* OBJECT TREES */ 26 | 27 | 28 | 29 | /* WINDOWS */ 30 | 31 | 32 | 33 | extern Adescr ACSdescr; 34 | 35 | 36 | 37 | /* ANSI-C Prototypes */ 38 | 39 | extern INT16 CDECL A_arrows (PARMBLK* pb); 40 | extern INT16 CDECL A_ftext (PARMBLK* pb); 41 | extern INT16 CDECL A_innerframe (PARMBLK* pb); 42 | extern INT16 Auo_ftext (OBJECT* entry, INT16 task, void* in_out); 43 | extern INT16 Auo_string (OBJECT* entry, INT16 task, void* in_out); 44 | extern void doloadscrap (void); 45 | extern void doloadsel_from_interpreter (void); 46 | extern INT16 editor_key (Awindow* wi, INT16 kstate, INT16 key); 47 | extern void handle_caps (void); 48 | extern void startupstream (void); 49 | 50 | 51 | -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/F68KACS.PRJ: -------------------------------------------------------------------------------- 1 | ; ACS Example Program (c) 1991 Stefan Bachert 2 | ; 3 | ..\f68kacs.prg ; name of executable program 4 | = ; list of modules follows... 5 | PCSTART.O ; startup code 6 | 7 | plotter.c 8 | f68kacs.C (f68kacs.H) ; depends also upon surface definition 9 | 10 | 11 | ..\clib.c 12 | ..\float.c 13 | ..\bgi.c 14 | 15 | ACS.LIB ; ACS Library 16 | ACSPLUS.LIB ; ACS Plus Library 17 | 18 | PCBGILIB.LIB ; BGI library 19 | PCFLTLIB.LIB ; floating point library 20 | PCSTDLIB.LIB ; standard library 21 | 22 | PCEXTLIB.LIB ; extended library 23 | PCTOSLIB.LIB ; TOS library 24 | PCGEMLIB.LIB ; AES and VDI library 25 | PCLNALIB.LIB ; LINE-A library 26 | 27 | ; THIS IS THE END 28 | -------------------------------------------------------------------------------- /F68KANS/ATARI/ACS/PLOTTER.C: -------------------------------------------------------------------------------- 1 | 2 | #include 3 | #include 4 | #include "..\loader.h" 5 | #include 6 | #include 7 | 8 | 9 | extern Awindow *plotter; 10 | 11 | 12 | void cdecl _w_arc(); 13 | void cdecl _w_bar(); 14 | void cdecl _w_circle(); 15 | void cdecl _w_clr(); 16 | void cdecl _w_contourfill(); 17 | void cdecl _w_draw(); 18 | void cdecl _w_ellarc(); 19 | void cdecl _w_ellipse(); 20 | void cdecl _w_ellpie(); 21 | void cdecl _w_fillarea(); 22 | void cdecl _w_gtext(); 23 | void cdecl _w_inv(); 24 | void cdecl _w_justified(); 25 | void cdecl _w_pieslice(); 26 | void cdecl _w_pline(); 27 | void cdecl _w_pmarker(); 28 | void cdecl _w_rbox(); 29 | void cdecl _w_rfbox(); 30 | void cdecl _w_update(); 31 | void cdecl _w_recfl(); 32 | void cdecl _w_plotsize(); 33 | void *cdecl _w_getMFDB(); 34 | 35 | 36 | SI_funcarr SI_PLOT_fa[] = { 37 | _w_arc, 38 | _w_bar, 39 | _w_circle, 40 | _w_clr, 41 | _w_contourfill, 42 | _w_draw, 43 | _w_ellarc, 44 | _w_ellipse, 45 | _w_ellpie, 46 | _w_fillarea, 47 | _w_gtext, 48 | _w_inv, 49 | _w_justified, 50 | _w_pieslice, 51 | _w_pline, 52 | _w_pmarker, 53 | _w_rbox, 54 | _w_rfbox, 55 | _w_update, 56 | _w_recfl, 57 | _w_plotsize, 58 | _w_getMFDB 59 | }; 60 | 61 | 62 | void cdecl _w_arc(x,y,rad,begang,endang) 63 | long x,y,rad,begang,endang; 64 | { 65 | w_arc(plotter, (INT16)x, (INT16)y, (INT16) rad, 66 | (INT16)begang, (INT16)endang); 67 | } 68 | 69 | 70 | void cdecl _w_bar(x1,y1,x2,y2) 71 | long x1,y1,x2,y2; 72 | { 73 | INT16 pxy[4]; 74 | 75 | pxy[0] = (INT16)x1; 76 | pxy[1] = (INT16)y1; 77 | pxy[2] = (INT16)x2; 78 | pxy[3] = (INT16)y2; 79 | w_bar(plotter, pxy); 80 | } 81 | 82 | 83 | void cdecl _w_circle(x,y,rad) 84 | long x,y,rad; 85 | { w_circle(plotter, (INT16)x, (INT16)y, (INT16) rad); } 86 | 87 | void cdecl _w_clr() 88 | { w_clr(plotter); } 89 | 90 | 91 | void cdecl _w_contourfill(x,y,index) 92 | long x,y,index; 93 | { w_contourfill(plotter, (INT16)x, (INT16)y, (INT16)index); } 94 | 95 | 96 | void cdecl _w_draw(x1,y1,x2,y2) 97 | long x1,y1,x2,y2; 98 | { w_draw(plotter, (INT16)x1, (INT16)y1, (INT16)x2, (INT16)y2 ); } 99 | 100 | 101 | 102 | void cdecl _w_ellarc(x,y,xrad,yrad,begang,endang) 103 | long x,y,xrad,yrad,begang,endang; 104 | { 105 | w_ellarc(plotter, (INT16)x, (INT16)y, (INT16)xrad, (INT16)yrad, 106 | (INT16)begang, (INT16)endang); 107 | } 108 | 109 | 110 | 111 | void cdecl _w_ellipse(x,y,xrad,yrad) 112 | long x,y,xrad,yrad; 113 | { 114 | w_ellipse(plotter, (INT16)x, (INT16)y, 115 | (INT16)xrad, (INT16)yrad); 116 | } 117 | 118 | 119 | void cdecl _w_ellpie(x,y,xrad,yrad,begang,endang) 120 | long x,y,xrad,yrad,begang,endang; 121 | { 122 | w_ellpie(plotter, (INT16)x, (INT16)y, (INT16)xrad, (INT16)yrad, 123 | (INT16)begang, (INT16)endang); 124 | } 125 | 126 | 127 | void cdecl _w_fillarea(count, pxy) 128 | long count; 129 | INT16 *pxy; 130 | { w_fillarea(plotter, (INT16)count, pxy); } 131 | 132 | 133 | 134 | void cdecl _w_gtext(x,y,string,len) 135 | long x,y; 136 | char *string; 137 | long len; 138 | { 139 | char str[256]; 140 | 141 | memcpy( str, string, (size_t)len ); 142 | str[len] = '\0'; 143 | 144 | 145 | w_gtext(plotter, (INT16)x, (INT16)y, str ); 146 | } 147 | 148 | 149 | 150 | void cdecl _w_inv() 151 | { w_inv(plotter); } 152 | 153 | 154 | 155 | void cdecl _w_justified(x,y,string,len,length,word_space,char_space) 156 | long x,y; 157 | char *string; 158 | long len,length; 159 | long word_space, char_space; 160 | { 161 | char str[256]; 162 | 163 | memcpy( str, string, (size_t)len ); 164 | str[len] = '\0'; 165 | 166 | 167 | w_justified(plotter, (INT16)x, (INT16)y, str,(INT16)length, 168 | (INT16)word_space, (INT16)char_space ); 169 | } 170 | 171 | 172 | 173 | 174 | void cdecl _w_pieslice(x,y,rad,begang,endang) 175 | long x,y,rad,begang,endang; 176 | { 177 | w_pieslice(plotter, (INT16)x, (INT16)y, (INT16)rad, 178 | (INT16)begang, (INT16)endang); 179 | } 180 | 181 | 182 | 183 | 184 | void cdecl _w_pline(count, pxy) 185 | long count; 186 | INT16 *pxy; 187 | { w_pline(plotter, (INT16)count, pxy); } 188 | 189 | 190 | 191 | 192 | void cdecl _w_pmarker(count, pxy) 193 | long count; 194 | INT16 *pxy; 195 | { w_pmarker(plotter, (INT16)count, pxy); } 196 | 197 | 198 | 199 | 200 | void cdecl _w_rbox(x1,y1,x2,y2) 201 | long x1,y1,x2,y2; 202 | { 203 | INT16 pxy[4]; 204 | 205 | pxy[0] = (INT16)x1; 206 | pxy[1] = (INT16)y1; 207 | pxy[2] = (INT16)x2; 208 | pxy[3] = (INT16)y2; 209 | w_rbox(plotter, pxy); 210 | } 211 | 212 | 213 | 214 | void cdecl _w_rfbox(x1,y1,x2,y2) 215 | long x1,y1,x2,y2; 216 | { 217 | INT16 pxy[4]; 218 | 219 | pxy[0] = (INT16)x1; 220 | pxy[1] = (INT16)y1; 221 | pxy[2] = (INT16)x2; 222 | pxy[3] = (INT16)y2; 223 | w_rfbox(plotter, pxy); 224 | } 225 | 226 | 227 | 228 | void cdecl _w_update() 229 | { w_update(plotter); } 230 | 231 | 232 | 233 | void cdecl _w_recfl(x1,y1,x2,y2) 234 | long x1,y1,x2,y2; 235 | { 236 | INT16 pxy[4]; 237 | 238 | pxy[0] = (INT16)x1; 239 | pxy[1] = (INT16)y1; 240 | pxy[2] = (INT16)x2; 241 | pxy[3] = (INT16)y2; 242 | wr_recfl(plotter, pxy); 243 | } 244 | 245 | 246 | 247 | 248 | 249 | void cdecl _w_plotsize(w,h) 250 | long w,h; 251 | { 252 | INT16 size[2]; 253 | 254 | size[0] = (INT16)w; 255 | size[1] = (INT16)h; 256 | plotter->service(plotter, AS_PLOTSIZE, size); 257 | } 258 | 259 | 260 | void* cdecl _w_getMFDB() 261 | { 262 | MFDB *mfdb; 263 | 264 | plotter->service(plotter, AS_PLOTMFDB, &mfdb); 265 | 266 | return mfdb; 267 | } 268 | -------------------------------------------------------------------------------- /F68KANS/ATARI/BIOS.C: -------------------------------------------------------------------------------- 1 | /************************************************************************ 2 | * * 3 | * the F68KANS BIOS-functions * 4 | * * 5 | ************************************************************************/ 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include "loader.h" 12 | 13 | 14 | 15 | /* 16 | * declaration of the BIOS functions 17 | */ 18 | long cdecl key(); 19 | long cdecl key_quest(); 20 | void cdecl emit(); 21 | long cdecl emit_quest(); 22 | char* cdecl biostest(); 23 | 24 | extern int echo; 25 | 26 | extern FILE *(infiles[100]); 27 | extern int current_infile; 28 | 29 | SI_funcarr SI_BIOS_fa[] = {key, key_quest, emit, emit_quest, biostest}; 30 | 31 | 32 | long cdecl key() 33 | { 34 | long c; 35 | long cdecl key(void); 36 | int n; 37 | 38 | /* return (long)Bconin(CONSOLE); */ 39 | 40 | if(infiles[current_infile] == NULL) 41 | { 42 | c = (long)(char)Cnecin(); 43 | } 44 | else 45 | { 46 | n = getc(infiles[current_infile]); 47 | if(n == EOF) 48 | { 49 | fclose(infiles[current_infile]); 50 | current_infile++; 51 | return key(); 52 | } 53 | c = (long)n; 54 | } 55 | 56 | return c; 57 | } 58 | 59 | 60 | 61 | 62 | long cdecl key_quest() 63 | { 64 | /* return (long)Bconstat(CONSOLE); */ 65 | /* return (long)Cconis(); */ 66 | return (long)kbhit(); 67 | } 68 | 69 | 70 | 71 | 72 | void cdecl emit(ch) 73 | long ch; 74 | { 75 | if( (infiles[current_infile] == NULL) || echo ) 76 | { 77 | /* Bconout(CONSOLE,(int)ch); */ 78 | Cconout((int)ch); 79 | } 80 | } 81 | 82 | 83 | 84 | 85 | long cdecl emit_quest() 86 | { 87 | return (long)Cconos(); 88 | } 89 | 90 | 91 | 92 | 93 | char* cdecl biostest(str, n) 94 | char *str; 95 | long n; 96 | { 97 | static char dest[256]; 98 | 99 | dest[0] = '\0'; 100 | sprintf(dest, str, n); 101 | return dest; 102 | } 103 | 104 | /************************************************************************ 105 | * end of BIOS functions * 106 | ************************************************************************/ 107 | 108 | -------------------------------------------------------------------------------- /F68KANS/ATARI/BYE: -------------------------------------------------------------------------------- 1 | BYE 2 | -------------------------------------------------------------------------------- /F68KANS/ATARI/CEWS.EWS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/CEWS.EWS -------------------------------------------------------------------------------- /F68KANS/ATARI/DESKTOP.CFG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/DESKTOP.CFG -------------------------------------------------------------------------------- /F68KANS/ATARI/EDITOR.CFG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/EDITOR.CFG -------------------------------------------------------------------------------- /F68KANS/ATARI/F68KACS.PRG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/F68KACS.PRG -------------------------------------------------------------------------------- /F68KANS/ATARI/F68KANS.CFG: -------------------------------------------------------------------------------- 1 | image: SAVED.IMG 2 | code: 0x20000 3 | data: 0x40000 4 | -------------------------------------------------------------------------------- /F68KANS/ATARI/F68KANS.IMG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/F68KANS.IMG -------------------------------------------------------------------------------- /F68KANS/ATARI/F68KANS.TTP: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/F68KANS.TTP -------------------------------------------------------------------------------- /F68KANS/ATARI/F68KKERN.PRJ: -------------------------------------------------------------------------------- 1 | f68kans.imx 2 | 3 | .S [ ] 4 | .L [ -J ] 5 | = ; list of modules follows... 6 | 7 | ..\kernel\f68kans.s (..\kernel\cmacros.s, ..\kernel\code.s, ..\kernel\dmacros.s, ..\kernel\equ.s, ..\kernel\errmsg.s, ..\kernel\header.s, ..\kernel\imghead.s, ..\kernel\init.s, ..\kernel\sysvars.s, ..\kernel\uservars.s, ..\kernel\vocstack.s) 8 | 9 | 10 | ;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -------------------------------------------------------------------------------- /F68KANS/ATARI/FONTS/BOLD.CHR: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/FONTS/BOLD.CHR -------------------------------------------------------------------------------- /F68KANS/ATARI/FONTS/EURO.CHR: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/FONTS/EURO.CHR -------------------------------------------------------------------------------- /F68KANS/ATARI/FONTS/GOTH.CHR: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/FONTS/GOTH.CHR -------------------------------------------------------------------------------- /F68KANS/ATARI/FONTS/LCOM.CHR: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/FONTS/LCOM.CHR -------------------------------------------------------------------------------- /F68KANS/ATARI/FONTS/LITT.CHR: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/FONTS/LITT.CHR -------------------------------------------------------------------------------- /F68KANS/ATARI/FONTS/SANS.CHR: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/FONTS/SANS.CHR -------------------------------------------------------------------------------- /F68KANS/ATARI/FONTS/SCRI.CHR: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/FONTS/SCRI.CHR -------------------------------------------------------------------------------- /F68KANS/ATARI/FONTS/SIMP.CHR: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/FONTS/SIMP.CHR -------------------------------------------------------------------------------- /F68KANS/ATARI/FONTS/TRIP.CHR: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/FONTS/TRIP.CHR -------------------------------------------------------------------------------- /F68KANS/ATARI/FONTS/TSCR.CHR: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/FONTS/TSCR.CHR -------------------------------------------------------------------------------- /F68KANS/ATARI/FONTS/VDI.BGI: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/FONTS/VDI.BGI -------------------------------------------------------------------------------- /F68KANS/ATARI/KOPFWEG.PRJ: -------------------------------------------------------------------------------- 1 | ;>>>>>>> DEFAULT.PRJ for use with single module programs <<<<<<<< 2 | 3 | kopfweg.tos ; name of executable program is topmost window 4 | .C [ -Y ] 5 | .L [ -L -Y ] 6 | .S [ -Y ] 7 | = ; list of modules follows... 8 | 9 | 10 | PCSTART.O ; startup code 11 | 12 | 13 | test.s ; compile topmost window 14 | 15 | ;PCSTDLIB.LIB ; standard library 16 | 17 | ;PCTOSLIB.LIB ; TOS library 18 | 19 | ;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -------------------------------------------------------------------------------- /F68KANS/ATARI/KOPFWEG.TOS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/KOPFWEG.TOS -------------------------------------------------------------------------------- /F68KANS/ATARI/LOADER.C: -------------------------------------------------------------------------------- 1 | /******************************************************************** 2 | 3 | Loader program for a F68K image file 4 | 5 | 6 | This loader tries to open a file F68K.CFG which 7 | holds information about the F68K system to be loaded. 8 | 9 | 10 | ********************************************************************/ 11 | /*#define DEBUG 12 | */ 13 | 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include "loader.h" 19 | 20 | 21 | #define CODESIZE 0x20000L 22 | #define DATASIZE 0x20000L 23 | #define TIBSIZE 2048 24 | #define MAX_DEVICES 10 25 | #define BPB 2048 /* Bytes Per Block */ 26 | 27 | #define FALSE (0) 28 | #define TRUE (-1) 29 | 30 | #define CONSOLE 2 31 | 32 | #define fsize(x) Fseek(0L,fileno(x),2) 33 | 34 | 35 | /* 36 | * declaration of the BIOS functions 37 | */ 38 | long cdecl key(); 39 | long cdecl key_quest(); 40 | void cdecl emit(); 41 | long cdecl emit_quest(); 42 | void cdecl biostest(); 43 | 44 | 45 | 46 | /* 47 | * declaration of internal functions 48 | */ 49 | void parameter(int,char**); 50 | int getinfiles(char*,int); 51 | void read_paras(void); 52 | void read_segments(void**,void**); 53 | 54 | 55 | /* 56 | * some globals 57 | */ 58 | long codesz = CODESIZE; 59 | long datasz = DATASIZE; 60 | char imagename[FILENAME_MAX] = "F68KANS.IMG"; 61 | char cfgname[FILENAME_MAX] = "F68KANS.CFG"; 62 | 63 | int echo = 0; /* echo loading files? */ 64 | 65 | FILE *(infiles[100]); 66 | int current_infile = 0; 67 | 68 | extern SI_funcarr SI_BIOS_fa[]; 69 | extern SI_funcarr SI_CLIB_fa[]; 70 | extern SI_funcarr SI_FLOT_fa[]; 71 | extern SI_funcarr SI_PBGI_fa[]; 72 | 73 | /* 74 | * main 75 | */ 76 | int main(int argc, const char *argv[]) 77 | { 78 | void *codeseg,*dataseg; 79 | FORTHPARAS forthparas; 80 | 81 | SI_group SI[4]; 82 | 83 | /* 84 | * initialisation of system interface 85 | */ 86 | strcpy(SI[0].SI_id, "BIOS"); 87 | SI[0].SI_fa = SI_BIOS_fa; 88 | 89 | strcpy(SI[1].SI_id, "CLIB"); 90 | SI[1].SI_fa = SI_CLIB_fa; 91 | 92 | strcpy(SI[2].SI_id, "FLOT"); 93 | SI[2].SI_fa = SI_FLOT_fa; 94 | 95 | strcpy(SI[3].SI_id, "PBGI"); 96 | SI[3].SI_fa = SI_PBGI_fa; 97 | 98 | strcpy(SI[4].SI_id, " "); 99 | SI[4].SI_fa = NULL; 100 | 101 | 102 | parameter(argc,(char**)argv); 103 | 104 | 105 | forthparas.si = SI; 106 | 107 | read_paras(); 108 | forthparas.codelen = codesz; 109 | forthparas.datalen = datasz; 110 | 111 | read_segments(&codeseg,&dataseg); 112 | forthparas.code = codeseg; 113 | forthparas.data = dataseg; 114 | forthparas.datastack= (void*)((long)dataseg+datasz-TIBSIZE); 115 | forthparas.retstack = (void*)((long)dataseg+datasz); 116 | forthparas.TIBptr = (void*)((long)dataseg+datasz-TIBSIZE); 117 | 118 | Super(0); 119 | (*(FUNC*)codeseg)(&forthparas); 120 | 121 | return 0; 122 | } 123 | 124 | 125 | /* 126 | * Checking for input files in commadline 127 | */ 128 | void parameter(argc, argv) 129 | int argc; 130 | char** argv; 131 | { 132 | int i, filecntr = 0; 133 | 134 | for(i=1; i>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -------------------------------------------------------------------------------- /F68KANS/ATARI/README.GER: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/README.GER -------------------------------------------------------------------------------- /F68KANS/ATARI/README.TXT: -------------------------------------------------------------------------------- 1 | F68KANS 2 | a Forth system for 680x0-computer 3 | 4 | 5 | * experimental release * 6 | 7 | 8 | Notes on the Atari installation: 9 | 10 | This file shortly introduces you to the implementation of F68KANS on 11 | Atari ST/TT/FALCON computers. It concentrates on a TOS-only loader 12 | without GEM-support. 13 | 14 | F68KANS has been developed on Atari computers, mainly on an Atari TT030. 15 | Here I used highly sophisticated tools available for this machine, which 16 | are of very good quality. 17 | 18 | 19 | How to start F68KANS: 20 | 21 | The TOS loader program is called F68KANS.TTP. As indicated by the 22 | extension of the filename (TOS Takes Parameters) this program allows 23 | you to enter a couple of parameters on startup, which will be described 24 | in the following. 25 | 26 | Filenames 27 | 28 | These filenames describe source files. The loader will open these files 29 | and feed their contents to F68KANS KEY-function. The procedure is called 30 | 'streaming in' in the GEM-based loader as well. More than one file may 31 | be specified on the commandline. F68KANS will not echo the content of 32 | these files unless the '-v' option is set. Use this possibilty to 33 | initialize your system interfaces (SI). 34 | 35 | 36 | -fFilename 37 | 38 | If you have a couple of file for 'stream in' you can write their names 39 | to a file and specify this file with the '-f' option. The file is read 40 | line by line and the content of each line will be taken as a filename 41 | for stream in. 42 | An example may be my file STREAM.IN which leads from the pure assembler 43 | kernel F68KANS.IMG to a full featured ATARI Forth. 44 | 45 | 46 | -cFilename 47 | 48 | The loader automatically tries to load a configuration file F68KANS.CFG. 49 | This file contains the filename of the F68KANS binary image and the 50 | sizes of code and date you want to give for F68KANS. Here is an example: 51 | 52 | image: saved.IMG 53 | code: 0x20000 54 | data: 0x40000 55 | 56 | To use another configuration file use the '-c' option to specify its name. 57 | 58 | -v 59 | 60 | Echos all characters that are streamed in at system startup. 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | -------------------------------------------------------------------------------- /F68KANS/ATARI/SAVED.IMG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/ATARI/SAVED.IMG -------------------------------------------------------------------------------- /F68KANS/ATARI/STARTUP.IN: -------------------------------------------------------------------------------- 1 | initFLOT 2 | initPBGI 3 | initPLOT 4 | initCLIB 5 | initBIOS 6 | INCLUDE \F\SRC\DEBUG.4 7 | MARKER NEW 8 | -------------------------------------------------------------------------------- /F68KANS/ATARI/STREAM.IN: -------------------------------------------------------------------------------- 1 | ..\sysfth\core.4 2 | ..\SYSFTH\SEARCH.4 3 | ..\sysfth\local.4 4 | ..\sysfth\terminal.4 5 | ..\sysfth\si.4 6 | ..\sysfth\float.si 7 | ..\sysfth\clib.si 8 | ..\sysfth\sysinit.4 9 | ..\sysfth\memory.4 10 | ..\sysfth\file.4 11 | ..\sysfth\block.4 12 | ..\sysfth\string.4 13 | ..\sysfth\toolkit.4 14 | ..\sysfth\double.4 15 | ..\sysfth\multask.4 16 | ..\appfth\bios.si 17 | ..\appfth\bgi.si 18 | ..\appfth\plotter.si 19 | ..\appfth\appinit.4 20 | ..\appfth\graf_acs.4 21 | ..\appfth\savesys.4 22 | ..\sysfth\revoc.4 23 | ..\SYSFTH\REVOC.LST 24 | ..\appfth\finish.4 25 | -------------------------------------------------------------------------------- /F68KANS/DOC/ERROR.GER: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/DOC/ERROR.GER -------------------------------------------------------------------------------- /F68KANS/DOC/ERROR.TXT: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/DOC/ERROR.TXT -------------------------------------------------------------------------------- /F68KANS/DOC/PORTIER.TXT: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/DOC/PORTIER.TXT -------------------------------------------------------------------------------- /F68KANS/DOC/SNCE1094.TXT: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/DOC/SNCE1094.TXT -------------------------------------------------------------------------------- /F68KANS/DOCREQ.TXT: -------------------------------------------------------------------------------- 1 | Documentation requirements are still missing! 2 | 3 | Sorry! 4 | 5 | 6 | -------------------------------------------------------------------------------- /F68KANS/KERNEL/CMACROS.S: -------------------------------------------------------------------------------- 1 | * 2 | * Definition of macros used in code 3 | * 4 | * started: JPS, 8feb93 5 | * 6 | 7 | 8 | 9 | * USEROffset 10 | MACRO USERO varname,reg 11 | move.l d5,reg 12 | addi.l #o&varname,reg 13 | ENDM 14 | 15 | 16 | * usage: e.g increasing SPAN: 17 | ; USERO span,d0 18 | ; addq.l #1,0(a3,d0.l) 19 | 20 | 21 | 22 | 23 | 24 | * 25 | * Definition of a header preceeding the code of 26 | * each Forth-word 27 | * 28 | 29 | MACRO CHEAD lname, propbits 30 | .CODE 31 | * VIEW information 32 | 33 | dc.l 0 34 | 35 | * compiler information 36 | 37 | dc.b (x&lname - lname) / 2 38 | dc.b propbits 39 | 40 | ENDM 41 | 42 | cheadsize EQU 6 43 | 44 | 45 | * example: 46 | * CHEAD recurse, 2 47 | * recurse: 48 | * dc.l 7 49 | * dc.l 8 50 | * dc.l 9 51 | * xrecurse: rts 52 | 53 | -------------------------------------------------------------------------------- /F68KANS/KERNEL/CODE.S: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/KERNEL/CODE.S -------------------------------------------------------------------------------- /F68KANS/KERNEL/COMMENTS.S: -------------------------------------------------------------------------------- 1 | ************************************************************************* 2 | * * 3 | * * 4 | * F68KANS * 5 | * a portable ANS-FORTHsystem * 6 | * * 7 | * Version 1.0 * 8 | * * 9 | * by * 10 | * Joerg Plewe * 11 | * Haarzopfer Str. 32 * 12 | * 45472 Muelheim a.d. Ruhr * 13 | * * 14 | * started 7jan1993 at 11.11pm * 15 | * * 16 | * * 17 | * * 18 | ************************************************************************* 19 | 20 | ************************************************************************* 21 | * usage of registers: * 22 | * * 23 | * us equr d5 ;userarea * 24 | * seg equr a2 ;pointer to actual segment * 25 | * DT equr a3 ;pointer to data segment * 26 | * fs equr a4 ;Floatingpointstack * 27 | * SB equr a5 ;pointer to start of system+$8000 * 28 | * ds equr a6 ;data-stackpointer * 29 | * rp equr a7 ;returnstackpointer * 30 | * d6,d7 are used for DO...LOOP * 31 | * * 32 | * a0-a2,d0-d4 are for common use * 33 | * BE CAREFULL! not all words save their registers!!! * 34 | ************************************************************************* 35 | * * 36 | ************************************************************************* 37 | * * 38 | * Bitusage in the controlword: * 39 | * * 40 | * Bit0 smudge, word cannot be found * 41 | * Bit1 immediate, word will execute during compilation * 42 | * Bit2 restrict, word may only be used in compiletime * 43 | * Bit3 macro, word is a macro * 44 | * * 45 | ************************************************************************* 46 | * ENDPART 47 | -------------------------------------------------------------------------------- /F68KANS/KERNEL/DMACROS.S: -------------------------------------------------------------------------------- 1 | * 2 | * Definition of a macro to define the words header 3 | * 4 | * started: JPS, 8feb93 5 | * 6 | 7 | 8 | .DATA 9 | 10 | __headerroot: dc.l 0 11 | .SET __successor__,__headerroot 12 | 13 | 14 | MACRO HEADER name, prt 15 | .DATA 16 | dc.l (name-sys-of) 17 | __&name: dc.l (__successor__-datas) 18 | ASCIIL prt 19 | .EVEN 20 | .SET __successor__, __&name 21 | ENDM 22 | 23 | * these values have to be edited in equ.s 24 | *headsize EQU 8 25 | *cfaoffset EQU 0 26 | *lfaoffset EQU 4 27 | *nameoffset EQU 8 28 | 29 | 30 | 31 | 32 | * the last two lines define a pointer to zero, which 33 | * indicates the end of the list 34 | *of equ $8000 35 | *sys: 36 | *datas: 37 | *test: 38 | *HEADER test, 'TEST', 123 39 | *test1: 40 | *HEADER test1, 'TEST1', 456 41 | 42 | 43 | * definition of USER-variables 44 | .SET __curoffset, 0 45 | 46 | MACRO USERVAR name, val 47 | t&name: dc.l val 48 | o&name EQU __curoffset 49 | .SET __curoffset, (__curoffset+4) 50 | ENDM 51 | -------------------------------------------------------------------------------- /F68KANS/KERNEL/EQU.S: -------------------------------------------------------------------------------- 1 | ***************************************************************** 2 | 3 | * for codegeneration during runtime: 4 | jmp_code EQU $4EFC 5 | jsr_code EQU $4EAA ;jsr off(seg) 6 | jsrSB_code EQU $4EAD ;jsr off(SB) 7 | move_seg_code EQU $246B ;move.l off(DT),seg 8 | rts_code EQU $4E75 9 | bsr_code EQU $6100 10 | bsrb_code EQU $61 11 | movesp_anull EQU $205F 12 | moveimm_sp EQU $2D3C 13 | beq_code EQU $6700 14 | tsta6_code EQU $4A9E 15 | bra_code EQU $6000 16 | 17 | 18 | BKSP EQU $08 19 | CR EQU 13 20 | 21 | *headsize EQU 10 22 | of EQU $8000 ;half a code segment 23 | bytesperblock EQU 2000 24 | 25 | * Constants for header: 26 | headsize EQU 8 27 | cfaoffset EQU 0 28 | lfaoffset EQU 4 29 | nameoffset EQU 8 30 | 31 | 32 | localcodesize EQU $10 33 | 34 | 35 | -------------------------------------------------------------------------------- /F68KANS/KERNEL/ERRMSG.S: -------------------------------------------------------------------------------- 1 | * 2 | * the F68KANS provided messages 3 | * 4 | .DATA 5 | 6 | msg_undef: ASCIIL ' ' 7 | 8 | .EVEN 9 | msg_stkunder: ASCIIL ' ' 10 | 11 | .EVEN 12 | 13 | msg_unknown: ASCIIL ' unknown!' 14 | .EVEN 15 | 16 | msg_restrict: ASCIIL ' compile only!' 17 | .EVEN 18 | 19 | msg_divbyzero: ASCIIL '' 20 | .EVEN 21 | 22 | msg_outofrange: ASCIIL '' 23 | .EVEN 24 | 25 | msg_emptyname: ASCIIL '' 26 | .EVEN 27 | 28 | msg_notunique: ASCIIL ' is not unique!' 29 | .EVEN 30 | 31 | msg_filenotfound: ASCIIL 'non-existent file: ' 32 | .EVEN 33 | -------------------------------------------------------------------------------- /F68KANS/KERNEL/F68KANS.S: -------------------------------------------------------------------------------- 1 | .CODE 2 | version EQU $19950801 3 | 4 | .INCLUDE 'imghead.s' 5 | * .INCLUDE 'comments.s' 6 | .INCLUDE 'equ.s' 7 | .INCLUDE 'init.s' 8 | 9 | .INCLUDE 'cmacros.s' 10 | .INCLUDE 'code.s' 11 | 12 | 13 | .DATA 14 | datas: * extremely important label! 15 | .INCLUDE 'sysvars.s' 16 | .INCLUDE 'dmacros.s' 17 | .INCLUDE 'uservars.s' 18 | .INCLUDE 'vocstack.s' 19 | .INCLUDE 'errmsg.s' 20 | .INCLUDE 'header.s' 21 | 22 | 23 | .END 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /F68KANS/KERNEL/IMGHEAD.S: -------------------------------------------------------------------------------- 1 | .TEXT 2 | 3 | magic: DC.W 'JP' 4 | iscodelen: DC.L HERE-sys 5 | isdatalen: DC.L dataHERE-datas 6 | DS.W 9 ;yet unused 7 | 8 | -------------------------------------------------------------------------------- /F68KANS/KERNEL/INIT.S: -------------------------------------------------------------------------------- 1 | 2 | ; 3 | ; history 4 | ; 5 | ; Sigh! No notices for a couple of years, here 6 | ; 7 | ; JPS950310 added a CR after displaying the startup message 8 | ; 9 | 10 | ***************************************************************** 11 | * >PART 'initialising' 12 | ********************************************************************* 13 | * initialising the system 14 | ********************************************************************* 15 | *On the returnstack there will come only one pointer to a structure, 16 | *which contains all necessary data to run F68KANS which are 17 | ;registers: DS.L 16 ;d0,d1,d2,d3.......,a5,a6,a7 18 | ;forthregs: DS.L 4 ;a3,a5,a6,a7 19 | ;TIBptr DS.L 1 20 | ;codelen: DS.L 1 21 | ;datalen: DS.L 1 22 | ;SI_GROUP DS.L 1 ;Pointer to the System Interface 23 | 24 | 25 | forthregs EQU 16*4 26 | TIBptr EQU forthregs+(4*4) 27 | codelen EQU TIBptr+4 28 | datalen EQU codelen+4 29 | SI_group EQU datalen+4 30 | 31 | 32 | ;; A0 is important during initialisation!!! 33 | 34 | sys: 35 | init: move.l A0,-(SP) 36 | addq.l #8,SP ;A7 to returnheigth 37 | movea.l (SP),A0 ;Pointer to parastruc 38 | movem.l D0-A7,(A0) ;save all registers 39 | move.l -8(SP),8*4(A0) ;save old A0, too 40 | movea.l -4(SP),A1 ;get returnaddress 41 | 42 | movem.l forthregs(A0),A3/A5-A7 ;load forth registers 43 | 44 | adda.l #of,A5 ;points to the middle of first segment 45 | move.l A0,D0 ;pointer to forthparas 46 | sub.l A3,D0 ;make it data segment relativ 47 | move.l D0,(tforthparas-datas)(A3) ;and save it 48 | move.l A1,(bootsys-datas)(A3) ;remember exit 49 | move.l (15*4)(A0),(saveret-datas)(A3) ;remember loaders SP 50 | 51 | * relocate the segment table 52 | lea (table-datas)(A3),A1 ;pointer to the table 53 | move.l A5,D1 ;0.th segment pointer 54 | move.l #(tablesize-1),D0 55 | relo_loop: 56 | move.l D1,(A1)+ 57 | addi.l #$010000,D1 58 | dbra D0,relo_loop 59 | 60 | 61 | * set memory parameters 62 | move.l (bootuser-datas)(A3),D5 ;initialize USER-Pointer 63 | 64 | move.l codelen(A0),D0 ;fetch length of code 65 | add.l A5,D0 ;calculate systop 66 | sub.l A3,D0 ;make ist rel. to DT 67 | subi.l #of,D0 ;substract offset 68 | move.l D0,(tsystop-datas)(A3) ;set systop 69 | 70 | move.l datalen(A0),D0 ;fetch length of data 71 | move.l D0,(tdatatop-datas)(A3) ;set datatop 72 | move.l #0,(tdatabot-datas)(A3) ;because all rel. to DT 73 | lea -of(A5),A1 74 | suba.l A3,A1 ;calculate offset of segm. 75 | move.l A1,(tsysbot-datas)(A3) ;set it 76 | 77 | 78 | * fetch stackbases 79 | move.l D5,D0 80 | addi.l #ototib,D0 81 | move.l TIBptr(A0),D1 82 | sub.l A3,D1 ;make pointer relativ 83 | move.l D1,0(A3,D0.w) ;set >TIB 84 | 85 | * now fetch I/O-addresses 86 | * 87 | * The first entry in the SI_group has to be the BIOS table. 88 | * Let's have a look after it. 89 | * 90 | move.l SI_group(a0),a1 ;pointer to the System Interface SI 91 | cmp.l #'BIOS',(a1) 92 | bne biosmissing 93 | *ok, the BIOS seems to be there 94 | 95 | move.l 4(a1),a1 ;pointer to BIOS functiontable 96 | 97 | sibioskey equ 0 98 | sibioskey_quest equ 4 99 | sibiosemit equ 8 100 | sibiosemit_quest equ 12 101 | 102 | *KEY 103 | move.l D5,D0 104 | addi.l #olkey,D0 105 | move.l sibioskey(A1),D1 106 | * sub.l A3,D1 ;make pointer relativ to SB 107 | move.l D1,0(A3,D0.l) ;set KEY 108 | 109 | *KEY? 110 | move.l D5,D0 111 | addi.l #olkey_quest,D0 112 | move.l sibioskey_quest(A1),D1 113 | * sub.l A3,D1 ;make pointer relativ to SB 114 | move.l D1,0(A3,D0.l) ;set KEY? 115 | 116 | *EMIT 117 | move.l D5,D0 118 | addi.l #olemit,D0 119 | move.l sibiosemit(A1),D1 120 | * sub.l A3,D1 ;make pointer relativ to SB 121 | move.l D1,0(A3,D0.l) ;set EMIT 122 | 123 | 124 | *EMIT? 125 | move.l D5,D0 126 | addi.l #olemit_quest,D0 127 | move.l sibiosemit_quest(A1),D1 128 | * sub.l A3,D1 ;make pointer relativ to SB 129 | move.l D1,0(A3,D0.l) ;set EMIT? 130 | 131 | 132 | 133 | * now initialise with given pointers 134 | 135 | move.l D5,D0 136 | addi.l #osnull,D0 137 | move.l A6,D1 138 | sub.l A3,D1 ;make pointer relativ 139 | move.l D1,0(A3,D0.l) ;set data-stackbase 140 | 141 | move.l D5,D0 142 | addi.l #ornull,D0 143 | move.l SP,D1 144 | sub.l A3,D1 ;make pointer relativ 145 | move.l D1,0(A3,D0.l) ;set returnstack 146 | 147 | move.l #(hello-datas),-(A6) 148 | * move.l #50,-(A6) 149 | bsr count 150 | bsr type 151 | bsr cr 152 | 153 | jmp (cold-(sys+of))(A5) ;jump into the system 154 | 155 | 156 | ************* Errors ******************* 157 | biosmissing: jmp (bye-sys-of)(a5) ; ... 158 | 159 | 160 | * rts ;jump out of the system 161 | 162 | 163 | ************************************************************************* 164 | * ENDPART 165 | -------------------------------------------------------------------------------- /F68KANS/KERNEL/SYSVARS.S: -------------------------------------------------------------------------------- 1 | .DATA 2 | 3 | 4 | ***************************************************************** 5 | * >PART 'System tables and variables' 6 | 7 | tablesize EQU 10 8 | table: DS.L tablesize ;table of segment pointers 9 | * SB 10 | * SB + $10000 11 | * SB + $20000 12 | * . 13 | * . 14 | * . 15 | * SB + (tablesize * $10000) 16 | 17 | hello: ASCIIL '*** F68KANS *** (C) 1988-1995 by J. Plewe ***' 18 | EVEN 19 | 20 | ************************************************************************* 21 | * system variables * 22 | ************************************************************************* 23 | mtable: 24 | tcold: DC.L (quit-sys-of) ;vector for cold 25 | tsystop: DS.L 1 ;highest possible address 26 | tsysbot: DS.L 1 27 | tdatatop: DS.L 1 28 | tdatabot: DS.L 1 29 | tforthparas: DC.L 0 30 | bootsys: DC.L 0 ;return to loader 31 | saveret: DC.L 0 ;SP of loader 32 | bootuser: DC.L (usertable-datas) ; 33 | troot: DS.L 1 ;pointer to table of devices 34 | tfront_opt: DC.L (noop-sys-of) ;for an optimizer 35 | tend_opt: DC.L (noop-sys-of) ;dto. 36 | EVEN 37 | 38 | 39 | * ENDPART 40 | -------------------------------------------------------------------------------- /F68KANS/KERNEL/USERVARS.S: -------------------------------------------------------------------------------- 1 | .DATA 2 | .EVEN 3 | 4 | ***************************************************************** 5 | * USER variables * 6 | ***************************************************************** 7 | DS.L (16+24+10) ;room to save registers in multitasking 8 | 9 | usertable: 10 | USERVAR nextuser, (usertable-datas) ;points to usertable of next task 11 | USERVAR rnull, 0 ;r0 -- returnstackbase 12 | USERVAR snull, 0 ;s0 -- datastackbase 13 | USERVAR fnull, 0 ;f0 -- floatstackbase 14 | USERVAR state, 0 ;compiler on/off 15 | USERVAR number_quest,(n_number_quest-sys-of) ;numberconversion 16 | USERVAR base, 10 ;base 17 | USERVAR dp, (HERE-sys-of) ;dictionary pointer (code) 18 | USERVAR data, (dataHERE-datas) ;dictionary pointer (data) 19 | 20 | USERVAR totib, 0 ;>tib, maybe as s0 21 | USERVAR _tib, 0 ;number of characters in tib 22 | USERVAR toin, 0 ;>in 23 | USERVAR toevaluateib, 0 24 | USERVAR _evaluateib, 0 25 | USERVAR tofileib, 0 26 | USERVAR _fileib, 0 27 | USERVAR p_blocksource, (noop-sys-of) 28 | USERVAR tosourceid, 0 29 | 30 | USERVAR current, (last_forth-datas) ;current (pfa) 31 | USERVAR vocpa, (VOCPA-datas) ;points to vocabularystack 32 | USERVAR last, (lasthead-datas) ;address of last header 33 | USERVAR catchhandler, 0 ; handler for CATCH/THROW 34 | USERVAR abortqmess, 0 ; message pointer for ABORT" 35 | USERVAR abortqcnt, 0 ; count for the message 36 | USERVAR errorqmess, 0 37 | USERVAR p_errorhandler, (errorhandler-sys-of) 38 | USERVAR key, (loaderkey-sys-of) 39 | USERVAR emit, (loaderemit-sys-of) 40 | USERVAR key_quest, (loaderkey_quest-sys-of) 41 | USERVAR lkey, 0 42 | USERVAR lemit, 0 43 | USERVAR lkey_quest, 0 44 | USERVAR lemit_quest, 0 45 | USERVAR accept, (lcaccept-sys-of) 46 | USERVAR type, (lctype-sys-of) 47 | USERVAR find, (lcfind-sys-of) 48 | USERVAR parser, (interpreter-sys-of) 49 | USERVAR macro, -1 ;should macros be used? 50 | USERVAR is_macro, 0 ;shall the new word be a macro? 51 | USERVAR warning, 0 ;give out warnings? 52 | USERVAR out, 0 ;counts characters emitted 53 | USERVAR fwidth, 8 ;bytes per float 54 | USERVAR fliteral, (noop-sys-of) ;(flit-sys-of) ;routine for floatcompilation 55 | USERVAR blk, 0 ;number of actual block 56 | USERVAR userbufs, (VOCPA-datas-8) ;pointer to list of buffers 57 | USERVAR echo, -1 ;echo characters during input with expect? 58 | USERVAR udp, oudp+4 59 | 60 | DS.B ($0800-oudp+4) ;room for the rest 61 | EVEN 62 | 63 | 64 | -------------------------------------------------------------------------------- /F68KANS/KERNEL/VOCSTACK.S: -------------------------------------------------------------------------------- 1 | .DATA 2 | 3 | ***************************************************************** 4 | * >PART 'vocabulary stack' 5 | 6 | ************************************************************************* 7 | * vocabulary stack * 8 | ************************************************************************* 9 | DC.L 0 ;last user's buffer 10 | DC.L 144 ;length is 144 bytes 11 | VOCPA: DC.L 8 ;height of voc-stacks 12 | DC.L (last_forth-datas) ;context (pfa) 13 | DC.L (last_forth-datas) ;transient (pfa) 14 | DS.L 33 ;room for another 32 15 | EVEN 16 | 17 | * ENDPART 18 | -------------------------------------------------------------------------------- /F68KANS/LICENSE.legacy: -------------------------------------------------------------------------------- 1 | **************************************************************** 2 | * 3 | * License for the F68KANS software by Joerg Plewe, Germany 4 | * 5 | **************************************************************** 6 | 7 | The F68KANS software package is copyrighted by me as its author. 8 | 9 | You are granted the right to use and distribute this software as long as 10 | no commercial goal is persuid. 11 | 12 | In the moment you think of any commercial use or exploit of this 13 | software you will have to contact me as the author and ask for a 14 | license agreement. This software may not be bundled together with other 15 | products without my permission. 16 | 17 | ('License agreement' does not necessarily mean 'license fee') 18 | 19 | In any case you will have to preserve my copyright. 20 | 21 | 22 | Disclaimer 23 | 24 | The author of this program accepts no responsibility for damages 25 | resulting from the use of this product and makes no warranty or 26 | representation, either express or implied, including but not limited to, 27 | any implied warranty of merchantability or fitness for a particular 28 | purpose. This software is provided "AS IS", and you, its user, assume 29 | all risks when using it. 30 | 31 | 32 | For I am not a laywer I hope this license file will not hurt any laws. 33 | In this case, the hurted law has to be considered as valid and superior. 34 | 35 | 36 | Joerg Plewe, Germany, Muelheim, 26feb1995 37 | 38 | 39 | -------------------------------------------------------------------------------- /F68KANS/OS9/Makefile: -------------------------------------------------------------------------------- 1 | CC = gcc loader: loader.r bios.r cc -fd=loader loader.r bios.r bios.r: bios.a r68 -o=bios.r bios.a -------------------------------------------------------------------------------- /F68KANS/OS9/bios.a: -------------------------------------------------------------------------------- 1 | * nam bios ttl F68KANS FORTH System BIOS Routines for OSK * * psect stdin equ 0 stdout equ 1 true equ -1 false equ 0 vsect SI_BIOS_fa: dc.l =key dc.l =key_quest dc.l =emit dc.l =emit_quest ends align key: moveq #stdin,d0 path moveq #1,d1 read one byte lea -1(a7),a0 use stack as buffer os9 I$Read bcc.s key_ok key_err move.l d1,d0 return neg code on error neg.l d0 rts RETURN key_ok move.b -1(a7),d0 return data from stack rts return key_quest: moveq #stdin,d0 path moveq #SS_Ready,d1 bytes ready func code os9 I$GetStt bcc.s kq_ok moveq #true,d0 return 0 (FALSE) rts kq_ok moveq #false,d0 return -1 (TRUE) rts emit: moveq #stdout,d0 path moveq #1,d1 write one byte lea 7(a7),a0 char is on stack os9 I$Write rts emit_quest: moveq #true,d0 can't test, so always true rts ends -------------------------------------------------------------------------------- /F68KANS/OS9/bios.r: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/OS9/bios.r -------------------------------------------------------------------------------- /F68KANS/OS9/f68kans.cfg: -------------------------------------------------------------------------------- 1 | image: f68kans.img code: 0x10000 data: 0x20000 2 | -------------------------------------------------------------------------------- /F68KANS/OS9/f68kans.img: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/OS9/f68kans.img -------------------------------------------------------------------------------- /F68KANS/OS9/loader: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cstrotm/f68kans/8317ac537be53ca8bdf97b34df632153f7c686eb/F68KANS/OS9/loader -------------------------------------------------------------------------------- /F68KANS/OS9/loader.c: -------------------------------------------------------------------------------- 1 | /******************************************************************** Loader program for a F68K image file This loader tries to open a file F68K.CFG which holds information about the F68K system to be loaded. ********************************************************************/ /*#define DEBUG */ #include #include #include "loader.h" #define CODESIZE 0x20000L #define DATASIZE 0x20000L #define TIBSIZE 2048 #define MAX_DEVICES 10 #define BPB 2048 /* Bytes Per Block */ #define FILENAME_MAX 32 #define CONSOLE 2 #define fsize(x) Fseek(0L,fileno(x),2) /* * declaration of the BIOS functions */ long cdecl key(); long cdecl key_quest(); void cdecl emit(); long cdecl emit_quest(); void cdecl biostest(); /* * declaration of internal functions */ void parameter(int,char**); int getinfiles(char*,int); void read_paras(void); void read_segments(void**,void**); /* * some globals */ long codesz = CODESIZE; long datasz = DATASIZE; char imagename[FILENAME_MAX] = "F68KANS.IMG"; char cfgname[FILENAME_MAX] = "F68KANS.CFG"; int echo = 0; /* echo loading files? */ FILE *(infiles[100]); int current_infile = 0; extern SI_funcarr SI_BIOS_fa[]; extern SI_funcarr SI_CLIB_fa[]; extern SI_funcarr SI_FLOT_fa[]; extern SI_funcarr SI_PBGI_fa[]; FORTHPARAS forthparas; /* */ /* * main */ int main(int argc, const char *argv[]) { void *codeseg,*dataseg; /* FORTHPARAS forthparas; /* */ SI_group SI[2]; /* * initialisation of system interface */ strcpy(SI[0].SI_id, "BIOS"); SI[0].SI_fa = SI_BIOS_fa; /* * Leave these out for now strcpy(SI[1].SI_id, "CLIB"); SI[1].SI_fa = SI_CLIB_fa; strcpy(SI[2].SI_id, "FLOT"); SI[2].SI_fa = SI_FLOT_fa; strcpy(SI[3].SI_id, "PBGI"); SI[3].SI_fa = SI_PBGI_fa; */ strcpy(SI[4].SI_id, " "); SI[4].SI_fa = NULL; /* parameter(argc,(char**)argv); /* */ forthparas.si = SI; read_paras(); forthparas.codelen = codesz; forthparas.datalen = datasz; read_segments(&codeseg,&dataseg); forthparas.code = codeseg; forthparas.data = dataseg; forthparas.datastack= (void*)((long)dataseg+datasz-TIBSIZE); forthparas.retstack = (void*)getstack((double)0,0xabcd); /* */ /* forthparas.retstack = (void*)((long)dataseg+datasz); /* */ forthparas.TIBptr = (void*)((long)dataseg+datasz-TIBSIZE); /* Super(0); /* What is this ?? */ (*(FUNC*)codeseg)((double)0,&forthparas); return 0; } void *getstack(double dummy, int stackarg) { return (void *)&stackarg; } /* * Checking for input files in commadline */ void parameter(argc, argv) int argc; char** argv; { int i, filecntr = 0; for(i=1; i [So..Sa] */ ) 16 | ( int tm_yday; /* Tag im Jahr [0..365] */ ) 17 | ( int tm_isdst; /* ungleich Null entspricht Sommerzeit */ ) 18 | ( }; ) 19 | 20 | 21 | WORDLIST CONSTANT local-wordlist 22 | local-wordlist vpush vswap 23 | 24 | systeminterface initCLIB CLIB 25 | GET-CURRENT local-wordlist SET-CURRENT 26 | SWAP CONSTANT CLIBBASE 27 | 28 | 29 | 30 | DECIMAL 31 | 32 | 33 | : tm ( -- ) 34 | CREATE 18 ALLOT ; 35 | 36 | : |create_tm_offsets ( -- ) 37 | 9 0 DO 38 | : 39 | I 2* POSTPONE LITERAL POSTPONE + 40 | POSTPONE ; 41 | LOOP ; 42 | 43 | ( always use w@ to access ) 44 | 45 | |create_tm_offsets >tm_sec >tm_min >tm_hour >tm_mday >tm_mon >tm_year >tm_wday >tm_yday >tm_isdst 46 | 47 | 48 | ( ============================= ) 49 | ( now: declaration of functions ) 50 | ( ============================= ) 51 | 52 | CLIBBASE 0 53 | 54 | ( date and time ) 55 | _a SI: _asctime outstr 56 | SI: _clk_tck outint 57 | SI: _clock outint 58 | _a SI: _ctime outstr 59 | ( n n SI: _difftime ??double?? ) 60 | _a SI: _gmtime outptr 61 | _a SI: _localtime outptr 62 | _a SI: _mktime outint 63 | _a _n _s _a SI: _strftime outint 64 | SI: _time outint 65 | SI: _timezone outint 66 | 67 | ( memory ) 68 | ( when returning pointer, the memory words return it as an absolute ) 69 | ( address, because they will have to be checked against NULL in a ) 70 | ( high-level call ) 71 | _n _n SI: _calloc outint ( n size -- aaddr ) 72 | _a SI: _free nothing ( block -- ) 73 | _n SI: _malloc outint ( size -- aaddr ) 74 | _a _n SI: _realloc outint ( block news -- aaddr ) 75 | 76 | _n SI: _clearerr nothing ( FILE* -- ) 77 | _n SI: _close outint ( handle -- ior ) 78 | _s SI: _creat outint ( filen -- handle ) 79 | _n SI: _fclose outint ( FILE* -- ior ) 80 | _n SI: _feof outint ( FILE* -- ior ) 81 | _n SI: _ferror outint ( FILE* -- ior ) 82 | _n SI: _fflush outint ( FILE* -- ior ) 83 | _n SI: _fgetc outint ( FILE* -- char ) 84 | _n _a SI: _fgetpos outint ( FILE* long* -- ior ) 85 | _a _n _n SI: _fgets outstr ( char* n FILE* -- c-addr u ) 86 | _n SI: _fileno outint ( FILE* -- handle ) 87 | _s _s SI: _fopen outint ( c-addr1 u1 c-addr2 u2 -- FILE* ) 88 | _n _n SI: _fputc outint ( char FILE* -- char ) 89 | _s _n SI: _fputs outint ( c-addr u FILE* -- len2 ) 90 | _a _n _n _n SI: _fread outint ( void* size count FILE* -- count2 ) 91 | _s _s _n SI: _freopen outint ( c-addr1 u1 c-addr2 u2 FILE* -- FILE* ) 92 | _n _n _n SI: _fseek outint ( FILE* offset mode -- ior ) 93 | _n _a SI: _fsetpos outint ( FILE* fpos_t* -- ior ) 94 | _n SI: _ftell outint ( FILE* -- fpos ) 95 | _a _n _n _n SI: _fwrite outint ( void* size cnt FILE* -- cnt2 ) 96 | _n SI: _getc outint ( FILE* -- char ) 97 | SI: _getchar outint ( -- char ) 98 | _a SI: _gets outstr ( c-addr -- c-addr u ) 99 | _n _n _n SI: _lseek outint ( handle offset whence -- pos ) 100 | _s _n SI: _open outint ( c-addr u access -- handle ) 101 | _s SI: _perror nothing ( c-addr u -- ) 102 | _n _n SI: _putc outint ( char FILE* -- char ) 103 | _n SI: _putchar outint ( char -- char ) 104 | _s SI: _puts outint ( c-addr u -- ior ) 105 | _n _a _n SI: _read outint ( handle void* len -- len2 ) 106 | _s SI: _remove outint ( c-addr u -- ior ) 107 | _s _s SI: _rename outint ( c-addr1 u1 c-addr2 u2 -- ior ) 108 | _n SI: _rewind nothing ( FILE* -- ) 109 | _n _a SI: _setbuf nothing ( FILE* void* -- ) 110 | _a _a _n _n SI: _setvbuf outint ( FILE* void* type size -- ior ) 111 | _n SI: _strerror outstr ( errnum -- c-addr u ) 112 | _a SI: _tmpnam outstr ( c-addr -- c-addr u ) 113 | SI: _tmpfile outint ( -- FILE* ) 114 | _n _n SI: _ungetc outint ( char FILE* -- char ) 115 | _n _a _n SI: _write outint ( handle void* len -- len2 ) 116 | _s SI: _unlink outint ( c-addr u -- ior ) 117 | SI: _errno outint ( -- errno ) 118 | SI: _stdout outint ( -- stdout ) 119 | SI: _stdin outint ( -- stdin ) 120 | SI: _stderr outint ( -- stderr ) 121 | SI: _stdaux outint ( -- stdaux ) 122 | SI: _stdprn outint ( -- stdprn ) 123 | 124 | _s _s SI: _strcmp outint ( c-addr1 u1 c-addr2 u2 -- n ) 125 | _s _s _n SI: _strncmp outint ( c-addr1 u1 c-addr2 u2 n -- n' ) 126 | _s _s SI: _stricmp outint ( c-addr1 u1 c-addr2 u2 -- n ) 127 | _s _s _n SI: _strnicmp outint ( c-addr1 u1 c-addr2 u2 n -- n' ) 128 | _s _s SI: _strstr outint ( c-addr1 u1 c-addr2 u2 -- index1 | -1 ) 129 | 130 | 131 | _n SI: _srand nothing ( seed -- ) 132 | SI: _rand outint ( -- random ) 133 | _n SI: _random outint ( max -- random ) 134 | 135 | 2DROP 136 | 137 | 138 | 0 CONSTANT _seek_set 139 | 1 CONSTANT _seek_cur 140 | 2 CONSTANT _seek_end 141 | 142 | 143 | SET-CURRENT ( restore ) 144 | 145 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/CONTROL.4: -------------------------------------------------------------------------------- 1 | \ 2 | \ Controls 3 | \ 4 | 5 | : BEGIN 6 | resolve 29 | ; 30 | IMMEDIATE restrict 31 | 32 | 33 | : WHILE 34 | POSTPONE ?branch 35 | >mark SWAP 36 | ; 37 | IMMEDIATE restrict 38 | 39 | 40 | 41 | 42 | : IF 43 | POSTPONE ?branch 44 | >mark 45 | ; 46 | IMMEDIATE restrict 47 | 48 | 49 | : THEN 50 | >resolve 51 | ; 52 | IMMEDIATE restrict 53 | 54 | 55 | : ELSE 56 | POSTPONE branch 57 | >mark SWAP 58 | >resolve 59 | ; 60 | IMMEDIATE restrict 61 | 62 | 63 | : DO 64 | ['] (do jsrsb, 65 | >mark 66 | 0 is_macro ! 67 | ; 68 | IMMEDIATE restrict 69 | 70 | 71 | : LOOP 72 | ['] (loop jsrsb, 73 | >resolve 74 | ; 75 | IMMEDIATE restrict 76 | 77 | 78 | : ?DO 79 | ['] (?do jsrsb, 80 | >mark 81 | 0 is_macro ! 82 | ; 83 | IMMEDIATE restrict 84 | 85 | 86 | : +LOOP 87 | ['] (+loop jsrsb, 88 | >resolve 89 | ; 90 | IMMEDIATE restrict 91 | 92 | 93 | 94 | 95 | 96 | 97 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/DOUBLE.4: -------------------------------------------------------------------------------- 1 | \ 2 | \ 3 | \ DOUBLE numbers wordset 4 | \ 5 | ( JPS940920: D+ and D- added ) 6 | ( JPS940920: DU< added ) 7 | ( JPS950112: commented out M+. Already defined in kernel!! ) 8 | ( JPS950117: D< added ) 9 | ( JPS950403: M*/ added, taken from U.Hoffmann ) 10 | 11 | WORDLIST CONSTANT double-wordlist 12 | double-wordlist vpush vswap 13 | GET-CURRENT double-wordlist SET-CURRENT 14 | 15 | 16 | 17 | : 2VARIABLE 18 | CREATE 2 CELLS ALLOT ; 19 | 20 | \ : 2CONSTANT 21 | \ CREATE SWAP , , 22 | \ DOES> 2@ ; 23 | 24 | : 2CONSTANT ( d -- ) 25 | m: POSTPONE 2LITERAL POSTPONE ; ; 26 | 27 | 28 | m: D>S ( d -- n ) 29 | DROP ; 30 | 31 | 32 | HEX 33 | : D+ ( d1 d2 -- d1+d2 ) 34 | [ 35 | 4CDE codew, 36 | 000F codew, \ movem.l (a6)+,d0-d3 37 | D283 codew, \ add.l d3,d1 38 | 2D01 codew, \ move.l d1,-(a6) 39 | D182 codew, \ addx.l d2,d0 40 | 2D00 codew, \ move.l d0,-(a6) 41 | ] ; 42 | 43 | 44 | : D- ( d1 d2 -- d1-d2 ) 45 | [ 46 | 4CDE codew, 47 | 000F codew, \ movem.l (a6)+,d0-d3 48 | 9681 codew, \ sub.l d1,d3 49 | 9580 codew, \ subx.l d0,d2 50 | 2D03 codew, \ move.l d3,-(a6) 51 | 2D02 codew, \ move.l d2,-(a6) 52 | ] ; 53 | DECIMAL 54 | 55 | 56 | \ m: M+ ( d1|ud1 n -- d2|ud2 ) 57 | \ S>D D+ ; 58 | 59 | 60 | : DU< ( ud1 ud2 -- flag ) ( double ext) 61 | ROT SWAP 2DUP U< IF 2DROP 2DROP TRUE EXIT THEN 62 | = >R U< R> AND ; 63 | 64 | : D< ( d1 d2 -- flag ) ( double) 65 | ROT SWAP 2DUP < IF 2DROP 2DROP TRUE EXIT THEN 66 | = >R < R> AND ; 67 | 68 | 69 | : D. ( d -- ) 70 | DUP >R 71 | <# #S R> SIGN #> TYPE SPACE ; 72 | 73 | : D.R ( d count -- ) 74 | >R DUP >R 75 | <# #S R> SIGN #> 76 | R> OVER - SPACES 77 | TYPE SPACE ; 78 | 79 | 80 | 81 | : D= ( d1 d2 -- f ) 82 | SWAP >R = 83 | SWAP R> = 84 | AND ; 85 | 86 | m: D0< ( d -- flag ) 87 | NIP 0< ; 88 | 89 | : D0= ( d -- flag ) 90 | 0= SWAP 0= AND ; 91 | 92 | : D2* ( d -- d*2 ) 93 | OVER 0< 0= 1+ \ FLAG=0/-1!! 94 | SWAP 1 LSHIFT OR 95 | SWAP 1 LSHIFT SWAP 96 | ; 97 | 98 | : D2/ ( d -- d/2 ) 99 | DUP 1 AND 31 LSHIFT 100 | ROT 1 RSHIFT OR 101 | SWAP 1 RSHIFT 102 | ; 103 | 104 | : 2>R 105 | POSTPONE >R POSTPONE >R ; IMMEDIATE 106 | : 2R> 107 | POSTPONE R> POSTPONE R> ; IMMEDIATE 108 | 109 | 110 | 111 | : 2ROT 112 | 2>R 2SWAP 2R> 2SWAP ; 113 | 114 | 115 | \ 116 | \ M*/ (I don't like this kind of stuff) 117 | \ 118 | \ "An exercise in mathematical algorithm design" 119 | 120 | : un* ( u n -- d ) 121 | DUP 0< IF NEGATE UM* DNEGATE ELSE UM* THEN ; 122 | 123 | : dn* ( d n -- t ) 124 | ROT OVER un* 2SWAP M* ROT S>D D+ ; 125 | 126 | : tn/ ( t +n -- d ) 127 | >R ROT 128 | 0 R@ UM/MOD SWAP 129 | 2SWAP R@ FM/MOD 130 | ROT ROT R> UM/MOD NIP 131 | 0 D+ ; 132 | 133 | : M*/ ( d1 n1 +n2 -- d2 ) >R dn* R> tn/ ; 134 | 135 | \ Dies sollte die floored Variante sein. 136 | 137 | 138 | \ 139 | \ 140 | \ set the ENVIRONMENT 141 | \ 142 | \ 143 | S" DOUBLE" FALSE 1 SET-ENVIRONMENT 144 | S" DOUBLE-EXT" TRUE 1 SET-ENVIRONMENT 145 | 146 | 147 | SET-CURRENT ( restore ) 148 | 149 | 150 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/FILE.4: -------------------------------------------------------------------------------- 1 | ( Definition of FILE and FILE EXT wordsets ) 2 | ( JPS, 01jun93 ) 3 | 4 | ( changes: ) 5 | ( JPS940815: CREATE-FILE: make mode fit for creation ) 6 | ( JPS950106: WRITE-FILE: when u=0 it returned -1 as ior, fixed) 7 | 8 | ( Dependencies: ) 9 | ( The SI CLIB shall be defined ) 10 | 11 | 12 | WORDLIST CONSTANT file-wordlist 13 | file-wordlist vpush vswap 14 | GET-CURRENT file-wordlist SET-CURRENT 15 | 16 | 17 | DECIMAL 18 | 19 | 20 | : '" ( "ccc<">" -- c-addr u ) 21 | HERE DUP 22 | POSTPONE S" 23 | DUP >R ALLOT 24 | SWAP R@ CMOVE 25 | R> 26 | ; 27 | 28 | '" a+" '" w+" '" r+" '" a" '" wb" '" rb" '" w" '" r" 29 | 30 | 31 | CREATE access-methods 32 | , , , , , , , , , , , , , , , , 33 | 34 | 35 | : access-method ( x1 -- c-addr u ) 36 | 2 CELLS * 37 | access-methods + DUP CELL+ 38 | @ SWAP @ 39 | ; 40 | 41 | 42 | 43 | 0 CONSTANT R/O ( -- x ) ( FILE ) 44 | 1 CONSTANT W/O ( -- x ) ( FILE ) 45 | 5 CONSTANT R/W ( -- x ) ( FILE ) 46 | 47 | : BIN ( x1 -- x2 ) ( FILE ) 48 | DUP 2 < IF 2 + THEN ; 49 | 50 | 51 | : CLOSE-FILE ( fileid -- ior ) ( FILE ) 52 | _fclose ; 53 | 54 | 55 | : CREATE-FILE ( c-addr u x1 -- x2 ior ) ( FILE ) 56 | DUP R/W = IF 1+ THEN 57 | ( JPS940815 ) 58 | ( this is a ugly hack, but my CLIB forces to use fopen for both, ) 59 | ( opening and creating. So I have to modify the mode ) 60 | access-method _fopen DUP 0= 61 | ; 62 | 63 | 64 | : DELETE-FILE ( c-addr u -- ior ) ( FILE ) 65 | _unlink 66 | ; 67 | 68 | 69 | : FILE-POSITION ( fileid -- ud ior ) ( FILE ) 70 | _ftell DUP -1 = 71 | ; 72 | 73 | 74 | : FILE-SIZE ( fileid -- ud ior ) ( FILE ) 75 | DUP _ftell OVER 76 | _fileno 0 ( offset ) _seek_end _lseek >R 77 | ( fileid _ftell ) _seek_set _fseek DROP 78 | R> DUP -1 = 0 SWAP ( >double ) 79 | ; 80 | 81 | 82 | : -rot ( n1 n2 n3 -- n3 n1 n2 ) 83 | ROT ROT 84 | ; 85 | 86 | 87 | VARIABLE #line 88 | 89 | : INCLUDE-FILE ( i*x fileid -- j*x ) ( FILE ) 90 | \ first, save input specification on returnstack 91 | SAVE-INPUT DUP 92 | BEGIN DUP WHILE 1- ROT >R REPEAT DROP >R 93 | 94 | 0 #line ! \ reset current number of line 95 | 96 | rp@ 256 - rp! \ allocate linebuffer on returnstack 97 | 98 | rp@ >file-ib ! 99 | DUP >source-id ! 0 BLK ! 100 | 101 | >R 102 | BEGIN 103 | >file-ib @ 256 R@ _fgets OVER 104 | \ _fgets returns NULL at EOF 105 | WHILE 106 | 107 | 1 #line +! 108 | 109 | 1- #file-ib ! DROP 0 >IN ! 110 | ['] interpret CATCH ?DUP \ interpret it 111 | IF \ ON ERROR clear up the whole stuff 112 | 113 | CR 114 | ." Error in line " #line @ . ." : " 115 | 116 | R> DROP 117 | rp@ 256 + rp! 118 | 119 | R> DUP BEGIN DUP WHILE 1- R> -rot REPEAT 120 | DROP RESTORE-INPUT 121 | THROW 122 | THEN 123 | REPEAT 124 | 125 | \ and clear up the whole stuff 126 | R> 2DROP DROP 127 | rp@ 256 + rp! 128 | 129 | R> DUP BEGIN DUP WHILE 1- R> -rot REPEAT 130 | DROP RESTORE-INPUT 131 | ; 132 | 133 | 134 | 135 | : OPEN-FILE ( c-addr u x1 -- x2 ior ) ( FILE ) 136 | access-method _fopen DUP 0= 137 | ; 138 | 139 | 140 | 141 | : INCLUDED ( i*x c-addr u - j*x ) ( FILE ) 142 | 2DUP abort"cnt ! abort"msg ! 143 | R/O OPEN-FILE 0= 144 | IF 145 | DUP >R ['] INCLUDE-FILE CATCH 146 | R> CLOSE-FILE DROP 147 | THROW 148 | ELSE 149 | DROP -38 THROW \ TRUE ABORT" " 150 | THEN 151 | ; 152 | 153 | 154 | 155 | : READ-FILE ( c-addr u1 fileid -- u2 ior ) ( FILE ) 156 | 1 -rot _fread DUP 0< ; 157 | 158 | 159 | : READ-LINE ( c-addr u1 fileid -- u2 flag ior ) ( FILE ) 160 | SWAP 1+ SWAP 161 | _fgets OVER 162 | IF 163 | 2DUP 1- + C@ 10 = IF 1- THEN ( strip EOL if present ) 164 | NIP TRUE 0 165 | ELSE 166 | 2DROP 0 FALSE 0 167 | THEN 168 | ; 169 | 170 | 171 | : REPOSITION-FILE ( ud fileid -- ior ) ( FILE ) 172 | >R DROP R> SWAP _seek_set _fseek 173 | ; 174 | 175 | : WRITE-FILE ( c-addr u fileid -- ior ) ( FILE ) 176 | 1 SWAP _fwrite 1 - ; 177 | 178 | 179 | 180 | :NONAME ( : add-0-to-file ( n fileid -- ior ) 181 | DUP >R FILE-SIZE DROP 182 | R@ REPOSITION-FILE DROP ( >eof ) 183 | PAD 512 0 FILL 184 | 512 /MOD R> SWAP 0 185 | DO ( mod fileid ) 186 | PAD 512 ROT DUP >R WRITE-FILE DROP R> 187 | LOOP ( mod fileid ) 188 | PAD -rot WRITE-FILE 189 | ; 190 | 191 | 192 | : RESIZE-FILE ( ud fileid -- ior ) ( FILE ) 193 | NIP ( no double number needed ) 194 | DUP >R FILE-SIZE 2DROP 2DUP > ( new size larger than existing? ) 195 | IF 196 | - ( size of expansion ) R> [ SWAP ] LITERAL EXECUTE 197 | ( !^^^^^^^^! ) 198 | ELSE 199 | R> DROP -1 200 | THEN 201 | ; 202 | 203 | 204 | : WRITE-FILE ( c-addr u fileid -- ior ) ( FILE ) 205 | OVER 0= IF 2DROP 0 EXIT THEN 206 | 1 SWAP _fwrite 1 - ; 207 | 208 | 209 | :NONAME 13 PAD C! 10 PAD 1+ C! PAD 2 ; 210 | 211 | : WRITE-LINE ( c-addr u fileid -- ior ) ( FILE ) 212 | DUP >R _fputs DROP 213 | LITERAL EXECUTE R> _fputs ; 214 | 215 | 216 | ( ) 217 | ( FILE EXTENSION ) 218 | ( ) 219 | 220 | : FILE-STATUS ( c-addr u -- x ior ) ( FILE EXT ) 221 | R/O OPEN-FILE DUP 0= 222 | IF 223 | DROP DUP FILE-SIZE 2DROP 224 | 0 225 | THEN ; 226 | 227 | 228 | : FLUSH-FILE ( fileid -- ior ) ( FILE EXT ) 229 | _fflush ; 230 | 231 | 232 | : RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ior ) ( FILE EXT ) 233 | _rename ; 234 | 235 | S" FILE" TRUE 1 SET-ENVIRONMENT 236 | S" FILE-EXT" TRUE 1 SET-ENVIRONMENT 237 | 238 | 239 | \ 240 | \ 241 | \ words in common use 242 | \ 243 | \ 244 | : INCLUDE ( -- ) 245 | BL WORD COUNT INCLUDED ; 246 | 247 | 248 | SET-CURRENT ( restore ) 249 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/FLOAT.SI: -------------------------------------------------------------------------------- 1 | 2 | ( JPS950117: >FLOAT returns int instead of nothing ) 3 | 4 | DECIMAL 5 | 6 | WORDLIST CONSTANT float-wordlist 7 | float-wordlist vpush vswap 8 | 9 | systeminterface _initFLOT FLOT 10 | GET-CURRENT float-wordlist SET-CURRENT 11 | SWAP CONSTANT FLOTBASE 12 | 13 | 14 | FLOTBASE 0 15 | 16 | SI: _sizeoffloat outint 17 | 18 | _s SI: >FLOAT outint 19 | _n _n SI: D>F nothing 20 | SI: f>d_low outint 21 | SI: f>d_high outint 22 | _n _a _a SI: _ecvt outstr ( ndig *dec *sign -- c-addr u ) 23 | _n _a _a SI: _fcvt outstr 24 | ( _n SI: _gcvt outstr ) 25 | _s _n _a SI: _sprintfdouble outstr 26 | _s SI: _sscanfdouble outint 27 | 28 | SI: F* nothing 29 | SI: F+ nothing 30 | SI: F- nothing 31 | SI: F/ nothing 32 | 33 | SI: FLOOR nothing 34 | SI: FNEGATE nothing 35 | SI: FROUND nothing 36 | 37 | SI: FDEPTH outint 38 | SI: FDROP nothing 39 | SI: FDUP nothing 40 | SI: FOVER nothing 41 | SI: FROT nothing 42 | SI: FSWAP nothing 43 | 44 | _a SI: F! nothing 45 | _a SI: F@ nothing 46 | 47 | SI: F0< outint 48 | SI: F0= outint 49 | SI: F< outint 50 | SI: FMAX nothing 51 | SI: FMIN nothing 52 | 53 | ( float extension ) 54 | SI: F** nothing 55 | SI: FABS nothing 56 | SI: FACOS nothing 57 | SI: FACOSH nothing 58 | SI: FALOG nothing 59 | SI: FASIN nothing 60 | SI: FASINH nothing 61 | SI: FATAN nothing 62 | SI: FATAN2 nothing 63 | SI: FATANH nothing 64 | SI: FCOS nothing 65 | SI: FCOSH nothing 66 | SI: FEXP nothing 67 | SI: FEXPM1 nothing 68 | SI: FLN nothing 69 | SI: FLNP1 nothing 70 | SI: FLOG nothing 71 | SI: FSIN nothing 72 | SI: FSINCOS nothing 73 | SI: FSINH nothing 74 | SI: FSQRT nothing 75 | SI: FTAN nothing 76 | SI: FTANH nothing 77 | SI: F~ outint 78 | 79 | _n _n SI: _difftime nothing ( time1 time2 -- )( F: -- r ) 80 | 81 | 2DROP 82 | 83 | 84 | ( high level definitions ) 85 | 86 | : FLOAT+ ( n -- n+sizeoffloat ) 87 | _sizeoffloat + ; 88 | 89 | : FLOATS ( n -- n*sizeoffloat ) 90 | _sizeoffloat * ; 91 | 92 | 93 | m: FALIGN ( -- ) 94 | ALIGN ; 95 | 96 | m: FALIGNED ( addr -- f-addr ) 97 | ALIGNED ; 98 | 99 | 100 | 101 | : F>D ( -- d )( F: r -- ) 102 | f>d_low f>d_high ; 103 | 104 | 105 | ( FLOAT output in dpANS5/6 ) 106 | 107 | : REPRESENT ( c-addr u -- n flag1 flag2)( F: r -- ) 108 | DUP 0 >R rp@ ( *DEC) 0 >R rp@ ( *SIGN) 109 | _fcvt ( c-addr u c-addr1 u1 ) 110 | DROP DUP >R ROT ROT MOVE R> 111 | rp@ @ R> DROP ( SIGN) rp@ @ R> DROP ( DEC) SWAP 112 | ROT C@ digit? 113 | DUP IF NIP THEN 114 | ; 115 | 116 | 117 | \ : F, ( F: r -- ) 118 | \ HERE 1 FLOATS ALLOT F! ; 119 | 120 | : flit ( ??????? ) ( compile as runtime only ) 121 | R> DUP code>data F@ 122 | _sizeoffloat + >R ; 123 | 124 | : FLITERAL ( F: r -- ) 125 | POSTPONE flit 126 | cp @ _sizeoffloat cp +! 127 | code>data F! 128 | ; IMMEDIATE 129 | 130 | 131 | 132 | 133 | 134 | : FVARIABLE ( -- )( F: -- ) 135 | CREATE F, ; 136 | 137 | : FCONSTANT ( -- )( F: r -- ) 138 | FVARIABLE DOES> F@ ; 139 | 140 | 141 | 142 | : FNUMBER? ( c-addr -- f ) ( F: -- ?r ) 143 | DUP COUNT _sscanfdouble 144 | DUP IF NIP THEN ; 145 | 146 | 147 | : FNNUMBER? ( c-addr -- str | n | F: r flag ) 148 | nnumber? 149 | ?DUP IF EXIT THEN 150 | FNUMBER? DUP IF DROP -1 THEN 151 | ; 152 | 153 | 154 | 155 | ( ) 156 | ( extensions ) 157 | ( ) 158 | 159 | VARIABLE precision 160 | 5 precision ! 161 | 162 | : PRECISION ( -- u ) 163 | precision @ ; 164 | 165 | : SET-PRECISION ( u -- ) 166 | precision ! ; 167 | 168 | 169 | : (F.) ( -- c-addr u )( F: r -- ) 170 | S" %.*f" precision @ 1+ PAD _sprintfdouble ; 171 | 172 | : F. ( -- )( F: r -- ) 173 | (F.) TYPE SPACE ; 174 | 175 | 176 | : (FS.) ( -- c-addr u )( F: r -- ) 177 | S" %.*E" precision @ PAD _sprintfdouble ; 178 | 179 | : FS. ( -- )( F: r -- ) 180 | (FS.) TYPE SPACE ; 181 | 182 | 183 | SET-CURRENT ( restore ) 184 | 185 | 186 | ( ) 187 | ( initialising the package ) 188 | ( ) 189 | 190 | : initFLOT ( -- ) 191 | _initFLOT 192 | _sizeoffloat fwidth ! 193 | ['] FLITERAL (fliteral) ! 194 | ['] FNNUMBER? (number?) ! ; 195 | 196 | 197 | 198 | S" FLOATING" TRUE 1 SET-ENVIRONMENT 199 | S" FLOATING-EXT" TRUE 1 SET-ENVIRONMENT 200 | S" FLOATING-STACK" 1000 1 SET-ENVIRONMENT 201 | 202 | 203 | 204 | 205 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/LOCAL.4: -------------------------------------------------------------------------------- 1 | ( LOCAL EXT wordset and alternatives bases on LOCAL ) 2 | ( JPS, 18apr93 ) 3 | 4 | 5 | : LOCALS| ( "name_n" ... "name_2" "name_1" "|" -- ) 6 | BEGIN 7 | BL WORD COUNT 2DUP 8 | 1 = 0= SWAP C@ [CHAR] | = 0= OR 9 | WHILE 10 | (LOCAL) 11 | REPEAT 12 | 2DROP 13 | ; 14 | IMMEDIATE 15 | 16 | 17 | ( alternatives ) 18 | 19 | : LOCAL ( -- ) 20 | BL WORD COUNT (LOCAL) ; 21 | IMMEDIATE 22 | 23 | 24 | S" #LOCALS" 1000 1 SET-ENVIRONMENT 25 | S" LOCALS" TRUE 1 SET-ENVIRONMENT 26 | S" LOCALS-EXT" TRUE 1 SET-ENVIRONMENT 27 | 28 | 29 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/MEMORY.4: -------------------------------------------------------------------------------- 1 | ( *********************************************** ) 2 | ( definition of the memory and memory ext wordset ) 3 | ( *********************************************** ) 4 | 5 | ( dependencies: ) 6 | ( you already should have loaded the CLIB systeminterface ) 7 | 8 | : |save-length ( len absaddr -- a-addr ) 9 | (abs) SWAP OVER ! CELL+ 10 | ; 11 | 12 | 13 | : ALLOCATE ( u -- a-addr ior ) ( MEMORY ) 14 | DUP CELL+ _malloc ?DUP 15 | IF |save-length 0 16 | ELSE -1 17 | THEN 18 | ; 19 | 20 | 21 | : CELL- ( addr -- addr-cell ) 22 | 1 CELLS - 23 | ; 24 | 25 | 26 | : FREE ( a-addr -- ior ) ( MEMORY ) 27 | CELL- _free 0 ( _free cannot fail! ) 28 | ; 29 | 30 | 31 | : RESIZE ( a-addr1 u -- a-addr2 ior ) ( MEMORY ) 32 | LOCALS| U ADDR | 33 | ADDR CELL- U CELL+ _realloc ?DUP 34 | IF 35 | U SWAP |save-length 0 ( succeeded ) 36 | ELSE ( -- ) 37 | U CELL+ _malloc DUP ( allocate new ) 38 | IF ( ptr ) 39 | DUP CELL+ ADDR 40 | ADDR CELL- @ U MIN ( minimal length ) 41 | ( ptr ptrCELL+ ADDR minlen ) 42 | CMOVE ( move old memory to new ) 43 | ADDR _free ( free old ) 44 | U SWAP |save-length 0 ( note: success! ) 45 | ELSE -1 ( RESIZE failed ) 46 | THEN 47 | THEN 48 | ; 49 | 50 | 51 | : AVAILABLE ( -- u ) 52 | -1 _malloc ; 53 | 54 | 55 | 56 | S" MEMORY-ALLOC" TRUE 1 SET-ENVIRONMENT 57 | S" MEMORY-ALLOC-EXT" TRUE 1 SET-ENVIRONMENT 58 | 59 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/MSS.4: -------------------------------------------------------------------------------- 1 | 2 | \ "An exercise in mathematical algorithm design" 3 | 4 | : un* ( u n -- d ) 5 | DUP 0< IF NEGATE UM* DNEGATE ELSE UM* THEN ; 6 | 7 | : dn* ( d n -- t ) 8 | ROT OVER un* 2SWAP M* ROT S>D D+ ; 9 | 10 | : tn/ ( t +n -- d ) 11 | >R ROT 12 | 0 R@ UM/MOD SWAP 13 | 2SWAP R@ FM/MOD 14 | ROT ROT R> UM/MOD NIP 15 | 0 D+ ; 16 | 17 | : M*/ ( d1 n1 +n2 -- d2 ) >R dn* R> tn/ ; 18 | 19 | \ Dies sollte die floored Variante sein. 20 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/MULTASK.4: -------------------------------------------------------------------------------- 1 | \ 2 | \ the F68KANS multitasker 3 | \ 4 | \ 5 | 6 | \ 7 | \ JPS940419 8 | \ 9 | 10 | \ what a cooperative PAUSE has to do: 11 | \ 12 | \ 1.) 13 | \ save registers: a6 (datastack), a7 (returnstack) 14 | \ d6/d7 (DO..LOOP) 15 | \ 16 | \ lea 0(a3,d5.l),a0 17 | \ movem.l a6-a7/d6-d7,-(a0) 18 | \ 19 | \ 20 | \ 2.) 21 | \ get pointer to next task (userarea) 22 | \ 23 | \ move.l 0(a3,d5.l),d5 24 | \ 25 | \ 26 | \ 3.) 27 | \ restore registers 28 | \ 29 | \ lea -16(a3,d5.l),a0 30 | \ movem.l (a0)+,a6-a7/d6-d7 31 | \ 32 | 33 | 34 | WORDLIST CONSTANT tasker-wordlist 35 | tasker-wordlist vpush vswap 36 | GET-CURRENT tasker-wordlist SET-CURRENT 37 | 38 | 39 | 40 | 41 | HEX 42 | 43 | : PAUSE 44 | [ 45 | 41F35800 code, \ lea 0(a3,d5.l),a0 46 | 48E00303 code, \ movem.l a6-a7/d6-d7,-(a0) 47 | 2A335800 code, \ move.l 0(a3,d5.l),d5 48 | 41F358F0 code, \ lea -16(a3,d5.l),a0 49 | 4CD8C0C0 code, \ movem.l (a0)+,a6-a7/d6-d7 50 | ] ; 51 | 52 | 53 | \ 54 | \ creating a new task 55 | \ 56 | \ 57 | HEX 58 | 0800 CONSTANT usize \ size of USER area 59 | 0400 CONSTANT dsize \ size of data stack 60 | 0400 CONSTANT rsize \ size of returnstack 61 | 0010 CONSTANT regsize \ size of space for registers 62 | nextuser CONSTANT bootuser \ original USER area 63 | 64 | 65 | : allotuser ( -- addr-of-userarea ) 66 | regsize ALLOT \ space to save registers 67 | HERE usize ALLOT 68 | ; 69 | 70 | 71 | : allotstacks ( -- addr-rstack addr-dstack ) 72 | rsize ALLOT HERE 73 | dsize ALLOT HERE \ stack grow to lower addresses 74 | ; 75 | 76 | r0 nextuser - CONSTANT o_r0 77 | s0 nextuser - CONSTANT o_s0 78 | 79 | : 0!uarea ( addr-rstack addr-dstck addr-user -- ) 80 | >R 81 | bootuser R@ usize CMOVE 82 | R@ o_s0 + ! \ set base of datastack 83 | R> o_r0 + ! \ set base of returnstack 84 | ; 85 | 86 | 87 | : 0!rstack ( xt addr-rstack -- ) 88 | SWAP code>data >abs SWAP \ calculate absolute codeaddress 89 | 1 CELLS - ! \ store in returnstack 90 | ; 91 | 92 | 93 | : 0!registers ( addr-rstack addr-dstack addr-user -- ) 94 | >R 95 | >abs R@ 2 CELLS - ! 96 | 1 CELLS - >abs R> 1 CELLS - ! 97 | ; 98 | 99 | 100 | : 3DUP ( a b c -- a b c a b c ) 101 | >R 2DUP R@ -rot R> 102 | ; 103 | 104 | : TASK ( compile: xt -- ) 105 | ( runtime: -- addr-task ) 106 | CREATE 107 | allotuser 108 | allotstacks ( xt addr-user addr-rstack addr-dstack ) 109 | OVER >R \ save rstack 110 | ROT 3DUP 111 | 0!uarea 0!registers 112 | R> 0!rstack 113 | DOES> 114 | regsize + 115 | ; 116 | 117 | : ?awake ( task -- t/f) 118 | >R 0 nextuser 119 | BEGIN 120 | DUP R@ = DUP ( 0 nextuser flag flag ) 121 | IF >R >R DROP TRUE R> R> THEN 0= 122 | WHILE 123 | @ DUP nextuser = 124 | UNTIL THEN 125 | DROP R> DROP ; 126 | 127 | 128 | : WAKE ( addr-task -- ) 129 | DUP ?awake 130 | IF DROP 131 | ELSE 132 | nextuser @ OVER ! 133 | nextuser ! 134 | THEN 135 | ; 136 | 137 | : SLEEP ( addr-task -- ) 138 | DUP ?awake 139 | IF 140 | >R nextuser 141 | BEGIN DUP @ R@ = 0= 142 | WHILE @ 143 | REPEAT 144 | R> @ SWAP ! 145 | ELSE DROP THEN 146 | ; 147 | 148 | 149 | : STOP ( -- ) 150 | nextuser SLEEP PAUSE 151 | ; 152 | 153 | 154 | 155 | \ 156 | \ patch I/O 157 | \ 158 | VARIABLE BGPRIORITY 159 | 8 BGPRIORITY ! 160 | 161 | : multiKEY ( -- char ) 162 | BEGIN 163 | BGPRIORITY @ 0 ?DO PAUSE LOOP 164 | KEY? 165 | UNTIL 166 | [ (key) @ ] LITERAL EXECUTE ; 167 | 168 | : multiEMIT ( char -- ) 169 | [ (emit) @ ] LITERAL EXECUTE 170 | BGPRIORITY @ 0 ?DO PAUSE LOOP ; 171 | 172 | 173 | 174 | ' multiKEY (key) ! 175 | ' multiEMIT (emit) ! 176 | 177 | 178 | 179 | \ 180 | \ 181 | \ install and uninstall the tasker 182 | \ 183 | \ 184 | VARIABLE savepausecode 185 | ' PAUSE code>data w@ savepausecode ! 186 | 187 | : SINGLETASK ( -- ) 188 | 4E75 ( rts ) ['] PAUSE code>data w! 189 | ; 190 | 191 | : MULTITASK ( -- ) 192 | savepausecode @ ['] PAUSE code>data w! 193 | ; 194 | 195 | SINGLETASK 196 | 197 | DECIMAL 198 | 199 | SET-CURRENT ( restore ) 200 | 201 | 202 | 203 | \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 204 | \ test 205 | \ 206 | \ 207 | \ VARIABLE COUNTER 208 | \ 209 | \ 0 COUNTER ! 210 | \ 211 | \ : TESTTASK 212 | \ BEGIN 1 COUNTER +! PAUSE 213 | \ AGAIN ; 214 | \ 215 | \ ' TESTTASK TASK TTASK 216 | \ MULTITASK 217 | \ TTASK WAKE 218 | \ 219 | 220 | 221 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/PAUSE.S: -------------------------------------------------------------------------------- 1 | .text 2 | GLOBL main 3 | main: lea 0(a3,d5.l),a0 4 | movem.l a6-a7/d6-d7,-(a0) 5 | move.l 0(a3,d5.l),d5 6 | lea -16(a3,d5.l),a0 7 | movem.l (a0)+,a6-a7/d6-d7 8 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/REVOC.4: -------------------------------------------------------------------------------- 1 | \ 2 | \ the REVOC utility is used to move words from one 3 | \ wordlist to another. 4 | \ 5 | \ This may be useful when removing words, which are not 6 | \ intended to be used by the programmer, from the standard 7 | \ FORTH-WORDLIST to another, which will not be searched. 8 | \ 9 | 10 | GET-CURRENT hidden-wordlist SET-CURRENT 11 | 12 | 13 | \ ------------------------------------------------------------------ 14 | 15 | 16 | 17 | : xt>prevhead ( voc xt -- previoushead | 0) 18 | >R @ 19 | BEGIN 20 | DUP @ 1 CELLS - @ R@ <> 21 | WHILE 22 | @ DUP @ 0= 23 | UNTIL THEN 24 | R> DROP 25 | ; 26 | 27 | 28 | : >prevhead ( xt -- prevhead | 0 ) 29 | vocpa @ @ 0 30 | DO 31 | vocpa @ I CELL+ + @ OVER 32 | xt>prevhead ?DUP IF NIP UNLOOP EXIT THEN 33 | 1 CELLS +LOOP ( xt ) 34 | DROP FALSE ; 35 | 36 | 37 | : unlink_header ( previoushead -- head ) 38 | DUP @ DUP >R ( get link to head and save as result ) 39 | @ ( get link from head to next ) 40 | SWAP ! ( establish new link ) 41 | R> ; 42 | 43 | : append_header ( header voc -- ) 44 | 2DUP 45 | @ SWAP ! \ build the link-chain 46 | ! \ update the vocabulary 47 | ; 48 | 49 | 50 | : REVOC ( xt voc -- ) 51 | SWAP >prevhead 52 | unlink_header 53 | SWAP append_header 54 | ; 55 | 56 | \ WORDLIST CONSTANT HIDDEN 57 | \ ' NEW HIDDEN REVOC 58 | 59 | 60 | \ --------------------------------------------------------------- 61 | \ 62 | \ may be useful: 63 | \ 64 | \ : revoc-words ( c-addr -- ) 65 | \ >R 66 | \ context @ ( lfa ) 67 | \ BEGIN DUP WHILE 68 | \ CR ." ' " 69 | \ DUP CELL+ COUNT TYPE SPACE 70 | \ R@ COUNT TYPE16 ." REVOC" 71 | \ @ STOP? 72 | \ UNTIL THEN DROP CR 73 | \ R> DROP ; 74 | 75 | 76 | VARIABLE towordlist 77 | : revoc-words ( c-addr -- ) 78 | towordlist ! 0 >R 79 | context @ ( lfa ) 80 | BEGIN DUP WHILE 81 | R> 1+ >R 82 | DUP 83 | @ 84 | REPEAT DROP 85 | R> 0 DO 86 | CR ." ' " 87 | CELL+ COUNT TYPE SPACE 88 | towordlist @ COUNT TYPE16 ." REVOC" 89 | LOOP 90 | CR ; 91 | 92 | \ e.g.: C" hidden-wordlist" revoc-words 93 | 94 | 95 | SET-CURRENT ( restore ) 96 | 97 | 98 | \ --------------------------------------------------------------- 99 | 100 | FALSE [IF] 101 | 102 | \ sucht in voc nach einem Wort mit dem 103 | \ passenden xt und liefert die Adresse des Namens im Header 104 | : xt>name ( voc xt -- c-addr | 0) 105 | >R @ 106 | BEGIN 107 | DUP 1 CELLS - @ R@ <> 108 | WHILE 109 | @ DUP 0= 110 | UNTIL THEN 111 | R> DROP 112 | DUP IF CELL+ THEN 113 | ; 114 | 115 | : >NAME ( xt -- c-addr | 0 ) 116 | vocpa @ @ 0 117 | DO 118 | vocpa @ I CELL+ + @ OVER 119 | xt>name ?DUP IF NIP UNLOOP EXIT THEN 120 | 1 CELLS +LOOP ( xt ) 121 | DROP FALSE ; 122 | 123 | [THEN] 124 | 125 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/REVOC.LST: -------------------------------------------------------------------------------- 1 | \ 2 | \ 3 | 4 | 5 | ' F68kAns hidden-wordlist REVOC 6 | ' accept hidden-wordlist REVOC 7 | ' type hidden-wordlist REVOC 8 | ' (cold) hidden-wordlist REVOC 9 | ' systop hidden-wordlist REVOC 10 | ' sysbot hidden-wordlist REVOC 11 | ' datatop hidden-wordlist REVOC 12 | ' databot hidden-wordlist REVOC 13 | ' forthparas hidden-wordlist REVOC 14 | ' (front_opt) hidden-wordlist REVOC 15 | ' (end_opt) hidden-wordlist REVOC 16 | ' codeheadsize hidden-wordlist REVOC 17 | ' blankbits hidden-wordlist REVOC 18 | ' nextuser hidden-wordlist REVOC 19 | ' r0 hidden-wordlist REVOC 20 | ' s0 hidden-wordlist REVOC 21 | ' f0 hidden-wordlist REVOC 22 | ' (number?) hidden-wordlist REVOC 23 | ' cp hidden-wordlist REVOC 24 | ' dp hidden-wordlist REVOC 25 | ' >evaluate-ib hidden-wordlist REVOC 26 | ' #evaluate-ib hidden-wordlist REVOC 27 | ' >file-ib hidden-wordlist REVOC 28 | ' #file-ib hidden-wordlist REVOC 29 | ' (block-source) hidden-wordlist REVOC 30 | ' >source-id hidden-wordlist REVOC 31 | ' current hidden-wordlist REVOC 32 | ' vocpa hidden-wordlist REVOC 33 | ' last hidden-wordlist REVOC 34 | ' abort"msg hidden-wordlist REVOC 35 | ' abort"cnt hidden-wordlist REVOC 36 | ' error"msg hidden-wordlist REVOC 37 | ' (errorhandler) hidden-wordlist REVOC 38 | ' (key) hidden-wordlist REVOC 39 | ' (emit) hidden-wordlist REVOC 40 | ' (key?) hidden-wordlist REVOC 41 | ' ^key hidden-wordlist REVOC 42 | ' ^emit hidden-wordlist REVOC 43 | ' ^key? hidden-wordlist REVOC 44 | ' ^emit? hidden-wordlist REVOC 45 | ' (accept) hidden-wordlist REVOC 46 | ' (type) hidden-wordlist REVOC 47 | ' (find) hidden-wordlist REVOC 48 | ' (parser) hidden-wordlist REVOC 49 | ' (fliteral) hidden-wordlist REVOC 50 | ' macro hidden-wordlist REVOC 51 | ' is_macro hidden-wordlist REVOC 52 | ' warning hidden-wordlist REVOC 53 | ' out hidden-wordlist REVOC 54 | ' fwidth hidden-wordlist REVOC 55 | ' userbufs hidden-wordlist REVOC 56 | ' echo hidden-wordlist REVOC 57 | ' udp hidden-wordlist REVOC 58 | ' number? hidden-wordlist REVOC 59 | ' loaderkey hidden-wordlist REVOC 60 | ' loaderemit hidden-wordlist REVOC 61 | ' loaderkey? hidden-wordlist REVOC 62 | ' jsr, hidden-wordlist REVOC 63 | ' code, hidden-wordlist REVOC 64 | ' codew, hidden-wordlist REVOC 65 | ' jsrsb, hidden-wordlist REVOC 66 | ' w, hidden-wordlist REVOC 67 | ' sp@ hidden-wordlist REVOC 68 | ' sp! hidden-wordlist REVOC 69 | ' rp@ hidden-wordlist REVOC 70 | ' rp! hidden-wordlist REVOC 71 | ' (abs) hidden-wordlist REVOC 72 | ' >abs hidden-wordlist REVOC 73 | ' code>data hidden-wordlist REVOC 74 | ' data>code hidden-wordlist REVOC 75 | ' (s") hidden-wordlist REVOC 76 | ' (.") hidden-wordlist REVOC 77 | ' (error" hidden-wordlist REVOC 78 | ' (abort" hidden-wordlist REVOC 79 | ' skip hidden-wordlist REVOC 80 | ' scan hidden-wordlist REVOC 81 | ' name hidden-wordlist REVOC 82 | ' vocsearch hidden-wordlist REVOC 83 | ' find hidden-wordlist REVOC 84 | ' nullstr? hidden-wordlist REVOC 85 | ' notfound hidden-wordlist REVOC 86 | ' ?stack hidden-wordlist REVOC 87 | ' compiler hidden-wordlist REVOC 88 | ' interpreter hidden-wordlist REVOC 89 | ' parser hidden-wordlist REVOC 90 | ' interpret hidden-wordlist REVOC 91 | ' prompt hidden-wordlist REVOC 92 | ' errorhandler hidden-wordlist REVOC 93 | ' cold hidden-wordlist REVOC 94 | ' digit? hidden-wordlist REVOC 95 | ' nnumber? hidden-wordlist REVOC 96 | ' w@ hidden-wordlist REVOC 97 | ' w! hidden-wordlist REVOC 98 | ' header hidden-wordlist REVOC 99 | ' header: hidden-wordlist REVOC 100 | ' m: hidden-wordlist REVOC 101 | ' reveal hidden-wordlist REVOC 102 | ' ;code) hidden-wordlist REVOC 103 | ' (do hidden-wordlist REVOC 104 | ' (?do hidden-wordlist REVOC 105 | ' (loop hidden-wordlist REVOC 106 | ' (+loop hidden-wordlist REVOC 107 | ' ?branch hidden-wordlist REVOC 108 | ' branch hidden-wordlist REVOC 109 | ' ," hidden-wordlist REVOC 110 | ' error" hidden-wordlist REVOC 111 | ' restrict hidden-wordlist REVOC 112 | ' >mark hidden-wordlist REVOC 113 | ' >resolve hidden-wordlist REVOC 114 | ' R 21 | ( change c-addr u to a counted string in srch-wlbuf ) 22 | SWAP OVER srch-wlbuf 1+ SWAP CMOVE 23 | srch-wlbuf C! 24 | srch-wlbuf R> vocsearch ( do the search ) ( xt 1 | xt -1 | str 0 ) 25 | DUP 0= IF NIP THEN 26 | ; 27 | 28 | 29 | : DEFINITIONS ( -- ) 30 | vocpa @ DUP @ + @ current ! ; 31 | 32 | 33 | : GET-CURRENT ( -- wid ) 34 | current @ ; 35 | 36 | : GET-ORDER ( -- wid1 ... widn n ) 37 | vocpa @ DUP 38 | @ 4 / DUP >R 39 | 0 DO 40 | CELL+ DUP @ SWAP 41 | LOOP 42 | DROP ( addr ) 43 | R> ; 44 | 45 | 46 | : SET-CURRENT ( wid -- ) 47 | current ! ; 48 | 49 | : SET-ORDER ( wid1 ... widn n -- ) 50 | DUP >R ( save n ) 51 | 4 * vocpa @ ! ( save height of vocstack ) 52 | R> 0 53 | DO 54 | vocpa @ DUP @ + 55 | I CELLS - ! 56 | LOOP ; 57 | 58 | ALIGN HERE 0 , 0 , CONSTANT emptyheader 59 | 60 | : WORDLIST ( -- wid ) 61 | ALIGN HERE emptyheader , ; 62 | 63 | \ 64 | \ extensions 65 | \ 66 | 67 | : ALSO ( -- ) 68 | GET-ORDER OVER SWAP 1+ SET-ORDER ; 69 | 70 | : PREVIOUS ( -- ) 71 | GET-ORDER NIP 1- SET-ORDER ; 72 | 73 | : FORTH ( -- ) 74 | GET-ORDER NIP FORTH-WORDLIST SWAP SET-ORDER ; 75 | 76 | 77 | WORDLIST CONSTANT ROOT 78 | 79 | GET-CURRENT ROOT SET-CURRENT 80 | 81 | FORTH-WORDLIST CONSTANT FORTH-WORDLIST 82 | 83 | : SET-ORDER SET-ORDER ; 84 | 85 | SET-CURRENT 86 | 87 | 88 | : ONLY ( -- ) 89 | ROOT ROOT 2 SET-ORDER ; 90 | 91 | 92 | : ORDER ( -- ) 93 | CR ." Order: " GET-ORDER 0 94 | DO . LOOP 95 | CR ." Current: " GET-CURRENT . 96 | ; 97 | 98 | S" SEARCH-ORDER" TRUE 1 SET-ENVIRONMENT 99 | S" SEARCH-ORDER-EXT" TRUE 1 SET-ENVIRONMENT 100 | S" WORDLISTS" 20 1 SET-ENVIRONMENT 101 | 102 | 103 | \ 104 | \ 105 | \ things of common use 106 | \ 107 | \ 108 | 109 | : do-vocabulary ( -- ) 110 | DOES> @ >R 111 | GET-ORDER NIP 112 | R> SWAP SET-ORDER 113 | ; 114 | 115 | : VOCABULARY ( -- ) 116 | WORDLIST CREATE , do-vocabulary 117 | ; 118 | 119 | 120 | : discard ( x1 .... xu u -- ) 121 | 0 ?DO DROP LOOP ; 122 | 123 | : SEAL ( -- ) 124 | GET-ORDER OVER 1 SET-ORDER discard ; 125 | 126 | 127 | : vpush ( wid -- ) 128 | >R GET-ORDER R> SWAP 1+ 129 | SET-ORDER ; 130 | 131 | : vswap ( -- ) 132 | GET-ORDER >R SWAP R> 133 | SET-ORDER ; 134 | 135 | : vdrop ( -- ) 136 | GET-ORDER 1- NIP 137 | SET-ORDER ; 138 | 139 | 140 | WORDLIST CONSTANT hidden-wordlist 141 | hidden-wordlist vpush vswap 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/SI.4: -------------------------------------------------------------------------------- 1 | ( ######################################### ) 2 | ( using the system interface SI for Atari ) 3 | ( ######################################### ) 4 | 5 | ( JPS, 30mar93 ) 6 | 7 | GET-CURRENT hidden-wordlist SET-CURRENT 8 | 9 | 10 | HEX 11 | 12 | ( fetch an absolut address ) 13 | : @abs ( addr -- aaddr ) 14 | @ (abs) ; 15 | 16 | 17 | 18 | ( work with loader provided parameter field ) 19 | 20 | CREATE "" BL C, BL C, BL C, BL C, 21 | 22 | 23 | HEX 24 | 25 | : (@) ( addr -- value ) ( @ on unaligned addresses ) 26 | COUNT ( 1000000 *) 18 LSHIFT SWAP 27 | COUNT ( 0010000 *) 10 LSHIFT SWAP 28 | COUNT ( 0000100 *) 8 LSHIFT SWAP 29 | COUNT SWAP DROP 30 | ( + + +) OR OR OR ; 31 | 32 | 33 | : FINDSI ( 4str -- addr ) 34 | COUNT DROP (@) >R 35 | forthparas 17 CELLS + @abs 36 | BEGIN DUP @ DUP R@ = ( 0=) 37 | SWAP "" @ = ( 0= AND) OR 0= 38 | WHILE 2 CELLS + 39 | REPEAT 40 | R> DROP 41 | CELL+ @ DUP 42 | IF (abs) 43 | ELSE DROP -1 ABORT" Cannot locate SI!" 44 | THEN ; 45 | 46 | 47 | 48 | 49 | ( a generic interface ) 50 | 51 | ( a key defining word ) 52 | : systeminterface ( -- ) 53 | CREATE 54 | HERE 55 | 0 , ( for basepointer ) 56 | BL WORD COUNT 1+ ALLOT DROP ( the ID ) 57 | ( supposes, that WORD lays the string down at HERE! ) 58 | DOES> 59 | DUP CELL+ FINDSI 60 | SWAP ! ; 61 | 62 | ( example: ) 63 | ( systeminterface initBIOS BIOS CONSTANT BIOSBASE ) 64 | ( initBIOS ( BIOS should always be available ) 65 | 66 | 67 | ( describing incoming parameters ) 68 | ( ============================== ) 69 | 70 | ( some 68k opcodes ) 71 | 2D00 CONSTANT move.l_d0,-(a6) 72 | 2F1E CONSTANT move.l_(a6)+,-(a7) 73 | DFFC CONSTANT adda.l_#n,a7 74 | 205E CONSTANT move.l_(a6)+,a0 75 | 4E90 CONSTANT jsr_(a0) 76 | 77 | 78 | ( some codegeneration words ) 79 | 80 | : [getresult] ( -- ) 81 | move.l_d0,-(a6) codew, ; 82 | 83 | 84 | 85 | : [getptrresult] ( -- ) 86 | move.l_d0,-(a6) codew, 87 | POSTPONE (abs) ; 88 | 89 | 90 | 91 | : [pushn] ( -- ) 92 | move.l_(a6)+,-(a7) codew, ; 93 | 94 | 95 | 96 | : [pushptr] ( -- ) 97 | POSTPONE >abs [pushn] ; 98 | 99 | 100 | 101 | : [releasestack] ( n -- ) 102 | adda.l_#n,a7 codew, code, ; 103 | 104 | 105 | 106 | : [doSIcall] ( -- ) 107 | move.l_(a6)+,a0 codew, 108 | jsr_(a0) codew, ; 109 | 110 | 111 | 112 | 113 | 114 | VARIABLE #incoming 115 | 0 #incoming ! 116 | 117 | : _n ( -- cfa ) 118 | ['] [pushn] 119 | 1 #incoming +! ; 120 | 121 | : _a ( -- cfa ) 122 | ['] [pushptr] 123 | 1 #incoming +! ; 124 | 125 | 126 | 127 | ( strings ) 128 | 129 | CREATE STRBUF1 100 ALLOT 130 | CREATE STRBUF2 100 ALLOT 131 | CREATE STRBUF3 100 ALLOT 132 | CREATE STRBUF4 100 ALLOT 133 | 134 | : STR1>0 ( c-addr u -- 0str-addr ) 135 | DUP >R STRBUF1 SWAP CMOVE 136 | 0 R> STRBUF1 + C! 137 | STRBUF1 ; 138 | : STR2>0 ( c-addr u-- 0str-addr ) 139 | DUP >R STRBUF2 SWAP CMOVE 140 | 0 R> STRBUF2 + C! 141 | STRBUF2 ; 142 | : STR3>0 ( c-addr u -- 0str-addr ) 143 | DUP >R STRBUF3 SWAP CMOVE 144 | 0 R> STRBUF3 + C! 145 | STRBUF3 ; 146 | : STR4>0 ( c-addr u -- 0str-addr ) 147 | DUP >R STRBUF4 SWAP CMOVE 148 | 0 R> STRBUF4 + C! 149 | STRBUF4 ; 150 | 151 | : [pushstr1] ( -- ) 152 | POSTPONE STR1>0 153 | [pushptr] ; 154 | : [pushstr2] ( -- ) 155 | POSTPONE STR2>0 156 | [pushptr] ; 157 | : [pushstr3] ( -- ) 158 | POSTPONE STR3>0 159 | [pushptr] ; 160 | : [pushstr4] ( -- ) 161 | POSTPONE STR4>0 162 | [pushptr] ; 163 | 164 | 165 | : s1 ( -- cfa ) 166 | ['] [pushstr1] 167 | 1 #incoming +! ; 168 | : s2 ( -- cfa ) 169 | ['] [pushstr2] 170 | 1 #incoming +! ; 171 | : s3 ( -- cfa ) 172 | ['] [pushstr3] 173 | 1 #incoming +! ; 174 | : s4 ( -- cfa ) 175 | ['] [pushstr4] 176 | 1 #incoming +! ; 177 | 178 | : _s ( -- cfa cfa ) 179 | _a _n ; 180 | 181 | 182 | ( outcoming parameter ) 183 | 184 | : CSTR>COUNTED ( 0str-addr -- addr cnt ) 185 | DUP 186 | IF 187 | (abs) DUP 188 | BEGIN DUP C@ WHILE 1+ REPEAT 189 | OVER - 190 | ELSE 191 | 0 192 | THEN ; 193 | 194 | ( CSTR>COUNTED gives the Forth address and the count except ) 195 | ( the 0str-addr is NULL. Then the result is ( 0 0 ) 196 | 197 | 198 | : outstr ( -- ) 199 | [getresult] 200 | POSTPONE CSTR>COUNTED ; 201 | 202 | 203 | : outint ( -- ) 204 | [getresult] ; 205 | 206 | 207 | : outptr ( -- ) 208 | [getptrresult] ; 209 | 210 | 211 | : nothing ( -- ) ; 212 | 213 | 214 | ( central defining word for SI functions ) 215 | 216 | : SI: ( base offset -- base offset+cell ) 217 | : 218 | #incoming @ 0 219 | ?DO EXECUTE LOOP ( generate code ) 220 | 2DUP 221 | POSTPONE LITERAL ( offset ) 222 | POSTPONE LITERAL ( xxxBASE ) 223 | POSTPONE @ POSTPONE + 224 | POSTPONE @ 225 | [doSIcall] 226 | #incoming @ CELLS [releasestack] 227 | ' EXECUTE 228 | POSTPONE ; 229 | CELL+ 0 #incoming ! 230 | ; 231 | 232 | 233 | SET-CURRENT ( restore ) 234 | 235 | 236 | ( example: ) 237 | ( BIOSBASE 0 ) 238 | ( SI: BIOSKEY outint ) 239 | ( SI: BIOSKEY? outint ) 240 | ( n SI: BIOSEMIT nothing ) 241 | 242 | 243 | 244 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/STRING.4: -------------------------------------------------------------------------------- 1 | \ 2 | \ the STRING wordset 3 | \ 4 | \ JPS, 28jan94 5 | \ 6 | \ JPS940903: /STRING modified, to avoid S" " 1 /STRING . ==> -1 trouble 7 | \ 8 | 9 | : -TRAILING ( c-addr u1 -- c-addr u2 ) 10 | DUP 0 11 | ?DO 12 | 1- 2DUP + 13 | C@ BL <> IF 1+ LEAVE THEN 14 | LOOP ; 15 | 16 | 17 | : /STRING ( c-addr1 u1 n -- c-addr2 u2 ) 18 | DUP 0< 0= >R 19 | 2DUP U< R> AND ( JPS940903: introduced condition ) 20 | IF 21 | DROP + 0 EXIT 22 | ELSE 23 | DUP >R - SWAP R> + SWAP 24 | THEN ; 25 | 26 | 27 | m: BLANK ( c-addr u -- ) 28 | BL FILL ; 29 | 30 | 31 | \ 32 | \ COMPARE and SEARCH are using standard C-functions 33 | \ provided by the loader 34 | \ 35 | 36 | m: COMPARE ( c-addr1 u1 c-addr2 u2 -- n ) 37 | _strcmp ; 38 | 39 | : SEARCH ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag ) 40 | 2OVER >R >R 41 | _strstr DUP 0< 42 | IF \ not found 43 | DROP R> R> 0 44 | ELSE 45 | R> R> ROT /STRING TRUE 46 | THEN ; 47 | 48 | 49 | : SLITERAL ( c-addr1 u -- ) 50 | POSTPONE (s") 51 | HERE code, 52 | DUP C, 53 | HERE OVER 1+ ALLOT 54 | SWAP CMOVE 55 | ; IMMEDIATE 56 | 57 | 58 | \ Environment 59 | S" STRING" TRUE 1 SET-ENVIRONMENT 60 | S" STRING-EXT" TRUE 1 SET-ENVIRONMENT 61 | 62 | 63 | 64 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/SYSINIT.4: -------------------------------------------------------------------------------- 1 | initFLOT 2 | initCLIB 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/TERMINAL.4: -------------------------------------------------------------------------------- 1 | 2 | 3 | GET-CURRENT hidden-wordlist SET-CURRENT 4 | 5 | 6 | VARIABLE ROWS ( AVAILABLE COLUMNS ON TERMINAL ) 7 | VARIABLE COLUMNS ( AVAILABLE ROWS ON TERMINAL ) 8 | 9 | DECIMAL 10 | 25 ROWS ! 80 COLUMNS ! 11 | 12 | : BELL ( -- ) 7 EMIT ; 13 | 14 | : BACKSPACE ( -- ) 8 EMIT -2 out +! ; 15 | : BACKSPACES ( N -- ) 0 ?DO BACKSPACE LOOP ; 16 | 17 | : TAB ( N -- ) 18 | out @ - DUP 0< IF NEGATE BACKSPACES EXIT THEN 19 | SPACES ; 20 | 21 | : ?CR ( N -- ) out @ < IF CR THEN ; 22 | : ?16CR ( -- ) COLUMNS @ 16 - ?CR ; ( 16 CHARS FREE TO EOL? ) 23 | 24 | SET-CURRENT ( restore ) 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /F68KANS/SYSFTH/TOOLKIT.4: -------------------------------------------------------------------------------- 1 | ( TOOLKIT & TOOLKIT EXTENSIONS ) 2 | ( JPS, 12apr93 ) 3 | 4 | 5 | ( JPS940813: [IF] [ELSE] [THEN] added ) 6 | 7 | : ? ( addr -- ) ( TOOLKIT ) 8 | @ . ; 9 | 10 | 11 | 12 | : .S ( -- ) ( TOOLKIT ) 13 | DEPTH 0 ?DO s0 @ I 1+ CELLS - @ LOOP 14 | ." ToS: " DEPTH 2 / 0 ?DO . LOOP ; 15 | 16 | 17 | 18 | GET-CURRENT hidden-wordlist SET-CURRENT 19 | 20 | : ?TERMINAL ( -- CHAR / FALSE ) 21 | KEY? IF KEY ELSE 0 THEN ; 22 | 23 | : DUMPLINE ( ADR -- ) 24 | BASE @ >R HEX 25 | DUP [ DECIMAL ] 8 .R ." : " 26 | 16 0 DO 27 | DUP I + C@ 2 .R SPACE 28 | LOOP 29 | SPACE 16 0 30 | DO 31 | DUP I + C@ DUP BL < 0= 32 | IF EMIT ELSE DROP ." ." THEN 33 | LOOP 34 | DROP R> BASE ! ; 35 | 36 | 37 | 38 | : FIRSTLINE ( -- ) 39 | CR ." ADDRESS: " 40 | BASE @ >R HEX 41 | [ DECIMAL ] 16 0 DO I 2 .R SPACE LOOP SPACE 42 | 16 0 DO I 1 .R LOOP 43 | R> BASE ! CR 44 | 75 0 DO [CHAR] - EMIT LOOP CR ; 45 | 46 | : STOP? ( -- FLAG ) 47 | ?TERMINAL DUP IF 48 | [ HEX ] 1B = IF -1 EXIT THEN 49 | KEY 1B = 50 | THEN ; 51 | 52 | 53 | SET-CURRENT 54 | 55 | ( DUMP, WORDS ) 56 | 57 | : DUMP ( ADR COUNT -- ) ( TOOLKIT ) 58 | FIRSTLINE 59 | [ DECIMAL ] 16 / 1+ 0 60 | ?DO 61 | DUP I 16 * + DUMPLINE 62 | STOP? IF CR CR LEAVE THEN CR 63 | LOOP DROP ; 64 | 65 | 66 | : TYPE16 ( ADDR LEN -- ) 67 | BEGIN out @ [ HEX ] F AND WHILE SPACE REPEAT TYPE ; 68 | 69 | 70 | : context ( -- voc-addr ) 71 | vocpa @ DUP @ + @ ; 72 | 73 | : WORDS ( -- ) ( TOOLKIT ) 74 | 0 >R ( counter ) 75 | context @ ( lfa ) 76 | BEGIN DUP WHILE 77 | R> 1+ >R 78 | ?16CR DUP CELL+ COUNT TYPE16 79 | @ STOP? 80 | UNTIL THEN DROP CR 81 | R> . ." words displayed" CR ; 82 | 83 | 84 | : SEE ." SEE not implemented" ABORT ; 85 | 86 | 87 | 88 | \ MARKER [IF][ELSE][THEN] 89 | \ : WORD ." word:" WORD DUP COUNT TYPE CR ; 90 | 91 | 92 | : [ELSE] ( -- ) ( TOOLKIT ) 93 | 1 BEGIN \ LEVEL 94 | BEGIN 95 | blankbits ( **) WORD COUNT DUP 96 | WHILE \ LEVEL ADR LEN 97 | 2DUP S" [IF]" COMPARE 0= IF \ LEVEL ADR LEN 98 | 2DROP 1+ \ LEVEL' 99 | ELSE \ LEVEL ADR LEN 100 | 2DUP S" [ELSE]" COMPARE 0= IF \ LEVEL ADR LEN 101 | 2DROP 1- DUP IF 1+ THEN \ LEVEL' 102 | ELSE \ LEVEL ADR LEN 103 | S" [THEN]" COMPARE 0= IF \ LEVEL 104 | 1- \ LEVEL' 105 | THEN 106 | THEN 107 | THEN ?DUP 0= IF EXIT THEN \ LEVEL' 108 | REPEAT 2DROP \ LEVEL 109 | REFILL 0= UNTIL \ LEVEL 110 | DROP ; IMMEDIATE 111 | 112 | : [IF] ( flag -- ) ( TOOLKIT ) 113 | 0= IF POSTPONE [ELSE] THEN ; IMMEDIATE 114 | 115 | : [THEN] ( -- ) ; IMMEDIATE ( TOOLKIT ) 116 | 117 | 118 | 119 | 120 | S" TOOLS" TRUE 1 SET-ENVIRONMENT 121 | S" TOOLS-EXT" TRUE 1 SET-ENVIRONMENT 122 | 123 | 124 | -------------------------------------------------------------------------------- /F68KANS/TST/BGI.TST: -------------------------------------------------------------------------------- 1 | 2 | ( Variable ) 3 | 4 | VARIABLE GRAPHMODE 5 | VARIABLE GRAPHDRIVER 6 | 7 | VARIABLE GRAPH_IS_ON 8 | 0 GRAPH_IS_ON ! 9 | 10 | DETECT GRAPHDRIVER ! 11 | 12 | : PATHTODRIVER ( -- c-addr u ) 13 | S" .\fonts" ; 14 | 15 | viewporttype vp 16 | 17 | 0 VALUE XRES 18 | 0 VALUE YRES 19 | 20 | 21 | DECIMAL 22 | 23 | 24 | : INITGRAPH ( -- ) 25 | GRAPH_IS_ON @ 0= 26 | IF 27 | GRAPHDRIVER GRAPHMODE PATHTODRIVER _initgraph 28 | _cleardevice 29 | 30 | ( 100 100 1200 900 1 _setviewport ) 31 | ( _clearviewport ) 32 | 33 | vp _getviewsettings 34 | vp >vp_left w@ . 35 | vp >vp_top w@ . 36 | vp >vp_right w@ . 37 | vp >vp_bottom w@ . 38 | vp >vp_clip w@ . 39 | vp >vp_right w@ vp >vp_left w@ - TO XRES 40 | vp >vp_bottom w@ vp >vp_top w@ - TO YRES 41 | 42 | _graphresult _grapherrormsg TYPE 43 | THEN 44 | 1 GRAPH_IS_ON +! 45 | ; 46 | 47 | 48 | : EXITGRAPH ( -- ) 49 | -1 GRAPH_IS_ON +! 50 | GRAPH_IS_ON @ 0= 51 | IF _closegraph THEN ; 52 | 53 | 54 | : putpixeltest ( -- ) 55 | 100 0 56 | DO I 6 * I 2 * 1 _putpixel LOOP ; 57 | 58 | 59 | : PUTPIXELDEMO ( -- ) 60 | INITGRAPH 61 | 10000 0 62 | DO 63 | XRES _random YRES _random 1 _putpixel 64 | LOOP 65 | EXITGRAPH ; 66 | 67 | 68 | 6 CONSTANT MAXPTS 69 | CREATE CORNERS MAXPTS CELLS ALLOT ( 2*MAXPTS ints ) 70 | 71 | : RANDOM-CORNERS ( -- ) 72 | MAXPTS 1- 0 73 | DO 74 | XRES _random CORNERS I CELLS + w! 75 | YRES _random CORNERS I CELLS 2 + + w! 76 | LOOP 77 | CORNERS @ 78 | CORNERS MAXPTS 1- CELLS + ! ( last point = first point ) 79 | ; 80 | 81 | 82 | : FILLPOLYDEMO ( -- ) 83 | INITGRAPH 84 | 100 0 85 | DO 86 | RANDOM-CORNERS 87 | 12 _random 1 ( color ) _setfillstyle 88 | MAXPTS CORNERS _fillpoly 89 | LOOP 90 | EXITGRAPH ; 91 | 92 | : DRAWPOLYDEMO ( -- ) 93 | INITGRAPH 94 | 500 0 95 | DO 96 | RANDOM-CORNERS 97 | 12 _random 1 ( color ) _setfillstyle 98 | MAXPTS CORNERS _drawpoly 99 | LOOP 100 | EXITGRAPH ; 101 | 102 | 103 | : CIRCLEDEMO ( -- ) 104 | INITGRAPH 105 | 2000 0 106 | DO 107 | XRES _random YRES _random 150 _random 108 | _circle 109 | LOOP 110 | EXITGRAPH ; 111 | 112 | 113 | : ARCDEMO ( -- ) 114 | INITGRAPH 115 | 2000 0 116 | DO 117 | XRES _random YRES _random 118 | 360 _random 360 _random 119 | 150 _random 120 | _arc 121 | LOOP 122 | EXITGRAPH ; 123 | 124 | 125 | : ELLIPSEDEMO ( -- ) 126 | INITGRAPH 127 | 2000 0 128 | DO 129 | XRES _random YRES _random 130 | 360 _random 360 _random 131 | 150 _random 150 _random 132 | _ellipse 133 | LOOP 134 | EXITGRAPH ; 135 | 136 | 137 | : FILLELLIPSEDEMO ( -- ) 138 | INITGRAPH 139 | 800 0 140 | DO 141 | 12 _random 1 ( color ) _setfillstyle 142 | XRES _random YRES _random 143 | 150 _random 150 _random 144 | _fillellipse 145 | LOOP 146 | EXITGRAPH ; 147 | 148 | : WAIT ( -- ) 149 | 3000000 0 DO LOOP ; 150 | 151 | : BARDEMO ( -- ) 152 | INITGRAPH 153 | 6 1 154 | DO 155 | 12 _random 1 ( color ) _setfillstyle 156 | XRES 7 / I * YRES 7 / I * 157 | OVER XRES 8 / + YRES 10 - 158 | _bar 159 | LOOP 160 | WAIT 161 | EXITGRAPH ; 162 | 163 | 164 | : BAR3DDEMO ( -- ) 165 | INITGRAPH 166 | 6 1 167 | DO 168 | 12 _random 1 ( color ) _setfillstyle 169 | XRES 7 / I * YRES 7 / I * 170 | OVER XRES 10 / + YRES 10 - 171 | XRES 40 / 1 172 | _bar3d 173 | LOOP 174 | WAIT 175 | EXITGRAPH ; 176 | 177 | 178 | : LINEDEMO ( -- ) 179 | INITGRAPH 180 | 5000 0 181 | DO 182 | XRES _random YRES _random 183 | XRES _random YRES _random 184 | _line 185 | LOOP 186 | EXITGRAPH ; 187 | 188 | 189 | 190 | ( Textdemo ) 191 | 192 | 2 VALUE MAXTH 193 | 194 | : TESTSTRING ( -- c-addr u ) 195 | S" F68KANS" ; 196 | 197 | : FIND_MAXTH ( -- ) 198 | 100000 2 199 | DO 200 | TRIPLEX_FONT TEXT_HORIZ_DIR I _settextstyle 201 | XRES TESTSTRING _textwidth - 10 - 202 | 0 < 203 | IF I TO MAXTH LEAVE THEN 204 | LOOP ; 205 | 206 | 207 | : DOBOTTEXT ( -- ) 208 | 5 TESTSTRING _textheight 209 | YRES 10 - SWAP - TESTSTRING _outtextxy ; 210 | 211 | 212 | : DOTOPTEXT 213 | XRES TESTSTRING _textwidth - 5 - 214 | 10 TESTSTRING _outtextxy ; 215 | 216 | 217 | 218 | : DOMIDTEXT ( -- ) 219 | TRIPLEX_FONT TEXT_HORIZ_DIR MAXTH _settextstyle 220 | 5 YRES 3 / TESTSTRING _outtextxy ; 221 | 222 | 223 | 224 | : TEXTDEMO ( -- ) 225 | INITGRAPH 226 | FIND_MAXTH 227 | _clearviewport 228 | ( 2 0 ) 229 | ( DO ) 230 | MAXTH 1+ 1 231 | DO 232 | TRIPLEX_FONT TEXT_HORIZ_DIR I _settextstyle 233 | DOTOPTEXT 234 | DOBOTTEXT 235 | LOOP 236 | _clearviewport 237 | DOMIDTEXT 238 | 0 MAXTH 239 | DO 240 | TRIPLEX_FONT TEXT_HORIZ_DIR I _settextstyle 241 | DOTOPTEXT 242 | DOBOTTEXT 243 | -1 +LOOP 244 | _clearviewport 245 | ( LOOP ) 246 | EXITGRAPH ; 247 | 248 | 249 | 250 | ( PUTPIXELDEMO FILLPOLYDEMO DRAWPOLYDEMO CIRCLEDEMO ARCDEMO 251 | ( ELLIPSEDEMO FILLELLIPSEDEMO 252 | ( BARDEMO BAR3DDEMO 253 | ( LINEDEMO 254 | 255 | 256 | 257 | : FULLDEMO ( -- ) 258 | INITGRAPH 259 | TEXTDEMO 260 | PUTPIXELDEMO TEXTDEMO 261 | FILLPOLYDEMO TEXTDEMO 262 | DRAWPOLYDEMO TEXTDEMO 263 | CIRCLEDEMO TEXTDEMO 264 | ARCDEMO TEXTDEMO 265 | ELLIPSEDEMO TEXTDEMO 266 | FILLELLIPSEDEMO TEXTDEMO 267 | BARDEMO TEXTDEMO 268 | BAR3DDEMO TEXTDEMO 269 | LINEDEMO TEXTDEMO 270 | EXITGRAPH 271 | ; 272 | 273 | 274 | 275 | : DAUERDEMO INITGRAPH BEGIN FULLDEMO AGAIN EXITGRAPH ; 276 | 277 | 278 | 279 | -------------------------------------------------------------------------------- /F68KANS/TST/CLIB.TST: -------------------------------------------------------------------------------- 1 | ( tests for CLIB SI ) 2 | DECIMAL 3 | 4 | initCLIB 5 | 6 | tm t ( define a tm-structure ) 7 | 8 | 25 t >tm_sec w! 9 | 12 t >tm_min w! 10 | 8 t >tm_hour w! 11 | 19 t >tm_mday w! 12 | 8 t >tm_mon w! 13 | 93 t >tm_year w! 14 | 3 t >tm_wday w! 15 | 0 t >tm_yday w! 16 | 0 t >tm_isdst w! 17 | 18 | 19 | 20 | t _asctime TYPE 21 | 22 | 23 | _clk_tck . 24 | ( should give 200 ) 25 | 26 | _clock U. 27 | 28 | VARIABLE timer 29 | 30 | _time timer ! 31 | timer _ctime TYPE 32 | ( important: _ctime wants a pointer! ) 33 | 34 | timer _gmtime _asctime TYPE 35 | 36 | timer _localtime _asctime TYPE 37 | 38 | _timezone . 39 | ( should give 3600 = 1h to GMT ) 40 | 41 | 42 | t _mktime timer ! 43 | timer _ctime TYPE 44 | 45 | 256 CONSTANT maxtimestrsz 46 | CREATE timestrbuf maxtimestrsz ALLOT 47 | 48 | : frmt ( -- str ) 49 | S" Now is: %Z %a %d%b%y %H:%M:%S" ; 50 | 51 | 52 | _time timer ! 53 | 54 | timestrbuf maxtimestrsz frmt timer _gmtime _strftime 55 | 56 | timestrbuf SWAP CR TYPE 57 | 58 | 59 | ( security check ) 60 | DEPTH . ( should yield 0 ) 61 | 62 | 63 | -------------------------------------------------------------------------------- /F68KANS/TST/COMPCOND.TST: -------------------------------------------------------------------------------- 1 | MARKER *TT* 2 | 3 | 1 CONSTANT LANGUAGE 4 | 5 | CR 6 | 7 | LANGUAGE 8 | [IF] 9 | .( HALLO ) 10 | LANGUAGE [IF] 11 | .( WELT! ) CR 12 | [ELSE] 13 | .( *** Das darf hier nicht stehen!!! *** ) 14 | [THEN] 15 | [ELSE] 16 | .( HELLO ) 17 | [THEN] 18 | 19 | *TT* 20 | 21 | 22 | -------------------------------------------------------------------------------- /F68KANS/TST/EXCPTION.TST: -------------------------------------------------------------------------------- 1 | ( EXCEPTION tests ) 2 | ( JPS, 18apr93 ) 3 | 4 | : could-fail ( -- char ) 5 | KEY DUP [CHAR] Q = THROW ; 6 | 7 | : do-it ( a b -- c) 8 | 2DROP could-fail ; 9 | 10 | : try-it ( --) 11 | 1 2 ['] do-it CATCH 12 | IF 2DROP ." There was an exception!" 13 | ELSE ." The character was " DUP . EMIT 14 | THEN CR ; 15 | 16 | -------------------------------------------------------------------------------- /F68KANS/TST/FLOAT.TST: -------------------------------------------------------------------------------- 1 | ( test of float interface ) 2 | 3 | initFLOT 4 | 5 | 6 | 7 | 8 | S" -1234.456e-6" >FLOAT 9 | 10 | 11 | 123.456E4 12 | VARIABLE DEC 13 | VARIABLE SIGN 14 | 15 | 10 DEC SIGN _fcvt 16 | 17 | 18 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /F68KANS/TST/MULTASK.TST: -------------------------------------------------------------------------------- 1 | DECIMAL 2 | VARIABLE COUNTER 3 | 4 | 0 COUNTER ! 5 | 6 | : TESTTASK 7 | BEGIN 8 | COUNTER @ 1000 MOD 0= IF COUNTER @ . CR THEN 9 | 1 COUNTER +! PAUSE 10 | AGAIN ; 11 | 12 | ' TESTTASK TASK TTASK 13 | 14 | MULTITASK 15 | 16 | TTASK WAKE 17 | -------------------------------------------------------------------------------- /F68KANS/TST/PLOT.TST: -------------------------------------------------------------------------------- 1 | initPLOT 2 | 3 | 100 100 90 100 3000 _w_arc 4 | 5 | 10 20 100 150 _w_bar 6 | 7 | _w_update 8 | 9 | 10 | : CIRCLETEST ( -- ) 11 | 500 0 12 | DO 13 | 500 400 I _w_circle 14 | _w_update 15 | LOOP ; 16 | -------------------------------------------------------------------------------- /F68KANS/TST/VDI.TST: -------------------------------------------------------------------------------- 1 | \ 3.09.93 2 | 3 | DECIMAL 4 | 5 | S" ..\APPFTH\AES.4" INCLUDED 6 | S" ..\APPFTH\VDI.4" INCLUDED 7 | 8 | 0 VALUE VDI_HANDLE 9 | 0 VALUE xmax 0 VALUE ymax 10 | 11 | : WAIT 200000 0 DO LOOP ; 12 | 13 | : INITGRAPH open_vwork TO VDI_HANDLE 14 | 0 intout w@ TO xmax 1 intout w@ TO ymax 15 | v_clrwk 16 | 0 0 xmax ymax 1 vs_clip ; 17 | 18 | : EXITGRAPH v_clsvwk ; 19 | 20 | : LINEDEMO ( -- ) 21 | INITGRAPH 22 | 3 vswr_mode 23 | xmax 0 DO I 0 xmax I - ymax 2 v_pline LOOP 24 | ymax 0 DO xmax I 0 ymax I - 2 v_pline LOOP 25 | EXITGRAPH ; 26 | 27 | : PUTPIXELDEMO ( -- ) 28 | INITGRAPH 29 | 5000 0 30 | DO 31 | xmax _random ymax _random 2DUP 2 v_pline 32 | LOOP 33 | EXITGRAPH ; 34 | 35 | 6 CONSTANT MAXPTS 36 | 37 | : RANDOM-CORNERS ( -- ) 38 | MAXPTS 0 39 | DO 40 | xmax _random ymax _random 41 | LOOP ; 42 | 43 | 44 | : FILLPOLYDEMO1 ( -- ) 45 | INITGRAPH 46 | 3 vsf_interior ( Fuellmusterart = Schraffur ) 47 | 100 0 48 | DO 49 | RANDOM-CORNERS 50 | 13 _random vsf_style 51 | MAXPTS v_fillarea 52 | LOOP 53 | EXITGRAPH ; 54 | 55 | : FILLPOLYDEMO2 ( -- ) 56 | INITGRAPH 57 | 100 0 58 | DO 59 | RANDOM-CORNERS 60 | 2 vsf_interior ( Fuellmusterart = Muster ) 61 | 25 _random vsf_style 62 | MAXPTS v_fillarea 63 | LOOP 64 | EXITGRAPH ; 65 | 66 | : DRAWPOLYDEMO ( -- ) 67 | INITGRAPH 68 | 200 0 69 | DO 70 | RANDOM-CORNERS 71 | MAXPTS v_pline 72 | LOOP 73 | EXITGRAPH ; 74 | 75 | : CIRCLEDEMO ( -- ) 76 | INITGRAPH 77 | 3 vsf_interior ( Fuellmusterart = Schraffur ) 78 | 100 0 79 | DO 80 | 13 _random vsf_style 81 | xmax _random ymax _random 150 _random 82 | v_circle 83 | LOOP 84 | EXITGRAPH ; 85 | 86 | : ARCDEMO ( -- ) 87 | INITGRAPH 88 | 200 0 89 | DO 90 | xmax _random ymax _random 91 | 150 _random 92 | 3600 _random 3600 _random 93 | v_arc 94 | LOOP 95 | EXITGRAPH ; 96 | 97 | : ELLIPSEDEMO ( -- ) 98 | INITGRAPH 99 | 3 vsf_interior 100 | 100 0 101 | DO 102 | 13 _random vsf_style 103 | xmax _random ymax _random 104 | 150 _random 150 _random 105 | v_ellipse 106 | LOOP 107 | EXITGRAPH ; 108 | 109 | : ELLPIEDEMO ( -- ) 110 | INITGRAPH 111 | 2 vsf_interior 112 | 100 0 113 | DO 114 | 25 _random vsf_style 115 | xmax _random ymax _random 116 | 150 _random 150 _random 117 | 3600 _random 3600 _random 118 | 0 0 xmax ymax 1 vs_clip 119 | v_ellpie 120 | LOOP 121 | EXITGRAPH ; 122 | 123 | CREATE test$ ," F68KANS" 0 C, 124 | 125 | : POLYMARKERDEMO ( -- ) 126 | INITGRAPH 127 | 100 0 128 | DO 129 | 6 _random vsm_type 130 | 21 _random vsm_height 131 | RANDOM-CORNERS 132 | MAXPTS v_pmarker 133 | LOOP 134 | EXITGRAPH WAIT ; 135 | 136 | : BARDEMO ( -- ) 137 | INITGRAPH 138 | 2 vsf_interior 139 | ymax 2/ 0 140 | DO 141 | 25 _random vsf_style 142 | I I xmax I - ymax I - v_bar 143 | 16 +LOOP 144 | EXITGRAPH WAIT ; 145 | 146 | CREATE justified$ ," Dies ist justierter Text" 0 C, 147 | 148 | 149 | : JUSTLINKSDEMO ( -- ) 150 | INITGRAPH 151 | 0 5 vst_alignment 152 | ymax 0 DO 153 | 0 I 150 I + 1 1 justified$ v_justified 154 | 16 +LOOP 155 | EXITGRAPH ; 156 | 157 | : JUSTRECHTSDEMO ( -- ) 158 | INITGRAPH 159 | 2 5 vst_alignment 160 | ymax 0 DO 161 | xmax I 150 I + 1 1 justified$ v_justified 162 | 16 +LOOP 163 | EXITGRAPH ; 164 | 165 | : JUSTMITTEDEMO ( -- ) 166 | INITGRAPH 167 | 1 5 vst_alignment 168 | ymax 0 DO 169 | xmax 2/ I 150 I + 1 1 justified$ v_justified 170 | 16 +LOOP 171 | EXITGRAPH ; 172 | 173 | : JUSTIFIEDDEMO ( -- ) 174 | JUSTRECHTSDEMO WAIT JUSTLINKSDEMO WAIT JUSTMITTEDEMO WAIT ; 175 | 176 | : TEXTDEMO ( -- ) 177 | INITGRAPH 178 | 0 5 vst_alignment 179 | 14 _random 6 + vst_point 180 | ymax 18 - 0 DO 181 | 31 _random 27 AND vst_effects \ KURSIV AUSBLENDEN 182 | 50 I test$ v_gtext 200 I test$ v_gtext 183 | 350 I test$ v_gtext 500 I test$ v_gtext 184 | 20 +LOOP 185 | ( 3600 _random vst_rotation ) 186 | EXITGRAPH WAIT ; 187 | 188 | : FULLDEMO 189 | LINEDEMO WAIT 190 | PUTPIXELDEMO TEXTDEMO 191 | FILLPOLYDEMO1 TEXTDEMO 192 | FILLPOLYDEMO2 TEXTDEMO 193 | DRAWPOLYDEMO TEXTDEMO 194 | CIRCLEDEMO TEXTDEMO 195 | ARCDEMO TEXTDEMO 196 | ELLIPSEDEMO TEXTDEMO 197 | ELLPIEDEMO TEXTDEMO 198 | POLYMARKERDEMO TEXTDEMO 199 | BARDEMO TEXTDEMO 200 | JUSTIFIEDDEMO TEXTDEMO 201 | ; 202 | 203 | \ FULLDEMO 204 | 205 | 206 | 207 | -------------------------------------------------------------------------------- /FTHSRC/APFEL.4: -------------------------------------------------------------------------------- 1 | 2 | 3 | 400 VALUE XRES 4 | 400 VALUE YRES 5 | 6 | 101 VALUE TIEFE 7 | 8 | FVARIABLE XMIN -2E XMIN F! 9 | FVARIABLE XMAX 2E XMAX F! 10 | FVARIABLE YMIN -2E YMIN F! 11 | FVARIABLE YMAX 2E YMAX F! 12 | FVARIABLE DX 13 | FVARIABLE DY 14 | 15 | FVARIABLE CX 16 | FVARIABLE CY 17 | FVARIABLE X 18 | FVARIABLE Y 19 | 20 | FVARIABLE SQRX 21 | FVARIABLE SQRY 22 | 23 | 24 | 25 | : SET-DX ( -- ) 26 | XMAX F@ XMIN F@ F- 27 | XRES S>D D>F F/ DX F! ; 28 | 29 | 30 | : SET-DY ( -- ) 31 | YMAX F@ YMIN F@ F- 32 | YRES S>D D>F F/ DY F! ; 33 | 34 | 35 | : APFEL-INIT ( -- ) 36 | XRES YRES OPEN-GRAPHICS DROP 37 | TO YRES TO XRES 38 | SET-DX SET-DY 39 | CLEAR-GRAPHICS 40 | ; 41 | 42 | 43 | 44 | : FIRST-STEP ( -- ) 45 | CX F@ X F! 46 | CY F@ Y F! 47 | ; 48 | 49 | 50 | : ITERATION-SCHRITT ( -- ) 51 | CX F@ SQRX F@ SQRY F@ F- F+ 52 | CY F@ X F@ Y F@ 2E F* F* F+ 53 | Y F! X F! 54 | ; 55 | 56 | 57 | : |Z| ( -- r*r ) 58 | X F@ FDUP F* FDUP SQRX F! 59 | Y F@ FDUP F* FDUP SQRY F! 60 | F+ 61 | ; 62 | 63 | 64 | : ITERATION-LOOP ( -- tiefe ) 65 | 0 66 | BEGIN 67 | 1+ DUP TIEFE < |Z| 4E F< AND 68 | WHILE 69 | ITERATION-SCHRITT 70 | REPEAT ; 71 | 72 | 73 | : APFEL-LOOP ( -- tiefe ) 74 | FIRST-STEP ITERATION-LOOP ; 75 | 76 | 77 | 78 | : APFEL-SPALTE ( i -- ) 79 | YMIN F@ CY F! 80 | YRES 0 81 | DO 82 | APFEL-LOOP 1 AND 83 | IF DUP I SET-PIXEL THEN 84 | DY F@ CY F@ F+ CY F! 85 | LOOP 86 | DROP 87 | ; 88 | 89 | 90 | 91 | : APFEL ( -- ) 92 | APFEL-INIT 93 | XMIN F@ CX F! 94 | XRES 0 95 | DO 96 | I APFEL-SPALTE 97 | UPDATE-GRAPHICS 98 | DX F@ CX F@ F+ CX F! 99 | LOOP 100 | CLOSE-GRAPHICS 101 | ; 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | -------------------------------------------------------------------------------- /FTHSRC/ATARI.4: -------------------------------------------------------------------------------- 1 | \ 2 | \ Special for Atari ST/TT 3 | \ 4 | \ JPS940422 5 | \ 6 | HEX 7 | 8 | : {undisturbed 9 | [ 10 | 40C0 codew, \ move.w sr,d0 11 | 00400700 code, \ ori.w #$0700,d0 12 | 46C0 codew, \ move.w d0,sr 13 | ] ; 14 | 15 | : }undisturbed 16 | [ 17 | 40C0 codew, \ move.w sr,d0 18 | 0240F3FF code, \ andi.w #$F3FF,d0 19 | 46C0 codew, \ move.w d0,sr 20 | ] ; 21 | 22 | : Supexec ( xt -- ? ) \ executes xt in supervisor mode 23 | code>data >abs 24 | [ 25 | 2F1E codew, \ move.l (a6)+,-(a7) 26 | 3F3C0026 code, \ move.w #$26,-(a7) 27 | 4E4E codew, \ trap #14 28 | 5C8F codew, \ addq.l #6,a7 29 | ] ; 30 | 31 | \ 32 | \ Carefull: Supexec saves and restores registers!! 33 | \ 34 | \ That means, that words executed by Supexec cannot change 35 | \ the height of the stack! 36 | \ 37 | \ and: in a Supexec-word, A5 seems to be destroyd. So a complete 38 | \ class of words will NOT work with Supexec, e.g. words 39 | \ created by CREATE DOES> 40 | \ 41 | 42 | 43 | : @sys ( addr -- value ) \ access address in supervisor mode 44 | ['] @ Supexec ; 45 | 46 | : !sys ( value addr -- ) \ access address in supervisor mode 47 | ['] ! Supexec 2DROP ; 48 | 49 | : C@sys ( addr -- value ) \ access address in supervisor mode 50 | ['] C@ Supexec ; 51 | 52 | : C!sys ( value addr -- ) \ access address in supervisor mode 53 | ['] C! Supexec 2DROP ; 54 | 55 | : w@sys ( addr -- value ) \ access address in supervisor mode 56 | ['] w@ Supexec ; 57 | 58 | : w!sys ( value addr -- ) \ access address in supervisor mode 59 | ['] w! Supexec 2DROP ; 60 | 61 | 62 | 63 | 64 | HEX 65 | 0114 CONSTANT 200HzInterrupt 66 | 04BA CONSTANT _hz_200 67 | 68 | FF8800 CONSTANT PSGgiselect 69 | FF8802 CONSTANT PSGgiwrite 70 | FF8800 CONSTANT PSGgiread 71 | 72 | FFFA01 CONSTANT MFPgpip 73 | 74 | HEX 75 | 76 | : (portB! 77 | {undisturbed 78 | F PSGgiselect (abs) C! 79 | PSGgiwrite (abs) C! 80 | }undisturbed 81 | ; 82 | 83 | : portB! ( byte -- ) 84 | ['] (portB! Supexec DROP ; 85 | 86 | : (portA! 87 | {undisturbed 88 | E PSGgiselect (abs) C! 89 | PSGgiwrite (abs) C! 90 | }undisturbed 91 | ; 92 | 93 | : portA! ( byte -- ) 94 | ['] (portA! Supexec DROP ; 95 | 96 | 97 | : (portA@ 98 | {undisturbed 99 | E PSGgiselect (abs) C! 100 | DROP PSGgiread (abs) C@ 101 | }undisturbed 102 | ; 103 | 104 | : portA@ ( -- ) 105 | 0 ['] (portA@ Supexec ; 106 | 107 | 108 | : gpip@ ( -- byte ) 109 | MFPgpip (abs) C@sys 110 | ; 111 | 112 | 113 | 114 | 115 | \ 116 | \ work with bitmasks 117 | \ 118 | 119 | : BSET ( n bitnr -- n1 ) 120 | 1 SWAP LSHIFT OR ; 121 | 122 | : BCLEAR ( n bitnr -- n1 ) 123 | 1 SWAP LSHIFT INVERT AND ; 124 | 125 | : BTOGGLE ( n bitnr -- n1 ) 126 | 1 SWAP LSHIFT XOR ; 127 | 128 | : BTEST ( n bitnr -- flag ) 129 | 1 SWAP LSHIFT AND 0= 0= ; 130 | 131 | 132 | \ 133 | \ time 134 | \ 135 | 136 | DECIMAL 137 | 138 | : MS ( n -- ) 139 | 5 / _hz_200 (abs) @sys + \ ticker value in the end 140 | DUP 141 | BEGIN 142 | _hz_200 (abs) @sys > 143 | WHILE 144 | DUP PAUSE 145 | REPEAT DROP 146 | ; 147 | 148 | \ 149 | \ 150 | \ 151 | : doWatchDog 152 | BEGIN 30000 MS ." *" CR AGAIN ; 153 | 154 | ' doWatchDog TASK WatchDog 155 | 156 | WatchDog WAKE 157 | 158 | 159 | \ 160 | \ peripherial IO 161 | \ 162 | 163 | : C!aux ( char -- ) 164 | _stdaux _putc DROP ; 165 | 166 | : C@aux ( -- char ) 167 | _stdaux _getc ; 168 | 169 | 170 | 171 | 172 | \ 173 | \ 174 | \ 175 | : !prn ( byte -- ) 176 | portB! 177 | portA@ 5 BCLEAR portA! 178 | portA@ 5 BSET portA! 179 | BEGIN gpip@ 0 BTEST INVERT UNTIL 180 | ; 181 | 182 | 183 | : TYPEprn ( addr u -- ) 184 | 0 ?DO 185 | COUNT !prn 186 | LOOP 187 | DROP ; 188 | 189 | 190 | 191 | 192 | -------------------------------------------------------------------------------- /FTHSRC/COMPCOND.4: -------------------------------------------------------------------------------- 1 | 2 | \ MARKER [IF][ELSE][THEN] 3 | \ : WORD ." word:" WORD DUP COUNT TYPE CR ; 4 | 5 | 6 | : [ELSE] ( -- ) 7 | 1 BEGIN \ LEVEL 8 | BEGIN 9 | blankbits ( **) WORD COUNT DUP 10 | WHILE \ LEVEL ADR LEN 11 | 2DUP S" [IF]" COMPARE 0= IF \ LEVEL ADR LEN 12 | 2DROP 1+ \ LEVEL' 13 | ELSE \ LEVEL ADR LEN 14 | 2DUP S" [ELSE]" COMPARE 0= IF \ LEVEL ADR LEN 15 | 2DROP 1- DUP IF 1+ THEN \ LEVEL' 16 | ELSE \ LEVEL ADR LEN 17 | S" [THEN]" COMPARE 0= IF \ LEVEL 18 | 1- \ LEVEL' 19 | THEN 20 | THEN 21 | THEN ?DUP 0= IF EXIT THEN \ LEVEL' 22 | REPEAT 2DROP \ LEVEL 23 | REFILL 0= UNTIL \ LEVEL 24 | DROP ; IMMEDIATE 25 | 26 | : [IF] ( flag -- ) 27 | 0= IF POSTPONE [ELSE] THEN ; IMMEDIATE 28 | 29 | : [THEN] ( -- ) ; IMMEDIATE 30 | 31 | -------------------------------------------------------------------------------- /FTHSRC/OO.4: -------------------------------------------------------------------------------- 1 | \ Definitions 2 | \ ~~~~~~~~~~~ 3 | 0 VALUE NIL 0 VALUE CUROBJ 4 | ' NIL >BODY TO NIL 5 | : .$ ( a--) COUNT TYPE ; 6 | : PART: ( a--) CREATE NIL , , HERE 0 , :NONAME DOES> ( --pfa) ; 7 | : ;; ( x--) POSTPONE ; SWAP ! ; IMMEDIATE 8 | : OBJECT: ( --) NIL PART: ; 9 | : WORD, ( c-a) WORD C@ CHAR+ ALLOT ALIGN ; 10 | : METHOD: ( a--) HERE OVER @ , SWAP ! BL WORD, HERE 0 , :NONAME ; 11 | : M? ( sl--at|f) BEGIN @ DUP NIL <> WHILE OVER COUNT 2 PICK CELL+ COUNT 12 | COMPARE 0= IF NIP -1 NIL THEN REPEAT DROP -1 = ; 13 | : (MEXEC) ( a--) CELL+ DUP C@ CHAR+ + ALIGNED @ EXECUTE ; 14 | : PARENT ( a--a) CELL+ @ ; 15 | : MEXEC ( sa--) 2DUP M? IF NIP NIP (MEXEC) EXIT THEN 16 | PARENT DUP NIL = IF DROP .$ ." ? " ELSE RECURSE THEN ; 17 | : --> ( s--) ' >BODY DUP TO CUROBJ MEXEC ; 18 | 19 | 20 | \ Examples 21 | \ ~~~~~~~~ 22 | OBJECT: TEST ;; 23 | TEST METHOD: HELLO ." Hello world " ;; 24 | 25 | C" HELLO" --> TEST \ Hello world ok 26 | 27 | TEST PART: TEST2 ;; 28 | TEST2 METHOD: GOODBYE ." That's all " ;; 29 | 30 | C" GOODBYE" --> TEST2 \ That's all ok 31 | C" HELLO" --> TEST2 \ Hello world ok 32 | 33 | TEST PART: SHAPE ;; 34 | SHAPE METHOD: COLOUR CUROBJ 2 CELLS + @ EXECUTE .$ ." " ;; 35 | SHAPE PART: BLOCK C" Red" ;; 36 | SHAPE PART: SPHERE C" Green" ;; 37 | 38 | C" COLOUR" --> BLOCK \ Red ok 39 | C" COLOUR" --> SPHERE \ Green ok 40 | C" HELLO" --> BLOCK \ Hello World ok 41 | 42 | 43 | -------------------------------------------------------------------------------- /FTHSRC/POSTPONS.4: -------------------------------------------------------------------------------- 1 | : POSTPONE# POSTPONE LITERAL ; 2 | 3 | : ]] BEGIN 4 | ( ) >IN @ BL WORD DUP C@ WHILE 5 | ( >in ca ) DUP COUNT S" [[" COMPARE WHILE 6 | ( >in ca ) FIND IF 7 | ( >in xt ) DROP >IN ! POSTPONE POSTPONE ELSE 8 | ( >in ca ) 0 0 ROT COUNT >NUMBER ABORT" can't ]]" 9 | ( >in d ca) 2DROP POSTPONE# POSTPONE POSTPONE# DROP THEN 10 | REPEAT 11 | ( >in ca ) THEN 2DROP ; IMMEDIATE 12 | -------------------------------------------------------------------------------- /FTHSRC/POSTPONS.TXT: -------------------------------------------------------------------------------- 1 | From willett!dwp@vax.cs.pitt.edu Wed Jan 26 02:42:39 1994 2 | Return-Path: 3 | Received: from vax.cs.pitt.edu by ks.mpi-dortmund.mpg.de (4.1/SMI-4.1MHS-mpi-1.4.93) 4 | id AA13400; Wed, 26 Jan 94 02:42:30 +0100 5 | Received: from willett.UUCP by vax.cs.pitt.edu (5.65/1.14) 6 | id AA16582; Tue, 25 Jan 94 20:30:36 -0500 7 | Date: Tue, 25 Jan 94 06:53:38 EDT 8 | From: dwp@willett.pgh.pa.us (Doug Philips) 9 | Subject: Part 1 of 1 of POSTPONS.TXT 10 | Message-Id: <9401250653.0.UUL1.3#5129@willett.pgh.pa.us> 11 | To: plewe@mpi-dortmund.mpg.de 12 | Content-Length: 3439 13 | X-Lines: 90 14 | Status: RO 15 | 16 | } 17 | Here is Standard code that lets you POSTPONE multiple commands 18 | without typing POSTPONE in front of each of them. 19 | { 20 | : POSTPONE# POSTPONE LITERAL ; 21 | 22 | : ]] BEGIN 23 | ( ) >IN @ BL WORD DUP C@ WHILE 24 | ( >in ca ) DUP COUNT S" [[" COMPARE WHILE 25 | ( >in ca ) FIND IF 26 | ( >in xt ) DROP >IN ! POSTPONE POSTPONE ELSE 27 | ( >in ca ) 0 0 ROT COUNT >NUMBER ABORT" can't ]]" 28 | ( >in d ca) 2DROP POSTPONE# POSTPONE POSTPONE# DROP THEN 29 | REPEAT 30 | ( >in ca ) THEN 2DROP ; IMMEDIATE 31 | } 32 | 33 | This has the following environmental dependencies: 34 | 35 | It will not handle double or floating point numbers. 36 | 37 | COMPARE is required by the String wordset, and will not be 38 | present in every system. 39 | 40 | In some systems FIND may not find compile-only commands, and in 41 | some systems it may find interpreted commands with the same 42 | names which have different actions. In the one case you get an 43 | error message, while in the other you get a bug. So this is 44 | only 100% portable among systems in which, while compiling, 45 | FIND finds the execution token for the compilation behavior -- 46 | the same behavior that POSTPONE postpones. 47 | 48 | Some minimal systems may make the block buffer invalid when you 49 | do any parsing operation. ( LOAD will take care of that for 50 | itself, but when _you_ do it you're on your own.) ]] does WORD 51 | which parses. So ]] is not portable to those minimal systems. 52 | 53 | 54 | This is used in the following form: 55 | 56 | : LOOP ]] 1 +LOOP [[ ; IMMEDIATE 57 | 58 | When you do LOOP inside a definition, the 1 gets compiled as a 59 | literal and +LOOP gets executed. 60 | 61 | You can use this for macros -- lists of commands that all get 62 | postponed -- without having to type POSTPONE in front of each 63 | of them. The code is as long as if you did type POSTPONE in 64 | front of each of them, though, and POSTPONE LITERAL after each 65 | number. 66 | 67 | I use such macros to make it easier to type sophisticated 68 | control structures. The usual methods don't work to debug such 69 | things, so I try to keep them simple -- if there's any error 70 | they lose me time. Here is a simple example: 71 | 72 | : ?EXIT ( f -- ) ]] IF EXIT THEN [[ ; IMMEDIATE 73 | 74 | You can't portably do R> DROP in a Standard program. There's 75 | no guarantee that popping the return stack will have the result 76 | of skipping out of the next nested command. This is a 77 | limitation on programs which allows much greater flexibility in 78 | systems. Well, but how can a command slip out of the command 79 | that called it? It can return a flag, and the outer command 80 | does EXIT. It's clumsy, but it works. And ?EXIT keeps me from 81 | having to write IF EXIT THEN each time, I can just type ?EXIT . 82 | And ]] keeps me from having to type POSTPONE three times. 83 | 84 | I don't know whether ]] is worth using. Maybe the code it 85 | produces is harder to debug and harder to maintain. But if it 86 | is worth using, almost every standard compiler that has COMPARE 87 | can handle it. It's portable. 88 | 89 | : POSTPONE# POSTPONE LITERAL ; 90 | 91 | : [[ ABORT" [[ used without ]] " ; IMMEDIATE 92 | : ]] BEGIN 93 | ( ) >IN @ BL WORD DUP C@ WHILE 94 | ( >in ca ) FIND IF 95 | ( >in xt ) ['] [[ = IF DROP EXIT ELSE 96 | ( >in ) >IN ! POSTPONE POSTPONE THEN 97 | ELSE 98 | ( >in ca ) 0 0 ROT COUNT >NUMBER ABORT" can't ]]" 99 | ( >in d ca) DROP POSTPONE# POSTPONE POSTPONE# DROP THEN 100 | REPEAT 101 | ( >in ca ) 2DROP ; IMMEDIATE 102 | 103 | Come to think of it, something like this code should work, 104 | without the COMPARE . Someday I'll debug it. 105 | 106 | 107 | -------------------------------------------------------------------------------- /FTHSRC/RANDOM.4: -------------------------------------------------------------------------------- 1 | \ generates random numbers 12jan94py 2 | BASE @ 3 | 4 | VARIABLE SEED 5 | 6 | HEX 10450405 CONSTANT generator 7 | 8 | : RND ( -- n ) SEED @ generator UM* DROP 1+ DUP SEED ! ; 9 | 10 | : RANDOM ( n -- 0..n-1 ) RND UM* NIP ; 11 | 12 | BASE ! 13 | -------------------------------------------------------------------------------- /FTHSRC/SAVAGE.4: -------------------------------------------------------------------------------- 1 | \ Savage-Benchmark 2 | \ Julian V. Noble 3 | \ jvn@fermi.clas.Virginia.edu 4 | 5 | \ x = tan(atan(exp(log(sqrt((x+1)^2))))) 6 | 7 | 8 | : (SAVAGE) 9 | 1.E 0E 0 10 | DO 11 | FOVER F+ 12 | FDUP F* FSQRT 13 | FLN FEXP 14 | FATAN FTAN 15 | LOOP 16 | ; 17 | 18 | 19 | : SAVAGE 20 | 2500 (SAVAGE) F. FDROP ; 21 | 22 | -------------------------------------------------------------------------------- /FTHSRC/SVARS.4: -------------------------------------------------------------------------------- 1 | 2 | VARIABLE LAST-SVARIABLE 3 | LAST-SVARIABLE OFF 4 | : SVARIABLE CREATE 0 , 0 , HERE LAST-SVARIABLE DUP @ , ! ; 5 | 256 CONSTANT POOL 6 | CREATE FREELIST POOL 2* 1+ CELLS ALLOT 7 | : CELLSLINK 8 | FREELIST POOL 0 DO 9 | 0 OVER CELL+ ! 10 | DUP 2 CELLS + DUP ROT ! LOOP 11 | OFF ; CELLSLINK 12 | : >THREAD CELL+ ; 13 | : THREAD> 1 CELLS - ; 14 | : PREVIOUS-SV> 2 CELLS - ; 15 | 16 | 17 | 18 | : V-NEW ( aa -- ) FREELIST @ 19 | ( aa 1st-free ) DUP 0= ABORT" Out of stack-variable space" 20 | ( aa 1st-free ) DUP @ FREELIST ! 21 | ( aa free ) 2DUP THREAD> 2 CELLS MOVE 22 | ( aa free ) SWAP >THREAD ! ; 23 | 24 | : V-OLD ( aa -- ) DUP >THREAD @ DUP IF 25 | ( sv old-link ) DUP THREAD> ROT 26 | ( old-link old-value sv ) 2 CELLS MOVE 27 | ( ) FREELIST @ OVER ! FREELIST ! ELSE 28 | ( sv old-link ) 2DROP THEN ; 29 | 30 | : V-PUSH ( x aa -- ) DUP V-NEW ! ; 31 | : V-POP ( aa -- x ) DUP @ SWAP V-OLD ; 32 | 33 | 34 | : V-PICK ( n aa -- x ) >THREAD SWAP ?DUP IF 0 DO @ LOOP 35 | THEN THREAD> @ ; 36 | : ONLY-V? ( aa -- f ) >THREAD @ 0= 0= ; 37 | : .SV ( svar -- ) CR >THREAD BEGIN DUP THREAD> 38 | @ U. @ ?DUP 0= UNTIL ; 39 | 40 | 41 | SVARIABLE SACTION ( SACTION will provide a flag ) 42 | ( j* svariable-link -- j*' f ) 43 | : SSEARCH ( i* svar -- j* f ) 44 | >R BEGIN 45 | ( j* ) R@ @ SACTION @ EXECUTE 46 | ( j* f ) R> OVER 0= WHILE 47 | ( j* f wida) >THREAD @ DUP WHILE THREAD> >R DROP REPEAT THEN 48 | ( j* f wida) DROP ; 49 | 50 | : VOID ( svar -- ) BEGIN DUP >THREAD @ WHILE DUP V-OLD REPEAT 51 | DROP ; 52 | : VOID-ALL LAST-SVARIABLE @ 53 | BEGIN DUP WHILE DUP PREVIOUS-SV> VOID @ REPEAT DROP ; 54 | -------------------------------------------------------------------------------- /FTHSRC/TESTER.FR: -------------------------------------------------------------------------------- 1 | \ (C) 1993 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 2 | \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 3 | \ VERSION 1.0 4 | HEX 5 | 6 | \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY 7 | \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. 8 | VARIABLE VERBOSE 9 | FALSE VERBOSE ! 10 | 11 | : EMPTY-STACK \ ( ... -- ) EMPTY STACK. 12 | DEPTH ?DUP IF 0 DO DROP LOOP THEN ; 13 | 14 | : ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY 15 | \ THE LINE THAT HAD THE ERROR. 16 | TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR 17 | EMPTY-STACK \ THROW AWAY EVERY THING ELSE 18 | ; 19 | 20 | VARIABLE ACTUAL-DEPTH \ STACK RECORD 21 | CREATE ACTUAL-RESULTS 20 CELLS ALLOT 22 | 23 | : { \ ( -- ) SYNTACTIC SUGAR. 24 | ; 25 | 26 | : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. 27 | DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH 28 | ?DUP IF \ IF THERE IS SOMETHING ON STACK 29 | 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM 30 | THEN ; 31 | 32 | : } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 33 | \ (ACTUAL) CONTENTS. 34 | DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH 35 | DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK 36 | 0 DO \ FOR EACH STACK ITEM 37 | ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED 38 | <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN 39 | LOOP 40 | THEN 41 | ELSE \ DEPTH MISMATCH 42 | S" WRONG NUMBER OF RESULTS: " ERROR 43 | THEN ; 44 | 45 | : TESTING \ ( -- ) TALKING COMMENT. 46 | SOURCE VERBOSE @ 47 | IF DUP >R TYPE CR R> >IN ! 48 | ELSE >IN ! DROP 49 | THEN ; 50 | -------------------------------------------------------------------------------- /FTHSRC/TESTSUIT.4TH: -------------------------------------------------------------------------------- 1 | \ 2 | \ test.4th --- tests to verify the proper operation 3 | \ of the portable forth environment 4 | \ (duz 05Aug93) 5 | \ 6 | 7 | CR 8 | CR .( running "tester.fr" and "core.fr") 9 | CR .( =================================) 10 | CR 11 | 12 | INCLUDE test/tester.fr 13 | INCLUDE test/core.fr 14 | 15 | INCLUDE test/defs.4th 16 | 17 | WAIT 18 | 19 | \ display environment 20 | INCLUDE test/environ.4th 21 | 22 | WAIT 23 | 24 | CR 25 | CR .( More tests:) 26 | CR .( ===========) 27 | CR 28 | 29 | INCLUDE test/stack.4th WAIT 30 | INCLUDE test/compare.4th WAIT 31 | INCLUDE test/arith.4th WAIT 32 | INCLUDE test/float.4th WAIT 33 | INCLUDE test/exception.4th WAIT 34 | 35 | 36 | CR 37 | CR .( Finally some benchmarks:) 38 | CR .( ========================) 39 | CR 40 | 41 | USING test/benchm.blk 1 LOAD WAIT 42 | 43 | CR 44 | CR .( This should be nicely formatted FORTH-source:) 45 | CR .( =============================================) 46 | CR 47 | 48 | SEE DO-PRIME WAIT 49 | 50 | CR 51 | CR .( System survived so far?) 52 | CR .( Fine!) 53 | CR 54 | 55 | CR BYE 56 | -------------------------------------------------------------------------------- /FTHSRC/TST3D.4: -------------------------------------------------------------------------------- 1 | initCLIB 2 | initFLOT 3 | initPLOT 4 | initPBGI 5 | 6 | 7 | \ 8 | \ implementation dependend 9 | \ 10 | 11 | : COORD! ( 16bit addr -- ) \ COORDINATE-STORE 12 | STATE @ 13 | IF POSTPONE w! ELSE w! THEN 14 | ; IMMEDIATE 15 | 16 | : COORD@ ( addr -- 16bit ) \ COORDINATE-FETCH 17 | STATE @ 18 | IF POSTPONE w@ ELSE w@ THEN 19 | ; IMMEDIATE 20 | 21 | 22 | : COORD+ 23 | STATE @ 24 | IF 25 | 2 POSTPONE LITERAL 26 | POSTPONE + 27 | ELSE 2 + 28 | THEN 29 | ; IMMEDIATE 30 | 31 | : COORDS 32 | STATE @ 33 | IF POSTPONE 2* ELSE 2* THEN 34 | ; IMMEDIATE 35 | 36 | 37 | 38 | : 2COORD+ 39 | STATE @ 40 | IF POSTPONE CELL+ ELSE CELL+ THEN 41 | ; IMMEDIATE 42 | 43 | 44 | 45 | 46 | : CORNER+ 47 | STATE @ 48 | IF 49 | 6 POSTPONE LITERAL 50 | POSTPONE + 51 | ELSE 6 + 52 | THEN 53 | ; IMMEDIATE 54 | 55 | 56 | : CORNERS 57 | STATE @ 58 | IF 59 | POSTPONE DUP 60 | POSTPONE 2* 61 | POSTPONE + 62 | POSTPONE 2* 63 | ELSE DUP 2* + 2* 64 | THEN 65 | ; IMMEDIATE 66 | 67 | 68 | 69 | \ 70 | \ from here its standard 71 | \ 72 | 73 | 74 | : CONNECTIONS 75 | STATE @ 76 | IF 77 | POSTPONE 2* 78 | POSTPONE CELLS 79 | ELSE 2* CELLS 80 | THEN 81 | ; IMMEDIATE 82 | 83 | 84 | 85 | 86 | : 3D>2D ( x y z -- x' y' ) 87 | TUCK 512 SWAP */ >R 512 SWAP */ R> 88 | ; 89 | 90 | 91 | \ 92 | \ Objects 93 | \ 94 | 95 | 96 | 97 | 98 | \ 99 | \ an object is decribed by a list of corners and a list of 100 | \ connections 101 | \ additionally there is a point which is recognized as 102 | \ the center of the object, that is the point, which 103 | \ is invariant under rotation 104 | \ 105 | \ the corner-list contains CORNERS, while the connections- 106 | \ list contains integer indexes 107 | \ 108 | DECIMAL 109 | 110 | : OBJECT ( #corners #connections -- ) 111 | CREATE 112 | 1 CORNERS ALLOT \ for the center 113 | OVER , DUP , \ remember counts 114 | HERE 0 , \ pointer to connection list 115 | ROT CORNERS ALLOT 116 | HERE SWAP ! \ set pointer to connections 117 | 2* CELLS ALLOT 118 | ; 119 | 120 | 121 | 122 | : >CENTER ( object -- center ) 123 | ; IMMEDIATE 124 | 125 | : >CORNERS ( object -- corners #corners ) 126 | CORNER+ DUP 3 CELLS + SWAP @ ; 127 | 128 | : >CONNECTIONS ( object -- connections #connections ) 129 | CORNER+ CELL+ DUP CELL+ @ SWAP @ ; 130 | 131 | 132 | : CONNECTION! ( c1 c2 index object-connections -- ) 133 | SWAP CONNECTIONS + TUCK 134 | CELL+ ! ! 135 | ; 136 | 137 | : CONNECTION@ ( index object-connections -- c1 c2 ) 138 | SWAP CONNECTIONS + 139 | DUP @ 140 | SWAP CELL+ @ 141 | ; 142 | 143 | 144 | : CORNER! ( x y z index pxyz -- ) 145 | SWAP CORNERS + 146 | TUCK 2COORD+ COORD! 147 | TUCK COORD+ COORD! 148 | COORD! 149 | ; 150 | 151 | 152 | : CORNER@ ( index pxyz -- x y z ) 153 | SWAP CORNERS + 154 | DUP COORD@ 155 | SWAP DUP COORD+ COORD@ 156 | SWAP 2COORD+ COORD@ 157 | ; 158 | 159 | 160 | 161 | : CORNERS>2D ( corners #corners addr -- ) 162 | LOCALS| BUF | 163 | 0 164 | DO 165 | I OVER CORNER@ 166 | 3D>2D 167 | I BUF CONNECTION! 168 | LOOP 169 | DROP 170 | ; 171 | 172 | 173 | 174 | 175 | \ 176 | \ .2D-CONNECTIONS is implementation dependent, 177 | \ because it relies in DRAW-LINE 178 | \ 179 | 180 | : .2D-CONNECTIONS ( connections #connections 2d-corners -- ) 181 | LOCALS| CORS | 182 | 0 183 | DO 184 | I OVER CONNECTION@ >R 185 | CORS CONNECTION@ 186 | R> CORS CONNECTION@ 187 | DRAW-LINE 188 | LOOP 189 | DROP 190 | ; 191 | 192 | CREATE CORNERBUF 64 CONNECTIONS ALLOT 193 | 194 | : .OBJECT ( object -- ) 195 | DUP >CORNERS CORNERBUF CORNERS>2D 196 | >CONNECTIONS CORNERBUF .2D-CONNECTIONS 197 | ; 198 | 199 | 200 | \ 201 | \ manipulations on objects 202 | \ 203 | 204 | 205 | 206 | \ 207 | \ TEST 208 | \ 209 | 210 | : INIT-CUBE ( size x0 y0 z0 cube -- ) 211 | LOCALS| CUBE Z0 Y0 X0 SIZE | ( locals ) 212 | SIZE 2/ TO SIZE 213 | 214 | X0 Y0 Z0 0 CUBE >CENTER CORNER! 215 | 216 | CUBE >CORNERS 8 <> ABORT" NOT A CUBE!" ( object-corners ) 217 | >R 218 | X0 SIZE - Y0 SIZE - Z0 SIZE - 0 R@ CORNER! 219 | X0 SIZE - Y0 SIZE - Z0 SIZE + 1 R@ CORNER! 220 | X0 SIZE - Y0 SIZE + Z0 SIZE - 2 R@ CORNER! 221 | X0 SIZE + Y0 SIZE - Z0 SIZE - 3 R@ CORNER! 222 | X0 SIZE - Y0 SIZE + Z0 SIZE + 4 R@ CORNER! 223 | X0 SIZE + Y0 SIZE + Z0 SIZE - 5 R@ CORNER! 224 | X0 SIZE + Y0 SIZE - Z0 SIZE + 6 R@ CORNER! 225 | X0 SIZE + Y0 SIZE + Z0 SIZE + 7 R> CORNER! 226 | CUBE >CONNECTIONS 12 <> ABORT" NOT A CUBE!" ( object-connections ) 227 | >R 228 | 0 1 0 R@ CONNECTION! 229 | 0 2 1 R@ CONNECTION! 230 | 0 3 2 R@ CONNECTION! 231 | 1 4 3 R@ CONNECTION! 232 | 1 6 4 R@ CONNECTION! 233 | 2 4 5 R@ CONNECTION! 234 | 2 5 6 R@ CONNECTION! 235 | 3 5 7 R@ CONNECTION! 236 | 3 6 8 R@ CONNECTION! 237 | 4 7 9 R@ CONNECTION! 238 | 5 7 10 R@ CONNECTION! 239 | 6 7 11 R> CONNECTION! 240 | ; 241 | 242 | 243 | 244 | 8 12 OBJECT CB 245 | 2000 3000 3000 3000 CB INIT-CUBE 246 | 247 | : TEST 248 | 100 0 249 | DO 250 | 20 15 15 11 I + CB INIT-CUBE 251 | CLEAR-GRAPHICS 252 | CB .OBJECT 253 | UPDATE-GRAPHICS 254 | LOOP 255 | ; 256 | -------------------------------------------------------------------------------- /FTHSRC/UUDECODE.4: -------------------------------------------------------------------------------- 1 | \ uudecode V1.1 A Forth version of the Unix utility 2 | \ @(#)uudecode.seq 1.1 21:55:29 11/15/94 EFC 3 | 4 | \ Typical usage: 5 | \ s" file.uu" uudecode 6 | 7 | \ This program ignores the file mode number that follows the word begin. 8 | 9 | \ This is an ANS Forth program requiring: 10 | \ 1. The File word set 11 | \ 2. The word COMPARE in the String word set. 12 | 13 | \ (c) Copyright 1994 Everett F. Carter. Permission is granted by the 14 | \ author to use this software for any application provided this 15 | \ copyright notice is preserved. 16 | 17 | 18 | DECIMAL 19 | 20 | \ buffers and I/O handles 21 | 22 | \ inbuf0 includes count, inbuf starts after count 23 | CREATE inbuf0 82 ALLOT inbuf0 1+ CONSTANT inbuf 24 | CREATE outbuf 82 ALLOT 25 | 26 | VARIABLE obp 0 obp ! 27 | -1 VALUE in-handle 28 | -1 VALUE out-handle 29 | 30 | 31 | \ write, putb 32 | 33 | : write ( n -- ) \ write n bytes out out-handle 34 | outbuf SWAP out-handle WRITE-FILE 35 | ABORT" write error " 36 | ; 37 | 38 | : putb ( b -- ) \ put a byte to the output buffer 39 | outbuf obp @ + C! \ write if its nearly full 40 | obp @ 1+ DUP OBP ! 41 | DUP 74 > IF write 0 obp ! ELSE DROP THEN 42 | ; 43 | 44 | : flushb ( -- ) 45 | obp @ DUP 0 > IF write 0 obp ! ELSE DROP THEN 46 | ; 47 | 48 | \ readln 49 | \ read n bytes or to EOL from in-handle 50 | \ return a zero if an error, result goes to inbuf 51 | \ strip off any trailing CR/LF 52 | 53 | HEX 54 | 55 | : readln ( n -- 0->err/n->ok ) \ read n bytes or to EOL 56 | 0 inbuf0 C! 57 | inbuf SWAP in-handle READ-LINE 58 | 0= IF DROP 59 | inbuf0 C! 60 | THEN 61 | 62 | \ replace any CR or LF with SPACE 63 | inbuf0 C@ 0 ?DO inbuf I + C@ DUP 10 = SWAP 13 = OR 64 | IF 32 inbuf I + c! THEN 65 | LOOP 66 | inbuf0 C@ 67 | 68 | ; 69 | 70 | 71 | \ dec, outdec 72 | 73 | : dec ( c -- c ) \ single character decode 74 | 20 - 3F AND ; 75 | 76 | DECIMAL 77 | 78 | : outdec ( bp n -- ) \ output group of 3 bytes from bp 79 | OVER DUP C@ DEC 4 * SWAP 1+ C@ DEC 16 / OR putb 80 | DUP 1 > IF 81 | OVER 1+ DUP C@ dec 16 * SWAP 1+ C@ dec 4 / OR putb 82 | THEN 83 | 2 > IF 84 | 2+ DUP C@ dec 64 * SWAP 1+ C@ dec OR putb 85 | ELSE DROP THEN ; 86 | 87 | \ out-loop 88 | 89 | : out-loop ( n -- ) \ output until n is zero 90 | DUP 0 > IF 91 | inbuf 1+ SWAP BEGIN 92 | OVER OVER outdec 93 | 3 - SWAP 4 + SWAP 94 | DUP 0 <= 95 | UNTIL DROP 96 | THEN DROP 97 | 98 | ; 99 | 100 | 101 | \ Find the header line 102 | 103 | : find_head ( -- ) 104 | 105 | BEGIN 106 | 80 readln ?DUP 0= ABORT" no begin line" 107 | inbuf0 C! 108 | s" begin" inbuf0 COUNT 5 MIN COMPARE 0= 109 | UNTIL 110 | 111 | ; 112 | 113 | \ Parse the header line 114 | 115 | : $<< ( $addr n -- ) \ shift string by indicated amount 116 | OVER 1+ OVER OVER OVER 117 | + ROT ROT OVER 1- C@ SWAP - MOVE 118 | OVER C@ SWAP - SWAP C! ; 119 | 120 | : parse_head 121 | \ remove trailing SPACES 122 | inbuf0 COUNT -trailing inbuf0 C! DROP 123 | inbuf0 6 $<< \ next 3 chars are octal number 124 | 125 | inbuf0 4 $<< \ now inbuf is the output file name 126 | ; 127 | 128 | \ ====== everything above here could be made private ========================= 129 | 130 | : uudecode ( $addr count -- ) 131 | 132 | R/O OPEN-FILE ABORT" Unable to open file to decode " 133 | TO in-handle 134 | 135 | find_head parse_head 136 | inbuf0 COUNT W/O BIN CREATE-FILE ABORT" Unable to open destination file " 137 | TO out-handle 138 | 139 | BEGIN 0 80 readln 140 | DUP IF 2DROP inbuf C@ dec DUP 0 > THEN 141 | WHILE out-loop 142 | REPEAT DROP 143 | 144 | flushb 145 | 146 | in-handle CLOSE-FILE DROP 147 | out-handle CLOSE-FILE DROP 148 | 149 | ; 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | -------------------------------------------------------------------------------- /FTHSRC/UUENCODE.4: -------------------------------------------------------------------------------- 1 | \ uuencode V1.1 A Forth version of the Unix utility 2 | \ @(#)uuencode.seq 1.1 21:55:34 11/15/94 EFC 3 | 4 | \ Typical usage: 5 | \ s" infile.dat" s" outfile.uu" uuencode 6 | 7 | \ This program ignores the file mode number that follows the word begin. 8 | \ See the customization section for the proper newline and the coding 9 | \ scheme. Some UUENCODEs are written so that SPACE characters appear 10 | \ in the encode data, others do not. This code can be compiled either 11 | \ way depending upon whether a single line in 'enc' is commented out or not. 12 | 13 | \ This is an ANS Forth program requiring: 14 | \ 1. The File word set 15 | \ 2. The word CMOVE in the String word set. 16 | 17 | \ (c) Copyright 1994 Everett F. Carter. Permission is granted by the 18 | \ author to use this software for any application provided this 19 | \ copyright notice is preserved. 20 | 21 | 22 | 23 | DECIMAL 24 | 25 | \ buffers and I/O handles 26 | \ inbuf0 includes count, inbuf starts after count 27 | CREATE inbuf0 82 ALLOT inbuf0 1+ CONSTANT inbuf 28 | CREATE outbuf 82 ALLOT 29 | 30 | VARIABLE obp 0 obp ! 31 | -1 VALUE in-handle 32 | -1 VALUE out-handle 33 | 34 | 35 | \ write, putb 36 | 37 | : write ( n -- ) \ write n bytes out out-handle 38 | outbuf SWAP out-handle WRITE-FILE 39 | ABORT" write error " 40 | ; 41 | 42 | : putb ( b -- ) \ put a byte to the output buffer 43 | outbuf obp @ + C! \ write if its nearly full 44 | obp @ 1+ DUP OBP ! 45 | DUP 74 > IF write 0 obp ! ELSE DROP THEN 46 | ; 47 | 48 | 49 | : flushb ( -- ) 50 | obp @ DUP 0 > IF write 0 obp ! ELSE DROP THEN 51 | ; 52 | 53 | \ Basic Input 54 | \ read from in-handle and return the count 55 | \ return a zero if an error, result goes to inbuf 56 | 57 | : read ( n -- 0->err/n->ok ) \ read n bytes 58 | inbuf SWAP in-handle READ-FILE 59 | DROP DUP 60 | inbuf0 C! 61 | ; 62 | 63 | \ $write 64 | \ write a string to output buffer 65 | 66 | : $write ( $addr count -- ) 67 | 0 DO DUP I + C@ putb LOOP DROP 68 | ; 69 | 70 | \ ===================== CUSTOMIZATION SECTION ============================= 71 | : crlf 13 putb 10 putb ; \ output a CRLF 72 | 73 | : unix-newline 10 putb ; \ output a newline 74 | 75 | : newline unix-newline ; \ set to either unix-newline or crlf 76 | 77 | 78 | 79 | HEX 80 | : enc ( c -- c ) \ single character encode 81 | 3F AND 20 + 82 | 83 | \ comment out the next line for alternate (with blanks) encoding 84 | DUP 20 = IF 40 + THEN 85 | ; 86 | 87 | \ ======================= END CUSTOMIZATION ================================ 88 | 89 | DECIMAL 90 | 91 | : outenc ( bp -- ) \ output group of 3 bytes from bp 92 | DUP C@ 4 / enc putb 93 | DUP C@ 16 * 48 AND OVER 1+ C@ 16 / 15 AND OR enc putb 94 | 1+ DUP C@ 4 * 60 AND OVER 1+ C@ 64 / 3 AND OR enc putb 95 | 1+ C@ 63 AND enc putb 96 | 97 | ; 98 | 99 | \ out-loop 100 | 101 | : out-loop ( n -- ) \ output until n is zero 102 | DUP 0 > IF 103 | 0 DO inbuf I + outenc 3 +LOOP 104 | newline 105 | ELSE DROP THEN 106 | 107 | ; 108 | 109 | 110 | \ write_head 111 | 112 | \ expects $addr of remote file name 113 | 114 | : write_head ( $addr -- ) 115 | S" begin 644 " $write 116 | \ write file name 117 | COUNT $write newline 118 | 119 | ; 120 | 121 | 122 | \ ====== everything above here could be made private ========================= 123 | 124 | : uuencode ( $addr1 count1 $addr2 count2 -- ) 125 | ROT inbuf0 C! 126 | ROT inbuf inbuf0 C@ CMOVE 127 | 128 | W/O CREATE-FILE ABORT" Unable to open output file " 129 | TO out-handle 130 | 131 | inbuf0 COUNT R/O BIN OPEN-FILE ABORT" Unable to open input file to encode " 132 | TO in-handle 133 | 134 | inbuf0 write_head 135 | 136 | 137 | BEGIN 45 read DUP 0 > IF DUP enc putb ELSE DROP 0 THEN 138 | WHILE inbuf0 C@ out-loop 139 | REPEAT 140 | 141 | 0 enc putb 142 | 143 | newline S" end" $write newline 144 | 145 | flushb 146 | 147 | in-handle CLOSE-FILE DROP 148 | out-handle CLOSE-FILE DROP 149 | 150 | ; 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | -------------------------------------------------------------------------------- /FTHSRC/WITHIN.4: -------------------------------------------------------------------------------- 1 | \ 2 | \ Implementation von WITHIN 3 | \ entnommen aus dpANS6 4 | \ 5 | 6 | \ : WITHIN ( test low high -- flag ) ( CORE EXT) 7 | \ >R OVER < 0= ( test flag ) 8 | \ SWAP R> < AND ; 9 | 10 | 11 | \ speziell fuer 2er-Komplement geht besser 12 | 13 | : WITHIN ( test low high -- flag ) ( CORE EXT) 14 | OVER - >R - R> U< ; 15 | 16 | -------------------------------------------------------------------------------- /GRAY4.ANS/CALC.FS: -------------------------------------------------------------------------------- 1 | ( Copyright 1990,1994 Martin Anton Ertl ) 2 | ( This program is distributed WITHOUT ANY WARRANTY. ) 3 | ( See the file COPYING for the license. ) 4 | ( a little calculator ) 5 | ( a usage example: ) 6 | ( you: ? 2*3-5/4= ) 7 | ( calc: 5 ) 8 | ( the grammar is a bit unconventional in its treatment of unary - ) 9 | \ e.g., you have to write 3*(-5) instead of 3*-5 10 | 11 | DECIMAL 12 | 255 max-member ( the whole character set ) 13 | 2VARIABLE input ( a string in `addr count' representation ) 14 | 15 | 10 stack expected 16 | 17 | : sym ( -- c ) 18 | input 2@ IF 19 | C@ 20 | ELSE 21 | DROP [CHAR] = 22 | endif ; 23 | 24 | : testsym ( set -- f ) 25 | DUP expected push 26 | sym member? ; 27 | 28 | ' testsym test-vector ! 29 | 30 | : ?syntax-error ( f -- ) 31 | ?not? IF 32 | empty BEGIN 33 | expected top union 34 | expected pop 35 | expected clear? UNTIL 36 | ." expected: " ['] EMIT apply-to-members CR TRUE ABORT" syntax error" 37 | endif ; 38 | 39 | : ?readnext ( f -- ) 40 | ?syntax-error 41 | expected clear 42 | input 2@ 43 | DUP IF 44 | 1 CHARS - SWAP CHAR+ SWAP 45 | endif 46 | input 2! ; 47 | 48 | : init ( -- ) 49 | BL WORD COUNT input 2! ; 50 | 51 | : t ( -- ) ( use: t c name ) 52 | ( make terminal name with the token c ) 53 | CHAR singleton ['] ?readnext terminal ; 54 | 55 | : x ( set1 -- set2 ) 56 | ( read a char from the input and include it in the set ) 57 | CHAR singleton union ; 58 | 59 | ( make a terminal that accepts all digits ) 60 | empty x 0 x 1 x 2 x 3 x 4 x 5 x 6 x 7 x 8 x 9 ' ?readnext terminal digit 61 | 62 | t ( "(" 63 | t ) ")" 64 | t + "+" 65 | t - "-" 66 | t * "*" 67 | t / "/" 68 | t = "=" 69 | 70 | nonterminal expr 71 | 72 | (( {{ 0 }} 73 | (( {{ 10 * sym [CHAR] 0 - + }} digit )) ++ 74 | )) <- num ( -- n ) 75 | 76 | (( num 77 | || "(" expr ")" 78 | )) <- factor ( -- n ) 79 | 80 | (( factor (( "*" factor {{ * }} 81 | || "/" factor {{ / }} 82 | )) ** 83 | )) <- term ( -- n ) 84 | 85 | (( (( term 86 | || "-" term {{ 0 SWAP - }} )) 87 | (( "+" term {{ + }} 88 | || "-" term {{ - }} )) ** 89 | )) expr rule ( -- n ) 90 | 91 | (( {{ init }} expr "=" {{ . }} )) parser ? ( -- ) 92 | -------------------------------------------------------------------------------- /GRAY4.ANS/CHANGES: -------------------------------------------------------------------------------- 1 | Differences between Release 3 and Release 4 2 | 3 | Gray has been adapted to ANS Forth; it no longer runs on Tile. 4 | Semantic parsing conditions have been added (graycond.fs). The example 5 | program calc uses WORD (instead of KEY) for getting input; mini uses 6 | the file wordset (instead of KEY) for input. Gray is now licensed 7 | under the terms of the GNU General Public License. 8 | 9 | Differences between Release 2 and Release 3 10 | 11 | Gray runs now on Tile Release 2.1. It uses Tile's new "source" and 12 | "line" words for displaying error locations. Therefore it does not 13 | work on Release 1 of Tile. 14 | Some portability bugs have been removed. 15 | 16 | Differences between Release 1 and Release 2 17 | 18 | Gray now runs on computers with memory alignment restrictions, too. 19 | Tile Release 2 is now supported, it needs porting to run on Tile 20 | Release 1. 21 | Changed "(compile)" into "compile," (ANSI). 22 | No bugs were reported. Therefore they are still there. 23 | -------------------------------------------------------------------------------- /GRAY4.ANS/ELSE.FS: -------------------------------------------------------------------------------- 1 | ( Copyright 1990,1994 Martin Anton Ertl ) 2 | ( This program is distributed WITHOUT ANY WARRANTY. ) 3 | ( See the file COPYING for the license. ) 4 | ( dangling else ) 5 | ( tests if gray finds ambiguity ) 6 | 7 | 10 max-member 8 | 9 | : token ( u -- ) 10 | singleton ['] ABORT terminal ; 11 | 12 | 0 token "if" 13 | 1 token "then" 14 | 2 token "else" 15 | 3 token expr 16 | 4 token other 17 | 18 | nonterminal stmt 19 | (( other 20 | || (( "if" expr "then" stmt (( "else" stmt )) ?? )) 21 | )) stmt rule 22 | 23 | stmt parser test 24 | 25 | -------------------------------------------------------------------------------- /GRAY4.ANS/GRAYCOND.FS: -------------------------------------------------------------------------------- 1 | \ Copyright 1990,1994 Martin Anton Ertl 2 | \ This program is distributed WITHOUT ANY WARRANTY. 3 | \ See the file COPYING for the license. 4 | 5 | \ semantic conditions 6 | \ This is just a quick hack, I'm not sure about the best syntax and 7 | \ semantics yet. Suggestions welcome 8 | 9 | \ The syntax is this: 10 | \ a b cond 11 | \ It takes a flag from the stack. If it is true, "a" is parsed, otherwise "b" 12 | \ I.e., similar to alt, except that the condition is already on the stack. 13 | 14 | : compute-condition ( -- first maybe-empty ) 15 | operand1 compute 16 | operand2 compute 17 | ROT OR >R union R> ; 18 | 19 | : propagate-condition ( follow -- ) 20 | DUP 21 | operand1 propagate 22 | operand2 propagate ; 23 | 24 | : generate-condition ( -- ) 25 | POSTPONE IF 26 | operand1 generate 27 | POSTPONE ELSE 28 | operand2 generate 29 | POSTPONE endif ; 30 | 31 | CREATE condition-map 32 | ', compute-condition 33 | ', propagate-condition 34 | ', generate-condition 35 | ', pass2-binary 36 | 37 | : cond ( syntax-exp1 syntax-exp2 -- syntax-exp3 ) 38 | condition-map make-binary ; 39 | -------------------------------------------------------------------------------- /GRAY4.ANS/GRAYLIST.FS: -------------------------------------------------------------------------------- 1 | ( Copyright 1990,1994 Martin Anton Ertl ) 2 | ( This program is distributed WITHOUT ANY WARRANTY. ) 3 | ( See the file COPYING for the license. ) 4 | 5 | ( list construct for parsing ) 6 | ( a b && is the same as < a < b a > * > ) 7 | 8 | ( simple solution ) 9 | ( : && \ syntax-expr1 syntax-expr2 -- syntax-expr3 ) 10 | ( over concat ** concat ; ) 11 | 12 | binary-syntax-expr 13 | cell context-var test-set 14 | CONSTANT list-syntax-expr 15 | 16 | : compute-list ( -- first follow ) 17 | operand1 compute DUP IF 18 | SWAP operand2 get-first union SWAP 19 | endif ; 20 | 21 | : propagate-list ( follow -- ) 22 | operand2 compute IF 23 | operand1 get-first union 24 | endif 25 | union 26 | DUP operand1 propagate ( follow1 ) 27 | operand1 compute IF 28 | union 29 | ELSE 30 | SWAP DROP 31 | endif 32 | operand2 propagate ; 33 | 34 | : generate-list ( -- ) 35 | [COMPILE] BEGIN 36 | operand1 generate 37 | test-set @ compile-test 38 | [COMPILE] WHILE 39 | operand2 generate 40 | [COMPILE] REPEAT ; 41 | 42 | : pass2-list ( -- ) 43 | operand2 compute IF 44 | operand1 get-first union 45 | endif 46 | DUP test-set ! 47 | follow-set @ check-conflict 48 | pass2-binary ; 49 | 50 | CREATE list-map 51 | ', compute-list 52 | ', propagate-list 53 | ', generate-list 54 | ', pass2-list 55 | 56 | : && ( syntax-expr1 syntax-expr2 -- syntax-expr3 ) 57 | list-map make-binary 0 , ; 58 | 59 | -------------------------------------------------------------------------------- /GRAY4.ANS/MINI.FS: -------------------------------------------------------------------------------- 1 | ( Copyright 1990,1994 Martin Anton Ertl ) 2 | ( This program is distributed WITHOUT ANY WARRANTY. ) 3 | ( See the file COPYING for the license. ) 4 | 5 | ( a compiler for a tiny Pascal-like language ) 6 | ( to compile a program type `s" file" mini'; the program should be in file ) 7 | ( This creates a new word [its name is the name given after the program 8 | ( keyword], that you must call to execute the program ) 9 | ( mini programs take their input from the stack and write their ) 10 | ( output with . ) 11 | 12 | S" graylist.fs" INCLUDED 13 | 14 | .( Loading mini ... ) CR 15 | 16 | ( scanner ) 17 | ( it is implemented using gray to give an example ) 18 | ( that's probably not the best way ) 19 | S" max-char" ENVIRONMENT? ?not? [IF] 20 | 255 21 | [THEN] 22 | 1+ CONSTANT eof-char 23 | eof-char max-member ( the whole character set ) 24 | 25 | VARIABLE mini-file 26 | 27 | VARIABLE tokenval 0 tokenval ! 28 | : token ( -- ) ( use: token name ) ( name: -- n ) 29 | ( defines a token that returns a unique value ) 30 | tokenval @ CONSTANT 31 | 1 tokenval +! ; 32 | 33 | token ";" 34 | token "," 35 | token ":=" 36 | token "=" 37 | token "#" 38 | token ">" 39 | token "+" 40 | token "-" 41 | token "*" 42 | token "(" 43 | token ")" 44 | token Ident 45 | token Number-token 46 | token eof-token 47 | 48 | WORDLIST CONSTANT keyword-wordlist 49 | GET-CURRENT keyword-wordlist SET-CURRENT 50 | token PROGRAM 51 | token VAR 52 | token BEGIN 53 | token END 54 | token Read 55 | token Write 56 | token IF 57 | token THEN 58 | token WHILE 59 | token DO 60 | SET-CURRENT 61 | 62 | VARIABLE numval 63 | VARIABLE identp 64 | VARIABLE identlen 65 | 66 | : ident-string ( -- addr u ) 67 | identp @ identlen @ ; 68 | 69 | : adds ( addr1 c -- addr1+1 ) 70 | ( accumulates char to string ) 71 | OVER C! 1+ ; 72 | 73 | : key/ident ( addr u -- n ) 74 | ( checks string at addr for keyword and returns token value ) 75 | keyword-wordlist SEARCH-WORDLIST IF 76 | EXECUTE 77 | ELSE 78 | Ident 79 | endif ; 80 | 81 | VARIABLE ch 82 | 83 | : testchar? ( set -- f ) 84 | ch @ member? ; 85 | ' testchar? test-vector ! 86 | 87 | CREATE c1 1 CHARS ALLOT 88 | 89 | : ?nextchar ( f -- ) 90 | \ this will not earn a speed record 91 | ?not? ABORT" non-mini character or '=' missing after ':'" 92 | c1 1 mini-file @ READ-FILE ABORT" read-file error" 93 | IF \ read <>0 chars 94 | c1 C@ ch ! 95 | ELSE 96 | eof-char ch ! 97 | endif ; 98 | 99 | : .. ( c1 c2 -- set ) 100 | ( creates a set that includes the characters c, c1<=c<=c2 ) 101 | empty copy-set 102 | SWAP 1+ ROT DO 103 | I OVER add-member 104 | LOOP ; 105 | 106 | : ` ( -- terminal ) ( use: ` c ) 107 | ( creates anonymous terminal for the character c ) 108 | CHAR singleton ['] ?nextchar make-terminal ; 109 | 110 | CHAR a CHAR z .. CHAR A CHAR Z .. union ' ?nextchar terminal letter 111 | CHAR 0 CHAR 9 .. ' ?nextchar terminal digit 112 | 0 32 .. ' ?nextchar terminal BLANK 113 | eof-char singleton ' ?nextchar terminal eof-scanner 114 | 115 | (( BLANK ** 116 | (( ` ; {{ ";" }} 117 | || ` , {{ "," }} 118 | || ` : ` = {{ ":=" }} 119 | || ` = {{ "=" }} 120 | || ` # {{ "#" }} 121 | || ` > {{ ">" }} 122 | || ` + {{ "+" }} 123 | || ` - {{ "-" }} 124 | || ` * {{ "*" }} 125 | || ` ( {{ "(" }} 126 | || ` ) {{ ")" }} 127 | || eof-scanner {{ eof-token }} 128 | || {{ 0 }} 129 | (( {{ 10 * ch @ + [CHAR] 0 - }} CR digit )) ++ 130 | {{ numval ! Number-token }} 131 | || {{ HERE identp ! HERE ch @ adds }} letter 132 | (( {{ ch @ adds }} (( letter || digit )) )) ** 133 | {{ HERE - DUP identlen ! HERE SWAP key/ident }} 134 | )) 135 | )) <- symbol 136 | 137 | symbol parser scan 138 | 139 | 140 | ( parser ) 141 | tokenval @ 1- max-member 142 | 143 | WORDLIST CONSTANT variable-wordlist ( for mini variables ) 144 | 145 | VARIABLE sym 146 | 147 | : testsym? ( set -- f ) 148 | sym @ member? ; 149 | ' testsym? test-vector ! 150 | 151 | : ?nextsym ( f -- ) 152 | ?not? ABORT" syntax error" 153 | scan sym ! ; 154 | 155 | : t ( n -- ) ( use: token t name ) 156 | singleton ['] ?nextsym terminal ; 157 | 158 | GET-ORDER keyword-wordlist SWAP 1+ SET-ORDER 159 | ";" t ";" 160 | "," t "," 161 | ":=" t ":=" 162 | "=" t "=" 163 | "#" t "#" 164 | ">" t ">" 165 | "+" t "+" 166 | "-" t "-" 167 | "*" t "*" 168 | "(" t "(" 169 | ")" t ")" 170 | Ident t Ident 171 | Number-token t number-parser 172 | PROGRAM t "PROGRAM" 173 | VAR t "VAR" 174 | BEGIN t "BEGIN" 175 | END t "END" 176 | Read t "Read" 177 | Write t "Write" 178 | IF t "IF" 179 | THEN t "THEN" 180 | WHILE t "WHILE" 181 | DO t "DO" 182 | eof-token t eof-parser 183 | PREVIOUS 184 | 185 | : append-string ( addr1 u1 addr2 u2 -- addr1 u3 ) 186 | 3 ROLL >R ( u1 a2 u2 ) 187 | ROT 2DUP + ( a2 u2 u1 u1+u2 ) 188 | R> SWAP >R ( a2 u2 u1 a1 ) 189 | DUP >R 190 | + SWAP MOVE 191 | R> R> ; 192 | 193 | : :name ( addr u -- colon-sys ) 194 | ( defines colon-def whose name is give by addr u ) 195 | PAD 0 S" : " append-string 2SWAP append-string EVALUATE ; 196 | 197 | : variable-name ( addr u -- ) 198 | ( defines variable whose name is given by addr u ) 199 | 2DUP variable-wordlist SEARCH-WORDLIST ABORT" variable already defined" 200 | GET-CURRENT >R variable-wordlist SET-CURRENT 201 | PAD 0 S" VARIABLE " append-string 2SWAP append-string EVALUATE 202 | R> SET-CURRENT ; 203 | 204 | : getvar ( addr u -- xt ) 205 | ( get the execution token of the var whose name is given by addr u ) 206 | variable-wordlist SEARCH-WORDLIST ?not? ABORT" variable undefined" ; 207 | 208 | : <> ( n1 n2 -- f ) 209 | = ?not? ; 210 | 211 | nonterminal Stat 212 | nonterminal Expr 213 | 214 | (( {{ numval @ }} number-parser )) <- Number 215 | 216 | \ (( {{ identp @ }} ident )) <- Ident 217 | 218 | (( Number {{ POSTPONE LITERAL }} 219 | || {{ ident-string getvar COMPILE, POSTPONE @ }} Ident 220 | || "(" Expr ")" 221 | )) <- Factor 222 | 223 | (( Factor (( "*" Factor {{ POSTPONE * }} )) ** )) <- Term 224 | 225 | (( Term (( (( "+" {{ ['] + }} || "-" {{ ['] - }} )) Term {{ COMPILE, }} )) ** 226 | )) Expr rule 227 | 228 | (( Expr 229 | (( "=" {{ ['] = }} || "#" {{ ['] <> }} || ">" {{ ['] > }} )) 230 | Expr {{ COMPILE, }} 231 | )) <- Cond 232 | 233 | Stat ";" && ?? <- StatSeq 234 | 235 | (( "Read" {{ ident-string getvar COMPILE, POSTPONE ! }} Ident )) <- ReadStat 236 | 237 | (( "Write" Expr {{ POSTPONE . }} )) <- WriteStat 238 | 239 | (( {{ ident-string getvar }} Ident ":=" Expr {{ COMPILE, POSTPONE ! }} 240 | )) <- AssStat 241 | 242 | (( "IF" Cond {{ POSTPONE IF }} "THEN" StatSeq "END" {{ POSTPONE endif }} 243 | )) <- IfStat 244 | 245 | (( {{ POSTPONE BEGIN }} "WHILE" Cond {{ POSTPONE WHILE }} "DO" 246 | StatSeq "END" {{ POSTPONE REPEAT }} 247 | )) <- WhileStat 248 | 249 | (( ReadStat || WriteStat || AssStat || IfStat || WhileStat )) Stat rule 250 | 251 | (( "VAR" {{ GET-CURRENT variable-wordlist SET-CURRENT }} 252 | (( {{ ident-string variable-name }} Ident )) "," && 253 | {{ SET-CURRENT }} 254 | )) <- Decl 255 | 256 | (( "PROGRAM" {{ identlen @ ALIGNED ALLOT ident-string }} Ident Decl ?? 257 | {{ :name }} "BEGIN" StatSeq {{ POSTPONE ; }} "END" eof-parser 258 | )) <- Program 259 | 260 | Program parser parsemini 261 | 262 | : mini ( addr u -- ) 263 | \ process the mini file whose name is given by addr u 264 | R/O OPEN-FILE ABORT" file opening error" mini-file ! 265 | TRUE ?nextchar TRUE ?nextsym parsemini 266 | mini-file @ CLOSE-FILE ABORT" file closing error" ; 267 | 268 | -------------------------------------------------------------------------------- /GRAY4.ANS/OBERON.FS: -------------------------------------------------------------------------------- 1 | \ Copyright 1990,1994 Martin Anton Ertl 2 | \ This program is distributed WITHOUT ANY WARRANTY. 3 | \ See the file COPYING for the license. 4 | 5 | \ parser for oberon ) 6 | \ i chose oberon, because it has a moderately complex grammar, ) 7 | \ not for its qualities as a language ) 8 | \ this is just a parser, without any semantic actions ) 9 | \ it was not tested ) 10 | \ the grammar was taken from: ) 11 | \ N.Wirth, The Programming Language Oberon, ) 12 | \ Software - Practice and Experience, 18, 671-690 (July 1988) 13 | \ corrections appeared in the january 89 issue, i believe ) 14 | 15 | \ space requirements on a 16-bit fig-forth using graylist.fs ) 16 | \ grammar: 8104 bytes ) 17 | \ generated code: 3551 bytes ) 18 | \ generated total: 5719 bytes ) 19 | \ context-stack: 220 bytes ) 20 | \ return-stack: 720 bytes WARNING: you must enlarge TILE's return-stack ) 21 | \ the data-stack is not critical- mine can only hold 60 cells ) 22 | \ if your return-stack cannot hold much, change the does> part ) 23 | \ of method: pop 3 cells off the return stack and save them ) 24 | \ elsewhere until after the execute ) 25 | \ generating the parser takes a while: 24.5 seconds on my 4Mhz 6502 system ) 26 | 27 | \ the grammar contains four conflicts, which are all harmful, ) 28 | \ i.e. the generated parser will not parse all oberon programs ) 29 | \ in the qualident rule there is a conflict between the two idents ) 30 | \ designator doesn't know, whether a "(" means a type guard or a procedure call) 31 | \ Procedure- and ForwardDeclaration have a conflict in a DeclarationSequence ) 32 | \ in statement there's a classical conflict between assigment and ProcedureCall) 33 | 34 | 63 max-member 35 | 36 | VARIABLE tcount 0 tcount ! 37 | : t \ -- ) 38 | tcount @ singleton ['] ABORT terminal 39 | 1 tcount +! ; 40 | 41 | 42 | t integer 43 | t real 44 | t CharConstant 45 | t string 46 | t ident 47 | t "+" 48 | t "-" 49 | t "*" 50 | t "/" 51 | t "~" 52 | t "&" 53 | t "." 54 | t "," 55 | t ";" 56 | t "|" 57 | t "(" 58 | t ")" 59 | t "[" 60 | t "]" 61 | t ":=" 62 | t "^" 63 | t "=" 64 | t "#" 65 | t "<" 66 | t ">" 67 | t "<=" 68 | t ">=" 69 | t ":" 70 | t ".." 71 | t "{" 72 | t "}" 73 | 74 | t "ARRAY" t "IN" t "THEN" 75 | t "BEGIN" t "IS" t "TO" 76 | t "CASE" t "LOOP" t "TYPE" 77 | t "CONST" t "MOD" t "UNTIL" 78 | t "DEFINITION" t "MODULE" t "VAR" 79 | t "DIV" t "NIL" t "WHILE" 80 | t "DO" t "OF" t "WITH" 81 | t "ELSE" t "OR" 82 | t "ELSIF" t "POINTER" 83 | t "END" t "PROCEDURE" 84 | t "EXIT" t "RECORD" 85 | t "IF" t "REPEAT" 86 | t "IMPORT" t "RETURN" 87 | 88 | 89 | : && \ syntax-expr1 syntax-expr2 -- syntax-expr3 ) 90 | OVER concat ** concat ; 91 | 92 | nonterminal factor 93 | nonterminal expression 94 | nonterminal TYPE 95 | nonterminal statement 96 | nonterminal DeclarationSequence 97 | 98 | 99 | (( integer || real )) <- number 100 | 101 | (( (( ident "." )) ?? ident )) <- qualident 102 | 103 | expression <- ConstExpression 104 | (( ident "=" ConstExpression )) <- ConstantDeclaration 105 | 106 | ConstExpression <- length 107 | (( "ARRAY" length "," && "OF" TYPE )) <- ArrayType 108 | 109 | ident "," && <- IdentList 110 | (( IdentList ":" TYPE )) ?? <- FieldList 111 | FieldList ";" && <- FieldListSequence 112 | qualident <- BaseType 113 | (( "RECORD" (( "(" BaseType ")" )) ?? FieldListSequence "END" )) <- RecordType 114 | 115 | (( "POINTER" "TO" TYPE )) <- PointerType 116 | 117 | (( (( "ARRAY" "OF" )) ** qualident )) <- FormalType 118 | (( "(" (( "VAR" ?? FormalType )) "," && ?? ")" (( ":" qualident )) ?? )) 119 | <- FormalTypeList 120 | (( "PROCEDURE" FormalTypeList ?? )) <- ProcedureType 121 | 122 | (( qualident || ArrayType || RecordType || PointerType || ProcedureType )) 123 | TYPE rule 124 | (( ident "=" TYPE )) <- TypeDeclaration 125 | 126 | (( IdentList ":" TYPE )) <- VariableDeclaration 127 | 128 | expression "," && <- ExpList 129 | (( qualident (( "." ident || "[" ExpList "]" || "(" qualident ")" || "^" )) ** 130 | )) <- designator 131 | 132 | 133 | (( "(" ExpList ?? ")" )) <- ActualParameters 134 | (( expression (( ".." expression )) ?? )) <- element 135 | (( "{" element "," && ?? "}" )) <- set 136 | (( number || CharConstant || string || "NIL" || set || 137 | designator ActualParameters ?? || "(" expression ")" || "~" factor )) 138 | factor rule 139 | (( "*" || "/" || "DIV" || "MOD" || "&" )) <- MulOperator 140 | factor MulOperator && <- term 141 | (( "+" || "-" || "OR" )) <- AddOperator 142 | (( (( "+" || "-" )) ?? term AddOperator && )) <- SimpleExpression 143 | (( "=" || "#" || "<" || "<=" || ">" || ">=" || "IN" || "IS" )) <- relation 144 | (( SimpleExpression (( relation SimpleExpression )) ?? )) expression rule 145 | 146 | (( designator ":=" expression )) <- assignment 147 | 148 | (( designator ActualParameters ?? )) <- ProcedureCall 149 | 150 | statement ";" && <- StatementSequence 151 | 152 | (( "IF" expression "THEN" StatementSequence 153 | (( "ELSIF" expression "THEN" StatementSequence )) ** 154 | (( "ELSE" StatementSequence )) ?? 155 | "END" 156 | )) <- IfStatement 157 | 158 | (( ConstExpression (( ".." ConstExpression )) ?? )) <- CaseLabels 159 | CaseLabels "," && <- CaseLabelList 160 | (( CaseLabelList ":" StatementSequence )) ?? <- CASE 161 | (( "CASE" expression "OF" CASE "|" && (( "ELSE" StatementSequence )) ?? "END" )) 162 | <- CaseStatement 163 | 164 | (( "WHILE" expression "DO" StatementSequence "END" )) <- WhileStatement 165 | 166 | (( "REPEAT" StatementSequence "UNTIL" expression )) <- RepeatStatement 167 | 168 | (( "LOOP" StatementSequence "END" )) <- LoopStatement 169 | 170 | (( "WITH" qualident ":" qualident "DO" StatementSequence "END" )) <- WithStatement 171 | 172 | (( assignment || ProcedureCall || 173 | IfStatement || CaseStatement || WhileStatement || RepeatStatement || 174 | LoopStatement || WithStatement || "EXIT" || "RETURN" expression ?? 175 | )) ?? statement rule 176 | 177 | (( "VAR" ?? IdentList ":" FormalType )) <- FPSection 178 | (( "(" FPSection ";" && ?? ")" (( ":" qualident )) ?? )) <- FormalParameters 179 | 180 | (( DeclarationSequence (( "BEGIN" StatementSequence )) ?? "END" )) <- ProcedureBody 181 | (( "PROCEDURE" "*" ?? ident FormalParameters ?? )) <- ProcedureHeading 182 | (( ProcedureHeading ";" ProcedureBody ident )) <- ProcedureDeclaration 183 | (( "PROCEDURE" "^" ident FormalParameters ?? )) <- ForwardDeclaration 184 | (( (( "CONST" (( ConstantDeclaration ";" )) ** )) ?? 185 | (( "TYPE" (( TypeDeclaration ";" )) ** )) ?? 186 | (( "VAR" (( VariableDeclaration ";" )) ** )) ?? 187 | (( ProcedureDeclaration ";" || ForwardDeclaration ";" )) ** 188 | )) DeclarationSequence rule 189 | 190 | (( (( "CONST" (( ConstantDeclaration ";" )) ** )) ?? 191 | (( "TYPE" (( TypeDeclaration ";" )) ** )) ?? 192 | (( "VAR" (( VariableDeclaration ";" )) ** )) ?? 193 | (( ProcedureHeading ";" )) ** 194 | )) <- DefSequence 195 | (( ident (( ":" ident )) ?? )) <- import 196 | (( "IMPORT" import "," && ";" )) <- ImportList 197 | (( "MODULE" ident ";" ImportList ?? DeclarationSequence 198 | (( "BEGIN" StatementSequence )) ?? "END" ident "." )) <- module 199 | (( "DEFINITION" ident ";" ImportList ?? DefSequence "END" ident "." )) <- definition 200 | (( module || definition )) <- CompilationUnit 201 | 202 | CompilationUnit parser oberon 203 | 204 | -------------------------------------------------------------------------------- /GRAY4.ANS/README: -------------------------------------------------------------------------------- 1 | This is Realease 4 of Gray, a parser generator written in Forth. It 2 | takes grammars in an extended BNF syntax and generates recursive 3 | descent parsers as executable Forth code. 4 | 5 | 6 | FILES 7 | 8 | README You are reading it 9 | CHANGES describes differences to earlier releases 10 | gray.fs parser generator source file 11 | gray.doc parser generator manual 12 | else.fs a very tiny example grammar 13 | oberon.fs a medium-sized example grammar 14 | calc.fs an example interpreter 15 | mini.fs an example compiler 16 | test.mini a program for mini (computes the square) 17 | graylist.fs example extension for Gray 18 | graycond.fs semantic parsing conditions, another extension 19 | test.fs runs the examples 20 | test.out output of test.fs on one system 21 | 22 | 23 | PORTING AND TESTING 24 | 25 | As far as I know, the current version is ANS Forth conformant, with 26 | environmental dependences on case-insensitivity, stacks that are big 27 | enough (in particular, it needs a lot of return stack, e.g. 360 cells 28 | for oberon.fs), , and that 1 CHARS equals 1. It requires words from the 29 | CORE EXT and TOOLS EXT wordsets. A standard system is still standard 30 | after loading Gray. Gray has been tested with pfe-0.9.6 and an 31 | unreleased ANS Forth implementation. 32 | 33 | Some of the test programs require more wordsets; in particular, 34 | mini.fs needs at least the FILE and SEARCH wordsets. Also, some test 35 | programs define standard names in nonstandard ways, so a system is not 36 | standard after loading them. 37 | 38 | As distributed, Grays uses a space-hungry, but ANS conformant way of 39 | remembering source code locations for later error messages (thanks to 40 | Marcel Hendrix for that). Most systems will have words for accessing 41 | the current source file name and line number. If you want to save 42 | space, replace the stuff in gray.fs marked with `!!' with code for 43 | accessing and printing your source location. 44 | 45 | You can test Gray by loading test.fs. This needs more than 100KB on a 46 | 32-bit Forth with the present source location storage method (much 47 | less if you reduce the amount space for storing source location 48 | information). The output should look similar to test.out (test.out was 49 | created with pfe). 50 | 51 | AKNOWLEDGEMENTS 52 | 53 | Thanks to Marcel Hendrix for his ANS conformant error location code. 54 | 55 | 56 | COPYRIGHT 57 | 58 | Copyright 1990, 1991, 1994 Martin Anton Ertl 59 | 60 | This program is free software; you can redistribute it and/or modify 61 | it under the terms of the GNU General Public License as published by 62 | the Free Software Foundation; either version 2 of the License, or 63 | (at your option) any later version. 64 | 65 | This program is distributed in the hope that it will be useful, 66 | but WITHOUT ANY WARRANTY; without even the implied warranty of 67 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 68 | GNU General Public License for more details. 69 | 70 | You should have received a copy of the GNU General Public License 71 | along with this program; if not, write to the Free Software 72 | Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 73 | -------------------------------------------------------------------------------- /GRAY4.ANS/TEST.FS: -------------------------------------------------------------------------------- 1 | ( Copyright 1990, 1994 Martin Anton Ertl ) 2 | ( This program is distributed WITHOUT ANY WARRANTY. ) 3 | ( See gray.doc or gray.f83 for the license. ) 4 | S" gray.fs" INCLUDED 5 | CR .( eps ) 6 | 1 max-member 7 | eps parser x 8 | CR 9 | .( else ) 10 | S" else.fs" INCLUDED 11 | CR 12 | .( oberon ) 13 | S" oberon.fs" INCLUDED 14 | CR 15 | \ s" graylist.fs" included 16 | \ s" oberon.fs " included 17 | .( calc ) CR 18 | S" calc.fs" INCLUDED 19 | CR 20 | ? 2*3-5/4= 21 | CR 22 | .( mini ) CR 23 | S" mini.fs" INCLUDED 24 | S" test.min" mini 25 | CR 26 | 5 test CR 27 | 28 | \ BYE ( never use BYE in the F68KANS GEM-environment!!! ) 29 | 30 | -------------------------------------------------------------------------------- /GRAY4.ANS/TEST.MIN: -------------------------------------------------------------------------------- 1 | PROGRAM test 2 | VAR laufVar, i, j, SUM 3 | BEGIN 4 | Read i; 5 | laufVar := i+1; 6 | j := 0 - 1; 7 | SUM := j; 8 | WHILE laufVar > 0 DO 9 | j := j + 2; 10 | IF j#3 THEN SUM := SUM+j END; 11 | laufVar := laufVar -1 12 | END; 13 | IF i+1 > 0 THEN j:=j-2 END; 14 | IF i > 0 THEN SUM := 3+SUM END; 15 | Write SUM - (j - 2 * 2 + 11 + 9 - (3*5)) 16 | END 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /GRAY4.ANS/TEST.OUT: -------------------------------------------------------------------------------- 1 | [?1hA portable Forth environment written in C. Version 0.9.6 of 28-Jul-94 2 | Copyright Dirk Uwe Zoller 1994. Please enter LICENSE and WARRANTY. 3 | 4 | To quit say BYE. 5 | 6 | Hi there, enjoy Forth! 7 | Loading Gray ... Copyright 1990-1994 Martin Anton Ertl; NO WARRANTY 8 | 9 | "noop" is redefined 10 | "?pairs" is redefined 11 | "**" is redefined 12 | eps 13 | else 14 | 15 | || (( "if" expr "then" stmt (( "else" stmt )) ?? )) 16 | ^ 17 | ::: conflict:2 18 | oberon 19 | ""THEN"" is redefined 20 | ""ELSE"" is redefined 21 | ""IF"" is redefined 22 | "type" is redefined 23 | "case" is redefined 24 | 25 | (( (( ident "." )) ?? ident )) <- qualident 26 | ^ 27 | ::: conflict:4 28 | 29 | (( qualident (( "." ident || "[" ExpList "]" || "(" qualident ")" || "^" )) ** 30 | ^ 31 | ::: conflict:15 32 | 33 | (( ProcedureDeclaration ";" || ForwardDeclaration ";" )) ** 34 | ^ 35 | ::: conflict:57 36 | 37 | )) ?? statement rule 38 | ^ 39 | ::: conflict:4 40 | calc 41 | 42 | "t" is redefined 43 | "x" is redefined 44 | ""("" is redefined 45 | "")"" is redefined 46 | ""+"" is redefined 47 | ""-"" is redefined 48 | ""*"" is redefined 49 | ""/"" is redefined 50 | ""="" is redefined 51 | "expr" is redefined 52 | "factor" is redefined 53 | "term" is redefined 54 | "?" is redefined 55 | 5 56 | mini 57 | 58 | "&&" is redefined Loading mini ... 59 | 60 | "token" is redefined 61 | "";"" is redefined 62 | "","" is redefined 63 | "":="" is redefined 64 | ""="" is redefined 65 | ""#"" is redefined 66 | "">"" is redefined 67 | ""+"" is redefined 68 | ""-"" is redefined 69 | ""*"" is redefined 70 | ""("" is redefined 71 | "")"" is redefined 72 | "Ident" is redefined 73 | "BEGIN" is redefined 74 | "IF" is redefined 75 | "THEN" is redefined 76 | "WHILE" is redefined 77 | "DO" is redefined 78 | "digit" is redefined 79 | "blank" is redefined 80 | 81 | "scan" is redefined 82 | "sym" is redefined 83 | "t" is redefined 84 | "";"" is redefined 85 | "","" is redefined 86 | "":="" is redefined 87 | ""="" is redefined 88 | ""#"" is redefined 89 | "">"" is redefined 90 | ""+"" is redefined 91 | ""-"" is redefined 92 | ""*"" is redefined 93 | ""("" is redefined 94 | "")"" is redefined 95 | "Ident" is redefined 96 | ""VAR"" is redefined 97 | ""BEGIN"" is redefined 98 | ""END"" is redefined 99 | ""IF"" is redefined 100 | ""THEN"" is redefined 101 | ""WHILE"" is redefined 102 | ""DO"" is redefined 103 | "<>" is redefined 104 | "Expr" is redefined 105 | "Number" is redefined 106 | "Factor" is redefined 107 | "Term" is redefined 108 | "i" is redefined 109 | "j" is redefined 110 | "test" is redefined 111 | 25 112 | 113 | Goodbye! 114 | [?1l -------------------------------------------------------------------------------- /GRAY4.TXT: -------------------------------------------------------------------------------- 1 | Anton Ertl's GRAY4 for F68KANS 2 | 3 | I have added the port of GRAY4 for F68KANS to my distribution. 4 | You may ask, why there has to be a port, because F68KANS is a 5 | ANSI standard Forth system and GRAY4 claims to be ANSI source. 6 | 7 | Well, GRAY4 is not really ANSI, because it expects a Forth system 8 | not to be case-sensitive. But F68KANS *is* case-sensitive! 9 | So Anton's sources had to be converted. This was managed with a nice 10 | tool from Ullrich Hoffman, which you can find in my ANSLIB 11 | directory. 12 | 13 | Beside this difficulty, there was a second (if you do not count the bugs 14 | I found in F68KANS with the help of GRAY4): be sure that your returnstack 15 | is big enough!! My initial value of 2kB was not large enough, so I turned 16 | it to 10kB. Think of the fact, that also the file words like INCLUDED 17 | are using the returnstack! 18 | (My effect was quite silly: when I typed the content of the file TEST.FS 19 | to my input window, all was fine. When I INCLUDED it, it crashed. It took 20 | me one complete evening to find out the reason!) 21 | 22 | The GRAY4 test in TEST.FS needs a lot of dictionary, too. Make sure that 23 | you have about 100kB free for it. 24 | 25 | Have fun, 26 | 27 | - Joerg 28 | 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 1995-2018 Joerg Plewe and Contributors 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 10 | -------------------------------------------------------------------------------- /README.TXT: -------------------------------------------------------------------------------- 1 | F68KANS 2 | a portable Forthsystem for 680x0-computer 3 | 4 | Important note: 5 | 6 | F68KANS is a open source product, made by a community of sophisticated 7 | developers. 8 | 9 | What is it about? 10 | 11 | F68KANS is an ANSI Forth system for any m680x0 computer. It is highly 12 | portable even as a binary image. 13 | 14 | This release contains all to run F68KANS on Atari computers and on 15 | machines running OS9. All the necessary bits to make F68KANS run on 16 | any other machine is also included. 17 | 18 | The implementation on Atari machines is highly elaborated. So there is really 19 | a lot of stuff usable on Atari only. When you port F68KANS, you will have to 20 | decide, what you can or should use. All the thing not located under the ATARI 21 | subdirectory are of broader interest, which does not mean that things in this 22 | subdirectory are of no interest. 23 | 24 | Installation: 25 | 26 | Just copy all the stuff from floppy to your harddisk or even leave it on 27 | the floppy. Do not forget to make a backup!! 28 | 29 | What did you get? 30 | What should you have? 31 | 32 | I now will try to describe whta is in the distribtution of this release. 33 | To keep this part of the documentation flexible, I will only describe 34 | files and directories at one level. You can expect README.TXT files in 35 | some of the subdirectories describing its contents. 36 | 37 | I strongly advice you not to store any of your own sources under the 38 | F68KANS subdirectory. This will make it possible for you just to 39 | exchange the whole F68KANS directory with the next release. You should 40 | think of this possibilty also when you intend to change sources of the 41 | distribution. For the same reason you should be careful to use 42 | non-standard worsin your application, because there is no garantuee that 43 | these words still exist in another release or keep their meaning. 44 | 45 | 46 | File in F68KANS: 47 | 48 | README.TXT 49 | This file. 50 | 51 | Sometimes: F68KANS.IMG 52 | This is the binary system image. It contains the most basic part of the 53 | system written in assembler. By default, I store it somewhere in the 54 | ATARI subdirectory for practical reasons. Look for it, it is important! 55 | 56 | 57 | Directories in F68KANS: 58 | 59 | KERNEL 60 | Here are all the assembler sources of the basic kernel. They will lead 61 | to the file F68KANS.IMG. There are some system dependent steps in the 62 | generation of F68KANS.IMG, which I do not wnat to explain here, because 63 | you never will have to do the generation of the kernel. 64 | 65 | 66 | SYSFTH 67 | This directory contains Forth sources necessary to build a full featured 68 | Forth system from the basic kernel. In this turn, non-ANSI-words are 69 | defined as well. You should avoid to any cost to use these words, 70 | because they may be a matter of change without notice. Do never rely on them! 71 | The only reason to change any of the sources contained in SYSFTH is due 72 | to porting the system itself. for application programmers, these files 73 | should be considered as read-only. 74 | 75 | 76 | APPFTH 77 | Here are all sources which are based on ANSI-kernel, but are strongly 78 | related to the development environment- Here, e.g. graphics may be 79 | defined. So these sources of course may be system dependent. Alter them 80 | as a system provider, but do not touch them as an application 81 | programmer. 82 | 83 | 84 | TST 85 | Some files to test the functionality of the thing in SYSFTH and APPFTH. 86 | Take them as examples and demos! 87 | 88 | 89 | ATARI 90 | All the ATARI stuff, especially the ATARI loader, with all its 91 | connections to the GEM/TOS operating system. Some project files and 92 | utilities of my environment can be found here. 93 | 94 | --------------------------------------------------------------------------------