-
Notifications
You must be signed in to change notification settings - Fork 2
/
EXTEND
executable file
·1 lines (1 loc) · 27 KB
/
EXTEND
1
\ EXTEND \ 14:38 15Nov87 b0b Extensions to the kernel are necessary for a workable Forth environment. One/Forth ( Load Screen to Bring up Standard System \ 20:17 15Jun89 b0b For system without editor, load from screen 15 ) FORGET IBOOT \ IBOOT won't be needed WARNING OFF .( Loading system extensions.) 3 LOAD CR .( Loading GEMDOS interface.) 18 LOAD CR .( Loading source management system.) 6 LOAD CR FROM ASSEMBLR.F83 1 LOAD \ the 68000 assembler WARNING ON FROM TOOLS 1 LOAD \ tools and utilities FROM EDITOR.BLK 1 LOAD --> \ the editor \ FROM STARLIST.BLK 1 LOAD --> \ Gemini 10 LISTING \ Load up the system \ 21:01 15Jun89 b0b : HELLO (S -- ) CR 35 SPACES TM 3 TYPE ." with editor" CR PROMPT \ initial prompt 27 EMIT ASCII v EMIT \ turn on line-wrap START ; ' HELLO IS BOOT HERE FENCE ! ONLY FORTH ALSO DEFINITIONS SAVE-SYSTEM ED1FORTH.TTP CR .( System saved as ED1FORTH.TTP) CR .( Size = $) HEX HERE U. DECIMAL ( Loading Words 11/13/85 plm \ 20:12 9Nov87 b0b ) : ? @ . ; ( : U? @ U. ; : C? C@ . ;) : ?ENOUGH (S n -- ) DEPTH 1- > ABORT" Not enough Parameters" ; : THRU (S n1 n2 -- ) 2 ?ENOUGH 1+ SWAP ?DO I LOAD LOOP ; : +THRU (S n1 n2 -- ) BLK @ + SWAP BLK @ + SWAP THRU ; : --> (S -- ) >IN OFF BLK INC ; IMMEDIATE 1 2 +THRU ( Rest of Basic Utilities ) \ The ALSO and ONLY Concept 07Feb84map CONTEXT DUP @ SWAP 2+ ! ( Make FORTH also ) VOCABULARY ROOT ROOT DEFINITIONS : ALSO (S -- ) CONTEXT DUP 2+ #VOCS 2- 2* CMOVE> ; : ONLY (S -- ) ['] ROOT >BODY CONTEXT #VOCS 1- 2* 2DUP ERASE + ! ROOT ; : SEAL (S -- ) ' >BODY CONTEXT #VOCS 2* ERASE CONTEXT ! ; : PREVIOUS (S -- ) CONTEXT DUP 2+ SWAP #VOCS 2- 2* CMOVE CONTEXT #VOCS 2- 2* + OFF ; \ The ALSO and ONLY Concept 18jan86plm : FORTH FORTH ; : DEFINITIONS DEFINITIONS ; : ORDER (S -- ) CR ." Context: " CONTEXT #VOCS 0 DO DUP @ ?DUP IF BODY> >NAME .ID THEN 2+ LOOP DROP CR ." Current: " CURRENT @ BODY> >NAME .ID ; : VOCS (S -- ) VOC-LINK @ BEGIN DUP #THREADS 2* - BODY> >NAME .ID #OUT @ 64 > IF CR THEN @ DUP 0= UNTIL DROP ; ONLY FORTH ALSO DEFINITIONS \ Load Screen for DOS Interface \ 21:54 31Oct87 b0b : !FILES ( fcb -- ) DUP FILE ! IN-FILE ! ; : UPPER ( addr len -- ) BOUNDS ?DO I DUP C@ UPC SWAP C! LOOP ; DOS DEFINITIONS 7 14 THRU FORTH DEFINITIONS \S The GEMDOS interface consists of a set of words that access the GEMDOS functions such as making, opening, and deleting files. There is also a word that parses a string and creates a file control block. Finally the word SAVE can be used to save the contents of memory as a GEMDOS file. \ DOS Interface \ 15:27 7Nov87 b0b \ READ & WRITE \ 14 \ 6Feb90 b0b : (WRITE) (S addr count fcb -- dcount ) >R >R ADD-BASE R> 0 R> HANDLE f_write DUP ABORT" Write error" ; : FSEEK (S mode dcount fcb -- filepointer ) HANDLE -ROT f_seek ; \ Create File Control Blocks \ 15:52 31Oct87 b0b : MAKE-FILE (S fcb -- ) 0 OVER ADD-BASE ( Attribute word = 0 = std. r/w file ) 60 GEMDOS >R 3DROP R> DUP 0< ABORT" Can't MAKE File " SWAP RW-HANDLE ! ; : !FCB (S FCB-addr | put filename into cleared fcb ) DUP CLR-FCB BL WORD COUNT CAPS @ IF 2DUP UPPER THEN ROT SWAP CMOVE ; \ Save a Core Image as a File on Disk \ 11Dec89 b0b DEFER HEADER HEX : 68K-HEADER ( ADR LEN -- ADR-28 LEN+28 ) 1C + SWAP 1C - SWAP OVER DUP 1C ERASE 601A OVER ! 4 + HERE OVER ! 14 + 100 OVER ! 2+ ON ; DECIMAL ' 68K-HEADER IS HEADER : SAVE (S Addr len --- ) FCB2 !FCB FCB2 MAKE-FILE HEADER FCB2 (WRITE) 2DROP HB@ f_close DROP ; FORTH DEFINITIONS : MORE (S #blocks -- ) [ DOS ] 1 ?ENOUGH CAPACITY SWAP DUP FILE @ MAXBLK# +! BOUNDS ?DO I BUFFER B/BUF BLANK UPDATE FLUSH LOOP HA@ f_close DROP ; : CREATE-FILE (S #blocks -- ) [ DOS ] FCB2 !FILES FCB2 !FCB FCB2 MAKE-FILE MORE ; FORTH DEFINITIONS \ 22:08 6Dec89 b0b : DRIVE? (S -- ) d_getdrv ASCII A + EMIT ASCII : EMIT ; : A: (S -- ) 0 d_setdrv ; : B: (S -- ) 1 d_setdrv ; : C: (S -- ) 2 d_setdrv ; : D: (S -- ) 3 d_setdrv ; DOS DEFINITIONS \ 22:17 31Oct87 b0b : FILE: (S -- fcb ) >IN @ CREATE >IN ! HERE DUP B/FCB ALLOT !FCB DOES> !FILES ; : ?DEFINE (S -- fcb ) >IN @ DEFINED IF NIP >BODY ELSE DROP >IN ! FILE: THEN ; : FRESET 0 0. FILE @ FSEEK 2DROP ; FORTH DEFINITIONS \ 22:10 6Dec89 b0b : DEFINE (S -- ) [ DOS ] ?DEFINE DROP ; : OPEN ( -- ) [ DOS ] \ HB@ 5 > HA@ HB@ <> AND IF HB@ f_close DROP THEN HA@ 5 > IF HA@ f_close DROP THEN ?DEFINE !FILES OPEN-FILE FRESET ; : FROM (S -- ) [ DOS ] HA@ HB@ <> IF HB@ f_close DROP THEN ?DEFINE IN-FILE ! OPEN-FILE ; : SAVE-SYSTEM (S -- ) [ DOS HEX ] 100 HERE SAVE ; DECIMAL \ DEPTH| \ 18:54 22Nov87 b0b : .DEPTH ( -- ) \ the DEPTH prompt CR DEPTH . BS EMIT BASE @ 16 = IF ASCII $ ELSE ASCII | THEN EMIT ; ' .DEPTH IS PROMPT \ a more informative prompt ( Load Screen creates a FORTH-83 System \ 20:22 15Jun89 b0b with assembler but without the editor. ) FORGET IBOOT \ IBOOT won't be needed WARNING OFF .( Loading system extensions.) 3 LOAD CR .( Loading GEMDOS interface.) 18 LOAD CR .( Loading source management system.) 6 LOAD CR FROM ASSEMBLR.F83 1 LOAD \ the 68000 assembler FROM TOOLS 11 LOAD \ H. B. FROM TOOLS 2 LOAD \ LIST, INDEX, WORDS \ FROM TOOLS 36 LOAD \ the multitasker --> \ Load up the system \ 21:20 22Nov87 b0b : HELLO (S -- ) CR 30 SPACES TM 3 TYPE ." for the Atari ST" CR PROMPT \ the initial prompt 27 EMIT ASCII v EMIT \ turn on line-wrap START ; ' HELLO IS BOOT HERE FENCE ! WARNING ON ONLY FORTH ALSO DEFINITIONS SAVE-SYSTEM 1FORTH.TTP CR .( System saved as 1FORTH.TTP ) CR .( Size = $) HEX HERE U. DECIMAL \ 4Mar87 bl \ GDOS: \ 10:07 30Nov87 b0b \ This source module Copyright 1987 by Bob Lee VARIABLE DOSTEMP : GDOS: (s retsize #params func# -- ) CREATE C, 1+ C, \ struct contains func#, #params+1, 2 - ABS C, \ & # of return words to drop DOES> (s n1...nx -- retval ) DUP 1+ @ DOSTEMP ! \ DOSTEMP contains #params, retsize C@ TRAP1 >R >R \ do the trap1, stash return value DOSTEMP C@ DROPS \ cleanup params, including func# R> R> \ long return value on stack DOSTEMP 1+ C@ \ retsize 2 - ABS DROPS ; \ effectively 2DROP, DROP, or NOOP 1 5 +THRU \ load the GEMDOS words HEX \ GEMDOS $01-$0E \ 11Dec89 b0b 2 0 01 GDOS: c_conin ( -- char scan ) 0 1 02 GDOS: c_conout ( char -- ) 1 0 03 GDOS: c_auxin ( -- n ) 0 1 04 GDOS: c_auxout ( char -- ) 1 1 05 GDOS: c_prnout ( char -- flag ) 1 1 06 GDOS: c_rawio ( byte -- char|flag ) 2 0 07 GDOS: c_rawcin ( -- char scan ) \ 2 0 08 GDOS: c_necin ( -- char scan ) 0 2 09 GDOS: c_conws ( ladr -- ) 0 2 0A GDOS: c_conrs ( ladr -- ) \ 1 0 0B GDOS: c_conis ( -- flag ) 1 1 0E GDOS: d_setdrv ( drive -- bitmap ) DECIMAL HEX \ GEMDOS $10-$2D \ 21:15 6Dec89 b0b 1 0 10 GDOS: c_conos ( -- flag ) 1 0 11 GDOS: c_prnos ( -- flag ) 1 0 12 GDOS: c_auxis ( -- flag ) 1 0 13 GDOS: c_auzos ( -- flag ) 1 0 19 GDOS: d_getdrv ( -- drive ) 0 2 1A GDOS: f_setdta ( ladr -- ) 2 2 20 GDOS: _super ( ladr -- ladr' ) 0 2 20 GDOS: _user ( ladr -- ) 1 0 2A GDOS: t_getdate ( -- %yyyyyyymmmmddddd ) 0 1 2B GDOS: t_setdate ( %yyyyyyymmmmddddd -- ) 1 0 2C GDOS: t_gettime ( -- %hhhhhmmmmmmsssss ) 0 1 2D GDOS: t_settime ( %hhhhhmmmmmmsssss -- ) DECIMAL HEX \ GEMDOS $2F-$40 \ 11Dec89 b0b 2 0 2F GDOS: f_getdta ( -- ladr ) 1 0 30 GDOS: s_version ( -- version ) 0 3 31 GDOS: p_termres ( code d -- ) 0 3 36 GDOS: d_free ( drive ladr -- ) 1 2 39 GDOS: d_create ( ladr -- 0|err ) 1 2 3A GDOS: d_delete ( ladr -- 0|err ) 1 2 3B GDOS: d_setpath ( ladr -- 0|err ) 1 3 3C GDOS: f_create ( attr ladr -- handle|err ) \ 1 3 3D GDOS: f_open ( mode ladr -- handle|err ) \ 1 1 3E GDOS: f_close ( handle -- 0|err ) \ 2 5 3F GDOS: f_read ( ladr d1 handle -- d2|err ) \ 2 5 40 GDOS: f_write ( ladr d2 handle -- d2|err ) DECIMAL HEX \ GEMDOS $41-$4C \ 11Dec89 b0b 1 2 41 GDOS: f_delete ( ladr -- 0|err ) \ 2 4 42 GDOS: f_seek ( mode handle d1 -- d2 ) 1 4 43 GDOS: f_attrib ( att mode ladr -- att|err ) 1 1 45 GDOS: f_dup ( handle1 -- handle2|err ) 1 2 46 GDOS: f_force ( handle1 handle2 -- 0|err ) 1 3 47 GDOS: d_getpath ( drive ladr -- 0|err ) 2 2 48 GDOS: m_alloc ( d1 -- d2|err ) 1 2 49 GDOS: m_free ( ladr -- 0|err ) 1 5 4A GDOS: m_shrink ( d ladr 0 -- 0|err ) 2 7 4B GDOS: p_exec ( ladr1 ladr2 ladr3 mode -- d|err ) 0 1 4C GDOS: p_term ( code -- ) DECIMAL HEX \ GEMDOS $4E-$57 \ 21:22 6Dec89 b0b 1 3 4E GDOS: f_sfirst ( attr ladr -- 0|err ) 1 0 4F GDOS: f_snext ( -- 0|err ) 1 5 56 GDOS: f_rename ( ladr1 ladr2 0 -- 0|err ) 1 4 57 GDOS: f_datime ( flag handle ladr -- 0|err ) DECIMAL : PATH ( -- ladr ) \ a convenience to create a pathname at PAD BL WORD COUNT PAD OVER 1+ ERASE PAD SWAP CMOVE PAD ADD-BASE ; \S Usage: 0 PATH \FORTH\TRIDENT.ACK MAKE HA ! Creates a file and puts its handle in the variable HA.