\ Memory structures                                                  vandys
only extensions definitions
64 constant (struct_max)
create (struct_prefix) (struct_max) allot
create (struct_name) (struct_max) allot
variable (struct_idx)
: $strconv ( a1 u1 a2 -- )   2dup c!   1+ swap move ;
: (struct_prefix!) ( a1 u1 -- )   (struct_prefix) $strconv ;
: struct   ( -- )   (struct_idx) off   bl parse (struct_prefix!) ;
: $strccat ( a2 u2 a1 -- )   dup c@ >r   2dup +c!   r> + 1+   swap move ;
: (cat_name) ( c -- )   (struct_prefix) (struct_name) (struct_max) move
   (struct_name) swap $ccat   ;
: (build_name) ( -- )   [char] > (cat_name)
   bl parse (struct_name) $strccat   ;
: (struct_prolog)   (struct_name) $,n   ['] doLIST call,   0 ,   overt   ;
: (compile_struct)   (build_name) (struct_prolog)   (struct_idx) @ ,   ;
: (build_struct)   (compile_struct)   does>   @ +   ;
: int8   (build_struct)   1 (struct_idx) +!   ;
: int16   (build_struct)   2 (struct_idx) +!   ;
: int32  (build_struct)   4 (struct_idx) +!   ;
: intcell   (build_struct)   1 cells (struct_idx) +! ;
: bytes ( u -- )   (build_struct)   (struct_idx) +! ;
: endstruct   [char] . (cat_name)   s" size" (struct_name) $strccat
   (struct_prolog)   (struct_idx) @ ,   does>   @ ;

\ Enumerations                                                       vandys
\ NOTE: uses same memory structures as a "struct" construct
variable (val_set)
: enum   (val_set) off   struct ;
: (build_enum_name) ( -- a )   [char] _ (cat_name)
   bl parse (struct_name) $strccat   ;
: (compile_enum)   (build_enum_name) (struct_prolog)   (struct_idx) @ ,   ;
: (build_enum)   (compile_enum)   does>   @ ;
: enumval!   (struct_idx) !   (val_set) on ;
: enumval   (build_enum)   1 (struct_idx) +! ;
: endenum   (val_set) @ if   exit   then
   [char] _ (cat_name)   s" MAX" (struct_name) $strccat
   (struct_prolog)   (struct_idx) @ 1- ,   does>   @ ;












\                                                                    vandys

\ More string functions
: $strcpy ( dest src -- )   dup c@ 1+   swap -rot move ;





















\ Named arguments--parsing                                           vandys
only extensions also forth \ Note: loading continues here system build

\ : my+1 { arg1 arg2 -- result }   arg1 arg2 + { sum }   sum 1+ ;
\ Basically, names whose scope is the def, acting as constant's for
\  the passed parameters.  We permit these at any point in the def.
\ Result part is parsed & checked
\ Note: the compile-time mechanism is not reentrant

variable curDef

: ($cstreq?) ( a1 u1 a2 u2 -- ? )   rot over - if   3drop   false exit then
   ( a a' u ) 0 do   2dup c@ swap c@ - if   unloop 2drop   false exit then
   1+ swap 1+ loop   2drop true ;











\ Named arguments--dictionary entries                                vandys

create localNFAs   #locals cells allot
create maxName   31 c, 31 allot   maxName 1+ 31 char * fill
: >localNFA ( u -- nfa )   cells localNFAs + @ ;

(local) up @ - constant off_(local)
also assembler : 'local->eax ( -- )   up # eax mov   0 [eax] eax mov
   off_(local) # eax add ; -also
code {@
   ebx pop   'local->eax   0 [eax] eax mov   4 [ebx] eax add
   0 [eax] eax mov   eax push   next c;

: cinc ( a -- )   dup c@   1+   swap c! ;











\ Named arguments--dictionary entries                                vandys

vocabulary (localVoc)   also (localVoc) definitions

:noname ( -- )   #locals 0 do   i 1+ cells maxName (constant)
      ['] {@   last @ name>   call!
      last @   i cells localNFAs +   !
   maxName 1+ cinc   loop ; execute

current @   -also definitions   constant localVocPtr

: resetLocals ( -- )   #locals 0 do   1   #markb 1 or ( ^A nfa-count )
      i >localNFA   c!+ c!   loop ;   resetLocals

: findLocal ( a -- ca na | a F )   localVocPtr find ;










\ Named arguments--name handling                                     vandys

variable curArg

:noname ( -- )   resetLocals ; 'endDef !

: nfa! ( a-str u-len nfa -- )   over #markb or   swap c!+
   swap move ;
: localName! ( a-str u-len -- )   curArg @ >localNFA   nfa! ;
















\ Named arguments--setting value                                     vandys

code {!
   ecx pop   'local->eax   0 [eax] ebx mov
   lods   eax ebx add   ecx 0 [ebx] mov   next c;




















\ Named arguments--setup and cleanup of local variable state         vandys

code end}
   #locals cells # ebp add
   0 [ebp] ebx mov   4 # ebp add   'local->eax   ebx 0 [eax] mov
   0 [ebp] esi mov   4 # ebp add   next c;
create 'end}   ' end} ,

code init{
   'local->eax   0 [eax] ebx mov
   #locals 2 + cells # ebp sub
   'end} # ecx mov   ecx 0 [ebp] mov
   ebx #locals 1+ cells [ebp] mov   ebp 0 [eax] mov
   1 cells # esi add   next c;











\ Named arguments--cleanup w. return value checking                  vandys

$8 constant TERMVAL   $88888888 constant TERMINIT
:noname ( -- a )   c" Bad return format" ; execute constant "badRet
code end}--
   #locals cells 8 + [ebp] ecx mov
   esp ecx sub   ecx 2 shr   $F # ecx and
   #locals cells 4 + [ebp] edx mov
1 $: edx eax mov   $F # eax and   ecx eax cmp   2 $ je
   TERMVAL # eax cmp   3 $ je   edx 4 shr   1 $ jmp
3 $:   4 # esi sub   "badRet push#   ' (abort) # eax mov   eax jmp
2 $:
   #locals cells [ebp] ebx mov   'local->eax   ebx 0 [eax] mov
   #locals cells 16 + [ebp] esi mov
   #locals cells 20 + # ebp add   next c;

' end}--   'end}-- !








\ Named arguments--setup w. return value checking                    vandys

code init{--
   lods   eax edx mov
   'local->eax   0 [eax] ebx mov
   #locals 5 + cells # ebp sub
   'end}-- # ecx mov   ecx 0 [ebp] mov
   edx #locals 2 + cells [ebp] mov
   esp #locals 3 + cells [ebp] mov
   esi #locals 4 + cells [ebp] mov
   ebx #locals 1+ cells [ebp] mov   ebp 0 [eax] mov   next c;














\ Named arguments--parsing of return value format                    vandys

code 2over ( d1 d2 -- d1 d2 d1 )   8 [esp] eax mov   12 [esp] ebx mov
   ebx push   eax push   next c;

variable narg   variable argEntry

: #args ( -- u ? )   0 begin   bl parse dup 0= abort" Missing }"
      s" |" 2over ($cstreq?) if   2drop false exit   then
      s" }" ($cstreq?) if   true exit   then
   1+ again ; scrLocal
: proc"--" ( -- )   ['] init{--   argEntry @ !
   TERMINIT begin   #args -rot ( done? mask #arg )
      narg @ - $F and   swap 4 << or ( done? mask' )
   swap until   argEntry @ cell+ ! ;










\ Named arguments--actual compilation words                          vandys

: ({) ( -- )   bl parse dup 0= abort" no name" ( a-str u-len )
   s" --" 2over ($cstreq?) if   2drop proc"--"   exit then
   s" }" 2over ($cstreq?) if   2drop   exit then
   narg inc   recurse
   localName!   compile {!   curArg @ 1+ cells ,   curArg inc ;
: { ( -- )   (genhook) curDef @ last @ - if
      here argEntry !   ['] findLocal 'local? !
      compile init{   0 ,   last @ curDef !
      narg off   curArg off   then
   ({) ; immediate compile-only

: } ( -- )   1 abort" Mismatched braces" ; immediate











\ Fast reboot                                                        vandys

$1000 constant NBPG scrLocal

here
code movjmp ( 'info entry src dest bytes -- )
   ecx pop   edi pop   esi pop   edx pop   ebx pop   rep byte movs
   $2BADB002 # eax mov   edx jmp   c; scrLocal
here swap - aligned constant movjmpSize scrLocal

: fastboot { blk -- }   ttchan @ abort" Must run on root console"

   blk block { blk0 }
   blk0 $20 + @ $1BADB002 - abort" Bad magic"
   blk0 $20 +   4 cells + @+ { ldaddr }   @+ { ldend }   cell+ @ { entry }
   ldend ldaddr -   NBPG roundup   NBPG / { nblk }   here { img }
   nblk 0 do   blk i + block   here NBPG move
      NBPG allot   loop
   here   $1 ,   640 ,   (mem_upper) @ 1024 / , ( 'info )
   ['] movjmp   here   movjmpSize move
   entry   img   ldaddr   nblk NBPG *   here execute ;

                                                                     vandys

Maximum struct name length
Struct name being compiled (not reentrant)
Assembled name of current field
Running tally of offset into structure
: $strconv Convert pointer and count to counted string
: (struct_prefix!) Set structure name prefix
: struct Define a structure
: $strccat Append indicated number of chars onto a counted string
: (cat_name) Build name plus a character separator

: (build_name) Create struct element definition

: (struct_prolog) Build initial code for a structure word run-time
: (compile_struct) Build struct element, saving offset as its body
: (build_struct) use (compile_struct), run-time adds offset to pointer
: int8/16/32/cell Define 1, 2, 4, and cell- byte struct members



: bytes   Allocate space for a string
: endstruct Record structure size as <name>.size




(val_set) Flag manual overriding of enumeration numbering
: enum Define name of a enumeration
: (build_enum_name) Concatenate the current enum name and an underscore,
   then the current enumeration entry name.
: (compile_enum) Construct enum name, build dir entry, save current value
: (build_enum)   Build enum element, set action to fetch value
: enumval! Choose value for enum sequence
: enumval Register next member of the enumeration
: endenum Wrap up generation of enums, <enum>_MAX set to highest value
 if the default zero-based sequencing is used.






































                                                                     vandys








Record of latest routine we've initialized for; lets us know when we're
 starting compilation for a new routine by comparing with "last"
: ($cstreq?) A counted-string string comparison, returns whether the two
 strings are identical














Table mapping index to dictionary entries for locals
Build a maximum-length name to init our local entries
: >localNFA Convert index to NFA pointer

Calculate offset to (local) user variable in user structure
Macro to put address of user (local) in eax

code {@ Run-time for a local reference
   Body of var, get (local), add index for this var to (local) ptr
   Fetch var, push on operand stack, and continue

: cinc Increment a char location













Local variable names live here
This is nameless code to init our local entries:
                 Iterate each possible local name, create the entry
      Set its runtime to be the {@ assembly code above
      Record its NFA in our table
   Mint a unique name for each placeholder

Record the vocab pointer so we can use it for our search hook

: resetLocals Set all local name placeholders to just ^A, so they don't
 crowd a vocab listing (and yet continue to exist)

: findLocal 'localName? hook to search our private list of local
 variable names











When processing arg names, the current index assigned to an arg

Nameless cleanup code run at end of a definition (";")

: nfa! Store string into NFA of an existing entry

: localName! Store string into name for current arg entry
















                                                                     vandys

code {! Store an arg into its local variable slot
   Arg       Get (local) value
   Arg offset           Store arg




















                                                                     vandys

code end} Code returned into from a locals-using word.
   Drop local storage from return stack
   Pop previous (local) value from return stack, write to (local)
   Pop back to true caller of word which just returned, and continue
Create a threaded reference to end}, so [esi] can reach end}

code init{ Initialize locals storage in return stack frame
   Point to (local) user variable, get current value
   New stack frame
   Arrange return to our cleanup code
   Save old (local) in frame        (local) is this frame
   Skip argument count word (unused), continue











                                                                     vandys

Magic numbers for return signatures
String constant for abort message on bad return format
code end}-- Code returned into from a locals-using word w. return checking
   Calculate delta opstack size in cells, put in ECX

   Get packed signature of acceptable stack deltas into EDX
Extract next signature, compare to ECX, bail out successfully on match
   Look for sentinel, no more sigs if match, otherwise shr next sig
Failure: throw an abort, with ESI pointing at our entry (for stack trace)
Success: remove local variable storage
   Pop previous (local) value from return stack, write to (local)
   Pop back to true caller of word which just returned
   Remove frame from stack, and continue

Create a threaded reference to end}--, so [esi] can reach end}--








                                                                     vandys

code init{-- Initialize locals storage in return stack frame, record opstack
   Get argument count so we can save it for later return value checking
   Point to (local) user variable, get current value
   New stack frame
   Arrange return to our cleanup code
   Save argument count in frame
   Save stack pointer in frame
   Save pointer into routine, so if we abort we can see who it was
   Save old (local) in frame        (local) is this frame & continue














                                                                     vandys

code 2over "over" for double words


Pointer to entry code for currently compiling word

: #args Parse next stream of words until "}" or "|", return count
 and whether it ended on "}" (flagging end of value list)


: proc"--" Parse the ... part of { <args> -- ... }















: ({) Compile-time handling of locals.  Process variable names
 until -- or }, using recursion to make local handling match
 standard stack commenting order.


: { Start local variable definition; trigger some init on first set
 within a given word.  Push out a (genhook) for each *set* of words defined



: } Sanity check/catch bad brace matching

















code movjmp Move a block of code, then jump (presumably into it).
 Emulate being a Multiboot loader so our code will pull in the
 correct memory size.


: fastboot Load our own variant of Multiboot-headed code at "here",
 then atomically move it to its load point and jump into it.
   Verify that it looks like a Multiboot image

   Decode its fields, get ready to load it at "here"

   Iterate the blocks, copying them to "here"

   Create a Multiboot information structure