-
Notifications
You must be signed in to change notification settings - Fork 2
/
KERNEL.BLK
executable file
·1 lines (1 loc) · 171 KB
/
KERNEL.BLK
1
\ FORTH-83 *** 68000 *** ATARI 520-ST REGISTER ASSIGNMENTS: ( must be preserved across Forth words) A7 SP Parameter Stack & Hdw. Stack combined A6 RP Return Stack A5 IP Interpreter Pointer A4 BASE Address base Register ( = GEMDOS "BASE" ) A3 (NEXT) Address of "NEXT" code (JMP (A3)=NEXT) D7 W "Word" Register ..NOT post incremented D6 SCRATCH Hi-half guaranteed to be zero Free: A0, A1, A2, D0, D1, D2, D3, D4, D5 ...may be used inside a CODE definition. Note: A2, D3, D4, D5 are NEVER used by the Kernel System. \ Load screen \ 11Dec89 b0b WARNING OFF ONLY FORTH ALSO META ALSO FORTH HEX AA00 ' TARGET-ORIGIN >BODY ! IN-META DECIMAL CAPS ON 2 CAPACITY THRU \ Declare Forward References \ 8Nov86 bl : ]] ] ; : [[ [COMPILE] [ ; FORTH IMMEDIATE META FORWARD: DEFINITIONS FORWARD: [ \ FILE-HEADER \ 8Nov86 bl 0 CONSTANT FILESTART HEX 100 1C - DP-T ! ( set target DP ) LABEL FILE-HEADER 601A ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 100 ,-T -1 ,-T DECIMAL \ ORIGIN NEXT \ 9Nov86 bl ASSEMBLER LABEL ORIGIN -1 PCD) JMP ( Low Level COLD Entry point ) -1 PCD) JMP ( Low Level WARM Entry point ) LABEL >NEXT \ position-independent NEXT IP )+ W MOVE \ 8 clocks 0 W.L BASE DI) D6.W MOVE \ 14 clocks 0 D6.L BASE DI) JMP \ 14 clocks \ total: 36 clocks ) ASSEMBLER DEFINITIONS META H: NEXT A3 ) JMP ; \ only 8 clocks \ what? \ 8Nov86 bl IN-META HERE-T DUP 100 + CURRENT-T ! ( harmless ) VOCABULARY FORTH FORTH DEFINITIONS 0 OVER 2+ !-T ( link ) DUP 2+ SWAP 16 + !-T ( thread ) IN-META \S This code is in the 8080 version, too. I'm not sure what it does; the comments are Laxon's. -bl \ NEST EXIT UNNEST \ 9Nov86 bl ASSEMBLER LABEL NEST \ runtime code for : IP RP -) LMOVE 2 W ADDQ \ 8 + 4 + 12 = 24 clocks 0 W.L BASE DI) IP LEA NEXT CODE EXIT (S -- ) \ as per FORTH 83 standard RP )+ IP LMOVE NEXT END-CODE \ 12 clocks CODE UNNEST \ Same as EXIT. Compiled by ' EXIT @-T \ ; to help decompiling ' UNNEST !-T END-CODE \ DODOES DOCREATE \ 9Nov86 bl ASSEMBLER LABEL DODOES \ The runtime portion of defining words IP RP -) LMOVE \ push old IP SP )+ IP LMOVE \ new IP comes from "JSR" in DOES> \ fall through to DOCREATE LABEL DOCREATE \ leaves a pointer to its own PFA 2 W ADDQ \ on the stack. W SP -) MOVE NEXT \ UP DOUSER-VARIABLE \ 10Nov86 bl VARIABLE UP \ points to current USER area \ ( multitasking ) LABEL DOUSER-VARIABLE \ Runtime code for USER variables 2 W ADDQ \ Places a pointer to the 0 W.L BASE DI) D0.W MOVE \ current version of this UP DELTA-T PCD) D0.W ADD \ variable on the stack. D0.W SP -) MOVE \ Needed for multitasking. NEXT \ DOCONSTANT (LIT) \ 9Nov86 bl LABEL DOCONSTANT \ Runtime code for CONSTANT. 2 W ADDQ 0 W.L BASE DI) SP.W -) MOVE NEXT CODE (LIT) (S -- n ) \ Runtime code for literals. Pushes IP )+ SP -) MOVE \ the following 2 bytes onto the NEXT END-CODE \ stack and moves the IP over them. \ (LIT) is compiled by the FORTH-83 \ standard word LITERAL. \ Meta Defining Words \ 9Nov86 bl T: LITERAL (S n -- ) [TARGET] (LIT) ,-T T; T: DLITERAL (S d -- ) SWAP [TARGET] (LIT) ,-T [TARGET] (LIT) ,-T T; T: ASCII (S -- ) [COMPILE] ASCII [[ TRANSITION ]] LITERAL [META] T; T: ['] (S -- ) 'T >BODY @ [[ TRANSITION ]] LITERAL [META] T; : CONSTANT (S n -- ) RECREATE [[ ASSEMBLER DOCONSTANT ]] LITERAL ,-T DUP ,-T CONSTANT ; \ Identify numbers and forward References 16jan86plmHEX FORWARD: <(;CODE)> T: DOES> (S -- ) ( uses JSR DODOES[BASE] inst. ) [FORWARD] <(;CODE)> HERE-T 4EAC ,-T [[ ASSEMBLER DODOES ]] LITERAL ,-T T; : NUMERIC (S -- ) [FORTH] HERE [META] NUMBER DPL @ 1+ IF [[ TRANSITION ]] DLITERAL [META] ELSE DROP [[ TRANSITION ]] LITERAL [META] THEN ; : UNDEFINED (S -- ) HERE-T 0 ,-T IN-FORWARD [FORTH] CREATE [META] TRANSITION [FORTH] , FALSE , [META] DOES> FORWARD-CODE ; DECIMAL \ Meta Compiler Compiling Loop 21Dec83map[FORTH] VARIABLE T-IN META : ] (S -- ) STATE-T ON IN-TRANSITION BEGIN >IN @ T-IN ! DEFINED IF EXECUTE ELSE COUNT NUMERIC? IF NUMERIC ELSE T-IN @ >IN ! UNDEFINED THEN THEN STATE-T @ 0= UNTIL ; T: [ (S -- ) IN-META STATE-T OFF T; T: ; (S -- ) [TARGET] UNNEST [[ TRANSITION ]] [ T; : : (S -- ) TARGET-CREATE [[ ASSEMBLER NEST ]] LITERAL ,-T ] ; \ BRANCH ?BRANCH \ 10Nov86 bl CODE BRANCH (S -- ) LABEL BRAN1 IP )+ D6 MOVE 0 D6.L BASE DI) IP LEA NEXT END-CODE CODE ?BRANCH (S f -- ) SP )+ TST BRAN1 BEQ 2 IP ADDQ NEXT END-CODE \ Meta Compiler Branching Words 01AUG83HHLT: BEGIN ?<MARK T; T: AGAIN [TARGET] BRANCH ?<RESOLVE T; T: UNTIL [TARGET] ?BRANCH ?<RESOLVE T; T: IF [TARGET] ?BRANCH ?>MARK T; T: THEN ?>RESOLVE T; T: ELSE [TARGET] BRANCH ?>MARK 2SWAP ?>RESOLVE T; T: WHILE [[ TRANSITION ]] IF T; T: REPEAT 2SWAP [[ TRANSITION ]] AGAIN THEN T; \ (LOOP) \ 10Nov86 bl CODE (LOOP) (S -- ) 1 RP ) ADDQ BRAN1 BVC LONG 6 RP ADDQ 2 IP ADDQ WORD NEXT END-CODE \ (+LOOP) \ 10Nov86 bl CODE (+LOOP) (S n -- ) SP )+ D0 MOVE D0.W RP ) ADD BRAN1 BVC LONG 6 RP ADDQ 2 IP ADDQ WORD NEXT END-CODE \ (DO) \ 10Nov86 bl HEX CODE (DO) (S limit index -- ) SP )+ D0 MOVE SP )+ D1 MOVE LABEL PDO IP )+ RP -) MOVE 8000 # D1 ADD D1 RP -) MOVE D1 D0 SUB D0 RP -) MOVE NEXT END-CODE DECIMAL \ (?DO) BOUNDS \ 10Nov86 bl CODE (?DO) (S limit index -- ) SP )+ D0 MOVE SP )+ D1 MOVE D0 D1 CMP PDO BNE IP ) D6 MOVE 0 D6.L BASE DI) IP LEA NEXT END-CODE : BOUNDS (S adr len -- lim first ) OVER + SWAP ; \ Meta compiler Branching & Looping \ 20:08 15Jun89 b0b T: ?DO [TARGET] (?DO) ?>MARK T; T: DO [TARGET] (DO) ?>MARK T; T: LOOP [TARGET] (LOOP) OVER 2+ OVER ?<RESOLVE ?>RESOLVE T; T: +LOOP [TARGET] (+LOOP) OVER 2+ OVER ?<RESOLVE ?>RESOLVE T; CODE GO (S daddr -- | 32-bit jmp) RTS END-CODE CODE NOOP NEXT END-CODE \S CODE PAUSE NEXT END-CODE multitasker never worked! -b0b- \ EXECUTE \ 10Nov86 bl CODE EXECUTE (S cfa -- ) SP )+ W MOVE LABEL DODEFER-EX 0 W.L BASE DI) D6.W MOVE 0 D6.L BASE DI) JMP END-CODE CODE PERFORM (S adr -- ) \ adr contains a cfa SP )+ D6 MOVE 0 D6.L BASE DI) W.W MOVE 0 W.L BASE DI) D6.W MOVE 0 D6.L BASE DI) JMP END-CODE \ DODEFER DOUSER-DEFER \ 10Nov86 bl LABEL DODEFER 2 W ADDQ 0 W.L BASE DI) W.W MOVE DODEFER-EX BRA LABEL DOUSER-DEFER 2 W ADDQ 0 W.L BASE DI) W.W MOVE WORD UP DELTA-T PCD) W ADD 0 W.L BASE DI) W.W MOVE 0 W.L BASE DI) D6.W MOVE 0 D6.L BASE DI) JMP \ I J \ 10Nov86 bl CODE I (S -- n ) RP ) D0 MOVE 2 RP D) D0 ADD D0 SP -) MOVE NEXT END-CODE CODE J (S -- n ) 6 RP D) D0 MOVE 8 RP D) D0 ADD D0 SP -) MOVE NEXT END-CODE \ (LEAVE) (?LEAVE) \ 10Nov86 bl CODE (LEAVE) (S -- ) LABEL PLEAVE 4 RP ADDQ RP )+ D6 MOVE 0 D6.L BASE DI) IP LEA NEXT END-CODE CODE (?LEAVE) (S f -- ) SP )+ TST PLEAVE BNE NEXT END-CODE T: LEAVE [TARGET] (LEAVE) T; T: ?LEAVE [TARGET] (?LEAVE) T; \ @ ! \ 10Nov86 bl CODE @ (S adr -- n ) SP ) D6 MOVE 0 D6.L BASE DI) A0 LEA BYTE A0 )+ D0 MOVE WORD 8 # D0 LSL BYTE A0 ) D0 MOVE WORD D0 SP ) MOVE NEXT END-CODE CODE ! (S n addr -- ) SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA WORD SP )+ D0 MOVE BYTE D0 1 A0 D) MOVE WORD 8 # D0 LSR BYTE D0 A0 ) MOVE NEXT END-CODE \ C@ C! \ 10Nov86 bl CODE C@ (S adr -- c ) SP ) D6 MOVE 0 D6.L BASE DI) A0 LEA LONG D0 CLR WORD BYTE A0 ) D0 MOVE WORD D0 SP ) MOVE NEXT END-CODE CODE C! (S c adr -- ) SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA WORD SP )+ D0 MOVE BYTE D0 A0 ) MOVE NEXT END-CODE \ 32 bit fetch & store \ 22:08 23Nov87 b0b CODE LC@ (S ladr -- b ) LONG SP )+ A0 MOVE WORD D0 CLR BYTE A0 ) D0 MOVE WORD D0 SP -) MOVE NEXT END-CODE CODE LC! (S b ladr -- ) LONG SP )+ A0 MOVE WORD SP )+ D0 MOVE BYTE D0 A0 ) MOVE NEXT END-CODE CODE L@ (S ladr -- n ) LONG SP )+ A0 MOVE WORD A0 ) SP -) MOVE NEXT END-CODE CODE L! (S n ladr -- ) LONG SP )+ A0 MOVE WORD SP )+ A0 ) MOVE NEXT END-CODE \ CMOVE \ 29Nov86 bl CODE CMOVE (S from to count -- ) SP )+ D0 MOVE \ count in D0 1 D0 ADDQ \ add 1 for loop overhead SP )+ D6 MOVE \ 16-bit destination in D6 0 D6.L BASE DI) A0 LEA \ actual 32-bit dest. in A0 WORD SP )+ D6 MOVE \ 16-bit source adr in D6 0 D6.L BASE DI) A1 LEA \ 32-bit source in A1 \ the loop itself: BEGIN WORD 1 D0 SUBQ \ subtract 1 from index 0<> \ if it's not 0 yet WHILE BYTE A1 )+ A0 )+ MOVE \ move byte and inc adrs REPEAT \ doit again NEXT END-CODE \ all done \ CMOVE> \ 29Nov86 bl CODE CMOVE> (S from to count -- ) SP )+ D0 MOVE \ count in D0 SP )+ D6 MOVE \ local destination in D6 D0 D6 ADD \ top of target in D6 0 D6.L BASE DI) A0 LEA WORD \ 32-bit dest in A0 SP )+ D6 MOVE \ local source in D6 D0 D6 ADD \ top af source string 0 D6.L BASE DI) A1 LEA \ 32-bit source adr in A1 1 D0 ADDQ \ D0 is loop index BEGIN WORD 1 D0 SUBQ 0<> \ subtract 1, is it 0? WHILE BYTE A1 -) A0 -) MOVE \ no, move byte & dec adrs REPEAT \ loop NEXT END-CODE \ done! \ SP@ SP! \ 23Nov86 bl CODE SP@ (S -- adr ) SP D0 LMOVE LONG \ stack adr in D0 BASE D0 SUB WORD \ subtract BASE D0 SP -) MOVE \ 16-bit adr to stack NEXT END-CODE CODE SP! (S adr -- ) \ used by ABORT" SP )+ D6 MOVE \ pop adr to D6 0 D6.L BASE DI) SP LEA \ new SP NEXT END-CODE \ RP@ RP! \ 19:19 22Nov87 b0b CODE RP@ (S -- addr ) \ not used in kernel RP D0 LMOVE LONG BASE D0 SUB WORD D0 SP -) MOVE NEXT END-CODE CODE RP! (S addr -- ) \ used by QUIT SP )+ D6 MOVE 0 D6.L BASE DI) RP LEA NEXT END-CODE \ DROP DUP SWAP \ 23Nov86 bl CODE DROP (S n1 -- ) 2 SP ADDQ \ adjust stack pointer NEXT END-CODE CODE DUP (S n1 -- n1 n1 ) SP ) SP -) MOVE \ easy!! NEXT END-CODE CODE SWAP (S n1 n2 -- n2 n1 ) LONG SP ) D0 MOVE \ both entries in D0 D0 SWAP \ how convenient! D0 SP ) MOVE \ put them back on the stack NEXT END-CODE \ OVER TUCK NIP \ 25Nov86 bl CODE OVER (S n1 n2 -- n1 n2 n1 ) 2 SP D) SP -) MOVE NEXT END-CODE CODE TUCK (S n1 n2 -- n2 n1 n2 ) LONG SP ) D0 MOVE D0 SWAP D0 SP ) MOVE WORD D0 SP -) MOVE NEXT END-CODE CODE NIP (S n1 n2 -- n2 ) SP )+ SP ) MOVE NEXT END-CODE \ ROT -ROT \ 23Nov86 bl CODE ROT (S n1 n2 n3 --- n2 n3 n1 ) LONG SP )+ D1 MOVE WORD SP )+ D0 MOVE LONG D1 SP -) MOVE WORD D0 SP -) MOVE NEXT END-CODE CODE -ROT (S n1 n2 n3 --- n3 n1 n2 ) WORD SP )+ D1 MOVE LONG SP )+ D0 MOVE WORD D1 SP -) MOVE LONG D0 SP -) MOVE NEXT END-CODE \ FLIP ?DUP \ 21:59 10Nov87 b0b \ CODE FLIP (S n1 -- n2 ) ( byte swap ) \ SP )+ D0 MOVE \ 8 # D0 ROL \ D0 SP -) MOVE \ NEXT END-CODE CODE ?DUP (S n -- n [n] ) SP ) D0 MOVE 0<> IF D0 SP -) MOVE THEN NEXT END-CODE \ R> >R R@ \ 23Nov86 bl CODE R> ( -- n ) \ note that the return stack is 32 bits wide LONG D0 CLR RP )+ D0 LMOVE \ pop return stack to D0 BASE D0 SUB \ subtract BASE address WORD D0 SP -) MOVE \ 16-bits to parameter stack NEXT END-CODE CODE >R ( n -- ) LONG D0 CLR WORD SP )+ D0 MOVE \ pop stack to D0 LONG BASE D0 ADD \ add BASE adr D0 RP -) LMOVE \ 32-bits to return stack NEXT END-CODE CODE R@ ( -- n ) LONG D0 CLR RP ) D0 MOVE \ copy return stack to D0 BASE D0 SUB \ subtract BASE address WORD D0 SP -) MOVE \ 16-bits to parameter stack NEXT END-CODE \ PICK ROLL \ 21:56 22Nov87 b0b CODE PICK (S nk ... n1 n0 k -- nk ... n1 n0 nk ) LONG D0 CLR WORD SP )+ D0 MOVE D0 D0 ADD LONG SP D0 ADD D0 A0 MOVE WORD A0 ) SP -) MOVE NEXT END-CODE : ROLL (S n1 n2 .. nk n -- wierd ) >R R@ PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; \ AND OR XOR \ 23Nov86 bl CODE AND (S n1 n2 -- n3 ) SP )+ D0 MOVE D0 SP ) AND NEXT END-CODE CODE OR (S n1 n2 -- n3 ) SP )+ D0 MOVE D0 SP ) OR NEXT END-CODE CODE XOR (S n1 n2 -- n3 ) SP )+ D0 MOVE D0 SP ) EOR NEXT END-CODE \ NOT TRUE FALSE ON OFF \ 23Nov86 bl -1 CONSTANT TRUE 0 CONSTANT FALSE CODE NOT ( n -- n' ) \ logical not SP ) NOT NEXT END-CODE CODE ON ( adr -- ) \ same as TRUE adr ! SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA WORD TRUE # A0 ) MOVE NEXT END-CODE CODE OFF ( adr -- ) \ same as 0 adr ! SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA WORD A0 ) CLR NEXT END-CODE \ INC DEC \ 20:17 30Oct87 b0b CODE INC ( adr -- ) \ 1 adr +! SP )+ D6 MOVE \ local adr in D6 0 D6.L BASE DI) A0 LEA \ extended adr in A0 WORD 1 A0 ) ADDQ \ add 1 NEXT END-CODE CODE DEC ( adr -- ) \ -1 adr +! SP )+ D6 MOVE \ local adr in D6 0 D6.L BASE DI) A0 LEA \ extended adr in A0 WORD 1 A0 ) SUBQ \ subtact 1 NEXT END-CODE \ CSET CRESET \ 20:03 15Jun89 b0b CODE CSET ( b adr -- ) SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA WORD SP )+ D0 MOVE BYTE D0 A0 ) OR NEXT END-CODE CODE CRESET ( b adr -- ) SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA WORD SP )+ D0 MOVE D0 NOT BYTE D0 A0 ) AND NEXT END-CODE \ CTOGGLE +! \ 20:24 30Oct87 b0b CODE CTOGGLE (S b addr -- ) SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA WORD SP )+ D0 MOVE BYTE D0 A0 ) EOR NEXT END-CODE CODE +! ( n adr -- ) SP )+ D6 MOVE \ local adr in D6 0 D6.L BASE DI) A0 LEA \ extended adr in A0 WORD A0 ) D0 MOVE \ word from adr in D0 SP )+ D0 ADD \ add n from stack D0 A0 ) MOVE \ put it back NEXT END-CODE \ + - NEGATE ABS numeric constants \ 23Nov86 bl CODE + (S n1 n2 -- sum ) SP )+ D0 MOVE D0 SP ) ADD NEXT END-CODE CODE - (S n1 n2 -- n1-n2 ) SP )+ D0 MOVE D0 SP ) SUB NEXT END-CODE CODE NEGATE (S n -- n' ) SP ) NEG NEXT END-CODE CODE ABS (S n -- n ) SP ) TST 0< IF SP ) NEG THEN NEXT END-CODE 0 CONSTANT 0 1 CONSTANT 1 2 CONSTANT 2 3 CONSTANT 3 \ 1+ 2+ 1- 2- \ 10Nov86 bl CODE 1+ (S n -- n+1 ) 1 SP ) ADDQ NEXT END-CODE CODE 2+ (S n -- n+2 ) 2 SP ) ADDQ NEXT END-CODE CODE 1- (S n -- n-1 ) 1 SP ) SUBQ NEXT END-CODE CODE 2- (S n -- n-2 ) 2 SP ) SUBQ NEXT END-CODE \ 2* 2/ ( U2/ ) \ 22:33 6Nov87 b0b CODE 2* (S n -- 2*n ) SP ) ASL NEXT END-CODE CODE 2/ (S n -- n/2 ) SP ) ASR NEXT END-CODE CODE 0. (S -- 0 0 ) LONG SP -) CLR NEXT END-CODE \S CODE U2/ (S u -- u/2 ) SP ) LSR NEXT END-CODE \ 3* 8* \ 24Nov86 bl \ my own little inventions -bl CODE 3* ( n -- n' ) SP ) D0 MOVE D0 SP ) ADD D0 SP ) ADD NEXT END-CODE CODE 8* SP ) ASL SP ) ASL SP ) ASL NEXT END-CODE \ UM* UM/MOD \ 27Nov86 bl CODE UM* ( n1 n2 -- d ) \ unsigned multiply, double # product WORD SP )+ D0 MOVE SP )+ D0 MULU LONG D0 SP -) MOVE NEXT END-CODE CODE UM/MOD ( d1 n1 -- Remainder Quotient ) WORD SP )+ D0 MOVE LONG SP ) D1 MOVE D0 D1 DIVU \ unsigned divide D1 SWAP D1 SP ) MOVE NEXT END-CODE \ 0< 0= 0> \ 24Nov86 bl ASSEMBLER LABEL YES TRUE # SP ) MOVE NEXT CODE 0< ( n -- f ) SP ) TST YES BMI SP ) CLR NEXT END-CODE CODE 0= ( n -- f ) SP ) TST YES BEQ SP ) CLR NEXT END-CODE CODE 0> ( n -- f ) SP ) TST YES BGT SP ) CLR NEXT END-CODE \ < > \ 24Nov86 bl CODE < ( n1 n2 -- f ) SP )+ D0 MOVE SP ) D0 CMP YES BGT SP ) CLR NEXT END-CODE CODE > (S n1 n2 -- f ) SP )+ D0 MOVE SP ) D0 CMP YES BLT SP ) CLR NEXT END-CODE \ 0<> = \ 24Nov86 bl CODE 0<> ( n -- f ) SP ) TST YES BNE SP ) CLR NEXT END-CODE CODE = ( n1 n2 -- f ) SP )+ D0 MOVE SP ) D0 CMP YES BEQ SP ) CLR NEXT END-CODE \ U< U> \ 24Nov86 bl CODE U< ( n1 n2 -- f ) SP )+ D0 MOVE SP ) D0 CMP YES BHI SP ) CLR NEXT END-CODE CODE U> (S n1 n2 -- f ) SP )+ D0 MOVE SP ) D1 MOVE D0 D1 CMP YES BHI SP ) CLR NEXT END-CODE \ <> MIN MAX \ 25Nov86 bl CODE <> ( n1 n2 -- f ) SP )+ D0 MOVE SP ) D0 CMP YES BNE SP ) CLR NEXT END-CODE : MIN ( n1 n2 -- n3 ) 2DUP > IF NIP ELSE DROP THEN ; : MAX ( n1 n2 -- n3 ) 2DUP < IF NIP ELSE DROP THEN ; \ BETWEEN WITHIN \ 19:31 22Nov87 b0b \S I didn't like the way these worked -b0b- : BETWEEN ( n1 min max -- f min<=n1<=max ) >R OVER > SWAP R> > OR NOT ; : WITHIN ( n1 min max -- f min<=n1<=max-1 ) 1- BETWEEN ; \ 2@ 2! \ 22:15 23Nov87 b0b : 2@ ( adr -- d ) DUP 2+ @ SWAP @ ; : 2! ( d adr -- ) TUCK ! 2+ ! ; CODE L2@ (S ladr -- d ) LONG SP )+ A0 MOVE A0 ) SP -) MOVE WORD NEXT END-CODE CODE L2! (S 32bits daddr -- ) LONG SP )+ A0 MOVE SP )+ A0 ) MOVE WORD NEXT END-CODE CODE DROPS ( n1...nx x -- ) \ drop x items from the stack WORD SP )+ D6 MOVE \ top of D6 guaranteed to be 0 WORD 1 # D6 LSL \ times 2 (neg x is illegal) LONG D6 SP ADDA \ add to stack pointer WORD NEXT END-CODE \ done! \ D+ DNEGATE D- \ 24Nov86 bl CODE D+ ( d1 d2 -- dsum ) LONG SP )+ D0 MOVE D0 SP ) ADD NEXT END-CODE CODE DNEGATE ( d# -- d#' ) LONG SP ) NEG NEXT END-CODE : D- ( d1 d2 -- d3 ) DNEGATE D+ ; \ S>D DABS \ 28Nov86 bl CODE S>D ( n -- d ) SP )+ A0 MOVE A0 SP -) LMOVE NEXT END-CODE ( a use for address sign extension !!!!! ) CODE DABS (S d# -- d# ) SP ) TST 0< IF LONG SP ) NEG THEN NEXT END-CODE \ D2/ ( D2* ?DNEGATE ) \ 24Nov86 bl CODE D2/ ( d -- d/2 ) LONG SP ) D0 MOVE 1 # D0 ASR D0 SP ) MOVE NEXT END-CODE \S these words not needed CODE D2* (S d -- d*2 ) LONG SP ) D0 MOVE 1 # D0 ASL D0 SP ) MOVE NEXT END-CODE : ?DNEGATE (S d1 n -- d2 ) 0< IF DNEGATE THEN ; \ 2DROP 2DUP 2SWAP 2OVER \ 27Nov86 bl CODE 2DROP (S a b -- ) 4 SP ADDQ NEXT END-CODE CODE 2DUP (S a b -- a b a b ) SP ) SP -) LMOVE NEXT END-CODE CODE 2SWAP (S a b c d -- c d a b ) LONG SP )+ D0 MOVE SP ) D1 MOVE D0 SP ) MOVE D1 SP -) MOVE NEXT END-CODE CODE 2OVER (S a b c d -- a b c d a b ) 4 SP D) SP -) LONG MOVE NEXT END-CODE \ 3DROP 4DROP DUPDUP \ 17:06 30Oct87 b0b CODE 3DROP ( n1 n2 n3 -- ) 6 SP ADDQ NEXT END-CODE CODE 4DROP ( n1 n2 n3 n4 -- ) 8 SP ADDQ NEXT END-CODE CODE DUPDUP ( n -- n n n ) SP ) SP -) MOVE SP ) SP -) MOVE \ easy!! NEXT END-CODE \ 3DUP 4DUP 2ROT \ 25Nov86 bl : 3DUP (S a b c -- a b c a b c ) DUP 2OVER ROT ; : 4DUP (S a b c d -- a b c d a b c d ) 2OVER 2OVER ; : 2ROT (S a b c d e f --- c d e f a b ) 5 ROLL 5 ROLL ; \ DU< \ 22:54 10Nov87 b0b ASSEMBLER LABEL YEP WORD TRUE # SP -) MOVE NEXT CODE DU< ( n1 n2 -- f ) LONG SP )+ D0 MOVE SP )+ D1 MOVE LONG D1 D0 CMP YEP BHI WORD SP -) CLR NEXT END-CODE \ D0= D= D< D> \ 25Nov86 bl : D0= ( d -- f ) OR 0= ; : D= ( d1 d2 -- f ) D- D0= ; : D< ( d1 d2 -- f ) 2 PICK OVER = IF DU< ELSE NIP ROT DROP < THEN ; : D> ( d1 d2 -- f ) 2SWAP D< ; \ DMAX DMIN \ 27Nov86 bl ASSEMBLER LABEL D0>SP D0 SP ) LMOVE NEXT CODE DMAX ( d1 d2 -- max ) LONG SP )+ D0 MOVE SP ) D0 CMP D0>SP BGT NEXT END-CODE CODE DMIN ( d1 d2 -- min ) LONG SP )+ D0 MOVE SP ) D0 CMP D0>SP BLT NEXT END-CODE \ *D * \ 28Nov86 bl CODE *D ( n1 n2 -- d ) \ signed multiply, double # product SP )+ D0 MOVE SP )+ D0 MULS LONG D0 SP -) MOVE NEXT END-CODE CODE * ( n1 n2 -- n3 ) \ signed multiply WORD SP )+ D0 MOVE SP ) D0 MULS D0 SP ) MOVE NEXT END-CODE \ M/MOD \ 29Nov86 bl CODE M/MOD ( d1 n1 -- rem quot ) \ floored division primitive WORD SP )+ D0 MOVE 0= IF NEXT THEN \ div by 0 aborts LONG SP ) D1 MOVE WORD D0 SP -) MOVE \ (S d1 n1 ) LABEL (/MOD) SP ) TST 0< IF D0 NEG THEN \ n1 abs in D0 LONG D1 TST 0< IF D1 NEG THEN \ d1 dabs in D1 D0 D1 DIVU D1 SWAP \ qout rem in D1 WORD SP )+ D0 MOVE \ n1 in D0 LONG SP ) D2 MOVE WORD D0 TST \ was n1 negative? 0< IF D1 NEG THEN \ yes, negate rem D2 SWAP D0 D2 EOR \ floor problem? 0< IF D1 SWAP D1 NEG \ yes, negate quot D1 SWAP D1 TST 0<> \ remainder exists? IF D1 D0 SUB D0 D1 MOVE \ sorry, fix it up D1 SWAP 1 D1 SUBQ D1 SWAP THEN THEN LONG D1 SP ) MOVE NEXT END-CODE \ /MOD \ 10:19 30Nov87 b0b CODE /MOD ( n2 n1 -- rem quot ) \ 16-bit floored division SP )+ D0 MOVE \ n1 in D0 SP )+ A0 MOVE \ the S>D trick A0 SP -) LMOVE \ n2 becomes a double # on stack SP ) D1 LMOVE \ d1 in D1 WORD D0 SP -) MOVE \ (S d1 n1 ) (/MOD) BRA \ floored division END-CODE \ Source code for the floored division module in OneForth \ including (/MOD), /MOD, MOD, (/), and / \ is Copyright 1987 by Bob Lee \ MOD \ 29Nov86 bl CODE MOD ( n2 n1 -- rem ) \ 16-bit floored division SP )+ D0 MOVE SP )+ A0 MOVE A0 SP -) LMOVE SP ) D1 LMOVE WORD D0 SP -) MOVE \ (S d1 n1 ) SP ) TST 0< IF D0 NEG THEN \ n1 abs in D0 LONG D1 TST 0< IF D1 NEG THEN \ d1 dabs in D1 D0 D1 DIVU D1 SWAP \ qout rem in D1 WORD SP )+ D0 MOVE D0 TST \ was n1 negative? 0< IF D1 NEG THEN \ yes, negate rem SP )+ D2 LMOVE \ dividend in D2 D2 SWAP D0 D2 EOR \ floor problem? 0< IF D1 TST 0<> \ & remainder non-zero? IF D1 D0 SUB D0 D1 MOVE \ sorry, fix it up THEN THEN D1 SP -) MOVE NEXT END-CODE \ remainder to stack \ / \ 29Nov86 bl CODE / ( n2 n1 -- quot ) \ 16-bit floored division SP )+ D0 MOVE SP )+ A0 MOVE A0 SP -) LMOVE SP ) D1 LMOVE D0 SP -) MOVE \ (S d1 n1 ) LABEL (/) SP ) TST 0< IF D0 NEG THEN \ n1 abs in D0 LONG D1 TST 0< IF D1 NEG THEN \ d1 dabs in D1 D0 D1 DIVU \ rem quot in D1 WORD SP )+ D0 MOVE \ n1 in D0 SP )+ D2 LMOVE \ dividend in D2 D2 SWAP D0 D2 EOR \ floor problem? 0< IF D1 NEG D1 SWAP \ yes, negate quot D1 D0 MOVE D1 SWAP \ rem in D0 D0 TST 0<> \ remainder non-zero? IF 1 D1 SUBQ THEN THEN \ floor the negative D1 SP -) MOVE NEXT END-CODE \ quotient to stack \ */MOD */ \ 29Nov86 bl CODE */MOD ( n3 n2 n1 -- rem quot ) SP )+ D0 MOVE \ n1 in D0 SP )+ D1 MOVE \ n2 in D1 SP )+ D1 MULS \ n2*n3 in LONG D1 D1 SP -) LMOVE \ d1 to stack D0 SP -) MOVE \ (S d1 n1 ) (/MOD) BRA END-CODE \ do floored division CODE */ ( n3 n2 n1 -- n3*n2/n1 ) SP )+ D0 MOVE \ n1 in D0 SP )+ D1 MOVE SP )+ D1 MULS \ n2*n3 in LONG D1 D1 SP -) LMOVE D0 SP -) MOVE \ (S d1 n1 ) (/) BRA END-CODE \ return quotient \ Task Dependant USER Variables \ 20:03 15Jun89 b0b USER DEFINITIONS VARIABLE TOS VARIABLE TOS+ ( TOP OF STACK - 32-BIT ) VARIABLE ENTRY ( ENTRY POINT, CONTAINS MACHINE CODE ) VARIABLE LINK ( LINK TO NEXT TASK - 32-BIT) VARIABLE LINK+ ( EXTENSION TO LINK FOR 32-BIT ADDRESS ) VARIABLE SP0 ( INITIAL PARAMETER STACK ) VARIABLE RP0 ( INITIAL RETURN STACK ) VARIABLE DP ( DICTIONARY POINTER ) VARIABLE #OUT ( NUMBER OF CHARACTERS EMITTED ) VARIABLE #LINE ( THE NUMBER OF LINES SENT SO FAR ) VARIABLE OFFSET ( RELATIVE TO ABSOLUTE DISK BLOCK 0 ) VARIABLE BASE ( FOR NUMERIC INPUT AND OUTPUT ) VARIABLE HLD ( POINTS TO LAST CHARACTER HELD IN PAD ) VARIABLE FILE ( POINTS TO FCB OF CURRENTLY OPEN FILE ) VARIABLE IN-FILE ( POINTS TO FCB OF CURRENTLY OPEN FILE ) \ System VARIABLEs \ 2Jan87 bl VARIABLE PRINTING DEFER EMIT ( TO ALLOW PRINT SPOOLING ) META DEFINITIONS VARIABLE SCR ( SCREEN LAST LISTED OR EDITED ) VARIABLE PRIOR ( USED FOR DICTIONARY SEARCHES ) VARIABLE STATE ( COMPILATION OR INTERPRETATION ) VARIABLE WARNING ( GIVE USER DUPLICATE WARNINGS IF ON ) VARIABLE DPL ( NUMERIC INPUT PUNCTUATION ) VARIABLE R# ( EDITING CURSOR POSITION ) VARIABLE LAST ( POINTS TO NFA OF LATEST DEFINITION ) VARIABLE CSP ( HOLDS STACK POINTER FOR ERROR CHECKING ) VARIABLE CURRENT ( VOCABULARY WHICH GETS DEFINITIONS ) \ System Variables \ 15:16 22Nov87 b0b 8 CONSTANT #VOCS ( THE NUMBER OF VOCABULARIES TO SEARCH ) VARIABLE CONTEXT ( VOCABULARY SEARCHED FIRST ) HERE THERE #VOCS 2* DUP ALLOT ERASE VARIABLE CAPS ( FLAG TRUE IF CASE IS INSIGNIFICANT) VARIABLE 'TIB ( ADDRESS OF TERMINAL INPUT BUFFER ) VARIABLE WIDTH ( WIDTH OF NAME FIELD ) VARIABLE VOC-LINK ( POINTS TO NEWEST VOCABULARY ) VARIABLE BLK ( BLOCK NUMBER TO INTERPRET ) VARIABLE >IN ( OFFSET INTO INPUT STREAM ) VARIABLE SPAN ( NUMBER OF CHARACTERS EXPECTED ) VARIABLE #TIB ( NUMBER OF CHARACTERS TO INTERPRET ) VARIABLE END? ( TRUE IF INPUT STREAM EXHAUSTED ) 32 CONSTANT BL 8 CONSTANT BS 7 CONSTANT BELL \ FILL ERASE BLANK \ 2Jan87 bl CODE FILL ( start-addr count char -- ) SP )+ D0 MOVE \ char in D0 SP )+ D1 MOVE \ count in D1 SP )+ D6 MOVE \ 16-bit adr in D6 0 D6.L BASE DI) A0 LEA \ 32-bit adr in A0 WORD 1 D1 SUBQ \ count is zero-based D1 DO BYTE D0 A0 )+ MOVE \ byte move loop LOOP NEXT END-CODE \ end : ERASE (S addr len -- ) 0 FILL ; : BLANK (S addr len -- ) BL FILL ; \ COUNT \ 2Jan87 bl CODE COUNT (S adr -- adr+1 len ) SP ) D6 MOVE \ 16-bit adr in D6 1 SP ) ADDQ \ adr+1 on stack 0 D6.L BASE DI) A0 LEA \ 32-bit adr in A0 LONG D0 CLR \ D0 is empty BYTE A0 ) D0 MOVE \ count byte in D0 WORD D0 SP -) MOVE \ count to stack NEXT END-CODE \ end \ LENGTH not used in kernel \ 2Jan87 bl CODE LENGTH (S adr -- adr+2 len ) SP ) D6 MOVE \ 16-bit adr in D6 2 SP ) ADDQ \ adr+2 on stack 0 D6.L BASE DI) A0 LEA \ 32-bit adr in A0 WORD A0 ) SP -) MOVE \ length word to stack NEXT END-CODE \ UPC \ 22:19 1Nov87 b0b CODE UPC (S c -- c' ) \ changes lower case to upper SP )+ D6 MOVE BYTE ASCII a D6 CMPI >= IF ASCII z D6 CMPI <= IF BL D6 SUBI THEN THEN WORD D6 SP -) MOVE NEXT END-CODE \ MOVE HERE PAD -TRAILING ( 14:39 10Oct87 bl ) : MOVE ( from to len -- ) -ROT 2DUP U< IF ROT CMOVE> ELSE ROT CMOVE THEN ; : HERE (S -- addr ) DP @ ; : PAD (S -- addr ) HERE 80 + ; : -TRAILING (S addr len -- addr len' ) DUP 0 ?DO 2DUP + 1- C@ BL <> ?LEAVE 1- LOOP ; \ COMP for strings 07Mar84map \ 22:18 1Nov87 b0b \ now named COMPARE, doesn't reference CAPS flag CODE COMPARE (S addr1 addr2 len -- -1|0|1 ) SP )+ D0 MOVE 1 D0 ADDQ SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA WORD SP )+ D6 MOVE 0 D6.L BASE DI) A1 LEA WORD BEGIN 1 D0 SUBQ 0<> WHILE BYTE A1 )+ A0 )+ CMPM WORD 0<> IF 0< IF 1 # SP -) MOVE ELSE -1 # SP -) MOVE THEN NEXT THEN REPEAT SP -) CLR NEXT END-CODE \ ADD-BASE ( 10:08 6Nov87 bl ) CODE ADD-BASE ( adr -- ladr ) SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA A0 SP -) LMOVE NEXT END-CODE \ 15:17 31Oct87 b0b \ TRAP1 \ 17:34 15Nov87 b0b CODE TRAP1 (s n1..nx func# -- n1..nx func# d ) 1 TRAP D0 SP -) LMOVE ( save results ..D0.. on stack ) NEXT END-CODE : GEMDOS ( param func# -- retval ) TRAP1 ROT 2DROP ; \ Terminal IO via GEMDOS \ 20 \ 11Dec89 b0b : C_CONIS (S -- f ) 11 GEMDOS ; \ DRI's name : (KEY?) C_CONIS ; \ F83's name : (KEY) (S -- keycode ) BEGIN C_CONIS UNTIL 8 TRAP1 \ Conin OVER IF DROP ELSE 256 * + THEN NIP ; \ trim TRAP1's func# : (CONSOLE) (S char -- ) 2 TRAP1 4DROP \ Conout #OUT INC ; \ Terminal Input and Output 19Apr84map \ 20:20 30Oct87 b0b DEFER KEY? DEFER KEY DEFER CR : CRLF (S -- ) 13 EMIT 10 EMIT #OUT OFF #LINE INC ; : TYPE (S addr len -- ) 0 ?DO COUNT EMIT LOOP DROP ; : SPACE (S -- ) BL EMIT ; : SPACES (S n -- ) 0 MAX 0 ?DO SPACE LOOP ; : BACKSPACES (S n -- ) 0 ?DO BS EMIT LOOP ; : BEEP (S -- ) BELL EMIT ; \ (PRINT) (EMIT) 19Apr84map \ 11Dec89 b0b : C_PRNOS (S -- f ) 17 GEMDOS ; \ DRI's name : PR-STAT C_PRNOS ; \ F83's name : (PRINT) (S char -- ) BEGIN C_PRNOS UNTIL 5 TRAP1 4DROP ( Prnout ) #OUT INC ; ( drop char & flag ) : (EMIT) (S char -- ) PRINTING @ IF DUP (PRINT) #OUT DEC THEN (CONSOLE) ; \ System Dependent Ctrl Chars 02Apr84map ( 15:50 10Oct87 bl ) : BS-IN (S n c -- 0 | n-1 ) DROP DUP IF 1- BS ELSE BELL THEN EMIT ; : (DEL-IN) (S n c -- 0 | n-1 ) DROP DUP IF 1- BS EMIT SPACE BS ELSE BELL THEN EMIT ; : BACK-UP (S n c -- 0 ) DROP DUP BACKSPACES DUP SPACES BACKSPACES 0 ; : RES-IN (S c -- ) FORTH TRUE ABORT" Reset" ; : P-IN (S c -- ) DROP PRINTING @ NOT PRINTING ! ; \ System Dependent Ctrl Chars 02Apr84map ( 15:50 10Oct87 bl ) : CR-IN (S m a n c -- m a m ) DROP SPAN ! OVER BL EMIT ; : (CHAR) (S a n char -- a n+1 ) 3DUP EMIT + C! 1+ ; DEFER CHAR DEFER DEL-IN \ CC-FORTH control char table \ 20:31 11Oct87 b0b VARIABLE CC CREATE CC-FORTH ] CHAR CHAR CHAR RES-IN CHAR CHAR CHAR CHAR BS-IN CHAR CHAR CHAR CHAR CR-IN CHAR CHAR P-IN CHAR CHAR CHAR CHAR BACK-UP CHAR CHAR BACK-UP CHAR CHAR CHAR CHAR CHAR CHAR CHAR [ \S @ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1Bh 1Ch 1Dh 1Eh 1Fh \ EXPECT ( 9:50 6Nov87 bl ) : EXPECT (S adr len -- ) DUP SPAN ! SWAP 0 ( len adr 0 ) BEGIN 2 PICK OVER - ( len adr #so-far #left ) WHILE KEY DUP BL < IF DUP 2* CC @ + PERFORM ELSE DUP 127 = IF DEL-IN ELSE CHAR THEN THEN REPEAT 3DROP ; \ TIB QUERY ( 9:48 6Nov87 bl ) : TIB (S -- adr ) 'TIB @ ; : QUERY (S -- ) TIB 80 EXPECT SPAN @ #TIB ! BLK OFF >IN OFF ; \ BLOCK I/O Constants & Variables \ 20:16 9Nov87 b0b 2 CONSTANT #BUFFERS 1024 CONSTANT B/BUF -2 CONSTANT LIMIT #BUFFERS 1+ 8* 2+ CONSTANT >SIZE LIMIT B/BUF #BUFFERS * - CONSTANT FIRST FIRST >SIZE - CONSTANT >BUFFERS \ Devices F_SEEK BLOCK I/O \ 11Dec89 b0b : >END (S -- adr ) FIRST 2- ; : BUFFER# (S n -- adr ) 8* >BUFFERS + ; : >UPDATE (S -- adr ) 1 BUFFER# 6 + ; DEFER READ-BLOCK (S buffer-header -- ) DEFER WRITE-BLOCK (S buffer-header -- ) CODE F_SEEK (S mode handle d1 -- d2 ) WORD 66 # SP -) MOVE \ function $42 1 TRAP \ call GEMDOS LONG 10. # SP ADDA \ cleanup stack LONG D0 SP -) MOVE \ new pointer to stack NEXT END-CODE \ F_OPEN F_CLOSE \ 11Dec89 b0b CODE F_OPEN ( mode ladr -- handle|errcode ) WORD 61 # SP -) MOVE \ function $3D 1 TRAP \ call GEMDOS LONG 8 SP ADDQ \ cleanup stack WORD D0 SP -) MOVE \ handle to stack NEXT END-CODE CODE F_CLOSE ( handle -- 0|errcode ) WORD 62 # SP -) MOVE \ function $3E 1 TRAP \ call GEMDOS LONG 4 SP ADDQ \ cleanup stack WORD D0 SP -) MOVE \ error code to stack NEXT END-CODE \ F_READ F_WRITE \ 11Dec89 b0b CODE F_READ ( ladr d1 handle -- d2|errcode ) WORD 63 # SP -) MOVE \ function $3F 1 TRAP \ call GEMDOS LONG 12. # SP ADDA \ cleanup stack LONG D0 SP -) MOVE \ bytes actually read NEXT END-CODE CODE F_WRITE ( ladr d1 handle -- d2|errcode ) WORD 64 # SP -) MOVE \ function $40 1 TRAP \ call GEMDOS LONG 12. # SP ADDA \ cleanup stack LONG D0 SP -) MOVE \ bytes actually written NEXT END-CODE \ .FILE FILE? \ 17:32 15Nov87 b0b : .FILE (S adr -- ) BEGIN DUP C@ ?DUP WHILE EMIT 1+ REPEAT DROP SPACE ; : FILE? (S -- ) FILE @ .FILE ; VOCABULARY DOS ( 10:05 6Nov87 bl ) DOS DEFINITIONS VARIABLE DISK-ERROR : DISK-ABORT (S fcb a n -- ) TYPE ." in " FILE? ." Error = " DISK-ERROR @ . DISK-ERROR OFF ABORT ; : ?DISK-ERROR (S n -- ) DUP 0< IF DISK-ERROR ! " Disk error" DISK-ABORT ELSE DROP THEN ; \ FCB stuff BLOCK I/O \ 15:43 14Nov87 b0b 44 CONSTANT B/FCB ( 0-31 = pathname ) CREATE FCB1 B/FCB ALLOT CREATE FCB2 B/FCB ALLOT : CLR-FCB (S fcb --) B/FCB ERASE ; : BLOCK# (S fcb -- adr ) 34 + ; : MAXBLK# (S fcb -- adr ) 38 + ; : RW-HANDLE (S fcb -- adr ) 40 + ; : HANDLE (S fcb -- handle ) 40 + @ ; : HA@ (S -- handle ) FILE @ HANDLE ; \ handle of FILE : HB@ (S -- handle ) IN-FILE @ HANDLE ; \ handle of IN-FILE \ BSEEK SET-RWADDR IN-RANGE? \ 11Dec89 b0b : BSEEK (S fcb -- fcb ) \ seek to BLOCK# DUP 0 OVER HANDLE \ fcb fcb 0 handle ROT BLOCK# @ 1024 UM* \ fcb 0 handle block*1k F_SEEK 2DROP ; : SET-RWADDR (S fcb adr -- daddr 1024. handle ) ADD-BASE ROT 1024. ROT HANDLE ; : IN-RANGE? (S fcb -- fcb ) DUP MAXBLK# @ 1- OVER BLOCK# @ U< DUP DISK-ERROR ! IF 1 BUFFER# ON " Out of Range" DISK-ABORT THEN ; \ Devices BLOCK I/O \ 11Dec89 b0b : BLOCK-READ (S d-addr 1024. handle --- ) F_READ NIP ?DISK-ERROR ; : BLOCK-WRITE (S d-addr 1024. handle --- ) F_WRITE NIP ?DISK-ERROR ; : SET-IO (S buf-header -- fcb buffer-addr ) DUP 2@ OVER BLOCK# ! IN-RANGE? BSEEK SWAP 4 + @ ( buf-addr ) ; : FILE-READ (S buffer-header -- ) SET-IO SET-RWADDR BLOCK-READ ; : FILE-WRITE (S buffer-header -- ) SET-IO SET-RWADDR BLOCK-WRITE ; : FILE-IO (S -- ) ['] FILE-READ IS READ-BLOCK ['] FILE-WRITE IS WRITE-BLOCK ; \ Devices BLOCK I/O \ 20:23 9Nov87 b0b FORTH DEFINITIONS : CAPACITY (S -- n ) [ DOS ] FILE @ MAXBLK# @ ; : LATEST? (S n fcb -- fcb n | a f ) DISK-ERROR OFF SWAP OFFSET @ + 2DUP 1 BUFFER# 2@ D= IF 2DROP 1 BUFFER# 4 + @ FALSE R> DROP THEN ; : ABSENT? (S n fcb -- a f ) LATEST? FALSE #BUFFERS 1+ 2 DO DROP 2DUP I BUFFER# 2@ D= IF 2DROP I LEAVE ELSE FALSE THEN LOOP ?DUP IF BUFFER# DUP >BUFFERS 8 CMOVE >R >BUFFERS DUP 8 + OVER R> SWAP - CMOVE> 1 BUFFER# 4 + @ FALSE ELSE >BUFFERS 2! TRUE THEN ; \ Devices BLOCK I/O \ 20:09 15Jun89 b0b : UPDATE (S -- ) >UPDATE ON ; : DISCARD (S -- ) 1 >UPDATE ! ( 1 BUFFER# ON ) ; : MISSING (S -- ) >END 2- @ 0< IF >END 2- OFF >END 8 - WRITE-BLOCK THEN >END 4 - @ >BUFFERS 4 + ! ( buffer ) 1 >BUFFERS 6 + ! >BUFFERS DUP 8 + #BUFFERS 8* CMOVE> ; : (BUFFER) (S n fcb -- a ) ABSENT? IF MISSING 1 BUFFER# 4 + @ THEN ; : BUFFER (S n -- a ) FILE @ (BUFFER) ; : (BLOCK) (S n fcb -- a ) (BUFFER) >UPDATE @ 0> IF 1 BUFFER# DUP READ-BLOCK 6 + OFF THEN ; : BLOCK (S n -- a ) FILE @ (BLOCK) ; : IN-BLOCK (S n -- a ) IN-FILE @ (BLOCK) ; \ 22:24 4Nov87 b0b \ Devices BLOCK I/O \ 15:45 14Nov87 b0b : EMPTY-BUFFERS (S -- ) FIRST LIMIT OVER - ERASE >BUFFERS #BUFFERS 1+ 8* ERASE FIRST 1 BUFFER# #BUFFERS 0 DO DUP ON 4 + 2DUP ! SWAP B/BUF + SWAP 4 + LOOP 2DROP ; : SAVE-BUFFERS (S -- ) 1 BUFFER# #BUFFERS 0 DO DUP @ 1+ IF DUP 6 + @ 0< IF DUP WRITE-BLOCK DUP 6 + OFF THEN 8 + THEN LOOP DROP ; : FLUSH (S -- ) SAVE-BUFFERS EMPTY-BUFFERS ; \ Devices BLOCK I/O \ 11Dec89 b0b DOS DEFINITIONS : FILE-SIZE (S fcb -- n ) \ returns file size in 1k blocks 2 SWAP HANDLE 0. F_SEEK 1024 M/MOD NIP ; : OPEN-FILE (S -- ) IN-FILE @ 2 OVER ADD-BASE F_OPEN DUP DISK-ERROR ! DUP 0< IF " Open error" DISK-ABORT THEN OVER RW-HANDLE ! DUP FILE-SIZE SWAP MAXBLK# ! ; HEX 080 CONSTANT DOS-FCB DECIMAL FORTH DEFINITIONS : DEFAULT (S -- ) [ DOS ] FCB1 DUP IN-FILE ! DUP FILE ! CLR-FCB DOS-FCB 1+ C@ IF DOS-FCB COUNT FCB1 SWAP CMOVE OPEN-FILE THEN ; \ $%? \ 0:57 4Nov87 b0b ASSEMBLER LABEL FAIL (S -- 0 ) SP -) CLR NEXT CODE $%? (S char -- base|0 ) WORD SP )+ D0 MOVE BYTE ASCII $ # D0 CMP 0= IF WORD 16 # SP -) MOVE NEXT THEN BYTE ASCII % # D0 CMP 0= IF WORD 2 # SP -) MOVE NEXT THEN FAIL BRA END-CODE \ Number Input DIGIT \ 0:26 4Nov87 b0b CODE DIGIT (S char base -- n true | char false ) WORD SP )+ D0 MOVE SP ) D1 MOVE BYTE 48 # D1 SUB FAIL BMI \ fail if char < ASCII 0 10 # D1 CMP 0>= \ if char is > 9 IF 17 # D1 CMP FAIL BMI \ fail if it's < "A" 7 D1 SUBQ \ adjust ASCII offset THEN \ (7 chars between 0 and A) D0 D1 CMP FAIL BPL \ fail if it's > BASE WORD D1 SP ) MOVE \ push the number TRUE # SP -) MOVE \ success flag NEXT END-CODE \ DOUBLE? CONVERT \ 23:13 3Nov87 b0b : DOUBLE? (S -- f ) DPL @ 1+ 0<> ; : CONVERT (S +d1 adr1 -- +d2 adr2 ) BEGIN 1+ DUP >R C@ BASE @ DIGIT \ S: d(low hi) n f WHILE SWAP \ S: low n hi BASE @ UM* DROP \ S: low n hi*base ROT BASE @ UM* \ S: d(n hi*base) d(low*base) D+ \ add 'em DOUBLE? IF DPL INC THEN R> REPEAT DROP R> ; \ Number Input (NUMBER?) \ 22:34 6Nov87 b0b : (NUMBER?) (S adr -- d flag ) -1 DPL ! \ no decimal places yet R: base BASE @ >R \ save base DUP 1+ C@ $%? ?DUP \ test for $ or % IF BASE ! 1+ THEN \ change to hex or binary DUP 1+ C@ ASCII - = \ S: adr flag(-) DUP >R - \ S: adr|adr+1 R: base flag(-) 0. ROT CONVERT \ convert string to # DUP C@ ASCII . = \ decimal point? IF 0 DPL ! CONVERT THEN \ yes, continue conversion -ROT R> IF DNEGATE THEN \ act on flag(-) R> BASE ! \ reset BASE ROT C@ BL = ; \ true means BL terminated \ NUMBER? (NUMBER) \ 10:47 30Nov87 b0b : NUMBER? (S adr -- d flag ) FALSE OVER COUNT BOUNDS ?DO I C@ BASE @ DIGIT NIP I C@ $%? OR IF DROP TRUE LEAVE THEN LOOP IF (NUMBER?) ELSE DROP 0. FALSE THEN ; : (NUMBER) (S adr -- d# ) NUMBER? NOT ?MISSING ; DEFER NUMBER \ Source code for $%?, NUMBER? and (NUMBER?) in OneForth \ is Copyright 1987 by Bob Lee \ # \ 20:21 30Oct87 b0b : HOLD (S char -- ) HLD DEC HLD @ C! ; : # ( +d1 -- +d2 ) 0 BASE @ UM/MOD >R BASE @ UM/MOD R> ROT 9 OVER < IF 7 + THEN ASCII 0 + HOLD ; \S \ Interactive Layer Number Output \ 24Apr87 b0b : <# (S -- ) PAD HLD ! ; : #> (S d# -- addr len ) 2DROP HLD @ PAD OVER - ; : SIGN (S n1 -- ) 0< IF ASCII - HOLD THEN ; : #S (S -- ) BEGIN # 2DUP OR 0= UNTIL ; : HEX (S -- ) 16 BASE ! ; : DECIMAL (S -- ) 10 BASE ! ; : DCX DECIMAL ; ( abbrev. ) \ Number Output \ 24Apr87 b0b : (U.) (S u -- a l ) 0 <# #S #> ; : U. (S u -- ) (U.) TYPE SPACE ; : U.R (S u l -- ) >R (U.) R> OVER - SPACES TYPE ; : (.) (S n -- a l ) DUP ABS 0 <# #S ROT SIGN #> ; : . (S n -- ) (.) TYPE SPACE ; : .R (S n l -- ) >R (.) R> OVER - SPACES TYPE ; : (D.) (S d -- a l ) TUCK DABS <# #S ROT SIGN #> ; : D. (S d -- ) (D.) TYPE SPACE ; : D.R (S d l -- ) >R (D.) R> OVER - SPACES TYPE ; ( UD. ) \S \ 20:03 9Nov87 b0b \ : (UD.) (S ud -- a l ) <# #S #> ; \ : UD. (S ud -- ) (UD.) TYPE SPACE ; \ : UD.R (S ud l -- ) >R (UD.) R> OVER - SPACES TYPE ; \ SKIP ( 16:51 6Nov87 bl ) ASSEMBLER LABEL DONE \ exit common to SKIP and SCAN LONG BASE A0 SUBA WORD A0 SP -) MOVE D1 SP -) MOVE NEXT END-CODE CODE SKIP (S adr1 len1 char -- adr2 len2 ) SP )+ D0 MOVE SP )+ D1 MOVE 1 D1 ADDQ SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA WORD BEGIN 1 D1 SUBQ 0<> WHILE BYTE A0 ) D2 MOVE D2 D0 CMP DONE BNE WORD 1 A0 ADDQ REPEAT DONE BRA END-CODE \ SCAN ( 16:49 6Nov87 bl ) CODE SCAN (S adr1 len1 char -- adr2 len2 ) SP )+ D0 MOVE SP )+ D1 MOVE 1 D1 ADDQ SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA WORD BEGIN 1 D1 SUBQ 0<> WHILE BYTE A0 ) D2 MOVE D2 D0 CMP DONE BEQ WORD 1 A0 ADDQ REPEAT DONE BRA END-CODE \ Parsing 02Apr84map ( 16:55 6Nov87 bl ) : /STRING (S addr len n -- addr' len' ) OVER MIN ROT OVER + -ROT - ; : PLACE (S str-addr len to -- ) 3DUP 1+ SWAP MOVE C! DROP ; : (SOURCE) (S -- addr len ) BLK @ ?DUP IF BLOCK B/BUF ELSE TIB #TIB @ THEN ; DEFER SOURCE \ Parsing 02Apr84map ( 16:57 6Nov87 bl ) : PARSE-WORD (S char -- addr len ) >R SOURCE TUCK >IN @ /STRING R@ SKIP OVER SWAP R> SCAN >R OVER - ROT R> DUP 0<> + - >IN ! ; : PARSE (S char -- addr len ) >R SOURCE >IN @ /STRING OVER SWAP R> SCAN >R OVER - DUP R> 0<> - >IN +! ; \ WORD Parsing \ 20:06 9Nov87 b0b : 'WORD (S -- adr ) HERE ; : WORD (S char -- addr ) PARSE-WORD 'WORD PLACE 'WORD DUP COUNT + BL SWAP C! ; ( Stick Blank at end ) : >TYPE (S adr len -- ) TUCK PAD SWAP CMOVE PAD SWAP TYPE ; \ .( ( (S \ \S \ 20:05 9Nov87 b0b : .( (S -- ) ASCII ) PARSE >TYPE ; IMMEDIATE : ( (S -- ) ASCII ) PARSE 2DROP ; IMMEDIATE : (S ( -- ) [COMPILE] ( ; IMMEDIATE 64 CONSTANT C/L 16 CONSTANT L/SCR : \ ( -- ) >IN @ NEGATE C/L MOD >IN +! ; IMMEDIATE : \S (S -- ) END? ON ; IMMEDIATE \ TRAVERSE Dictionary 03Jun84map ( 17:03 6Nov87 bl ) CODE TRAVERSE (S addr direction -- addr' ) SP )+ D0 MOVE SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA WORD D0 A0 ADDA BEGIN A0 ) 7 # BTST 0= WHILE D0 A0 ADDA REPEAT LONG BASE A0 SUBA WORD A0 SP -) MOVE NEXT END-CODE \ DONE? FORTH-83 03Jun84map ( 17:01 6Nov87 bl ) : DONE? (S n -- f ) STATE @ <> END? @ OR END? OFF ; : FORTH-83 (S -- ) FORTH DEFINITIONS CAPS OFF ; \ Dictionary Header words ( 15:59 10Oct87 bl ) : N>LINK 2- ; : L>NAME 2+ ; : BODY> 2- ; : NAME> 1 TRAVERSE 1+ ; : LINK> L>NAME NAME> ; : >BODY 2+ ; : >NAME 1- -1 TRAVERSE ; : >LINK >NAME N>LINK ; CODE HASH (S str-addr voc-ptr -- thread ) SP )+ D1 MOVE SP )+ D6 MOVE 0 D6.L BASE DI) A0 LEA BYTE A0 )+ TST A0 )+ D0 MOVE WORD 3 # D0 AND D0 D0 ADD D0 D1 ADD D1 SP -) MOVE NEXT END-CODE \ (FIND) ( 16:00 10Oct87 bl ) CODE (FIND) (S string link -- code true | adr false ) HEX D2 CLR SP )+ D7 MOVE BEGIN 0<> WHILE LONG 0 D7 BASE DI) A1 LEA WORD SP ) D6 MOVE 0 D6.L BASE DI) A0 LEA WORD A1 )+ TST BYTE A0 )+ D0 MOVE A1 )+ D1 MOVE D1 D2 MOVE D0 D1 EOR 3F # D1 AND ( mask flag bits ) 0= IF BEGIN A0 )+ D0 MOVE A1 )+ D1 MOVE D0 D1 EOR 0<> UNTIL 7F # D1 AND 0= ( found? ) WORD IF LONG BASE A1 SUBA WORD A1 SP ) MOVE 40 # D2 AND 0<> IF 1 # SP -) MOVE ELSE -1 # SP -) MOVE THEN NEXT THEN THEN LONG 0 D7 BASE DI) A1 LEA WORD A1 ) D7 MOVE REPEAT SP -) CLR NEXT END-CODE DECIMAL \ #THREADS FIND \ 21:08 22Nov87 b0b 4 CONSTANT #THREADS : FIND ( adr -- cfa flag | adr false ) DUP C@ IF PRIOR OFF FALSE #VOCS 0 DO DROP CONTEXT I 2* + @ DUP IF DUP PRIOR @ OVER PRIOR ! = IF DROP FALSE ELSE OVER SWAP HASH @ (FIND) DUP ?LEAVE THEN THEN LOOP ELSE DROP END? ON ['] NOOP 1 THEN ; \ ?UPPERCASE DEFINED \ 29Nov86 bl : ?UPPERCASE ( adr -- adr ) CAPS @ IF DUP COUNT BOUNDS ?DO I DUP C@ UPC SWAP C! LOOP THEN ; : DEFINED ( -- here 0 | cfa [ -1 | 1 ] ) BL WORD ?UPPERCASE FIND ; \ INTERPRET \ 21:15 22Nov87 b0b : ?STACK (S -- ) ( System dependant ) SP@ SP0 @ SWAP U< ABORT" Stack Underflow" SP@ PAD U< ABORT" Stack Overflow" ; : INTERPRET (S -- ) BEGIN ?STACK DEFINED IF EXECUTE ELSE NUMBER DOUBLE? NOT IF DROP THEN THEN FALSE DONE? UNTIL ; \ Extensible Layer Compiler \ 22:23 22Nov87 b0b : ALLOT (S n -- ) DP +! ; : , (S n -- ) HERE ! 2 ALLOT ; : C, (S char -- ) HERE C! 1 ALLOT ; : ALIGN HERE 1 AND IF BL C, THEN ; ( force word align DP ) : EVEN DUP 1 AND + ; ( make any number +even) : COMPILE (S -- ) R> DUP 2+ >R @ , ; : IMMEDIATE (S -- ) 64 ( Precedence bit ) LAST @ CSET ; \ LITERAL ASCII \ 22:05 22Nov87 b0b : LITERAL (S n -- ) COMPILE (LIT) , ; IMMEDIATE : DLITERAL (S d# -- ) SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE : ASCII (S -- n ) BL WORD 1+ C@ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE \S : CONTROL (S -- n ) BL WORD 1+ C@ 31 AND STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE \ Extensible Layer Compiler 08Oct83map: CRASH (S -- ) TRUE ABORT" Uninitialized execution vector." ; : ?MISSING (S f -- ) IF 'WORD COUNT TYPE TRUE ABORT" ?" THEN ; : ' (S -- cfa ) DEFINED 0= ?MISSING ; : ['] (S -- ) ' [COMPILE] LITERAL ; IMMEDIATE : [COMPILE] (S -- ) ' , ; IMMEDIATE : (") (S -- addr len ) R> COUNT 2DUP + EVEN >R ; : (.") (S -- ) R> COUNT 2DUP + EVEN >R TYPE ; : ," (S -- ) ASCII " PARSE TUCK 'WORD PLACE 1+ ALLOT ALIGN ; : ." (S -- ) COMPILE (.") ," ; IMMEDIATE : " (S -- ) COMPILE (") ," ; IMMEDIATE \ Interactive Layer Dictionary \ 15:16 22Nov87 b0b VARIABLE FENCE : TRIM (S faddr voc-addr -- | used by FORGET) #THREADS 0 DO 2DUP @ BEGIN 2DUP U> NOT WHILE @ REPEAT NIP OVER ! 2+ LOOP 2DROP ; : (FORGET) (S addr -- ) DUP FENCE @ U< ABORT" Below fence" DUP VOC-LINK @ BEGIN 2DUP U< WHILE @ REPEAT DUP VOC-LINK ! NIP BEGIN DUP WHILE 2DUP #THREADS 2* - TRIM @ REPEAT DROP DP ! ; : FORGET (S -- ) BL WORD ?UPPERCASE DUP CURRENT @ HASH @ (FIND) 0= ?MISSING ( >VIEW) >LINK (FORGET) ; \ Extensible Layer Compiler 11Mar84mapDEFER WHERE DEFER ?ERROR : (?ERROR) (S adr len f -- ) IF >R >R SP0 @ SP! PRINTING OFF BLK @ IF >IN @ BLK @ WHERE THEN R> R> SPACE TYPE SPACE QUIT ELSE 2DROP THEN ; : (ABORT") (S f -- ) R@ COUNT ROT ?ERROR R> COUNT + EVEN >R ; : ABORT" (S -- ) COMPILE (ABORT") ," ; IMMEDIATE : ABORT (S -- ) TRUE ABORT" " ; \ DEPTH PROMPT \ 21:06 22Nov87 b0b DEFER PROMPT : DEPTH ( -- n ) SP@ SP0 @ SWAP - 2/ ; HEX CREATE TM ACBF , 20 C, DECIMAL : CR.TM CR TM 3 TYPE ; \ Extensible Layer Structures 03Apr84map: ?CONDITION (S f -- ) NOT ABORT" Conditionals Wrong" ; : >MARK (S -- addr ) HERE 0 , ; : >RESOLVE (S addr -- ) HERE SWAP ! ; : <MARK (S -- addr ) HERE ; : <RESOLVE (S addr -- ) , ; : ?>MARK (S -- f addr ) TRUE >MARK ; : ?>RESOLVE (S f addr -- ) SWAP ?CONDITION >RESOLVE ; : ?<MARK (S -- f addr ) TRUE <MARK ; : ?<RESOLVE (S f addr -- ) SWAP ?CONDITION <RESOLVE ; : LEAVE COMPILE (LEAVE) ; IMMEDIATE : ?LEAVE COMPILE (?LEAVE) ; IMMEDIATE \ Extensible Layer Structures 01Oct83map: BEGIN ?<MARK ; IMMEDIATE : THEN ?>RESOLVE ; IMMEDIATE : DO COMPILE (DO) ?>MARK ; IMMEDIATE : ?DO COMPILE (?DO) ?>MARK ; IMMEDIATE : LOOP COMPILE (LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE ; IMMEDIATE : +LOOP COMPILE (+LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE ; IMMEDIATE : UNTIL COMPILE ?BRANCH ?<RESOLVE ; IMMEDIATE : AGAIN COMPILE BRANCH ?<RESOLVE ; IMMEDIATE : REPEAT 2SWAP [COMPILE] AGAIN [COMPILE] THEN ; IMMEDIATE : IF COMPILE ?BRANCH ?>MARK ; IMMEDIATE : ELSE COMPILE BRANCH ?>MARK 2SWAP ?>RESOLVE ; IMMEDIATE : WHILE [COMPILE] IF ; IMMEDIATE \ Extensible Layer Defining Word \ 22:27 23Nov87 b0b : "CREATE (S str -- ) COUNT HERE EVEN 2 + PLACE ALIGN HERE 0 , ( reserve link ) HERE LAST ! ( remember nfa ) HERE ( lfa nfa ) WARNING @ IF FIND IF CR HERE COUNT TYPE ." isn't unique " THEN DROP HERE THEN ( lfa nfa ) CURRENT @ HASH DUP @ ( lfa tha prev ) HERE 2- ROT ! ( lfa prev ) SWAP ! ( Resolve link field) HERE DUP C@ WIDTH @ MIN 1+ ALLOT ALIGN 128 SWAP CSET 128 HERE 1- CSET ( delimiter Bits ) COMPILE [ [FORTH] ASSEMBLER DOCREATE , META ] ; \ CREATE !CSP \ 22:11 22Nov87 b0b : CREATE (S -- ) BL WORD ?UPPERCASE "CREATE ; : !CSP (S -- ) SP@ CSP ! ; \ Extensible Layer Defining Words \ 10Nov86 bl : ?CSP (S -- ) SP@ CSP @ <> ABORT" Stack Changed" ; : HIDE (S -- ) LAST @ DUP N>LINK @ SWAP CURRENT @ HASH ! ; : REVEAL (S -- ) LAST @ DUP N>LINK SWAP CURRENT @ HASH ! ; : (;USES) (S -- ) R> @ LAST @ NAME> ! ; VOCABULARY ASSEMBLER : ;USES (S -- ) ?CSP COMPILE (;USES) [COMPILE] [ REVEAL ASSEMBLER ; IMMEDIATE : (;CODE) (S -- ) R> LAST @ NAME> ! ; : ;CODE (S -- ) ?CSP COMPILE (;CODE) [COMPILE] [ REVEAL ASSEMBLER ; IMMEDIATE HEX : DOES> (S -- ) COMPILE (;CODE) 4EAC , ( JSR dodoes[BASE] ) [ DECIMAL ] [ [ASSEMBLER] DODOES META ] LITERAL , ; IMMEDIATE \ Extensible Layer Defining Words 27Sep83map: [ (S -- ) STATE OFF ; IMMEDIATE : ] (S -- ) STATE ON BEGIN ?STACK DEFINED DUP IF 0> IF EXECUTE ELSE , THEN ELSE DROP NUMBER DOUBLE? IF [COMPILE] DLITERAL ELSE DROP [COMPILE] LITERAL THEN THEN TRUE DONE? UNTIL ; : : (S -- ) !CSP CURRENT @ CONTEXT ! CREATE HIDE ] ;USES NEST , : ; (S -- ) ?CSP COMPILE UNNEST REVEAL [COMPILE] [ ; IMMEDIATE \ Extensible Layer Defining Words 03Apr84map: RECURSIVE (S -- ) REVEAL ; IMMEDIATE : CONSTANT (S n -- ) CREATE , ;USES DOCONSTANT , : VARIABLE (S -- ) CREATE 0 , ;USES DOCREATE , : DEFER (S -- ) CREATE ['] CRASH , ;USES DODEFER , DODEFER RESOLVES <DEFER> : VOCABULARY (S -- ) CREATE #THREADS 0 DO 0 , LOOP HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; RESOLVES <VOCABULARY> : DEFINITIONS (S -- ) CONTEXT @ CURRENT ! ; \ Extensible Layer Defining Word \ 22:41 6Nov87 b0b : 2CONSTANT CREATE , , (S d# -- ) DOES> 2@ ; (S -- d# ) DROP : 2VARIABLE 0 0 2CONSTANT (S -- ) DOES> ; (S -- addr ) DROP VARIABLE AVOC : CODE (S -- ) CREATE HIDE HERE DUP 2- ! CONTEXT @ AVOC ! ASSEMBLER ; ASSEMBLER DEFINITIONS : END-CODE AVOC @ CONTEXT ! REVEAL ; FORTH DEFINITIONS META IN-META \ Extensible Layer Defining Word \ 14:55 22Nov87 b0b VARIABLE #USER VOCABULARY USER USER DEFINITIONS : ALLOT (S n -- ) #USER +! ; ' CREATE ( avoid recursion: leave address for , in CREATE ) : CREATE (S -- ) [ , ] #USER @ , ;USES DOUSER-VARIABLE , : VARIABLE (S -- ) CREATE 2 ALLOT ; : DEFER (S -- ) VARIABLE ;USES DOUSER-DEFER , FORTH DEFINITIONS META IN-META \ USERMODE SUPERMODE \ 14:59 22Nov87 b0b VARIABLE SAVE-SSP 2 ALLOT : SUPERMODE ( -- ) \ set 68000 to Supervisor mode 0. 32 TRAP1 SAVE-SSP 2! 3DROP ; : USERMODE ( -- ) \ reset 68000 to User mode SAVE-SSP 2@ 32 TRAP1 4DROP 0. SAVE-SSP 2! ; \ IS \ 15:01 22Nov87 b0b : >IS (S cfa -- data-address ) DUP @ DUP [ [ASSEMBLER] DOUSER-VARIABLE META ] LITERAL = SWAP DUP [ [ASSEMBLER] DOUSER-DEFER META ] LITERAL = SWAP DROP OR IF >BODY @ UP @ + ELSE >BODY THEN ; : (IS) (S cfa --- ) R@ @ >IS ! R> 2+ >R ; : IS (S cfa --- ) STATE @ IF COMPILE (IS) ELSE ' >IS ! THEN ; IMMEDIATE \ RUN QUIT \ 21:16 22Nov87 b0b : RUN ( -- ) STATE @ IF ] STATE @ NOT IF INTERPRET THEN ELSE INTERPRET THEN ; : QUIT ( -- ) SP0 @ 'TIB ! BLK OFF [COMPILE] [ BEGIN RP0 @ RP! QUERY RUN STATE @ NOT IF PROMPT THEN AGAIN ; \ Initialization High Level \ 29Nov86 bl : START EMPTY-BUFFERS SUPERMODE DEFAULT ; DEFER BOOT : WARM (S -- ) TRUE ABORT" Warm Start" ; HEX : COLD (S -- ) ( don't reset link if already linked ) ENTRY @ 4E47 - IF 4E47 ENTRY ! ENTRY ADD-BASE LINK 2! THEN BOOT QUIT ; DECIMAL \ (LOAD) LOAD \ 2Jan87 bl DEFER LOAD : (LOAD) ( n -- ) DUP . #OUT @ 74 > IF CR THEN FILE @ >R BLK @ >R >IN @ >R >IN OFF ( n) BLK ! IN-FILE @ FILE ! RUN R> >IN ! R> BLK ! R> DUP FILE ! IN-FILE ! ; \ OK BYE \ 11Dec89 b0b : OK (S -- ) 1 LOAD ; CODE P_TERM0 ( -- ) \ clean GemDos terminate command SP -) CLR 1 TRAP END-CODE : BYE ( -- ) HB@ 5 > IF HB@ F_CLOSE DROP THEN \ close FCB1 file HA@ 5 > IF HA@ F_CLOSE DROP THEN \ close FCB2 file SAVE-SSP 2@ OR IF USERMODE THEN \ be certain of user mode P_TERM0 ; \ WARM ENTRY POINT \ 22Apr87 b0b [ASSEMBLER] HERE ORIGIN - 2- ORIGIN 6 + !-T ( WARM ENTRY POINT ) LONG ' WARM 0 # W MOVE 0 W.L BASE DI) D6.W MOVE ( EXECUTE ) 0 D6.L BASE DI) JMP \ Initialization Low Level \ 19:41 9Nov87 b0b HERE ORIGIN - 2- ORIGIN 2 + !-T ( COLD ENTRY POINT ) SP IP LMOVE LONG 4 IP D) BASE MOVE LONG >BUFFERS 0 # RP MOVE LONG BASE RP ADDA ( form RP ) RP SP LMOVE LONG 256 0 # SP SUBA WORD ( set SP ) LONG D6 CLR WORD ( hi-half MUST ALWAYS be zero!! ) HEX LONG 10000. # SP -) MOVE BASE SP -) LMOVE D6.W SP -) MOVE 4A # SP -) MOVE 1 TRAP DECIMAL LONG 4 SP ADDQ SP )+ BASE LMOVE LONG 4 SP ADDQ >NEXT DELTA-T PCD) A3 LEA ( set address of NEXT ) LONG ' COLD 0 # W MOVE ( initial word addr ) 0 W.L BASE DI) D6.W MOVE ( EXECUTE ) 0 D6.L BASE DI) JMP \ Initialize User Variables \ 19:42 9Nov87 b0b HERE UP !-T ( SET UP USER AREA ) 0 , 0 , ( TOS ) 0 , ( ENTRY ) 0 , 0 , ( LINK ) >BUFFERS 256 - , ( SP0 ) >BUFFERS , ( RP0 ) 0 , ( DP ) ( Must be patched later ) 0 , ( #OUT ) 0 , ( #LINE ) 0 , ( OFFSET ) 10 , ( BASE ) 0 , ( HLD ) 0 , ( FILE ) 0 , ( IN-FILE ) FALSE , ( PRINTING ) ' (EMIT) , ( EMIT ) \ 29Nov86 bl \ .S .ID \ 11Dec89 b0b : .S (S -- ) DEPTH ?DUP IF 1- 0 SWAP DO I PICK U. -1 +LOOP ELSE ." Stack Empty " THEN ; : .ID (S nfa -- ) DUP 1+ DUP C@ ROT C@ 31 AND 0 ?DO DUP 127 AND EMIT 128 AND IF ASCII _ 128 OR ELSE 1+ DUP C@ THEN LOOP 2DROP SPACE ; \ DUMP \ 15:49 14Nov87 b0b \S : DUMP (S addr len -- ) BASE @ -ROT HEX 0 DO CR DUP U. 16 0 DO DUP C@ 3 .R 1+ LOOP 16 +LOOP DROP BASE ! ; \ RECURSE IBOOT \ 21:06 22Nov87 b0b : RECURSE (S -- ) LAST @ NAME> , ; IMMEDIATE : IBOOT (S -- ) \ initial boot sequence CR TM 2 TYPE ." Kernel" CR START PROMPT ; \S ' START IS BOOT will crash the system! I think that's because the boot word must be the highest word in the system. \ Resolve Forward References 21Dec83map ' (.") RESOLVES <(.")> ' (") RESOLVES <(")> ' (;CODE) RESOLVES <(;CODE)> ' (;USES) RESOLVES <(;USES)> ' (IS) RESOLVES <(IS)> ' (ABORT") RESOLVES <(ABORT")> [ASSEMBLER] DOCREATE META RESOLVES <VARIABLE> [ASSEMBLER] DOUSER-DEFER META RESOLVES <USER-DEFER> [ASSEMBLER] DOUSER-VARIABLE META RESOLVES <USER-VARIABLE> \ Resolve Forward References ( 16:03 10Oct87 bl ) ' SWAP RESOLVES SWAP ' DEFINITIONS RESOLVES DEFINITIONS ' + RESOLVES + ' OVER RESOLVES OVER ' [ RESOLVES [ ' 2+ RESOLVES 2+ ' 1+ RESOLVES 1+ ' 2* RESOLVES 2* ' 2DUP RESOLVES 2DUP ' ?MISSING RESOLVES ?MISSING \ ' RUN RESOLVES RUN ' ABORT RESOLVES ABORT ' QUIT RESOLVES QUIT ' . RESOLVES . \ Initialize DEFER words \ 11Dec89 b0b ' (LOAD) IS LOAD ' C_CONIS IS KEY? ' (KEY) IS KEY ' CRLF IS CR ' FILE-READ IS READ-BLOCK ' FILE-WRITE IS WRITE-BLOCK ' NOOP IS WHERE ' (SOURCE) IS SOURCE ' (NUMBER) IS NUMBER ' (CHAR) IS CHAR ' (DEL-IN) IS DEL-IN ' (?ERROR) IS ?ERROR ' CR.TM IS PROMPT ' IBOOT IS BOOT \ Initialize Variables 20Apr84map' FORTH >BODY CURRENT !-T ' FORTH >BODY CONTEXT !-T ' CC-FORTH >BODY CC !-T HERE-T DP UP @-T + !-T ( INIT USER DP ) #USER-T @ #USER !-T ( INIT USER VAR COUNT ) TRUE CAPS !-T ( SET TO IGNORE CASE ) TRUE WARNING !-T ( SET TO ISSUE WARNINGS ) 31 WIDTH !-T ( 31 CHARACTER NAMES ) VOC-LINK-T @ VOC-LINK !-T ( INIT VOC-LINK ) \ save NUKERNEL.TTP \ 17:33 30Oct87 b0b HEX CR .( Unresolved references: ) CR .UNRESOLVED CR .( Statistics: ) CR .( Last Host Address: ) [FORTH] HERE U. CR .( First Target Code Address: ) META 100 THERE U. CR .( Last Target Code Address: ) META HERE-T THERE U. CR CR DOS HERE-T 0E8 !-T META 100 THERE HERE-T 100 + ONLY FORTH ALSO DOS SAVE KERNEL.TTP FORTH CR .( Now return to desktop and double-click KERNEL.TTP ) CR KEY DROP BYE