\ Include.blk 06Sep88pJa Allows loading of (converted) Amiga include files. The include files are in a format suitable to use them with A4th. Some differences are noted in the file i/names. Which also addresses some other problems. Several macro's are not in- cluded. Note that the include files once loaded take 84k Could load all of the include files and still define a few windows. \ Load screen for making include files. 14Jun88pJawarning off 4 8 thru ( infix parser ) 12 load ( text file loading ) 21 load ( structure definitions ) warning on \ (spare) 19Jun88pJa \ Hex number conversion 16Mar88pJa: $number? (s adr -- d f ) count false -rot >r tuck r> bounds ?do i c@ base @ digit nip if drop true leave then loop if (number?) else drop 0 0 false then ; : ($number) (s adr -- d ) dup 1+ c@ ascii $ = if base @ swap hex $number? >r rot base ! r> else number? then not ?missing ; ' ($number) is number \ Recursive infix number parsing. 15Jun88pJavocabulary text only forth also text definitions variable symbols> variable insymbol defer expression : letter? (s char -- f ) dup ascii a ascii z between over ascii _ = or over ascii . = or swap ascii A ascii Z between or ; : digit? (s char -- f ) base @ digit nip ; : symbol (s -- char ) symbols> @ insymbol @ dup if - c@ else 2drop 0 then ; : readsymbol (s -- ) insymbol @ if -1 insymbol +! then ; : 'symbol (s -- adr ) symbols> @ insymbol @ - ; : startsymbols (s adr len -- ) dup insymbol ! + symbols> ! ; \ recursive infix parsing. 19Mar88pJa: getchar (s -- char ) symbol readsymbol symbol ascii ' <> abort" ' expected. " readsymbol ; : getnumber (s -- n ) symbol ascii $ = if hex readsymbol then 'symbol 1 begin readsymbol symbol digit? while 1+ repeat here place 0 here count + c! here number drop decimal ; : identifier (s -- n ) 'symbol 1 begin readsymbol symbol digit? symbol letter? or while 1+ repeat here place 0 here count + c! here find 0= if here count type ." undeclared identifier." abort then execute ; \ recursive infix parsing. 19Mar88pJa: getconstant (s -- n ) symbol ascii ' = if readsymbol getchar else symbol letter? if identifier else symbol ascii $ = symbol digit? or if getnumber then then then ; : factor2 (s -- n ) symbol ascii ( = if readsymbol expression symbol ascii ) <> abort" closing ) missing" readsymbol else getconstant then ; : factor1 (s -- n ) symbol ascii - = if readsymbol factor2 negate else symbol ascii ~ = if readsymbol factor2 not else factor2 then then ; \ recursive infix parsing. 19Mar88pJa: factor (s -- n ) recursive factor1 symbol ascii < = if readsymbol readsymbol factor << else symbol ascii > = if readsymbol readsymbol factor >> then then ; : term (s -- n ) recursive factor symbol ascii & = if readsymbol term and else symbol ascii ! = if readsymbol term or then then ; \ recursive infix parser. 15Jun88pJa: simple-ex recursive term symbol ascii * = if readsymbol simple-ex * else symbol ascii / = if readsymbol simple-ex / then then ; : (expression) simple-ex symbol ascii + = if readsymbol expression + else symbol ascii - = if readsymbol expression - then then ; ' (expression) is expression only forth also definitions : evaluate (s adr len -- n ) [ text ] startsymbols expression ; forth \ : test \ tib #tib @ >in @ /string bl skip evaluate #tib off ; \ (spare) 19Jun88pJa \ (spare) 19Jun88pJa \ (spare) 19Jun88pJa \ Text file handling. 19Jun88pJaonly forth also definitions 1 7 +thru cr .( Textfile handling loaded ) only forth also definitions \s Amiga Dos has some features not used in the kernel. When opening a file a Lock is a quick way of finding it and get-ting the size. Afterwards it needs to be opened. A filename specified is saved in a bit of Allocated memory, to be forgottenafter the file is used. The buffer to extract lines is also a temporary thing. This buffer can also be used to extract directory info, or disk info. All this to enable loading the Include files. And also to show text files, possibly to Import the text files into a blocked file. Sample useage would be : tload i:exec/nodes or: ttype df0:include/libraries/dosextens.h \ allocating resources. 15Jun88pJatext definitions also : 'name does> @ ; 'name 0 is 'name : 'buffer does> @ ; 'buffer 0 is 'buffer 512 constant bufmax : relbuffs [ Exec ] 'name ?dup if 108 FreeMem then 'buffer ?dup if bufmax FreeMem then 0 is 'name 0 is 'buffer ; : nomem? (s addr -- ) 0= if cr ." No Memory left!@#" relbuffs abort then ; : get'name [ Exec ] 0 108 AllocMem dup nomem? is 'name ; : get'buffer [ Exec ] 0 bufmax AllocMem dup nomem? is 'buffer ; : getbuffs get'name get'buffer ; \ locking and unlocking. 14Jun88pJaonly forth also Dos definitions -2 constant ACCES_READ >Dos ^ -84 (r d2 d1 r) Lock (s type name -- Lock ) >Dos -90 (r d1 r) UnLock (s Lock -- ) only forth also Dos also text also definitions variable lock variable handle : getname getbuffs bl word count dup >r 'name swap move 0 'name r> + c! ; : getlock ACCES_READ 'name Lock lock ! ; : unlock lock @ UnLock lock off ; : gethandle 1005 'name Open handle ! ; : unhandle handle @ Close handle off ; \ managing the buffer. 890119kel 10 constant LF variable >line variable ll variable #buffer variable lineno : line (s -- adr ) 'buffer >line @ + ; : #>end (s -- n ) #buffer @ >line @ - ; : binit (s -- ) >line off ll off #buffer off ; : llen (s -- n ) ll @ ; \ filling the buffer. 890119kel : fillit (s -- ) 0 #>end negate handle @ Seek drop bufmax 'buffer handle @ Read #buffer ! >line off ; : ?fillit (s -- ) #>end 0<= line #>end LF scan nip 0= or if fillit then ; : getline (s -- ) llen >line +! ?fillit line #>end LF scan LF skip nip #>end swap - ll ! 1 lineno +! ; \ opening and closing 890119kel : <text lineno off >in @ getname getlock lock @ 0= if >in ! bl word count type ." ??" relbuffs abort else drop binit gethandle then ; : text> unhandle unlock relbuffs ; : -filter (s adr len -- ) 1- bounds swap ?do i c@ LF = if bl i c! else leave then -1 +loop ; : tsource (s -- adr len ) line llen ; \ redefine ?error so (source) will be restored 890119kel : t?error (s addr len f -- ) if ['] (source) is source ['] (?error) is ?error >r >r sp0 @ sp! r> r> space type ." occured at file '" 'name dup a"count type ." ' line " lineno @ . blk @ if >in @ blk @ where then quit else 2drop then ; \ textfiles typing and loading. 890119kel forth definitions : more? (s -- fl | t=cont ) -1 key? if key 13 = if not else key 13 = if not then then then ; : ttype \ filename [ text ] <text begin getline llen more? and while line llen type repeat text> ; : tload \ filename (s -- ) >in @ defined nip if drop exit else dup >in ! 0 constant >in ! then [ text ] <text >in @ >r ['] tsource is source ['] t?error is ?error begin getline >in off bl line llen 2dup -filter + 1- c! run llen 0= until text> r> >in ! ['] (source) is source ['] (?error) is ?error ; \ (spare) 19Jun88pJa \ load screen for structure support 06Aug88pJaonly forth also definitions 1 7 +thru cr .( structure support loaded ) only forth also definitions \s Structures are small local words defined with the aid of the words defined in the next few screens. Each structure has a pointer to the start of the linked list of local words. The use of the structure will put this pointer in a special variable, which is then used to look for defined words. That way names can be re-used in different structures. \ Creating and finding local words. 06Sep88pJavariable scontext 0 scontext ! : s"create (s str -- ) count here even 4+ place align here scontext @ , scontext ! here dup last ! dup c@ width @ min 2dup + -rot 1+ allot align 128 swap cset 128 swap cset compile noop ; : screate bl word s"create ; : sdefined (s -- here 0| cfa -1|1 ) bl word scontext @ (find) ?dup 0= if ?uppercase find then ; ' sdefined is defined : forget ( word (s -- ) [ here 4- ] >in @ defined rot >in ! if dup fenced swap [ rot ] literal <= and if ['] (defined) is defined then else drop then scontext off forget ; \ Structures 06Sep88pJavariable soffset defer s@ ' @ is s@ defer s! ' ! is s! : {s (s -- ) create here 0 0 w, , 0 soffset ! 0 scontext ! does> (s -- pfa ) create dup 2+ @ , w@ allot align does> (s -- adr ) dup @ scontext ! 4+ ; : s} (s pfa -- ) soffset @ over w! scontext @ swap 2+ ! ; : sizeoff \ structurename (s -- n ) ' >body w@ ; : swords (s -- ) cr scontext begin @ ?dup while 3 spaces dup l>name .id cr more? not if drop exit then repeat ; \ field creating words. 15Jun88pJa: +offset" \ fieldname (s n -- ) screate soffset @ w, soffset +! ; : s+! (s n addr -- ) tuck s@ + swap s! ; : sets@! \ name (s n1 n2 -- ) create , , does> 2@ is s! is s@ ; ' c@ ' c! sets@! csized ' w@ ' w! sets@! wsized ' @ ' ! sets@! lsized : (c) \ fieldname (s n -- ) +offset" does> w@ + csized ; : (w) \ fieldname (s n -- ) +offset" does> w@ + wsized ; : (l) \ fieldname (s n -- ) +offset" does> w@ + lsized ; \ Structures 06Aug88pJa: getvalue (s -- n ) bl parse-word evaluate ; : BYTE 1 (c) ; : BYTES getvalue (c) ; : WORD 2 (w) ; : WORDS getvalue 2* (w) ; : LONG 4 (l) ; : LONGS getvalue 4* (l) ; : STRUCT sizeoff (c) ; : struct BYTES ; : EQU create getvalue , does> @ ; : APTR LONG ; : \\ source nip >in ! ; : ?\s (s code fl -- ) [ text ] if ll off then drop ; \ Structures 06Aug88pJa: [{] (s -- ) r@ @ >body 2+ @ scontext ! r> 4+ >r ; : { \ structure-name (s -- ) scontext off ' >body 2+ @ scontext ! ; immediate : fieldclass (s 'code -- 1|2|4 ) \ 1=char, 2=word, 4=long @ dup [ ' (l) 12+ ] literal = if drop 4 else [ ' (w) 12+ ] literal = if 2 else 1 then then ; : .fieldinfo (s link -- ) 3 spaces more? drop dup l>name .id link> fieldclass dup 4 = if drop ." LONG " else 2 = if ." WORD " else ." BYTE " then then ; \ Structures 06Aug88pJa: (.{) (s addr -- ) dup @ ?dup if recursive (.{) then .fieldinfo cr ; : .{ \ structure-name (s -- ) [compile] { scontext @ ?dup if cr (.{) then ; variable {fillat : ({fill) (s addr -- ) dup @ ?dup if recursive ({fill) then getvalue swap link> dup >body w@ {fillat @ + swap fieldclass dup 4 = if drop ! else 2 = if w! else c! then then ; : {fill (s addr -- ) {fillat ! scontext @ ?dup if ({fill) then ; \ Structures. 07Aug88pJa: ({?}) (s addr -- ) dup @ ?dup if recursive ({?}) then dup .fieldinfo link> dup >body w@ dup . {fillat @ + swap fieldclass dup 4 = if drop @ . else 2 = if w@ . else c@ . then then cr ; : {?} (s addr -- ) {fillat ! base @ hex scontext @ ?dup if cr ({?}) then base ! ; : libindex: libbase# @ 4* constant 1 libbase# +! ; \ Include.blk 06Sep88pJaThis version does not allow target (meta)compiling, used definitions must be present in the dictionary. This file does include the following: 1- an infix (as opposed to rpn) recursive parser. You can bracket as long as your stack holds out. 2- Text file listing and loading. When ttype-ing a file the name is forgotten, will not clutter the dictionary. Tload saves the name; will not load again, if asked for. 3- Structure support for interfacing with Amiga ROM calls. No nesting allowed, though, a complexity I considered, but rejected. If you want that, see C. 06Sep88 - Made a smart 'forget' for resetting 'defined'. Scr 22. \ Load screen for making include files. 19Jun88pJa See additional information in text file infix.txt \ (spare) 19Jun88pJa \ Hex number conversion 19Jun88pJaNumber in the include files are either decimal or hex. Hex numbers are identified by a preceding '$'. These words will alter number so it will correctly input hex numbers. BUT, the infix parser handles it better, so.. This is an example how to do it with L&P's kernel. $number? (s adr -- d f ) identical in operation to number? in Akernel. Skips the first character and starts at second character. ($number) (s adr -- d ) The new number routine. Checks the first character and if it is '$' will switch to hex base and convert the number. Restores the base to previous. If you 'forget' this application, you must set number back to (number). \ Recursive infix number parsing. 19Jun88pJatext is a vocabulary to hide all this stuff. symbols> Points to one character past expression string. insymbol The character count. Is decremented while parsing. expression Deferred to allow indirect recursion. letter? Returns true if character is a valid letter for an identifier. For me it's all Alpha's and _ plus . digit? Returns true if character is digit in current base. symbol Returns the character to be symbolized. Returns 0 if the end of the string is reached. readsymbol Advances to the next character in the input string.'symbol Returns address of next character in the string startsymbols Sets the pointer and counter to given string. \ recursive infix parsing. 19Mar88pJagetchar (s -- char ) Returns a character constant. They are formed between single quotes. getnumber (s -- n ) Gets and returns a number. If number is preceded by $ it is a hex number. Aborts if number is incorretly formed. Leaves the base in decimal, the default. identifier (s -- n ) Looks up the next identifier and executes the cfa. It should be a constant or anything returning a number. First char- acter must be a letter, other characters can also be numbers. \ recursive infix parsing. 19Mar88pJagetconstant (s -- n ) Parses an identifier, a numeric constant, or a character constant and returns the value on the stack. factor2 (s -- n ) Decides whether the next symbol is an expression nesting, or parses the string for a constant. This makes the nesting character '(' the highest priority of the operators. factor1 (s -- n ) Checks and performs negation and bit reversion on the constant following. The symbols are - and ~. \ recursive infix parsing. 19Mar88pJafactor (s -- n ) The shift level of priority. The shift characters are << and >>, although only the first one is checked. This is recursive. term (s -- n ) Logical and and or operators are recognized in this word, also recursive. Logical 'and' is &, logical 'or' is !. \ recursive infix parser. 19Jun88pJasimple-ex (s -- n ) Parses out the multiplication and division. ( *,/ ) Calls itself to get the next number to operate on. Allows stringing along like: 3*4*9/(1+2) (expression) (s -- n ) The default for expression. Takes care of the first operator priority level. Adding (+) and subtracting (-). Calls itself indirectly. must set the deferred expression only the next word is visible from Forth evaluate (s adr len -- n ) The interface word. Setup and evaluate the expression. test A little word to use the above,e.g.: test 3*4*9/(1+2) \ (spare) 19Jun88pJa \ Text file handling 19Jun88pJaUsing a seperate vocabulary, text, will allow redefinitions of some words, and hide much of the grunt names. Each time a file is specified a name is saved in allocated memory. A buffer is allocated to scan for lines. Both will be returned after loading/showing. Changing a directory is also possible, but care must be taken to change back to the original default directory. A nice feature of this section is that it leaves the Forth block buffers alone. \ allocating resources. 14Jun88pJatext vocabulary to seperate the utility 'name acts like a constant when used, but is changeable. 'buffer as above, to change use is. Inited to zero. bufmax size of buffer for text and or info. relbuffs returns allocated buffer and/or name memory nomem? (s addr -- ) common test for out-of-memory. Cleans up neatly. get'name Allocate the name buffer, size is programmed in. get'buffer Allocate the buffer, using bufmax as size. getbuffers Allocate both buffers \ locking and unlocking. 15Jun88pJaA couple of additions to Dos voc are useful. ACCES_READ to open a file in read mode. Lock (s type name -- Lock ) Obtains a lock UnLock (s Lock -- ) Returns a lock lock Holds the lock while the file is open handle After the file is opened the handle is saved here getname Opens the buffers for file access and sticks the name in the name buffer. getlock Get a lock according to the name in 'name. unlock Release the lock obtained with the above. gethandle Opens a file for input/reading. unhandle Closes the file. \ textfile, textbuffer. 890119kel Raw file access uses the Dos routines Read and Seek. The words maintain a sliding window, encompassing a line. >line Offset into the buffer. # of chars to start of line. ll Amount of characters in the current line. #buffer The amount of characters in the buffer lineno The current line number line Returns start of the current line #>end Returns number of character remaining in the buffer. binit Initializes the text buffer pointers. llen Returns number of characters in current line. \ filling the buffer. 14Jun88pJafillit Fills the buffer. First it seeks back to the end of the last text line. Then fills the buffer from there. Records number of characters read. ?fillit Fills the buffer if it is empty or there is no complete text line in the remaining part of the buffer. getline Scans out the next textline from the buffer. Fills it if required. The line starts at 'line' and has 'llen' characters in it. Zero characters is the end of the file. \ opening and closing 24Jun88pJa<text attempts to open the file specified on the input line. If not successfull, closes the resources and aborts. text> Closes the file used and releases the buffers. -filter filters out trailing LF and converts them to blanks, used for loading. tsource The input line from the text file while loading. \ textfile typing and loading Define a special ?error for the deferred word ?error This one must insure that (source) replaces deferred word 'source' because if tsource stays in there, errors in include files essentially crash the system. \ textfiles typing and loading. more? (s -- fl | t=cont ) Stops listing of file if cr is pressed, waits otherwise. ttype \ filename lists a text file on the terminal. Pressing a key will stop/start, pressing a cr will quit listing. tload \ filename loads a text file, as if it was a block file. Uses the regular terminal buffer tib to load the file. Regular forth screened files are left as is. It switches the source, and preserves the Forth input. Can use tload in blocks. Defines a constant with file name, preventing second load of the same file, in current 'context'. \ Creating and finding local words. 06Sep88pJascontext Pointer to small set of local field words. s"create (s str -- ) Creates a local word to scontext. No view field. Links to scontext. Rest of the header is identical to Forth's. The code field is set to noop. It is patched by a does> in the defining word. screate create a local field word. sdefined (s -- here 0| cfa -1|1 ) replacement for defined. Looks FIRST at the local field name words then at the normal Forth context. Set defined to structured defined. forget redefined in order to keep 'defined' in line. Also sets scontext off or it might look at some forgotten area. The literal is itself, without saying recursive, which would make trouble linking the forgets. \ Structures 06Sep88pJasoffset Used in the definition of a structure. s@ Structured fetch, can be one of three sizes:byte-word-cell.s! Structured store, dynamically set as s@ {s (s -- ) double defining word!! The first one is patched by s} to contain the size of the structure and pointer to fields. That word creates an instance of the structure. Use of that instance causes the field names to become accessable. s} (s pfa -- ) End of a structure definition. Patches size and local pointer NOTE: ALL FIELD AND STRUCTURE SIZES ARE WORD SIZED. 64K LIM. sizeoff \ structurename (s -- n ) Returns the size of the named structure, in bytes. swords (s -- ) Shows local field words, but in reverse order of declaration. See .{ for more.. \ field creating words. 16Jun88pJa+offset" \ fieldname (s n -- ) Creates a field word and stores the offset in the pf. s+! (s n addr -- ) Utility to add a number to a field. sets@! \ name (s n1 n2 -- ) Creates a word that sets the s@ and s!. csized Sets structured access to character (byte) size. wsized Sets structured access to word (16b) size. lsized Sets structured access to long (32b) size. (c) \ fieldname (s n -- ) Create a field of byte size, n bytes long. (w) \ fieldname (s n -- ) Create a field of word size, n bytes long. (l) \ fieldname (s n -- ) Create a field of long size, n bytes long \ Structures 24Jun88pJagetvalue (s -- n ) Gets a value from the input. BYTE Create a field of 1 byte type BYTES Create a field of n byte types. WORD Create a field of 1 word type WORDS Create a field of n word types LONG Create a field of 1 long type. LONGS Create a field of n long types. STRUCT Create a field using the structure as size. struct Create a field using n bytes as an unknown structure. EQU Create a constant like word. APTR A synonym for LONG. \\ Ignore the rest of the input line, used in text loading.?\s Ignore the rest of the input file, used after a defined. \ Structures 07Aug88pJa[{] Same as {, used to compile the next word to be used as the structure to use. { Takes the next name as a structure to be used when looking up field names. fieldclass Inspects the cfa and returns a number indicating what type of field it is, byte, word or long (=aptr). It's expected that cfa is a field type. .fieldinfo takes the link address and types the name of the field and what it is on the same line. \ Structures 07Aug88pJa(.{) (s addr -- ) Recursive part of .{ .{ Takes the next name to be a structure name and prints the field names and types in the order of declaration. {fillat Holds start addr of structure, filling or displaying. ({fill) (s addr -- ) Recursive part of {fill {fill Fills the current structure, it's addr is on the stack. Takes input until done in the declared order. Number or any words returning a value can be used. Same parser as for the include files is used. Fills the fields with their correct bit width. \ Structures. 07Aug88pJa({?}) (s addr -- ) Recursive part of {?}. {?} (s addr -- ) Dumps the current structure, showing the field name, type, offset and contents in hex. Handy to inspect things returned by the system ROMs. libindex: Create the next word as the next library base index. FINAL NOTE: I'm not entirely satisfied with the operation of structures, compiling gives some problems. Possibly will make them compile literals for speed, not for 'see'ing, fur sure.
