\ Amiga. 26Feb88pJa A Forth system for Amiga's based on Laxen & Perry's F83 Peter Appelman 1460 Ghent Ave apt 704 Burlington Ontario, Canada L7S-1X7 ( GEnie address: P.APPELMAN) legal: This is a public domain system, and may be freely distributed and copied, as long as the author is given credit and no copyright notice is placed upon it. \ Meta load screen, set up pre-compiler. 11Feb88pJaonly forth also definitions : nload cr .s (load) ; ' nload is load warning off 2 26 thru warning on cr .( Meta compiler loaded ) only forth definitions also from Akernel.blk 1 load \ Dump utility. 17Jan88pJa: .4 (s n -- ) 0 <# # # # # #> type space ; : dumpline (s addr -- ) \ display a line of hex info cr dup 6 u.r ." - " dup 16 bounds do i w@ .4 2 +loop space 16 bounds do i c@ 127 and dup bl 126 between not if drop ascii . then emit loop ; : dump (s addr len -- ) \ show memory starting at addr. base @ -rot hex bounds do i dumpline key? ?leave 16 +loop base ! cr ; \ Vocabulary helpers. 17Jan88pJaonly forth also vocabulary meta meta also meta definitions variable dp-t : [forth] forth ; immediate : [meta] meta ; immediate : [assembler] assembler ; immediate : switch (s -- ) \ swap context and current momentarily noop ( context ) noop ( current ) does> dup @ context @ swap context ! over ! 4+ dup @ current @ swap current ! swap ! ; switch \ Memory access words 17Jan88pJa0 constant target-origin : there (s tadr -- adr ) target-origin + ; : c@-t (s tadr -- char ) there c@ ; : w@-t (s tadr -- w ) there w@ ; : @-t (s tadr -- n ) there @ ; : c!-t (s char tadr -- ) there c! ; : w!-t (s w tadr -- ) there w! ; : !-t (s n tadr -- ) there ! ; : here-t (s -- tadr ) dp-t @ ; : allot-t (s n -- ) dp-t +! ; : c,-t (s char -- ) here-t c!-t 1 allot-t ; : w,-t (s w -- ) here-t w!-t 2 allot-t ; : ,-t (s n -- ) here-t !-t 4 allot-t ; : s,-t (s addr len -- ) 0 ?do count c,-t loop drop ; : align-t (s tadr -- tadr' ) here-t 1 and if 0 c,-t then ; \ Symbol table vocabularies. 17Jan88pJavocabulary target vocabulary transition vocabulary forward only definitions forth also meta also : meta meta ; : target target ; : transition transition ; : forward forward ; : assembler assembler ; only forth also meta also definitions \ Relocation information... 17Jan88pJadefer 'Rbuffer \ holds the buffer pointer code bitset (s bit# addr -- ) \ does what it says sp )+ a0 move sp )+ d0 move a0 ) d0 bset next c; code bitreset (s bit# adr -- ) \ resets bits in address sp )+ a0 move sp )+ d0 move a0 ) d0 bclr next c; code bitset? (s bit# adr -- f ) \ returns true if bit is set sp )+ a0 move sp )+ d0 move a0 ) d0 btst 0= if 0 d0 moveq else -1 d0 moveq then d0 sp -) move next c; code (tbit) (s tadr -- bit# addr ) \ target addr to bit # \ only even addresses are used sp )+ d0 move 1 # d0 lsr 7 d1 moveq d0 d1 and 3 # d0 lsr d1 sp -) move d0 sp -) move next c; : bitindex (s taddr -- bit# addr ) \ convert taddr into bitadr (tbit) 'Rbuffer + ; \ ....relocation information.... 12Feb88pJa: relocate (s taddr -- ) \ mark taddr relocated. bitindex bitset ; : -relocate (s taddr -- ) \ mark taddr not relocated bitindex bitreset ; : <rel (s -- ) \ relocate previous target cell. here-t 4- relocate ; : ,-tr (s n -- ) dup ,-t 0<> if <rel then ; \ ...relocation information. 12Feb88pJa: locate (s -- ) here-t 0 ?do i bitindex bitset? if target-origin i there +! 4 else 2 then +loop ; : -locate (s -- ) here-t 0 ?do i bitindex bitset? if target-origin negate i there +! 4 else 2 then +loop ; : #relocations (s -- n ) 0 here-t 0 ?do i bitindex bitset? if 1+ 4 else 2 then +loop ; : .relocations (s -- ) 0 here-t cr hex ?do i bitindex bitset? if i 0 <# # # # # # # # # #> type space 4 else 2 then negate +loop decimal ; \ BlockStorageSection support. 12Feb88pJavariable 'bss 4 allot 0 ( link ) 0 ( offset ) 'bss 2! : linkbss (s addr -- ) 'bss 4+ @ ( link ) here 'bss 4+ ! , , ; : bss: (s n -- ) \ creates a bss word, usually a label (s -- addr ) \ returns addr within bss section create 'bss @ , 'bss +! does> @ ; : (patchbss) (s taddr -- ) dup -relocate linkbss ; : patchbss (s -- ) here-t 4- (patchbss) ; : .bss (s -- ) hex cr ." next bss location: " 'bss ? cr ." here-t there bss: " cr 'bss 4+ begin @ ?dup while dup 4+ @ dup 6 .r target-origin + dup 10 .r @ 6 .r cr repeat decimal ; \ Saving the target system. 15Feb88pJa: Make-header (s addr -- ) \ .. for code and bss section 1011 over ! 4+ 0 over ! 4+ 2 over ! 4+ 0 over ! 4+ 1 over ! 4+ here-t u2/ u2/ over ! 4+ 'bss @ u2/ u2/ over ! 4+ 1001 over ! 4+ here-t u2/ u2/ swap ! ; : Save-code \ save the code with a header. target-origin 9 4* - dup Make-header here-t 9 4* + tuck swap file @ @ [ Dos ] Write <> abort" error writing code to target" ; \ Saving the target system. 15Feb88pJa: Make-relocations (s addr -- addr' ) 1004 over ! 4+ #relocations over ! 4+ 0 over ! 0 here-t do i bitindex bitset? if 4+ i over ! 4 else 2 then negate +loop 0 'bss 4+ begin @ ?dup while swap 1+ swap repeat swap 4+ tuck ! 4+ 1 over ! 'bss 4+ begin @ ?dup while swap 4+ over 4+ @ over ! swap repeat 4+ 0 over ! 4+ 1010 over ! 4+ 1003 over ! 4+ 'bss @ u2/ u2/ over ! 4+ 1010 over ! 4+ 1010 over ! ; : Save-target 4 here-t 3 and - allot-t >in @ 0 create-file >in ! open Save-code target-origin dup here-t erase Make-relocations target-origin 4- - dup target-origin file @ @ [ Dos ] Write <> abort" error writing relocations" close-file ; \ Assembler stuff... 19Jan88pJa: >pcd) (s taddr -- ) \ modifies taddr to allow program rel. \ address mode e.g. callit >pcd) a0 lea. here-t 2+ - [ assembler ] pcd) ; : M?>mark (s -- addr f ) here-t true ; : M?>resolve (s addr f -- ) ?condition here-t over - swap 1- c!-t ; : M?<mark (s -- addr f ) here-t true ; : M?<resolve (s addr f -- ) ?condition here-t - here-t 1- c!-t ; : ?>mark (s -- f addr ) true here-t 0 ,-t ; : ?>resolve (s f addr -- ) here-t swap dup relocate !-t ?condition ; : ?<mark (s -- f addr ) true here-t ; : ?<resolve (s f addr -- ) ,-tr ?condition ; \ ...Assembler stuff. 19Jan88pJaalso assembler meta ' c,-t assembler is c, meta ' w,-t assembler is w, meta ' ,-t assembler is , meta ' M?>mark assembler is ?>mark meta ' M?>resolve assembler is ?>resolve meta ' M?<mark assembler is ?<mark meta ' M?<resolve assembler is ?<resolve only forth also meta also definitions \ Vocabulary manipulators. 19Jan88pJa: make-code (s pfa -- ) @ ,-tr ; : label (s -- ) assembler definitions here-t constant ; : in-target (s -- ) only target definitions ; : in-transition (s -- ) only forward also target definitions also transition ; : in-meta (s -- ) only forth also meta definitions also ; : in-forward (s -- ) forward definitions ; \ Forward referencing. 20Jan88pJa: link-backwards (s addr -- ) here-t over @ ,-tr swap ! ; : resolved? (s pfa -- f ) 4+ @ ; : forward-code (s pfa -- ) dup resolved? if make-code else link-backwards then ; : forward: (s -- ) switch forward definitions create switch 0 , 0 , does> forward-code ; \ Create header in target image. 23Feb88pJavariable width 31 width ! variable last-t variable context-t variable current-t : hash (s str-addr voc-addr -- thread ) swap 1+ c@ 3 and 4* + ; : header (s -- ) bl word c@ 1+ width @ min ?dup if align-t blk @ 4096 + w,-t here current-t @ hash dup @-t ,-tr here-t 4- over !-t relocate here-t here rot s,-t dup last-t ! 128 swap there cset 128 here-t 1- there cset align-t then ; \ Create target image. 20Jan88pJa: target-create (s -- ) >in @ header >in ! in-target create in-meta here-t , true , does> make-code ; : recreate (s -- ) >in @ target-create >in ! ; : code (s -- ) target-create here-t 4+ ,-tr assembler !csp ; assembler also definitions : end-code in-meta ?csp ; : c; end-code ; meta in-meta \ Force compilation of target and forward words. 20Jan88pJa: 't (s -- cfa ) context @ target defined rot context ! 0= ?missing ; : [target] (s -- ) 't , ; immediate : 'f (s -- cfa ) context @ forward defined rot context ! 0= ?missing ; : [forward] (s -- ) 'f , ; immediate \ Meta defining words. 20Jan88pJa: t: (s -- ) switch transition definitions create switch ] does> >r ; : t; (s -- ) switch transition definitions [compile] ; switch ; immediate : digit? (s char -- f ) base @ digit nip ; : punct? (s char -- f ) ascii . over = swap ascii - over = swap ascii / over = swap drop or or ; : numeric? (s adr len -- f ) dup 1 = if drop c@ digit? exit then 1 -rot 0 ?do dup c@ dup digit? swap punct? or rot and swap 1+ loop drop ; \ Meta transition words 20Jan88pJat: ( [compile] ( t; t: (s [compile] (s t; t: \ [compile] \ t; : string,-t (s -- ) ascii " parse dup 1+ c,-t s,-t 0 c,-t align-t ; forward: <(.")> t: ." [forward] <(.")> string,-t t; forward: <(")> t: " [forward] <(")> string,-t t; forward: <(abort")> t: abort" [forward] <(abort")> string,-t t; \ Meta defining words. 20Jan88pJaforward: <variable> : create recreate [forward] <variable> here-t constant ; : variable create 0 ,-t ; forward: <defer> : defer target-create [forward] <defer> 0 ,-t ; forth variable voc-link-t meta forward: <vocabulary> : vocabulary (s -- ) recreate [forward] <vocabulary> here-t #threads 0 do 0 ,-t loop here-t voc-link-t @ ,-tr voc-link-t ! constant does> @ context-t ! ; \ Meta defining words. 20Jan88pJa: immediate width @ if 64 last-t @ there cset then ; forth variable state-t meta forward: <(;uses)> t: ;uses [forward] <(;uses)> in-meta assembler !csp state-t off t; t: [compile] 't execute t; forward: <(is)> t: is [forward] <(is)> t; : is 't >body @ >body dup relocate !-t ; \ ( spare ) 20Jan88pJa \ Display symbol table. 20Jan88pJa: .symbols target context @ here #threads 4* cmove begin here 4 largest dup while 8 ?line ." [[ " dup l>name .id dup link> >body @ u. ." ]] " @ swap ! key? if 2drop in-meta exit then repeat 2drop in-meta ; \ Resolve forward refences. 22Jan88pJa: .unresolved forward context @ here #threads 4* cmove begin here #threads largest dup while 8 ?line dup l>name name> >body resolved? 0= if dup l>name .id then @ swap ! repeat 2drop in-meta ; : find-unresolved 'f dup >body resolved? ; : resolve (s taddr cfa -- ) >body 2dup true over 4+ ! @ begin dup while 2dup @-t -rot swap dup relocate !-t repeat 2drop ! ; : resolves (s taddr -- ) find-unresolved if >name .id ." Already resolved" drop else resolve then ; \ Interpretive words for Meta. 20Jan88pJa: h: [compile] : ; h: ' 't >body @ ; h: , ,-tr ; h: w, w,-t ; h: c, c,-t ; h: here here-t ; h: allot allot-t ; h: definitions definitions context-t @ current-t ! ; 11Feb88pJaMeta Compiling is a term to describe the process of regenerating a forth system by comiling itself. It is similar in idea to the oridiary notion of compiling Forth, but has some important differences. Firts the code that is generated by the Meta Compiler is generally not immediately executable. This may be for a variety of reasons, such as the code generated needs to be relocated. Also it is possible through Meta compilation to generate a Forth System for a totally different CPU than the one the Meta Compiler is running on. \ Meta load screen, set up pre-compiler. 11Feb88pJa The meta compiler requires two spaces; 1: a target space, de- fined in the kernel, currently 32k big ( kernel compiled =24k ).2: a relocation bit array, taken from the host dictionary. To make sure there is enough room in the dictionary, forget everything after the dumping utility, see Utilities.blk. forget .4 A dump is on block 2. This way enough space is available for Meta Compiling. NLOAD Provides a visual check on the stack between screens, give a quick check on what screens are failing to load. \ Dump utility. 11Feb88pJa.4 print a number, for digits, used in printing a hex word. DUMPLINE Displays a line of hex information, printing the address, then sixteen bytes of memory contents, grouped in words and the ascii equivalent of each byte, masking the high bits in each byte. DUMP Dump a range of memory information. Useful for checking the generated system, or any memory locations. Can examine the target system by entering: ' <word> there nn dump after the system is compiled. \ Vocabulary helpers. 11Feb88pJa META The compiler environment, many redefinitions. DP-T Dictionary pointer to compile into target system. [FORTH] Need some immediate versions, to access the underlying[META] systems, after compiling is completed, or else these [ASSEMBLER] vocabularies will be hidden. SWITCH Exchange the saved values of CONTEXT and CURRENT with themselves. This should be used in pairs, and is only really meaningful in the second occurance. Its purpose is to save and restore the CONTEXT and CURRENT vocabularies. Following the first occurance you should invoke a vocabulary and perhaps DEFINITIONS. \ Memory access words 11Feb88pJaTARGET-ORIGIN patched later, start of system in memory. THERE Map a target addr into a Host address, could be changed to a virtual memory routine, using blocks to compile on disk directly. C@-T W@-T @-T fetch a target character, word and long C!-T W!-T !-T store a char, word and long at target address. HERE-T Target address of the next available dictionary byte ALLOT-T Allocate more space in the Target dictionary. C,-T W,-T ,-T Add a character word or cell to the dictionary. S,-T Add a string to the Target dictionary. ALIGN-T Makes the Target dictionary even, extremely important in 680nn processor systems. \ Symbol table vocabularies. 11Feb88pJaTARGET The SYMBOL table for target definitions. TRANSITION Holds special case compiling words, like ." and [ FORWARD Holds all forward references, easy to find 'm later. We add all of the vocabulary names to the ONLY vocabulary so that they are always accessible. This is mainly a convienence during debugging, when something fails and we need to look at different words in various vocabularies to figure out what is going on. Now we are guaranteed that we can reference all of the vocabularies inside META without standing on our heads. \ Relocation information... 11Feb88pJaRelocation is only on even boundaries. Only 32bit relocation is done. This section keeps track of relocation in "Rbuffer", allocated at the beginning of target kernel. Must be target size / 16 long. Used at the end of compiling, to save the sys. BITSET BITRESET BITSET? All use a bitnumber and an address to set, reset and test bit. (TBIT) maps a target address into a bit number in the Rbuffer array. This address and bit# can be used to call above words BITINDEX Convert a target address into a bitindex and address for use in accessing the relocation bit array; Rbuffer. \ ....relocation information.... 11Feb88pJaRELOCATE Mark target address as relocated, the loader must alter the address when loading the system. -RELOCATE Mark the target address as an absolute <REL Mark the previous target dictionary cell as relocated. ,-TR Store n into target dictionary cell and mark it relocated if it is not zero. Zero could indicate a null pointer, and these must not be relocated. Zero's can explicitly be relocated using <REL or RELOCATE. \ ...relocation information. 12Feb88pJaLOCATE Runs through the bit array and adds the target origin to each location flagged as relocated. System could be run in memory after this word has changed target image. -LOCATE Does the opposite of the word above. Allows the system to be saved on disk again. #RELOCATIONS Calculates how many relocations are flagged in the bit array. Returns the number. .RELOCATIONS After the system is compiled this word will print in rough format all the relocations. It will print all of them, I used this to check for possible misalignments in the list. \ BlockStorageSection support. 12Feb88pJa'BSS Holds current Block Storage Section offset and link pointer, to link all declared bss words. LINKBSS Links address into the linked list. Later the linked list is run through to save special loader information, so it can relocate the locations with the proper bss offset. BSS: Reserves a n byte sized word in the bss section. When that word is used again it will return the offset within the bss section. Must use a PATCHBSS to ensure proper loading. (PATCHBSS) The target address is marked as relocated in the bss section, and is unmarked in the Rbuffer. PATCHBSS marks previous target cell as bss-relocated. .BSS Prints a short list of bss-addresses used in the target system. Prints both the relative and the absolute memory location. \ Saving the target system. 12Feb88pJaSaving the target system as a run file, requires a header and relocating information. The code section and data (bss) sectionhave their own relocation information. MAKE-HEADER Makes a header for both code and bss sections. SAVE-CODE Saves the code with a file header. \ Saving the target system. 12Feb88pJaMAKE-RELOCATIONS Makes relocation information at address and returns the last address used. It presumes there is any relocation information to be written out, both code and bss section. Currently the address is the target image location after the target has been saved on disk. SAVE-TARGET <name> Saves the entire target as a runnable file, called <name>. Uses low level Amiga Dos calls to write to disk. \ Assembler stuff... 12Feb88pJa>PCD) modifies target address for use in program relative mode. e.g. r# >pcd) a0 lea is identical to lea r#(PC),a0 (in standard assembler format) M?>MARK These 4 primitives are for the assembler, and use M?>RESOLVE only +- 127 byte range. Note the flag and address areM?<MARK in opposite order of the ones below. M?<RESOLVE ?>MARK The 4 structure primitives to compile execution ?>RESOLVE control into the target system. ?<MARK ?<RESOLVE \ ...Assembler stuff. 12Feb88pJa Because the following words are DEFERRED in the ASSEMBLER, we can redefine them in the Meta Compiler and use the exact same assembler we were using before. This is very convenient since it saves time and space. In fact, because the assembling portions of the assembler are deferred, we can use this same Assembler to do target assembly at a totally different origin. Take note that the cell allocation word , (comma) in assembler does not assume relocation. That must be specified seperately. This is important in words such as USES; and "CREATE. \ Vocabulary manipulators. 12Feb88pJaMAKE-CODE Take the code field pointed to and compile it in the Target LABEL Remember the current Target address and asign it a name. IN-TARGET Search only the Symbol Table. IN-TRANSITION Search TRANSITION TARGET and FORWARD in that order. IN-META The normal environment when interpreting in Meta. IN-FORWARD (s -- ) Used when a word is undefined and compiled on the fly. \ Forward referencing. 12Feb88pJaLINK-BACKWARDS Create a linked list of unresolved forward references. RESOLVED? Return non-zero if the word is already resolved. FORWARD-CODE If a forward reference is resolved, compile code else link itFORWARD: Defines an explicit forward reference. Initializes it to be unresolved. \ Create header in target image. 12Feb88pJaWIDTH The maximum length of the names in the target, 31. LAST-T Points to the name of the most recent Target word. CONTEXT-T Not really used, unless DEFINITIONS follows. CURRENT-T Points to the Target vocabularies thread pointers. HASH Each name is linked into 1 of 4 threads to improve speed. HEADER Create a header in the Target Dictionary. If WIDTH is zero, then no heads are created. HEADER in the Meta Compiler behaves the same as CREATE does in ordinary Forth. It makes a header out of the next word in the input stream, and fixes up all of the appropriate pointers to link it into the Target Dictionary. \ Create target image. 14Feb88pJaTARGET-CREATE Create a target header and an entry in the symbol table. It is initialized to already resolved, so it compiles itself. RECREATE Same as TARGET-CREATE, but don't advance the input stream. CODE Set up for a low level word. As this is indirect threaded code, the code field points to the parameter field. END-CODE Terminate a low level word. Not required but tidy to have. \ Force compilation of target and forward words. 14Feb88pJa'T Look up the next word in the iput stream only in the TARGET vocabulary, disturbing nothing else. [TARGET] Force compilation of a TARGET word, regardless of CONTEXT 'F Look up the next word in the input stream only in the FORWARD vocabulary, disturbing nothing else. [FORWARD] Force compilation of a FORWARD word, regardless of CONTEXT. \ Meta defining words. 14Feb88pJaT: Used for special case compiling words. TRANSITION is normally searched before TARGET. Acts just like a : definition. T; Terminate a word defined by T: DIGIT? Retruns true if the character is a digit in current base. PUNCT? Returns true if the character is a valid punctuation character for numbers, such as leading - or decimal point. NUMERIC? Returns true if the string is a valid number in the current base. Note that a special test is made to make sure at least one digit is present. This prevents - from being a number. \ Meta transition words 14Feb88pJa( Inherit ( from host for comments. (s Inherit (s from host for comments. \ Inherit \ from host for comments. STRING,-T Scan the input stream for a " delimited text and compile it. NOTE that this system adds a 0 byte at the end of each string(xept heads). Allows Amiga calls compatibility.<(.")> Runtime forward reference for code compiled by ." ." Comp the unknown runtime code, followed by the string. <(")> Runtime forward reference for code compiled by " " Comp the unknown runtime code, followed by the string. <(ABORT")> runtime forward ref. for code compiled by ABORT" ABORT" Comp unknown runtime code, followed by the string. \ Meta defining words. 14Feb88pJa<VARIABLE> Forward reference for runtime of CREATE & VARIABLE CREATE Create a target word whose rutime is the rumtime for VARIABLE. Also create a host word to return Target Here addr.VARIABLE Make a variable in the Target Image. <DEFER> Forward reference for runtime of DEFER. DEFER An execution vector in the Target System. VOC-LINK-T Links defined Vocabularies together. <VOCABULARY> Forward reference to runtime of VOCABULARY. VOCABULARY Create a target word that behaves like a vocabulary. Only one target vocabulary can contain definitions in this meta compiler, but several can be defined. \ Meta defining words. 14Feb88pJaIMMEDIATE If heads are compiled, flip the Target IMMEDIATE bit. STATE-T True if compiling inside : def. False if outside. <(;USES)> Forward reference for code compiled by ;USES ;USES This is a new syntax that can be used to compile a code field whose code already exists. Similar to ;CODE. [COMPILE] Compile a TARGET word tather than execute its TRANSITION counterpart. <(IS)> Forward reference for runtime of IS. IS Compiles the unknown code field of <(IS)>. IS The Meta Version of IS actually does the patch. \ ( spare ) 20Jan88pJa \ Display symbol table. 14Feb88pJa.SYMBOLS Print a primitive unformatted symbol table on the display This is very useful if you ever need to debug with WACK, you have no idea where the addressed are. You can make it pretty if you like. One complication is the fact that all the addresses are relative. You will have to add the load address to find out where they actually are once loaded into a debugger. The way I usually debug: -Load the test system under a debug- ger. Note the START, SP, RP and NEXT location. Start the sys- tem. If an error occurs (eg. an address error), the debugger will catch it. Then work backward from the current IP and W to find out which word caused the problem. Not easy, but it's the only way at my disposal. ( and within my budget ). \ Resolve forward refences. 14Feb88pJa.UNRESOLVED Display all the words in the FORWARD vocabulary that have not already been resolved. You had better resolve them before saving a system, or else the GURU will appear, or maybe even Fireworks on the screen, fun to watch. FIND-UNRESOLVED Search for a word in FORWARD and return status.RESOLVE Run through the linked list of forward references and resolve each of them with the given address. RESOLVES The user interface for resolving forward references. Used as follows: ' resolution-name RESOLVES forward-name \ Interpretive words for Meta. 14Feb88pJaH: Save a version of old : for later. Will be redefined. ' How ' should behave during Target Compilation. , How , should behave during Target Compilation. w, How w, should behave during Target Compilation. c, How c, should behave during Target Compilation. HERE How HERE should behave during Target Compilation. ALLOT How ALLOT should behave during Target Compilation. DEFINITIONS How DEFINITIONS should behave when interpreted.
