\ A4th. Meta.blk 23Sep88pJa A4th A Public Domain Forth system for Amiga's based on Laxen & Perry's F83 This Forth system is Public Domain. You may freely distribute copy and use it, for any legal purposes. I cannot be held responsible for any errors and/or omissions, I do not warrant this system. I bear no responsibility for any use or abuse, with or without intend. Peter J. Appelman. \ Meta load screen, set up pre-compiler. 23Sep88pJaonly 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 \ (spare) 23Sep88pJa \ Vocabulary helpers. 23Sep88pJaonly 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 23Sep88pJa0 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. 23Sep88pJavocabulary target ' target >body <target> ! variable symbol-link vocabulary transition vocabulary forward vocabulary user only definitions forth also meta also : meta meta ; : target target ; : transition transition ; : forward forward ; : user user ; : assembler assembler ; only forth also meta also definitions \ Relocating Target Image. 23Sep88pJadefer 'Rbuffer \ holds the buffer pointer code (tbit) (s index -- bit# indexbyte ) sp )+ d0 move 1 # d0 lsr \ only even addresses d0 sp -) move 3 # d0 lsr d0 sp -) move next c; : bitindex (s taddr -- bit# addr ) \ convert taddr into bitadr (tbit) 'Rbuffer + ; \ Relocating Target Image. 23Sep88pJa: relocate (s taddr -- ) bitindex bset ; : -relocate (s taddr -- ) bitindex breset ; : <rel (s -- ) here-t 4- relocate ; : ,-tr (s n -- ) dup ,-t 0<> if <rel then ; \ Relocating Target Image. 23Sep88pJa: locate (s -- ) here-t 0 ?do i bitindex bset? if target-origin i there +! 4 else 2 then +loop ; : -locate (s -- ) here-t 0 ?do i bitindex bset? if target-origin negate i there +! 4 else 2 then +loop ; : #relocations (s -- n ) 0 here-t 0 ?do i bitindex bset? if 1+ 4 else 2 then +loop ; \ BlockStorageSection support. 23Sep88pJavariable 'bss 4 allot 0 ( link ) 0 ( offset ) 'bss 2! : linkbss (s taddr -- ) 'bss 4+ @ ( link ) here 'bss 4+ ! , , ; : bss: (s n -- ) create 'bss @ , 'bss +! does> (s -- offset ) @ ; : (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. 24Sep88pJa: ,+ (s addr n -- addr+4 ) over ! 4+ ; : bss? (s -- f ) 'bss @ 0 <> ; : bss-align (s -- ) 'bss @ 3 + -4 and 'bss ! ; : Make-header (s addr -- ) 1011 ,+ 0 ,+ 2 bss? not + ,+ 0 ,+ 1 bss? not + ,+ here-t u4/ ,+ bss? if 'bss @ u4/ ,+ then 1001 ,+ here-t u4/ swap ! ; : Save-code target-origin 9 bss? not + 4* - dup Make-header here-t 9 bss? not + 4* + tuck swap file @ @ [ Dos ] Write <> abort" error writing code to target" ; \ Saving the target system. 23Sep88pJa: Make-relocations (s addr -- addr' ) 1004 ,+ #relocations ,+ 0 ,+ 0 here-t do i bitindex bset? if i ,+ 4 else 2 then negate +loop bss? if 0 'bss 4+ begin @ ?dup while swap 1+ swap repeat ,+ 1 ,+ 'bss 4+ begin @ ?dup while swap over 4+ @ ,+ swap repeat then 0 ,+ 1010 ,+ bss? if 1003 ,+ 'bss @ u4/ ,+ 1010 ,+ then 1010 ,+ ; : Save-target 4 here-t 3 and - allot-t bss-align >in @ 0 create-file >in ! open Save-code target-origin dup here-t erase Make-relocations target-origin - dup target-origin file @ @ [ Dos ] Write <> abort" error writing relocations" close-file ; \ Assembler stuff. 23Sep88pJa: >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. 23Sep88pJaalso 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. 23Sep88pJa: 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. 23Sep88pJa: 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. 23Sep88pJavariable 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. 23Sep88pJa: target-create (s -- ) >in @ header >in ! in-target create in-meta here-t , 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. 23Sep88pJa: '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. 23Sep88pJa: 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 23Sep88pJat: ( [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. 23Sep88pJaforward: <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 ! [forth] create [meta] #threads 0 do 0 , loop here symbol-link @ , symbol-link ! , does> dup <context> ! #threads 1+ 4* + @ context-t ! ; \ Meta defining words. 23Sep88pJa: 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 ; \ Meta User defining words. 23Sep88pJa25 constant #users-t forth variable #user-t -4 #user-t ! meta also user definitions : allot (s n -- ) negate #user-t +! ; forward: <user-variable> : variable (s -- ) switch recreate [forward] <user-variable> #user-t @ dup ,-t 4 allot meta definitions constant switch ; forward: <user-defer> : defer (s -- ) switch target-create [forward] <user-defer> switch #user-t @ ,-t 4 allot ; only forth also meta also definitions \ Meta <context> manipulations. 23Sep88pJa: <empty> <context> #vocs 4* erase ; : <also> <context> dup 4+ #vocs 1- 4* cmove> ; : <order> cr ." <Context>: " <context> #vocs 0 do dup @ ?dup if body> >name .id then 4+ loop drop cr ." <Current>: " <current> @ body> >name .id ; : <vocs> symbol-link @ begin dup #threads 4* - body> >name .id @ dup 0= until drop ; : <words> context @ <context> @ context ! words context ! ; \ Resolve forward refences. 23Sep88pJa: .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. 23Sep88pJa: 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 <definitions> context-t @ current-t ! ; \ 23Sep88pJaMeta 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. 23Sep88pJaThe meta compiler requires two spaces; 1: a target space, defined 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. ( e.g. 'forget out') Alternatively, specify a larger user dictionary on startup. nload Provides a visual check on the stack between screens, give a quick check on which screen fails to load. \ Vocabulary helpers. 23Sep88pJa meta The meta compiler environment. dp-t Target dictionary pointer. [forth] Need some immediate versions, to access the under- .. [meta] ..lying systems, after compiling is completed, or .. [assembler] .. these 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 23Sep88pJatarget-origin patched later, start of system in memory. there Change a Target addr into a Host memory address. c@-t Fetch a target character. w@-t Fetch a target word. @-t Fetch a target cell (=long). c!-t Store a character at target address. w!-t Store a word at target address. !-t Store a 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 Add a character to the target dictionary. w,-t Add a word to the target dictionary. ,-t Add a long (cell) to target dictionary. s,-t Add a string to the Target dictionary. align-t Even the Target dictionary pointer. \ Symbol table vocabularies. 23Sep88pJatarget The flag indicating the target dictionary. symbol-link Linked list of target vocabularies. transition Holds special case compiling words, like ." and [ forward Holds all forward references, easy to find 'm later. user Holds user version of defining words We add all of the vocabulary names to the 'only' vocabulary so that they are always accessible. This is mainly a convenience 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. \ Relocating Target Image. 23Sep88pJaThe Amiga Dos loader needs relocation information. 'Rbuffer' is a buffer, declared at the beginning of the kernel, to keep trackof the relocation. A bit is set in Rbuffer for each address to be relocated. This requires the Rbuffer to be the size of the kernel/16, since relocation is only at even addresses. When saving the target kernel, the relocation information is written out in the Amiga-Loader format. (tbit) Maps an index into a bitnumber and an index byte number The bitnumber is not masked off, the bset routine takes care of that. bitindex Convert a target address into a bitnumber and address for use in accessing the relocation bit array; Rbuffer. \ Relocating Target Image. 23Sep88pJarelocate 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. A zero or null can explicitly be relocated using <rel or relocate, but that would result in the kernel start address once loaded under Amiga Dos. \ Relocating Target Image. 23Sep88pJalocate Runs through the bit array and adds the target origin to each location flagged as relocated. Fixes the target in the host; any addresses point to host memory. -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. \ BlockStorageSection support. 23Sep88pJa'bss Holds current Block Storage Section offset and link pointer, to link all declared bss words. linkbss Links target addr into linked list. The list is used to save the relocation information for bss section. The off- set into bssection will be at target address. bss: Reserves a n byte sized area in the bss section. When this word is used again it will return the offset within the bss section. Must use a patchbss to ensure proper relocation. (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 host memory location. \ Saving the target system. 24Sep88pJa,+ Save n at addr and increment addr to next cell. bss? Returns true if any bss storage has been declared. bss-align Long align the bss allocation, rounding up. Make-header Makes a Amiga-Dos load file header, knows if no bss sections have been declared. Save-code Makes a header for the Dos load file and saves the target image. Aborts on a write error. Uses low level Dos calls which are the same regardless of the Forth system. \ Saving the target system. 23Sep88pJaMake-relocations (s addr -- addr' ) Stores the relocation information for the load file, in the buffer at addr. Returns a pointer past the last cell used. Checks to see if bss sections are used and saves relocation information in the buffer for bss section. Save-target <name> Saves the target in a Amiga-Dos load file format with the supplied name. BSS sections are optional. Will abort if an error on writing occurs. \ Assembler stuff. 23Sep88pJa>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. 23Sep88pJa 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. 23Sep88pJamake-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 Used when a word is undefined and compiled on the fly. \ Forward referencing. 23Sep88pJalink-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. 23Sep88pJawidth 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. 23Sep88pJatarget-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. 23Sep88pJa'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. 23Sep88pJat: 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 23Sep88pJa( 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. 23Sep88pJa<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. derer 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 vocabulary. When Meta interpreting, it will set the <context> to this vocabulary, it will also make a symbol entry in <current>. The symbol vocabulary is linked to symbol-link. It will also set current-t to point to the target image version of the vocabulary. \ Meta defining words. 23Sep88pJaimmediate 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. \ Meta User defining words. 23Sep88pJaIn this (experimental) system, user vars are ahead of next. Next can double as UP as long as #user is started at -4. Makes for easy task inits and saves allocating a pointer/register to UP. Again full long sizes are maintained to allow jumps to any- where in 32bit of memory address. Even positive offsets are possible :) #users-t The number of task variables in this system. #user-t Counts the number of user variables defined so far. allot Allocate space in the user area. <user-variable> Forward reference for run time of user vars. variable Create a user variable, which is task local. <user-defer> Forward reference for run time of user vectors. defer Create a task local execution vector. \ Meta <context> manipulations. 23Sep88pJa<empty> empties out the symbol context. <also> the same as the also in standard forth, but for <context> <order> Prints the contents of <context> and <current>. <vocs> Prints the vocabylaries defined in the symbol, or target dictionary system. <words> Prints the words defined in the <context> vocabulary. \ Resolve forward refences. 23Sep88pJa.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. 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. 23Sep88pJah: 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.
