6471 lines
266 KiB
Text
6471 lines
266 KiB
Text
~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
~ ~~ Code transformation facility ~~
|
|
~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
~
|
|
~ The process of producing an executable binary out of Evocation involves
|
|
~ various bootstrapping phases during which code operates under different
|
|
~ constraints, and must be written with different styles. In some cases,
|
|
~ substantially the same code must be output multiple times in slightly
|
|
~ different ways, and it would be both arduous and verbose to write each of
|
|
~ these directly.
|
|
~
|
|
~ To solve this problem, this file implements a concept of code
|
|
~ transformation. There are two transforms, the label transform and the
|
|
~ log-load transform, each of which takes a string containing Evocation source
|
|
~ code and produces compiled code that has been modified to operate in a
|
|
~ specific way. The transforms rely on the label facility provided by
|
|
~ labels.e, and expect to run from within label-loop.
|
|
~
|
|
~ The label transform produces code that uses one label per word it defines,
|
|
~ to statically reference everything. Thus, when output to an executable
|
|
~ binary, this code will function without external dependencies. The tradeoff
|
|
~ is that it has no way to reference data that exists only at runtime.
|
|
~
|
|
~ The log-load transform relies on labels, but doesn't add any of its own.
|
|
~ It produces a compiled routine which, when run, dynamically looks up all the
|
|
~ references in the log, and appends the original code to the log. This adds
|
|
~ work that must be done when the runtime starts up, but the benefit is that
|
|
~ it can reference data that doesn't exist at compile-time. Most crucially,
|
|
~ it can reference the "here" and "latest" pointers in the log, which are
|
|
~ required for all the usual word-definition stuff to work, and whose
|
|
~ addresses are not known until runtime.
|
|
~
|
|
~ The log-load transform may also be useful for experimental tasks such as
|
|
~ creating additional, independent logs, or injecting Evocation into another
|
|
~ process's address space.
|
|
~
|
|
~ Please notice that both these transforms, in different ways, navigate the
|
|
~ same underlying design tension: The Forth compilation model hardcodes
|
|
~ references at the time compilation happens, and Evocation makes the choice
|
|
~ to not decide the address of the log until runtime. Thus the label transform
|
|
~ can't be sufficient on its own. Other Forths avoid this problem by
|
|
~ hardcoding an address for the log, or by using OS-provided load-time
|
|
~ symbol relocation. Evocation, however, does it on hard mode, mostly for fun.
|
|
~
|
|
~ Because it was clear from early on that the label transform couldn't stand
|
|
~ alone, and that another one would be necessary, we've refrained from adding
|
|
~ too many features to it. Since we have multiple transforms, they should each
|
|
~ be kept simple and well-defined, so that they can be composed in creative
|
|
~ new ways down the line. When adding additional behavior, always give thought
|
|
~ to whether it belongs in an existing transform or a new one.
|
|
~
|
|
~
|
|
~ About the label transform
|
|
~ ~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
~
|
|
~ The label transform operates on code that compiles itself, and ensures
|
|
~ that the result of the compilation is suitable to be included in an
|
|
~ executable binary as words that are statically referenced by their
|
|
~ addresses. To achieve this, it causes each newly-defined word to have a
|
|
~ corresponding label whose value is the offset of its codeword, and it causes
|
|
~ all compiled invocations of other words to be resolved by using these labels.
|
|
~ The label transform is suitable for code that must be directly invoked by
|
|
~ the warm-start routine provided by execution.e.
|
|
~
|
|
~ The most fundamental technique the label transform performs is to separate
|
|
~ words that run in compile mode from words that run immediately. There is no
|
|
~ distinction made between words running in immediate mode, and words declared
|
|
~ as immediate. Immediate words are looked up and executed based on their
|
|
~ "real", currently-executing definitions. Compiled words, including
|
|
~ literals, are looked up via the label facility.
|
|
~
|
|
~ Since the label facility is able to resolve forward references, there is
|
|
~ no hard requirement that everything in the file be topologically sorted.
|
|
~ However, the transform will refuse to create forward references to compiled
|
|
~ words. If you want them, you can create them by hand by calling use-label
|
|
~ yourself. This restriction is in place because allowing forward references
|
|
~ would be a significant difference from un-transformed code that could easily
|
|
~ become confusing, and because it simplifies the implementation a bit.
|
|
~
|
|
~ Compilation words do make extensive reference to the global variables
|
|
~ "here" and "latest". In particular, flow-control words such as if-else
|
|
~ expect the log to have recent compilation outputs on it, and to be able to
|
|
~ mutate them in-place. In order to make this work, we provide temporary
|
|
~ values of these two variables which point to the location of the output
|
|
~ buffer. This allows pointer resolution to work correctly without additional
|
|
~ effort, but notice that the buffer's address will differ from the address
|
|
~ the resulting program loads itself at. There's no simple way to avoid this
|
|
~ concern, since the variables must point to one of those addresses or the
|
|
~ other, not both.
|
|
~
|
|
~ We resolve the issue by running our own, alternate versions of most of the
|
|
~ critical word-defining words, including for example "create", ":", and ";".
|
|
~ These alternates run instead of the normal versions of these words, and use
|
|
~ the label facility to compute the addresses that will be needed at runtime.
|
|
~ The code being compiled is responsible for not doing anything else that
|
|
~ would rely on "here" and "latest" matching their runtime addresses, though
|
|
~ it is otherwise allowed to modify and rely on them in all the usual ways.
|
|
~ The alternate versions are defined in this file as their own words,
|
|
~ "label-create-alternate" and so on.
|
|
~
|
|
~ Note that these alternates are applied via a purely lexical
|
|
~ transformation: when a word would be looked up in the dictionary to
|
|
~ interpret, first check if it's one of these. That means the transformation
|
|
~ won't apply to indirect callers of these words, nor to tick-quotes of them.
|
|
~ The code being compiled is responsible for not doing either of those things.
|
|
~
|
|
~ Notably, the transformation uses the same "interpreter-flags" variable as
|
|
~ the rest of Evocation. There's no need to keep it separate like there is
|
|
~ with the other variables. This makes it easy to change modes.
|
|
~
|
|
~ The label transformation and its alternates rely on various labels, all of
|
|
~ which must be defined elsewhere, lest the label loop fail to converge:
|
|
~ "lit", "origin", "docol", "exit", ":", ";", and ";asm".
|
|
~
|
|
~ All of these limitations result in the compiled code being, in effect,
|
|
~ written in a dialect which is like Evocation, but more restricted. This is
|
|
~ acceptable, because the label transform is intended for compiling code that
|
|
~ is an early part of Evocation itself, and the necessary code has all been
|
|
~ written to follow these restrictions.
|
|
~
|
|
~
|
|
~ About the log-load transform
|
|
~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
~
|
|
~ The log-load transform also operates on code that compiles itself; it
|
|
~ produces a compiled routine which, when run, appends the original code to
|
|
~ the log. As the routine is run, each reference to another word is resolved
|
|
~ by looking up the name of the target word in the log. Furthermore, these
|
|
~ lookups are done using log-load-find, defined in log-load.e, which accepts
|
|
~ a pointer to the log's base address as a parameter. See that file for more
|
|
~ explanation of what the log is and why it's important. Thus, unlike normal
|
|
~ accesses to the log, this routine doesn't rely on already having the log's
|
|
~ base address hardcoded into it at the time of its own compilation. The
|
|
~ log-load transform is suitable for implementing the core responsibilities of
|
|
~ the warm-start routine provided by execution.e, relying on only a few
|
|
~ specific words that it statically references via labels.
|
|
~
|
|
~ Much like the label transform, the log-load transform provides alternate
|
|
~ versions of certain immediate words used in word definition. Also like the
|
|
~ label transform, it provides its own copies of "here" and "latest".
|
|
~
|
|
~ The log-load transform provides alternates for a significantly broader set
|
|
~ of words than the label transform, including all the flow-control words such
|
|
~ as if-else. It runs its own alternates immediately, but unlike the label
|
|
~ transform, immediate execution for the log-load transform is not actually
|
|
~ immediate; it is compiled into words which will have those immediate effects
|
|
~ at the time the generated routine is run. The generated routine can itself
|
|
~ be thought of as a compilation process, producing its output on the log, so
|
|
~ doing things later for us still means doing them immediately during the
|
|
~ routine.
|
|
~
|
|
~ The log-load transform does impose a no-forward-references requirement,
|
|
~ though it is applied at the time the routine is run, rather than at the time
|
|
~ of the transformation.
|
|
~
|
|
~ The log-load transformation and its alternates rely on the following
|
|
~ labels, all of which must be defined elsewhere: TODO
|
|
~
|
|
~
|
|
~ About the hex transform
|
|
~ ~~~~~~~~~~~~~~~~~~~~~~~
|
|
~
|
|
~ The hex transform's role is a bit different. Whereas the label and
|
|
~ log-load transforms are used as part of generating an executable binary, the
|
|
~ hex transform produces a commented hex dump that, when later processed by
|
|
~ the "hex" tool, produces that same binary. It achieves this by modifying
|
|
~ various words which are core parts of Evocation to keep track of appropriate
|
|
~ comments and other metadata, and modifying the output facility to output a
|
|
~ hex dump with any attached comments, rather than raw bytes.
|
|
~
|
|
~ By its nature, the hex transform needs to be able to cope with other
|
|
~ transforms running inside itself; that is, the transformation facility needs
|
|
~ to be reentrant. The other transforms don't have to cope with that, since
|
|
~ the code they run is mostly just about creating word definitions, but the
|
|
~ code given to the hex transform will normally include a call to label-loop,
|
|
~ all the memory manipulation that happens as part of binary generation, and
|
|
~ various output words.
|
|
~
|
|
~ While the label and log-load transforms allow Evocation to be a
|
|
~ self-hosting compiler, the hex transform attains the even higher bar of
|
|
~ making Evocation a "self-bootstrapping" compiler, able to create a running
|
|
~ copy of itself without having any sort of pre-existing compiler at all, only
|
|
~ a hex converter or similar small tool. The idea is that the hex converter is
|
|
~ small and simple enough that it's easy to perform a BINARY audit on, and
|
|
~ that there need be no other binary artifacts in the chain of trust.
|
|
~
|
|
~ This is not a new concept, but as far as Irenes are aware this name for it
|
|
~ is a new coinage. The approach of using a hex-to-binary conversion tool as
|
|
~ the initial bootstrapping stage is due to MesCC, which is quite inspiring in
|
|
~ that regard.
|
|
~
|
|
~ The key insight is that, some sense, the difference between source code
|
|
~ and binary is the ability to have comments.
|
|
~
|
|
~ The hex transform keeps some large, complex state as it runs, unlike the
|
|
~ label and log-load transforms, which only require very simple state. This
|
|
~ state is called the "output metadata". Entries in the output metadata are
|
|
~ created and modified as the code under transform runs, by "magic comments"
|
|
~ embedded within it. There is a complex command language for these comments,
|
|
~ which must be understood to write code designed to make good use of the hex
|
|
~ transform. Fortunately, that's really just assembly-language
|
|
~ implementations.
|
|
~
|
|
~ It's quite an intense topic, and many readers may wish only to know that
|
|
~ the hex transform exists, not how it's structured. So, details on the output
|
|
~ metadata and the magic comments are described below, under "hex transform
|
|
~ implementation", rather than here.
|
|
~
|
|
~ The hex transform DOES NOT WORK yet. It's still in development.
|
|
~ TODO update this note when it does work
|
|
|
|
|
|
~ Address-management helpers
|
|
~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
~
|
|
~ The facilities in this section are used as helper code in the
|
|
~ implementations of all three transforms.
|
|
|
|
|
|
~ We have a bunch of accessors for the transformation state structure, which
|
|
~ are all functions from pointers to pointers. We also define a global
|
|
~ variable which points to the transformation state.
|
|
: transformation-state-saved-here ;
|
|
: transformation-state-saved-latest 8 + ;
|
|
: transformation-state-output-buffer-start 2 8 * + ;
|
|
: transformation-state-user-stack-depth 3 8 * + ;
|
|
: transformation-state-label-scratch 4 8 * + ;
|
|
: transformation-state-output-metadata 5 8 * + ;
|
|
: allocate-transformation-state
|
|
6 8 * allocate
|
|
dup transformation-state-saved-here 0 swap !
|
|
dup transformation-state-saved-latest 0 swap !
|
|
dup transformation-state-output-buffer-start 0 swap !
|
|
dup transformation-state-user-stack-depth 0 swap !
|
|
dup transformation-state-label-scratch 0 swap !
|
|
dup transformation-state-output-metadata 0 swap ! ;
|
|
allocate-transformation-state s" transformation-state" variable
|
|
|
|
|
|
~ When calling the label facility during a transformation, it's necessary
|
|
~ to use the real, non-wrapped "here" and "latest".
|
|
: swap-transform-variables
|
|
here @ transformation-state transformation-state-saved-here @
|
|
here ! transformation-state transformation-state-saved-here !
|
|
latest @ transformation-state transformation-state-saved-latest @
|
|
latest ! transformation-state transformation-state-saved-latest ! ;
|
|
|
|
~ We deal with a few address spaces. There's the "host" address space, the
|
|
~ space this process performing the compilation is using for itself. There's
|
|
~ the "target" address space, the address space that will exist later, when
|
|
~ the program we've compiled is running.
|
|
~
|
|
~ Then there's "offsets", which are relative to the start of the output
|
|
~ buffer. For clarity's sake, we always refer to these as offsets, rather than
|
|
~ as addresses.
|
|
~
|
|
~ When we define labels for compiled words, we set their values to be
|
|
~ offsets pointing to the generated codeword. This is done by
|
|
~ label-create-alternate. We then need to convert them either to the host or
|
|
~ the target address space, depending on how we're using them.
|
|
~
|
|
~ There's no approach here that isn't confusing, but the hope is that by
|
|
~ using offsets, so that we always have to convert them regardless of what
|
|
~ we're doing with them, we won't miss a spot where conversion needs to
|
|
~ happen.
|
|
~
|
|
~ (output offset -- target address)
|
|
: offset-to-target-address-space
|
|
~ Don't transform null pointers.
|
|
dup { swap-transform-variables L@' origin swap-transform-variables + } if ;
|
|
|
|
~ (target address -- output offset)
|
|
: target-address-space-to-offset
|
|
~ Don't transform null pointers.
|
|
dup { swap-transform-variables L@' origin swap-transform-variables - } if ;
|
|
|
|
~ (output offset -- host address)
|
|
: offset-to-host-address-space
|
|
~ Don't transform null pointers
|
|
dup { transformation-state transformation-state-output-buffer-start @ + } if ;
|
|
|
|
~ (host address --output offset)
|
|
: host-address-space-to-offset
|
|
~ Don't transform null pointers
|
|
dup { transformation-state transformation-state-output-buffer-start @ - } if ;
|
|
|
|
~ (host address inside the output buffer -- target address)
|
|
: host-address-space-to-target
|
|
host-address-space-to-offset offset-to-target-address-space ;
|
|
|
|
~ (target address -- host address)
|
|
: target-address-space-to-host
|
|
target-address-space-to-offset offset-to-host-address-space ;
|
|
|
|
|
|
: describe-transformation
|
|
." active here " here @ .hex64 space
|
|
." latest " latest @ .hex64 newline
|
|
." saved here " transformation-state transformation-state-saved-here
|
|
@ .hex64 space
|
|
." latest " transformation-state transformation-state-saved-latest
|
|
@ .hex64 newline
|
|
." output start "
|
|
transformation-state transformation-state-output-buffer-start
|
|
@ .hex64 newline
|
|
." user stack depth "
|
|
transformation-state transformation-state-user-stack-depth
|
|
@ .hex64 newline ;
|
|
|
|
|
|
~ User stack depth tracking helper
|
|
~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
~
|
|
~ The transformation facility offers a feature which specific transforms can
|
|
~ use, or not, as they prefer, called user stack depth tracking. The log-load
|
|
~ transform uses it; the label transform does not. The most difficult part of
|
|
~ the tracking is the heler word below; it also relies on the user-stack-depth
|
|
~ field of the transformation-state variable.
|
|
~
|
|
~ What does user stack depth mean? Well, for every transform there's some
|
|
~ notion of running a word "immediately"; for the log-load transform, it means
|
|
~ that the word runs at the time the generated log-load routine executes. Each
|
|
~ time a word runs, it interacts with the value stack in some way. Some words
|
|
~ are neutral; others result in a net increase or decrease in its depth, which
|
|
~ we call the delta. The running total of these deltas is what we call the
|
|
~ user stack depth. By "user" we mean that these are values which were created
|
|
~ by and for the code being transformed, which the code doing the transforming
|
|
~ must be careful not to interfere with.
|
|
~
|
|
~ Why do we need to do this? Recall that the log-load routine is given the
|
|
~ log address as the only value on the stack when it begins, and any time it
|
|
~ does something that requires looking at the log, it needs to be able to find
|
|
~ that address. The log-load routine runs as part of the warm-start routine
|
|
~ (see execution.e), whose overall job is to get Evocation into a state where
|
|
~ it can freely work with dynamically-allocated data on the log whose address
|
|
~ isn't known at compile time. Therefore, necessarily, the log-load routine
|
|
~ itself cannot assume access to any scratch space; the value stack is the
|
|
~ only place it can store anything it needs, most crucially including the log
|
|
~ address.
|
|
~
|
|
~ Fortunately, it is possible for the transform's own generated code to
|
|
~ cooperate with the transformed code so that they can both share the stack,
|
|
~ as long as the log transform knows what the transformed code is doing with
|
|
~ it. Unfortunately, there's no general way to know that. We achieve it by
|
|
~ hard-coding a delta value for every single possible word, and looking up
|
|
~ that delta at transform-time, based on the word's name. Yes, that is quite a
|
|
~ thing to have to do, but it does mean we don't have to think about this
|
|
~ while writing the code we're transforming.
|
|
~
|
|
~ It's worth noticing that the delta only applies to things that happen
|
|
~ immediately. It does not apply to compiled words because they run later, and
|
|
~ it does not apply to alternates because they run too soon. Feel free to
|
|
~ contemplate how confusing it is that transformation-time is sooner than
|
|
~ "immediate".
|
|
~
|
|
~ (name pointer -- delta value)
|
|
: transform-get-stack-delta
|
|
~ From core.e.
|
|
dup s" docol" stringcmp 0 = { drop 1 exit } if
|
|
dup s" exit" stringcmp 0 = { drop 0 exit } if
|
|
dup s" swap" stringcmp 0 = { drop 0 exit } if
|
|
dup s" drop" stringcmp 0 = { drop -1 exit } if
|
|
dup s" 2drop" stringcmp 0 = { drop -2 exit } if
|
|
~ The following are deliberate omissions: roll, unroll.
|
|
dup s" 3roll" stringcmp 0 = { drop 0 exit } if
|
|
dup s" 3unroll" stringcmp 0 = { drop 0 exit } if
|
|
dup s" dup" stringcmp 0 = { drop 1 exit } if
|
|
dup s" 2dup" stringcmp 0 = { drop 2 exit } if
|
|
dup s" +" stringcmp 0 = { drop -1 exit } if
|
|
dup s" -" stringcmp 0 = { drop -1 exit } if
|
|
dup s" *" stringcmp 0 = { drop -1 exit } if
|
|
dup s" /%" stringcmp 0 = { drop 0 exit } if
|
|
dup s" 1+" stringcmp 0 = { drop 0 exit } if
|
|
dup s" 1-" stringcmp 0 = { drop 0 exit } if
|
|
dup s" =" stringcmp 0 = { drop -1 exit } if
|
|
dup s" !=" stringcmp 0 = { drop -1 exit } if
|
|
dup s" >" stringcmp 0 = { drop -1 exit } if
|
|
dup s" <" stringcmp 0 = { drop -1 exit } if
|
|
dup s" >=" stringcmp 0 = { drop -1 exit } if
|
|
dup s" <=" stringcmp 0 = { drop -1 exit } if
|
|
dup s" >unsigned" stringcmp 0 = { drop -1 exit } if
|
|
dup s" <unsigned" stringcmp 0 = { drop -1 exit } if
|
|
dup s" >=unsigned" stringcmp 0 = { drop -1 exit } if
|
|
dup s" <=unsigned" stringcmp 0 = { drop -1 exit } if
|
|
dup s" &" stringcmp 0 = { drop -1 exit } if
|
|
dup s" |" stringcmp 0 = { drop -1 exit } if
|
|
dup s" xor" stringcmp 0 = { drop -1 exit } if
|
|
dup s" invert" stringcmp 0 = { drop 0 exit } if
|
|
dup s" lit" stringcmp 0 = { drop 1 exit } if
|
|
dup s" litstring" stringcmp 0 = { drop 1 exit } if
|
|
dup s" !" stringcmp 0 = { drop -2 exit } if
|
|
dup s" @" stringcmp 0 = { drop 0 exit } if
|
|
dup s" +!" stringcmp 0 = { drop -2 exit } if
|
|
dup s" -!" stringcmp 0 = { drop -2 exit } if
|
|
dup s" 8!" stringcmp 0 = { drop -2 exit } if
|
|
dup s" 8@" stringcmp 0 = { drop 0 exit } if
|
|
dup s" 16!" stringcmp 0 = { drop -2 exit } if
|
|
dup s" 16@" stringcmp 0 = { drop 0 exit } if
|
|
dup s" 32!" stringcmp 0 = { drop -2 exit } if
|
|
dup s" 32@" stringcmp 0 = { drop 0 exit } if
|
|
dup s" control!" stringcmp 0 = { drop -1 exit } if
|
|
dup s" control@" stringcmp 0 = { drop 1 exit } if
|
|
dup s" value!" stringcmp 0 = { drop -1 exit } if
|
|
dup s" value@" stringcmp 0 = { drop 1 exit } if
|
|
dup s" memcopy" stringcmp 0 = { drop -3 exit } if
|
|
dup s" memmove" stringcmp 0 = { drop -3 exit } if
|
|
dup s" stringlen" stringcmp 0 = { drop 0 exit } if
|
|
dup s" reverse-stringlen" stringcmp 0 = { drop 0 exit } if
|
|
dup s" reverse-padding-len" stringcmp 0 = { drop 0 exit } if
|
|
dup s" stringcmp" stringcmp 0 = { drop -1 exit } if
|
|
dup s" branch" stringcmp 0 = { drop 0 exit } if
|
|
dup s" 0branch" stringcmp 0 = { drop 0 exit } if
|
|
~ This is kind of a big assumption.
|
|
dup s" execute" stringcmp 0 = { drop -1 exit } if
|
|
dup s" entry-to-execution-token" stringcmp 0 = { drop 0 exit } if
|
|
dup s" execution-token-to-entry" stringcmp 0 = { drop 0 exit } if
|
|
dup s" entry-flags@" stringcmp 0 = { drop 0 exit } if
|
|
dup s" entry-flags!" stringcmp 0 = { drop -2 exit } if
|
|
dup s" entry-to-name" stringcmp 0 = { drop 0 exit } if
|
|
dup s" pack64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" pack32" stringcmp 0 = { drop -1 exit } if
|
|
dup s" pack16" stringcmp 0 = { drop -1 exit } if
|
|
dup s" pack8" stringcmp 0 = { drop -1 exit } if
|
|
dup s" packstring" stringcmp 0 = { drop -1 exit } if
|
|
dup s" packalign" stringcmp 0 = { drop -1 exit } if
|
|
dup s" unpack64" stringcmp 0 = { drop 1 exit } if
|
|
dup s" unpack32" stringcmp 0 = { drop 1 exit } if
|
|
dup s" unpack16" stringcmp 0 = { drop 1 exit } if
|
|
dup s" unpack8" stringcmp 0 = { drop 1 exit } if
|
|
dup s" align-size" stringcmp 0 = { drop -1 exit } if
|
|
dup s" unpackalign" stringcmp 0 = { drop -1 exit } if
|
|
dup s" crash" stringcmp 0 = { drop 0 exit } if
|
|
dup s" max" stringcmp 0 = { drop -1 exit } if
|
|
dup s" min" stringcmp 0 = { drop -1 exit } if
|
|
dup s" over" stringcmp 0 = { drop 1 exit } if
|
|
dup s" pick" stringcmp 0 = { drop 0 exit } if
|
|
~ The following are deliberate omissions: ndrop, ndup.
|
|
dup s" 3drop" stringcmp 0 = { drop -3 exit } if
|
|
dup s" 3dup" stringcmp 0 = { drop 3 exit } if
|
|
dup s" &&" stringcmp 0 = { drop -1 exit } if
|
|
dup s" ||" stringcmp 0 = { drop -1 exit } if
|
|
dup s" not" stringcmp 0 = { drop 0 exit } if
|
|
dup s" negate" stringcmp 0 = { drop 0 exit } if
|
|
dup s" align-floor" stringcmp 0 = { drop -1 exit } if
|
|
|
|
~ From unix-like-syscalls.e.
|
|
dup s" sys-exit" stringcmp 0 = { drop -1 exit } if
|
|
dup s" sys-write" stringcmp 0 = { drop -2 exit } if
|
|
dup s" sys-read" stringcmp 0 = { drop -2 exit } if
|
|
|
|
~ From output.e.
|
|
dup s" emitstring" stringcmp 0 = { drop -1 exit } if
|
|
dup s" space" stringcmp 0 = { drop 0 exit } if
|
|
dup s" newline" stringcmp 0 = { drop 0 exit } if
|
|
dup s" pow" stringcmp 0 = { drop 2 exit } if
|
|
dup s" logfloor" stringcmp 0 = { drop 2 exit } if
|
|
dup s" logceil" stringcmp 0 = { drop 2 exit } if
|
|
dup s" .base-unsigned" stringcmp 0 = { drop -3 exit } if
|
|
dup s" .base" stringcmp 0 = { drop -2 exit } if
|
|
dup s" ." stringcmp 0 = { drop -1 exit } if
|
|
dup s" .hex" stringcmp 0 = { drop -1 exit } if
|
|
dup s" .hex8" stringcmp 0 = { drop -1 exit } if
|
|
dup s" .hex16" stringcmp 0 = { drop -1 exit } if
|
|
dup s" .hex32" stringcmp 0 = { drop -1 exit } if
|
|
dup s" .hex64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" .hexn" stringcmp 0 = { drop -2 exit } if
|
|
|
|
~ From amd64.e.
|
|
dup s" :rax" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :rcx" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :rdx" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :rbx" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :rsp" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :rbp" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :rsi" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :rdi" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :r8" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :r9" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :r10" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :r11" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :r12" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :r13" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :r14" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :r15" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :eax" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :ecx" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :edx" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :ebx" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :esp" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :ebp" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :esi" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :edi" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :ax" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cx" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :dx" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :bx" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :sp" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :bp" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :si" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :di" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :al" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cl" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :dl" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :bl" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :ah" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :ch" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :dh" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :bh" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-overflow" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-no-overflow" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-below" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-above-equal" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-equal" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-not-equal" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-below-equal" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-above" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-sign" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-not-sign" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-even" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-odd" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-less" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-greater-equal" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-less-equal" stringcmp 0 = { drop 1 exit } if
|
|
dup s" :cc-greater" stringcmp 0 = { drop 1 exit } if
|
|
dup s" reg64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" extrareg64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" reg32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" reg16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" reg8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" scalefield" stringcmp 0 = { drop 0 exit } if
|
|
dup s" condition-code" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-0" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-w" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-r" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-x" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-b" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-wr" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-wx" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-wb" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-rx" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-rb" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-xb" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-wrx" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-wrb" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-wxb" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-rxb" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rex-wrxb" stringcmp 0 = { drop 0 exit } if
|
|
dup s" opcodereg" stringcmp 0 = { drop -2 exit } if
|
|
dup s" opcodecc" stringcmp 0 = { drop -2 exit } if
|
|
dup s" modrm" stringcmp 0 = { drop -3 exit } if
|
|
dup s" sib" stringcmp 0 = { drop -3 exit } if
|
|
dup s" addressing-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" addressing-reg8" stringcmp 0 = { drop -2 exit } if
|
|
dup s" addressing-indirect-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" addressing-disp8-reg64" stringcmp 0 = { drop -3 exit } if
|
|
dup s" addressing-disp32-reg64" stringcmp 0 = { drop -3 exit } if
|
|
dup s" addressing-indexed-reg64" stringcmp 0 = { drop -4 exit } if
|
|
dup s" addressing-disp8-indexed-reg64" stringcmp 0 = { drop -5 exit } if
|
|
dup s" cld" stringcmp 0 = { drop 0 exit } if
|
|
dup s" std" stringcmp 0 = { drop 0 exit } if
|
|
dup s" syscall" stringcmp 0 = { drop 0 exit } if
|
|
dup s" hlt" stringcmp 0 = { drop 0 exit } if
|
|
dup s" push-reg64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" push-extrareg64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" pop-reg64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" pop-extrareg64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" push-imm32-extended64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" lea-reg64-disp8-reg64" stringcmp 0 = { drop -3 exit } if
|
|
dup s" lea-reg64-disp32-reg64" stringcmp 0 = { drop -3 exit } if
|
|
dup s" lea-reg64-indexed-reg64" stringcmp 0 = { drop -4 exit } if
|
|
dup s" lea-reg64-disp8-indexed-reg64" stringcmp 0 = { drop -5 exit } if
|
|
dup s" mov-reg64-imm32" stringcmp 0 = { drop -2 exit } if
|
|
dup s" mov-reg64-imm64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" mov-extrareg64-imm64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" mov-reg64-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" mov-indirect-reg64-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" mov-disp8-reg64-reg64" stringcmp 0 = { drop -3 exit } if
|
|
dup s" mov-reg64-indirect-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" mov-reg64-disp8-reg64" stringcmp 0 = { drop -3 exit } if
|
|
dup s" mov-reg64-disp32-reg64" stringcmp 0 = { drop -3 exit } if
|
|
dup s" mov-reg64-indexed-reg64" stringcmp 0 = { drop -4 exit } if
|
|
dup s" mov-indexed-reg64-reg64" stringcmp 0 = { drop -4 exit } if
|
|
dup s" mov-indirect-reg64-reg32" stringcmp 0 = { drop -2 exit } if
|
|
dup s" mov-disp8-reg64-reg32" stringcmp 0 = { drop -3 exit } if
|
|
dup s" mov-reg32-indirect-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" mov-reg32-disp8-reg64" stringcmp 0 = { drop -3 exit } if
|
|
dup s" mov-indirect-reg64-reg16" stringcmp 0 = { drop -2 exit } if
|
|
dup s" mov-disp8-reg64-reg16" stringcmp 0 = { drop -3 exit } if
|
|
dup s" mov-reg16-indirect-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" mov-reg16-disp8-reg64" stringcmp 0 = { drop -3 exit } if
|
|
dup s" mov-indirect-reg64-reg8" stringcmp 0 = { drop -2 exit } if
|
|
dup s" mov-disp8-reg64-reg8" stringcmp 0 = { drop -3 exit } if
|
|
dup s" mov-reg8-indirect-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" mov-reg8-disp8-reg64" stringcmp 0 = { drop -3 exit } if
|
|
dup s" mov-reg8-reg8" stringcmp 0 = { drop -2 exit } if
|
|
dup s" movs8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" movs16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" movs32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" movs64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rep-movs8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rep-movs16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rep-movs32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rep-movs64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" lods8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" lods16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" lods32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" lods64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rep-lods8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rep-lods16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rep-lods32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rep-lods64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" stos8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" stos16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" stos32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" stos64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rep-stos8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rep-stos16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rep-stos32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" rep-stos64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" cmps8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" cmps16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" cmps32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" cmps64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repz-cmps8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repz-cmps16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repz-cmps32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repz-cmps64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repnz-cmps8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repnz-cmps16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repnz-cmps32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repnz-cmps64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" scas8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" scas16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" scas32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" scas64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repz-scas8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repz-scas16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repz-scas32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repz-scas64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repnz-scas8" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repnz-scas16" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repnz-scas32" stringcmp 0 = { drop 0 exit } if
|
|
dup s" repnz-scas64" stringcmp 0 = { drop 0 exit } if
|
|
dup s" add-reg64-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" add-indirect-reg64-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" add-reg64-indirect-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" add-reg64-imm8" stringcmp 0 = { drop -2 exit } if
|
|
dup s" sub-reg64-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" sub-indirect-reg64-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" sub-reg64-imm8" stringcmp 0 = { drop -2 exit } if
|
|
dup s" sbb-reg64-imm8" stringcmp 0 = { drop -2 exit } if
|
|
dup s" neg-reg64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" mul-reg64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" divmod-reg64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" idivmod-reg64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" inc-reg64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" dec-reg64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" and-reg64-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" and-reg64-imm8" stringcmp 0 = { drop -2 exit } if
|
|
dup s" or-reg64-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" or-reg64-imm8" stringcmp 0 = { drop -2 exit } if
|
|
dup s" xor-reg64-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" not-reg64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" cmp-reg64-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" test-reg64-reg64" stringcmp 0 = { drop -2 exit } if
|
|
dup s" set-reg8-cc" stringcmp 0 = { drop -2 exit } if
|
|
dup s" jmp-cc-rel-imm8" stringcmp 0 = { drop -2 exit } if
|
|
dup s" jmp-cc-rel-imm32" stringcmp 0 = { drop -2 exit } if
|
|
dup s" jmp-abs-indirect-reg64" stringcmp 0 = { drop -1 exit } if
|
|
dup s" jmp-rel-imm8" stringcmp 0 = { drop -1 exit } if
|
|
dup s" jmp-rel-imm32" stringcmp 0 = { drop -1 exit } if
|
|
|
|
~ From execution-support.e.
|
|
dup s" pack-next" stringcmp 0 = { drop 0 exit } if
|
|
dup s" pack-beforenext" stringcmp 0 = { drop -1 exit } if
|
|
dup s" pack-pushcontrol" stringcmp 0 = { drop -1 exit } if
|
|
dup s" pack-popcontrol" stringcmp 0 = { drop -1 exit } if
|
|
|
|
~ From dynamic.e.
|
|
dup s" stack" stringcmp 0 = { drop 0 exit } if
|
|
dup s" stackhex" stringcmp 0 = { drop 0 exit } if
|
|
dup s" is-in-log" stringcmp 0 = { drop 0 exit } if
|
|
dup s" oldest-entry" stringcmp 0 = { drop 1 exit } if
|
|
dup s" next-newer-entry" stringcmp 0 = { drop 0 exit } if
|
|
dup s" guess-entry-end" stringcmp 0 = { drop 0 exit } if
|
|
dup s" containing-entry" stringcmp 0 = { drop 0 exit } if
|
|
dup s" is-assembly-word" stringcmp 0 = { drop 0 exit } if
|
|
dup s" is-docol-itself" stringcmp 0 = { drop 0 exit } if
|
|
dup s" is-docol-codeword" stringcmp 0 = { drop 0 exit } if
|
|
dup s" is-docol-interpreted-word" stringcmp 0 = { drop 0 exit } if
|
|
dup s" is-codeword-pointer" stringcmp 0 = { drop 0 exit } if
|
|
dup s" indent" stringcmp 0 = { drop -1 exit } if
|
|
dup s" word-heading" stringcmp 0 = { drop -1 exit } if
|
|
dup s" list-dictionary" stringcmp 0 = { drop 0 exit } if
|
|
dup s" hexdump-row" stringcmp 0 = { drop -3 exit } if
|
|
dup s" hexdump-between" stringcmp 0 = { drop -2 exit } if
|
|
dup s" hexdump-from" stringcmp 0 = { drop -2 exit } if
|
|
dup s" hexdump" stringcmp 0 = { drop -1 exit } if
|
|
dup s" describe-hex" stringcmp 0 = { drop -1 exit } if
|
|
dup s" describe-docol" stringcmp 0 = { drop -1 exit } if
|
|
dup s" describe" stringcmp 0 = { drop -1 exit } if
|
|
dup s" describe-all" stringcmp 0 = { drop 0 exit } if
|
|
dup s" describe-compilation" stringcmp 0 = { drop 0 exit } if
|
|
dup s" symbolize-pointer" stringcmp 0 = { drop -1 exit } if
|
|
dup s" list-callers" stringcmp 0 = { drop 0 exit } if
|
|
dup s" forget" stringcmp 0 = { drop -1 exit } if
|
|
dup s" ," stringcmp 0 = { drop -1 exit } if
|
|
dup s" make-immediate" stringcmp 0 = { drop 0 exit } if
|
|
dup s" make-hidden" stringcmp 0 = { drop 0 exit } if
|
|
dup s" make-visible" stringcmp 0 = { drop 0 exit } if
|
|
dup s" recurse" stringcmp 0 = { drop 0 exit } if
|
|
dup s" recurse" stringcmp 0 = { drop 0 exit } if
|
|
dup s" find" stringcmp 0 = { drop 0 exit } if
|
|
dup s" allocate" stringcmp 0 = { drop 0 exit } if
|
|
dup s" create" stringcmp 0 = { drop -1 exit } if
|
|
dup s" self-codeword" stringcmp 0 = { drop 0 exit } if
|
|
dup s" variable" stringcmp 0 = { drop -2 exit } if
|
|
dup s" keyword" stringcmp 0 = { drop -1 exit } if
|
|
dup s" literal" stringcmp 0 = { drop -1 exit } if
|
|
|
|
~ From input.e.
|
|
dup s" buffer-physical-start" stringcmp 0 = { drop 0 exit } if
|
|
dup s" buffer-physical-length" stringcmp 0 = { drop 0 exit } if
|
|
dup s" buffer-logical-start" stringcmp 0 = { drop 0 exit } if
|
|
dup s" buffer-logical-length" stringcmp 0 = { drop 0 exit } if
|
|
dup s" input-buffer-refill" stringcmp 0 = { drop 0 exit } if
|
|
dup s" input-buffer-next-source" stringcmp 0 = { drop 0 exit } if
|
|
dup s" clear-buffer" stringcmp 0 = { drop -1 exit } if
|
|
dup s" zero-input-buffer-metadata" stringcmp 0 = { drop -1 exit } if
|
|
dup s" allocate-input-buffer-metadata" stringcmp 0 = { drop 1 exit } if
|
|
dup s" allocate-input-buffer" stringcmp 0 = { drop 0 exit } if
|
|
dup s" attach-string-to-input-buffer" stringcmp 0 = { drop -2 exit } if
|
|
dup s" consume-from" stringcmp 0 = { drop -1 exit } if
|
|
dup s" peek-from" stringcmp 0 = { drop 0 exit } if
|
|
dup s" key-from" stringcmp 0 = { drop 0 exit } if
|
|
dup s" normalize-buffer" stringcmp 0 = { drop -1 exit } if
|
|
dup s" compute-next-buffer-free-block" stringcmp 0 = { drop 1 exit } if
|
|
dup s" refill-input-buffer-from-stdin" stringcmp 0 = { drop -1 exit } if
|
|
dup s" main-input-buffer" stringcmp 0 = { drop 1 exit } if
|
|
dup s" consume" stringcmp 0 = { drop 0 exit } if
|
|
dup s" peek" stringcmp 0 = { drop 1 exit } if
|
|
dup s" key" stringcmp 0 = { drop 1 exit } if
|
|
|
|
~ From interpret.e.
|
|
dup s" unroll-past-string" stringcmp 0 = { drop 0 exit } if
|
|
dup s" swap-past-string" stringcmp 0 = { drop 0 exit } if
|
|
~ The following are deliberate omissions: dropstring,
|
|
~ dropstring-with-result, accumulate-string.
|
|
dup s" is-space" stringcmp 0 = { drop 0 exit } if
|
|
dup s" is-alphanumeric" stringcmp 0 = { drop 0 exit } if
|
|
~ The following is a deliberate omission: word.
|
|
dup s" generalized-digit-value" stringcmp 0 = { drop 0 exit } if
|
|
~ The following are deliberate omissions: decode-generalized-digit,
|
|
~ read-base-unsigned, read-integer-unsigned, read-integer, read-decimal.
|
|
dup s" interpreter-flags" stringcmp 0 = { drop 1 exit } if
|
|
dup s" [" stringcmp 0 = { drop 0 exit } if
|
|
dup s" ]" stringcmp 0 = { drop 0 exit } if
|
|
dup s" :" stringcmp 0 = { drop 0 exit } if
|
|
dup s" ;" stringcmp 0 = { drop 0 exit } if
|
|
dup s" ;asm" stringcmp 0 = { drop 0 exit } if
|
|
dup s" '" stringcmp 0 = { drop 1 exit } if
|
|
dup s" relink-main-input-buffer-to-stdin" stringcmp 0 = { drop 0 exit } if
|
|
~ The following is a deliberate omission: interpret.
|
|
dup s" quit" stringcmp 0 = { drop 0 exit } if
|
|
|
|
~ From linux-dynamic.e.
|
|
dup s" allocate-timespec" stringcmp 0 = { drop 1 exit } if
|
|
dup s" timespec-seconds" stringcmp 0 = { drop 0 exit } if
|
|
dup s" timespec-nanoseconds" stringcmp 0 = { drop 0 exit } if
|
|
dup s" nanosleep" stringcmp 0 = { drop 0 exit } if
|
|
dup s" sys-sigaction" stringcmp 0 = { drop -2 exit } if
|
|
dup s" sys-sigaltstack" stringcmp 0 = { drop -1 exit } if
|
|
dup s" allocate-sigaction" stringcmp 0 = { drop 1 exit } if
|
|
dup s" sigaction-action" stringcmp 0 = { drop 0 exit } if
|
|
dup s" sigaction-flags" stringcmp 0 = { drop 0 exit } if
|
|
dup s" sigaction-restorer" stringcmp 0 = { drop 0 exit } if
|
|
dup s" sigaction-mask" stringcmp 0 = { drop 0 exit } if
|
|
dup s" allocate-sigaltstack" stringcmp 0 = { drop 1 exit } if
|
|
dup s" sigaltstack-pointer" stringcmp 0 = { drop 0 exit } if
|
|
dup s" sigaltstack-flags" stringcmp 0 = { drop 0 exit } if
|
|
dup s" sigaltstack-size" stringcmp 0 = { drop 0 exit } if
|
|
dup s" prepare-signal-stack" stringcmp 0 = { drop 0 exit } if
|
|
~ The following is a deliberate omission: signal-return-trampoline.
|
|
dup s" wrap-signal-handler" stringcmp 0 = { drop 0 exit } if
|
|
dup s" bind-signal" stringcmp 0 = { drop -2 exit } if
|
|
~ The following is a deliberate omission: handle-crash.
|
|
dup s" install-crash-handler" stringcmp 0 = { drop 0 exit } if
|
|
|
|
~ Created by warm-start in execution.e.
|
|
dup s" log" stringcmp 0 = { drop 1 exit } if
|
|
dup s" s0" stringcmp 0 = { drop 1 exit } if
|
|
dup s" r0" stringcmp 0 = { drop 1 exit } if
|
|
dup s" latest" stringcmp 0 = { drop 1 exit } if
|
|
dup s" here" stringcmp 0 = { drop 1 exit } if
|
|
|
|
~ Word not provided statically, but used during the log-load routine anyway.
|
|
dup s" L@'" stringcmp 0 = { drop 1 exit } if
|
|
dup s" L!'" stringcmp 0 = { drop -1 exit } if
|
|
dup s" labels" stringcmp 0 = { drop 1 exit } if
|
|
dup s" allocate-transformation-state" stringcmp 0 = { drop 1 exit } if
|
|
|
|
~ If we get here, that's a problem. Emit an error message to make sure
|
|
~ it's easy to diagnose. We also return a comically large negative value,
|
|
~ to make sure things fail as quickly as possible afterwards.
|
|
." No known stack delta: " emitstring newline
|
|
-256 ;
|
|
|
|
|
|
~ (delta --)
|
|
: transform-apply-stack-delta
|
|
transformation-state transformation-state-user-stack-depth @ +
|
|
transformation-state transformation-state-user-stack-depth ! ;
|
|
|
|
|
|
~ Label transform implementation
|
|
~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
~
|
|
~ The following code is all part of implementing the label transform. For
|
|
~ conceptual overview, see the top of this file.
|
|
|
|
|
|
~ This is the alternate version of "create" for use with the label
|
|
~ transform. Its code is the same as the regular "create" except as noted
|
|
~ below. It is likely to be extremely useful to read and understand "create"
|
|
~ in dynamic.e before attempting to understand label-create-alternate.
|
|
: label-create-alternate
|
|
~ While we could put magic comments here, and be guaranteed to catch every
|
|
~ word-defining word under the label transform, there's a subtle thing where
|
|
~ we need to make sure the "indent" command happens in the same places it
|
|
~ does when the same code runs under the log-load transform, and only those
|
|
~ places. So, we do it in the callers of "create" instead.
|
|
dup stringlen 1 +
|
|
~ : provide-data
|
|
dup 3unroll
|
|
here @ 10 + swap memmove
|
|
here @
|
|
|
|
~ This value of "latest" is going into the generated output, so we need
|
|
~ to map it to the target address space. It's stored in the host address
|
|
~ space to make immediate words work as expected, so the appropriate
|
|
~ conversion is host-address-space-to-target.
|
|
~ : 8 #-- (previous entry pointer)
|
|
latest @ host-address-space-to-target pack64
|
|
~ : 1 #-- (entry flags)
|
|
0 pack8
|
|
~ : bidirectional-null-terminated entry name
|
|
0 pack8
|
|
~ : 1 data-adjust-output-point
|
|
~ : fresh-line
|
|
+
|
|
8 packalign
|
|
here @ latest !
|
|
|
|
~ Now we're immediately after the word header, which is where the codeword
|
|
~ will be. This is the value the label should taken on, so we set it.
|
|
dup host-address-space-to-offset
|
|
here @ 10 +
|
|
swap-transform-variables
|
|
intern-label set-label
|
|
swap-transform-variables
|
|
|
|
here ! ;
|
|
|
|
|
|
~ This is the alternate version of ":" for use with the label transform. Its
|
|
~ code is the same as the regular "create" except as noted below. It is likely
|
|
~ to be extremely useful to read and understand ":" in dynamic.e before
|
|
~ attempting to understand label-colon-alternate.
|
|
: label-colon-alternate
|
|
~ This calls label-create-alternate instead of "create".
|
|
word value@
|
|
~ : blank-line
|
|
~ : blank-line
|
|
~ : provide-string-copy
|
|
~ : # is defined here via the label transform; this is its entry header.
|
|
~ : indent
|
|
label-create-alternate dropstring
|
|
|
|
~ This looks up "docol" by label.
|
|
~ : 8 #-- (docol codeword)
|
|
swap-transform-variables
|
|
L@' docol-codeword-value
|
|
L@' origin
|
|
swap-transform-variables
|
|
+ ,
|
|
~ : blank-line
|
|
|
|
latest @ dup entry-flags@ 0x80 | swap entry-flags!
|
|
] ;
|
|
|
|
|
|
~ So, the way docol's user-facing entry is set up in core.e, it really wants
|
|
~ to reference "here" to create its codeword, but "here" is in the host
|
|
~ address space. We solve this by having it call the word "self-codeword" and
|
|
~ then patching around the address space issue with alternates.
|
|
~
|
|
~ If we didn't have this fix, everything would appear to work fine but the
|
|
~ statically generated user-facing docol from the label transform would have
|
|
~ a wrong codeword, varying based on the host's memory usage. It's never
|
|
~ actually called by evoke itself (it would crash horribly), though it may
|
|
~ be from programs that use the facilities differently. It's a binary
|
|
~ reproducibility issue - our only known one, in fact - so it's worth fixing.
|
|
: label-self-codeword-alternate
|
|
here @ dup 8 + host-address-space-to-target pack64 here !
|
|
; make-immediate
|
|
|
|
|
|
~ This is the alternate version of ";" for use with the label transform. Its
|
|
~ code is the same as the regular "create" except as noted below. It is likely
|
|
~ to be extremely useful to read and understand ";" in dynamic.e before
|
|
~ attempting to understand label-semicolon-alternate.
|
|
: label-semicolon-alternate
|
|
~ This looks up "exit" by label.
|
|
swap-transform-variables
|
|
L@' exit
|
|
swap-transform-variables
|
|
offset-to-target-address-space , ~ : -8 exit #-- (codeword pointer)
|
|
~ : deindent
|
|
|
|
latest @ dup entry-flags@ 0x80 invert & swap entry-flags!
|
|
|
|
~ Since [ is an immediate word, we have to go to extra trouble to compile
|
|
~ it as part of ;.
|
|
[ ' [ entry-to-execution-token , ]
|
|
; make-immediate
|
|
|
|
|
|
~ This is the alternate version of ";asm" for use with the label transform.
|
|
~ Its code is the same as the regular "create" except as noted below. It is
|
|
~ likely to be extremely useful to read and understand ";asm" in dynamic.e
|
|
~ before attempting to understand label-semicolon-assembly-alternate.
|
|
: label-semicolon-assembly-alternate
|
|
here @ pack-next 8 packalign
|
|
~ : provide-data
|
|
here !
|
|
~ : deindent
|
|
|
|
latest @ dup dup entry-flags@ 0x80 invert & swap entry-flags!
|
|
entry-to-execution-token
|
|
~ The codeword needs to be transformed to the target address space.
|
|
~ : provide-data
|
|
~ : data-set-output-point
|
|
~ : delete-last-comment-at-output-point
|
|
~ : 8 #-- (self codeword)
|
|
dup 8 + host-address-space-to-target
|
|
swap !
|
|
~ : data-set-output-point
|
|
|
|
~ Since [ is an immediate word, we have to go to extra trouble to compile
|
|
~ it as part of ;asm.
|
|
[ ' [ entry-to-execution-token , ]
|
|
; make-immediate
|
|
|
|
|
|
~ TODO there should really be an actual word that this alternate is replacing
|
|
~
|
|
~ If it existed, that word would be (string pointer --).
|
|
: label-keyword-alternate
|
|
~ : blank-line
|
|
~ : blank-line
|
|
~ : provide-string-copy
|
|
~ : # is defined here via the label transform; this is its entry header.
|
|
~ : indent
|
|
label-create-alternate
|
|
|
|
here @ dup
|
|
~ (self execution token, output point)
|
|
dup 8 + host-address-space-to-target pack64
|
|
swap host-address-space-to-target :rax mov-reg64-imm64
|
|
~ (output point)
|
|
:rax push-reg64
|
|
pack-next
|
|
8 packalign
|
|
here !
|
|
~ : deindent
|
|
; make-immediate
|
|
|
|
|
|
~ It's convenient to be able to work with strings in label-transformed
|
|
~ code. If we don't provide an alternate for it, we get codeword pointers in
|
|
~ the host address space, which therefore don't work.
|
|
: label-string-alternate
|
|
~ Something subtle here: s" is state-dependent. That is, it does different
|
|
~ things depending on the interpreter flags. We would really rather know
|
|
~ which version we're getting, and also it would be best if it didn't
|
|
~ scribble on the output buffer. Fortunately we can achieve both of these,
|
|
~ by coercing things into a known state while calling it.
|
|
~
|
|
~ We could choose either version of s", but the interpreted one is more
|
|
~ convenient because it doesn't mess with a spurious litstring invocation,
|
|
~ just scribbled into scratch space after "here". Of course, that raises the
|
|
~ additional concern that we have the wrong "here", but we can just swap
|
|
~ that around, too.
|
|
~
|
|
~ This is all worth it to avoid reimplementing s". If we had two
|
|
~ implementations, they'd have to be kept in sync, and it's an important
|
|
~ user-facing word with semantics that are likely to improve over time.
|
|
interpreter-flags @
|
|
' s" entry-to-execution-token
|
|
swap-transform-variables
|
|
~ Since [ is an immediate word, we have to go to extra trouble to compile
|
|
~ it as part of the alternate.
|
|
[ ' [ entry-to-execution-token , ]
|
|
execute
|
|
swap-transform-variables
|
|
swap interpreter-flags !
|
|
|
|
~ Whew. What a mouthful.
|
|
~
|
|
~ Having done this, we have the string pointer on the stack at transform
|
|
~ time, which with the label transform is the same as immediate time. If
|
|
~ we're in immediate mode, therefore, we've left the string on the stack and
|
|
~ that's all we wanted. If we're in compile mode, it's our job to output a
|
|
~ litstring invocation.
|
|
|
|
interpreter-flags @ 0x01 & {
|
|
swap-transform-variables
|
|
L@' litstring
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer)
|
|
here @ swap packstring 8 packalign here !
|
|
} if
|
|
; make-immediate
|
|
|
|
|
|
: label-dot-string-alternate
|
|
' label-string-alternate entry-to-execution-token execute
|
|
|
|
interpreter-flags @ 0x01 & {
|
|
swap-transform-variables
|
|
L@' emitstring
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space , ~ : -8 emitstring #-- (codeword pointer)
|
|
} { emitstring } if-else
|
|
; make-immediate
|
|
|
|
|
|
~ Because docol requires it, we provide a special mini-version of the label
|
|
~ system. We only do L@' and L!', because that's all we need. These are real
|
|
~ labels; there can be arbitrarily many of them, and they can have forward
|
|
~ references.
|
|
~
|
|
~ The value that's accepted is in the host address space; the label is set
|
|
~ to an offset; and the value that's returned is in the target address space.
|
|
~
|
|
~ (-- value)
|
|
: label-L@'-alternate
|
|
word value@
|
|
|
|
swap-transform-variables
|
|
intern-label
|
|
use-label
|
|
swap-transform-variables
|
|
|
|
dropstring-with-result
|
|
|
|
offset-to-target-address-space
|
|
; make-immediate
|
|
|
|
|
|
~ (value --)
|
|
: label-L!'-alternate
|
|
host-address-space-to-offset
|
|
|
|
word value@
|
|
|
|
swap-transform-variables
|
|
intern-label
|
|
swap-transform-variables
|
|
|
|
dropstring-with-result
|
|
|
|
swap-transform-variables
|
|
set-label
|
|
swap-transform-variables
|
|
; make-immediate
|
|
|
|
|
|
~ We implement alternates of all the high-level flow-control words for the
|
|
~ label transform: if, unless, if-else, forever, and while. We leave { and }
|
|
~ as their usual implementations. The values { and } leave on the stack will
|
|
~ be in the host address space, which is convenient anyway. Those values don't
|
|
~ make their way into the output, since everything is relative, and the
|
|
~ relative offsets are correct regardless. What we do need to change, though,
|
|
~ is the addresses of branch and 0branch. We need to resolve these via label.
|
|
~
|
|
~ (start pointer, length --)
|
|
: label-if-alternate
|
|
2dup swap dup 5 8 * + 3roll
|
|
~ (start pointer, length, adjusted start pointer, start pointer, length)
|
|
memmove
|
|
~ (start pointer, length)
|
|
swap here @ swap here ! swap
|
|
~ (old here, length)
|
|
swap-transform-variables
|
|
L@' 0branch
|
|
L@' !=
|
|
L@' lit
|
|
swap-transform-variables
|
|
offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer)
|
|
0 ~ : provide-hex
|
|
, ~ : -8 # #-- (integer literal)
|
|
offset-to-target-address-space , ~ : -8 != #-- (codeword pointer)
|
|
~ The branch length needs to be one word longer than the block length,
|
|
~ because the length field itself is part of the scope of the branch.
|
|
offset-to-target-address-space , ~ : -8 0branch #-- (codeword pointer)
|
|
dup 8 + ~ : provide-hex
|
|
~ : 8 # #-- (branch offset)
|
|
,
|
|
~ (old here, length)
|
|
drop 5 8 * + here !
|
|
; make-immediate
|
|
|
|
~ (start pointer, length)
|
|
: label-unless-alternate
|
|
2dup swap dup 5 8 * + 3roll
|
|
~ (start pointer, length, adjusted start pointer, start pointer, length)
|
|
memmove
|
|
~ (start pointer, length)
|
|
swap here @ swap here ! swap
|
|
~ (old here, length)
|
|
swap-transform-variables
|
|
L@' 0branch
|
|
L@' =
|
|
L@' lit
|
|
swap-transform-variables
|
|
offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer)
|
|
0 ~ : provide-hex
|
|
, ~ : -8 # #-- (integer literal)
|
|
offset-to-target-address-space , ~ : -8 = #-- (codeword pointer)
|
|
~ The branch length needs to be one word longer than the block length,
|
|
~ because the length field itself is part of the scope of the branch.
|
|
offset-to-target-address-space , ~ : -8 0branch #-- (codeword pointer)
|
|
dup 8 + ~ : provide-hex
|
|
~ : 8 # #-- (branch offset)
|
|
,
|
|
~ (old here, length)
|
|
drop 5 8 * + here !
|
|
; make-immediate
|
|
|
|
~ (true start, true length, false start, false length)
|
|
: label-if-else-alternate
|
|
~ First we slide the false-block forward, then the true-block. We slide
|
|
~ them both directly into their final positions, leaving space at the start
|
|
~ for a test and branch, and space in between for an unconditional branch.
|
|
~ Those spaces will take five words, and two words, respectively. So the
|
|
~ false-block gets moved by seven words, and the true-block gets moved by
|
|
~ five words.
|
|
2dup swap dup 7 8 * + 3roll memmove
|
|
3 pick dup 5 8 * + 4 pick memmove
|
|
~ (true start, true length, false start, false length)
|
|
|
|
~ Now we write out the initial test-and-branch.
|
|
4 roll dup 5 unroll here @ 6 unroll here !
|
|
~ (old here, true start, true length, false start, false length)
|
|
swap-transform-variables
|
|
L@' 0branch
|
|
L@' !=
|
|
L@' lit
|
|
swap-transform-variables
|
|
offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer)
|
|
0 ~ : provide-hex
|
|
, ~ : -8 # #-- (integer literal)
|
|
offset-to-target-address-space , ~ : -8 != #-- (codeword pointer)
|
|
~ Branch past the length field, the true-block, and the unconditional
|
|
~ branch in the middle.
|
|
offset-to-target-address-space , ~ : -8 0branch #-- (codeword pointer)
|
|
3roll dup 4 unroll 3 8 * + ~ : provide-hex
|
|
~ : 8 # #-- (branch offset)
|
|
,
|
|
|
|
~ Next, write out the unconditional branch in the middle.
|
|
swap dup 3unroll 5 8 * + here !
|
|
swap-transform-variables
|
|
L@' branch
|
|
swap-transform-variables
|
|
offset-to-target-address-space , ~ : -8 branch #-- (codeword pointer)
|
|
~ Branch past the length field and the false-block.
|
|
dup 8 + ~ : provide-hex
|
|
~ : 8 # #-- (branch offset)
|
|
,
|
|
|
|
~ Set "here" to point to the true end.
|
|
drop drop drop drop 7 8 * + here !
|
|
; make-immediate
|
|
|
|
~ (start, length --)
|
|
: label-forever-alternate
|
|
swap-transform-variables
|
|
L@' branch
|
|
swap-transform-variables
|
|
offset-to-target-address-space , ~ : -8 branch #-- (codeword pointer)
|
|
8 + -1 * ~ : provide-hex
|
|
~ : 8 # #-- (branch offset)
|
|
, drop
|
|
; make-immediate
|
|
|
|
~ (test start, test length, body start, body length --)
|
|
: label-while-alternate
|
|
~ The conditional branch needs five words.
|
|
2dup swap dup 5 8 * + 3roll memmove
|
|
here @ 5 unroll swap dup 3unroll here !
|
|
~ (old here, test start, test length, body start, body length)
|
|
swap-transform-variables
|
|
L@' 0branch
|
|
L@' !=
|
|
L@' lit
|
|
swap-transform-variables
|
|
offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer)
|
|
0 ~ : provide-hex
|
|
, ~ : -8 # #-- (integer literal)
|
|
offset-to-target-address-space , ~ : -8 != #-- (codeword pointer)
|
|
~ Branch past the length field, the body, and the unconditional branch.
|
|
offset-to-target-address-space , ~ : -8 0branch #-- (codeword pointer)
|
|
dup 3 8 * + ~ : provide-hex
|
|
~ : 8 # #-- (branch offset)
|
|
,
|
|
~ Set "here" to the new end.
|
|
5 8 * 6 roll + here !
|
|
~ (test start, test length, body start, body length)
|
|
~ Unconditionally branch backwards past the branch word, the body, the
|
|
~ conditional branch, and the test.
|
|
swap-transform-variables
|
|
L@' branch
|
|
swap-transform-variables
|
|
offset-to-target-address-space , ~ : -8 branch #-- (codeword pointer)
|
|
6 8 * + swap drop + swap drop -1 * ~ : provide-hex
|
|
~ : 8 # #-- (branch offset)
|
|
,
|
|
; make-immediate
|
|
|
|
|
|
~ This implements the label transform for a single word. It is directly
|
|
~ analogous to "interpret", and reading dynamic.e may help in understanding
|
|
~ it, though it's meant to still make sense on its own.
|
|
~
|
|
~ It expects to be called from "label-transform", below, which loops.
|
|
~
|
|
~ (-- done)
|
|
: label-transform-one
|
|
word
|
|
|
|
~ If no word was returned, end the transformation.
|
|
dup 0 = { drop 1 exit } if
|
|
|
|
~ The string is on the top of the stack, so to get a pointer to it we get
|
|
~ the stack address.
|
|
~ (string)
|
|
value@
|
|
|
|
~ Check whether it's one of the words we have alternates for, and look up
|
|
~ the alternate if so.
|
|
dup 0 swap
|
|
~ (name as stack string, name pointer, placeholder, name pointer)
|
|
dup s" create" stringcmp 0 = { swap drop ' label-create-alternate swap } if
|
|
dup s" :" stringcmp 0 = { swap drop ' label-colon-alternate swap } if
|
|
dup s" self-codeword" stringcmp 0 = {
|
|
swap drop ' label-self-codeword-alternate swap } if
|
|
dup s" ;" stringcmp 0 = { swap drop ' label-semicolon-alternate swap } if
|
|
dup s" ;asm" stringcmp 0 = {
|
|
swap drop ' label-semicolon-assembly-alternate swap } if
|
|
~ It is nontrivial to construct a string with a double-quote in it.
|
|
dup ' s" entry-to-name stringcmp 0 = {
|
|
swap drop ' label-string-alternate swap } if
|
|
dup ' ." entry-to-name stringcmp 0 = {
|
|
swap drop ' label-dot-string-alternate swap } if
|
|
dup s" L@'" stringcmp 0 = { swap drop ' label-L@'-alternate swap } if
|
|
dup s" L!'" stringcmp 0 = { swap drop ' label-L!'-alternate swap } if
|
|
dup s" keyword" stringcmp 0 = {
|
|
swap drop ' label-keyword-alternate swap } if
|
|
dup s" if" stringcmp 0 = { swap drop ' label-if-alternate swap } if
|
|
dup s" unless" stringcmp 0 = { swap drop ' label-unless-alternate swap } if
|
|
dup s" if-else" stringcmp 0 = {
|
|
swap drop ' label-if-else-alternate swap } if
|
|
dup s" forever" stringcmp 0 = {
|
|
swap drop ' label-forever-alternate swap } if
|
|
dup s" while" stringcmp 0 = { swap drop ' label-while-alternate swap } if
|
|
drop swap
|
|
~ (name as stack string, 0 or alternate entry pointer, name pointer)
|
|
|
|
~ If an alternate was found, the alternate will be used in immediate mode.
|
|
~ If not, we look up the word in the regular, non-transformed dictionary
|
|
~ and use that for immediate mode.
|
|
over { dup
|
|
transformation-state transformation-state-saved-latest @ swap find-in
|
|
3roll drop swap } unless
|
|
~ (name as stack string, immediate entry pointer, name pointer)
|
|
|
|
~ In regular "interpret", we would check whether we found the word before
|
|
~ checking the mode. However, we have three different places words could
|
|
~ come from, so that's not a simple notion. So, we check the mode first.
|
|
interpreter-flags @ 0x01 & {
|
|
~ If we're in compile mode, there's still a chance it's an immediate
|
|
~ word. First check whether we have an immediate entry, then if so, check
|
|
~ that entry's flags. Notice that this means the generated code can't
|
|
~ override an immediate word with a non-immediate word of the same name.
|
|
over dup { entry-flags@ 0x01 & not } { not } if-else
|
|
|
|
{
|
|
~ Either there was no immediate entry, or the immediate entry wasn't
|
|
~ flagged as an immediate word. So we check whether this could be a
|
|
~ compilation.
|
|
~
|
|
~ To do this, we need to look the word up in the output buffer. We
|
|
~ can't easily traverse the next-entry pointers in the output buffer's
|
|
~ dictionary, so we check the label. Since we don't know the word's name
|
|
~ statically, this is a rare scenario where we can't use the abbreviated
|
|
~ label syntax, but that's easy enough.
|
|
~
|
|
~ Even though we've ruled out the possibility that the word is only
|
|
~ ever used immediately, it is still possible that there's some reason
|
|
~ the word doesn't exist. In particular, it could be an integer literal.
|
|
~ If we were to call use-label first, that would count as a requirement
|
|
~ that the label must eventually be set. We don't want to require that
|
|
~ quite yet, so we call find-label.
|
|
~
|
|
~ This check is the means by which forward references are disallowed:
|
|
~ On the very first pass, a forward-referenced label won't exist yet, so
|
|
~ transform will give a "no such word" error, which in an ideal world
|
|
~ would prevent there from being a subsequent pass, but at the very
|
|
~ least it will ensure the output isn't a valid ELF.
|
|
dup
|
|
swap-transform-variables
|
|
find-label
|
|
swap-transform-variables
|
|
{
|
|
~ It exists, so we declare our use of it (that's also the only way to
|
|
~ get a value for it).
|
|
~ : provide-string-copy
|
|
swap-transform-variables
|
|
intern-label use-label
|
|
swap-transform-variables
|
|
|
|
~ Labels point to codewords (because that's what
|
|
~ label-create-alternate does), which is already what we want to
|
|
~ output.
|
|
~
|
|
~ An important caveat: Though it would require something weird to be
|
|
~ happening, such as a forced forward reference, the label may be
|
|
~ zero! We need to allow for that possibility by not examining the
|
|
~ contents of a nonexistent entry.
|
|
~
|
|
~ Fortunately we don't have to look at it, just append it to the log
|
|
~ and clean up.
|
|
~ : 8 # #-- (codeword pointer)
|
|
offset-to-target-address-space , drop dropstring 0 exit
|
|
} if
|
|
|
|
~ If we got here, we're in compile mode, no label was found, and even
|
|
~ if there was a candidate for an immediate word it wasn't flagged as
|
|
~ immediate. There are two possibilities: It's genuinely missing, or it's
|
|
~ an integer literal. We decline to run the candidate immediate entry,
|
|
~ even if it exists, because that's not the correct semantics.
|
|
~
|
|
~ If the word is genuinely missing, we want to make sure we make it
|
|
~ all the way to the not-found error-handling code at the end, because
|
|
~ that will be way easier to debug than doing the wrong thing will. Way,
|
|
~ way easier. Far less staring at numbers.
|
|
~
|
|
~ Anyway, we no longer need the immediate entry pointer, so we drop
|
|
~ it.
|
|
drop drop
|
|
} {
|
|
~ If we get here, we're in compile mode, but there was a candidate
|
|
~ entry for an immediate word, and it was indeed flagged as immediate.
|
|
~ So, we run it and exit.
|
|
drop dropstring-with-result entry-to-execution-token execute
|
|
0 exit
|
|
} if-else
|
|
|
|
~ This is the end of the compile-mode branch. As you can see by tracing
|
|
~ through all the above cases, if we got here, the two possibilities are
|
|
~ that the word is genuinely missing, or it's an integer literal.
|
|
~
|
|
~ Please notice that these are the same two possibilities remaining at
|
|
~ the end of the immediate-mode branch, below.
|
|
} {
|
|
~ If we got here, we're in interpret mode. There are three
|
|
~ possibilities: there's an immediate word which we should run; it's an
|
|
~ integer literal; or the word is genuinely missing.
|
|
~
|
|
~ If the immediate entry pointer is non-zero, run it and exit.
|
|
over {
|
|
drop dropstring-with-result entry-to-execution-token execute
|
|
0 exit
|
|
} if
|
|
|
|
~ There was no immediate word, so either it's an integer literal or
|
|
~ the word is genuinely missing. Please notice that these are the same two
|
|
~ possibilities remaining at the end of the compile-mode branch, above.
|
|
~
|
|
~ We no longer need the immediate-mode pointer, so drop it.
|
|
drop drop
|
|
} if-else
|
|
~ (name as stack string)
|
|
|
|
~ If we got here, one of two things is true: the word is an integer
|
|
~ literal, or it's genuinely missing. We know this because both the mode
|
|
~ cases above end with these as the only two remaining possibilities. So
|
|
~
|
|
~ Check whether it's an integer literal. As before, we get the stack
|
|
~ address and use it as a string pointer.
|
|
value@ read-integer 0 = {
|
|
~ It's a number.
|
|
interpreter-flags @ 0x01 & {
|
|
~ We're in compile mode; append first "lit", then the number, to the
|
|
~ log. The version of "lit" we use is found by label, so it'll be the
|
|
~ one that exists when this code is ultimately run.
|
|
dropstring-with-result
|
|
|
|
~ We look up "lit" as a label.
|
|
swap-transform-variables L@' lit swap-transform-variables
|
|
offset-to-target-address-space
|
|
~ : 8 lit #-- (codeword pointer)
|
|
,
|
|
~ : provide-hex
|
|
~ : 8 # #-- (integer literal)
|
|
,
|
|
0 exit
|
|
} if
|
|
|
|
~ We're in interpret mode; push the number to the stack. Or at least, that's
|
|
~ what the code we're interpreting will see. Really it's already on the
|
|
~ stack, just clean everything else up and leave it there.
|
|
dropstring-with-result
|
|
0 exit
|
|
} if
|
|
|
|
~ If it's neither in the dictionary nor a number, just print an error.
|
|
~
|
|
~ It's really important, when maintaining this code, to make sure that all
|
|
~ the possible ways the word can fail to exist, end up here. Doing anything
|
|
~ else is going to result in many hours of trying to untangle the
|
|
~ consequences of incorrect behavior, after-the-fact.
|
|
s" No such word: " emitstring value@ emitstring newline dropstring 0 ;
|
|
|
|
|
|
~ This implements the label transform for all words in a region given as an
|
|
~ input string. It is directly analogous to "quit", in interpet.e, but is far
|
|
~ more complex.
|
|
~
|
|
~ (output buffer start, output point, input string pointer
|
|
~ -- output buffer start, output point)
|
|
: label-transform
|
|
~ : blank-line
|
|
~ : blank-line
|
|
~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
|
|
~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
|
|
~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
|
|
~ : ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
~ : blank-line
|
|
~ : This is the start of a long block of code which has been processed by
|
|
~ : the label transform, meaning it consists of ready-to-run Forth word
|
|
~ : definitions that reference each other by address, suitable for direct
|
|
~ : execution as soon as the cold-start routine has set up the basic
|
|
~ : registers, flags, and memory areas that form Evocation's internal ABI.
|
|
~ :
|
|
~ : Each word definition consists of a dictionary entry header, a
|
|
~ : codeword, and a word body. For words implemented as Forth code, the
|
|
~ : codeword points to the "docol" routine, and the word body is an array of
|
|
~ : pointers to the codewords of other words, occasionally interspersed with
|
|
~ : literal values. For words implemented as machine code, the codeword
|
|
~ : points to the start of the body, and the body is the machine code.
|
|
~ :
|
|
~ : All the word entry headers in this code link to each other, from last
|
|
~ : backwards to first, forming an Evocation dictionary.
|
|
~ :
|
|
~ : The warm-start routine relies on words defined by the label transform,
|
|
~ : as does the log-load routine.
|
|
~ : blank-line
|
|
|
|
main-input-buffer dup push-input-buffer
|
|
swap attach-string-to-input-buffer
|
|
|
|
~ Save the old values of "here" and "latest", and set the initial values
|
|
~ of the internal ones. These values need to persist across iterations,
|
|
~ since client code will make its own updates to them and then rely on those
|
|
~ updates having taken effect. So we do the swap just once, here outside the
|
|
~ loop, and set it back when the loop ends.
|
|
here @ transformation-state transformation-state-saved-here !
|
|
latest @ transformation-state transformation-state-saved-latest !
|
|
swap transformation-state transformation-state-output-buffer-start !
|
|
here !
|
|
0 latest !
|
|
~ Now the stack has nothing of ours on it, so client code can do its thing.
|
|
|
|
~ It's important that the stack has nothing of ours on it that persists
|
|
~ across iterations, so that client code can add and remove stuff there as
|
|
~ it sees fit.
|
|
{ label-transform-one
|
|
~ (..., done)
|
|
|
|
~ When the loop is done, get the real values of "here" and "latest"
|
|
~ back. The internal "here" is also the output point, and will become our
|
|
~ return value. The internal "latest" is discarded.
|
|
{ transformation-state transformation-state-output-buffer-start @
|
|
here @
|
|
transformation-state transformation-state-saved-here @ here !
|
|
transformation-state transformation-state-saved-latest @ latest !
|
|
~ (output buffer start, output point)
|
|
|
|
~ Though we don't actually use transformation-state outside of this
|
|
~ invocation, for tidiness we zero it out.
|
|
0 transformation-state transformation-state-saved-here !
|
|
0 transformation-state transformation-state-saved-latest !
|
|
0 transformation-state transformation-state-output-buffer-start !
|
|
|
|
~ Also put the input source back how it was.
|
|
main-input-buffer pop-input-buffer
|
|
|
|
exit } if } forever ;
|
|
|
|
|
|
~ Log-load transform implementation
|
|
~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
~
|
|
~ The following code is all part of implementing the log-load transform.
|
|
~ For conceptual overview, see the top of this file.
|
|
|
|
|
|
~ This outputs code that performs a roll of a given size, for use by the
|
|
~ words that rely on the tracked user stack depth.
|
|
~
|
|
~ (amount to roll by --)
|
|
: log-load-roll
|
|
~ A roll of size 1 is an nop, and a roll of size 0 crashes.
|
|
dup 2 > { drop exit } if
|
|
|
|
~ A roll of size 2 is equivalent to a swap, and we compile it as one for
|
|
~ clarity when reading the hexdump.
|
|
~
|
|
~ Yes, clarity when reading the hexdump.
|
|
dup 2 = {
|
|
drop
|
|
|
|
swap-transform-variables
|
|
L@' swap
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer)
|
|
|
|
exit
|
|
} if
|
|
|
|
swap-transform-variables
|
|
L@' roll
|
|
L@' lit
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer)
|
|
swap ~ : provide-hex
|
|
, ~ : -8 # #-- (integer literal)
|
|
offset-to-target-address-space , ~ : -8 roll #-- (codeword pointer)
|
|
;
|
|
|
|
|
|
~ This outputs code that perfoms an unroll of a given size, for use by the
|
|
~ words that rely on the tracked user stack depth.
|
|
|
|
~ (amount to unroll by --)
|
|
: log-load-unroll
|
|
~ An unroll of size 1 is an nop, and an unroll of size 0 crashes.
|
|
dup 2 > { drop exit } if
|
|
|
|
~ Yes, clarity when reading the hexdump! What's so weird about that? :)
|
|
dup 2 = {
|
|
drop
|
|
|
|
swap-transform-variables
|
|
L@' swap
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer)
|
|
|
|
exit
|
|
} if
|
|
|
|
swap-transform-variables
|
|
L@' unroll
|
|
L@' lit
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer)
|
|
swap ~ : provide-hex
|
|
, ~ : -8 # #-- (integer literal)
|
|
offset-to-target-address-space , ~ : -8 unroll #-- (codeword pointer)
|
|
;
|
|
|
|
|
|
~ This checks the tracked user stack depth and outputs an appropriate roll
|
|
~ to put the log address on top, as preparation for calling something that
|
|
~ relies on it.
|
|
: log-load-roll-log-address
|
|
transformation-state transformation-state-user-stack-depth @
|
|
~ The amount we're rolling includes the log address, which is not a user
|
|
~ value, so we add 1.
|
|
1 +
|
|
log-load-roll ;
|
|
|
|
|
|
~ This checks the tracked user stack depth and outputs an appropriate unroll
|
|
~ to put the log address back at the bottom, as cleanup after calling
|
|
~ something that relies on it.
|
|
: log-load-unroll-log-address
|
|
transformation-state transformation-state-user-stack-depth @
|
|
~ The amount we're rolling includes the log address, which is not a user
|
|
~ value, so we add 1.
|
|
1 +
|
|
log-load-unroll ;
|
|
|
|
|
|
~ This checks the tracked user stack depth and outputs an appropriate roll
|
|
~ to put the saved label value on top, as preparation for calling something
|
|
~ that consumes it.
|
|
: log-load-roll-saved-label
|
|
transformation-state transformation-state-user-stack-depth @
|
|
~ The amount we're rolling includes both the log address and the label
|
|
~ value, neither of which are user values, so we add 2.
|
|
2 +
|
|
log-load-roll ;
|
|
|
|
|
|
~ This checks the tracked user stack depth and outputs an appropriate unroll
|
|
~ to put a saved label value on the bottom, as a way of safely storing it away
|
|
~ when it's newly generated.
|
|
: log-load-unroll-saved-label
|
|
transformation-state transformation-state-user-stack-depth @
|
|
~ The amount we're rolling includes both the log address and the label
|
|
~ value, neither of which are user values, so we add 2.
|
|
2 +
|
|
log-load-unroll ;
|
|
|
|
|
|
~ (name pointer --)
|
|
: log-load-compile-dynamic-word
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
~ Looking these up in reverse order saves us some stack juggling. Does it
|
|
~ help readability, or hurt it? Who can say...
|
|
L@' log-load-comma
|
|
L@' log-load-find-execution-token
|
|
L@' litstring
|
|
swap-transform-variables
|
|
~ (name pointer, log-load-comma, log-load-find-execution-token, litstring)
|
|
|
|
~ The overall stack delta of this sequence is 0.
|
|
offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer)
|
|
3roll here @ swap packstring 8 packalign here !
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-find-execution-token #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-comma #-- (codeword pointer)
|
|
|
|
log-load-unroll-log-address ;
|
|
|
|
|
|
~ When we want the log-load routine to run a word that wasn't statically
|
|
~ compiled-in to the target executable, we output code that looks up the word
|
|
~ by name on the log, then calls it.
|
|
~
|
|
~ We update the user stack depth as we go, to account for our internal
|
|
~ needs. The last thing our generated code does is execute the word we were
|
|
~ asked to, and we have no way of knowing what its stack delta will be, so
|
|
~ that final delta is our caller's responsibility. The caller should only
|
|
~ consider the delta of the word it requested itself; we handle everything
|
|
~ pertaining to retrieving, and then consuming, its execution token.
|
|
~
|
|
~ (name pointer --)
|
|
: log-load-execute-dynamic-word
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
~ This is reverse order again.
|
|
L@' swap
|
|
L@' log-load-find-execution-token
|
|
L@' litstring
|
|
swap-transform-variables
|
|
~ (name pointer, swap, log-load-find-execution-token, litstring)
|
|
|
|
offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer)
|
|
3roll here @ swap packstring 8 packalign here !
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-find-execution-token #-- (codeword pointer)
|
|
offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer)
|
|
|
|
~ Now the execution token is on the stack, immediately below the log
|
|
~ address, so we apply a delta for it.
|
|
1 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' execute
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space , ~ : -8 execute #-- (codeword pointer)
|
|
|
|
~ Invoking execute consumes the execution token, which is a delta of -1.
|
|
~ Any additional delta is our caller's responsibility, per above.
|
|
-1 transform-apply-stack-delta ;
|
|
|
|
|
|
~ We generate code that looks up "docol" by name, runs it to get the
|
|
~ codeword pointer, then finally appends it to the entry.
|
|
~
|
|
~ This one's unusual in that it first executes the word, then compiles the
|
|
~ result. To avoid rolling and unrolling repeatedly, we implement it as a
|
|
~ special case. For clarity's sake we put the code here, with the other
|
|
~ dynamic word stuff.
|
|
~
|
|
: log-load-compile-docol
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
~ As usual, we do these in reverse.
|
|
L@' log-load-comma
|
|
L@' execute
|
|
L@' log-load-find-execution-token
|
|
L@' litstring
|
|
swap-transform-variables
|
|
|
|
~ The overall stack delta of this sequence is 0.
|
|
offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer)
|
|
here @ s" docol" packstring 8 packalign here !
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-find-execution-token #-- (codeword pointer)
|
|
offset-to-target-address-space , ~ : -8 execute #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-comma #-- (codeword pointer)
|
|
|
|
log-load-unroll-log-address ;
|
|
|
|
|
|
~ There's one more compilation case, where we wish to compile an integer
|
|
~ literal. Again, for clarity, we do it here.
|
|
~
|
|
~ (integer value --)
|
|
: log-load-compile-literal
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
~ As usual, we do these in reverse.
|
|
L@' log-load-comma
|
|
L@' lit
|
|
L@' log-load-comma
|
|
L@' log-load-find-execution-token
|
|
L@' litstring
|
|
swap-transform-variables
|
|
|
|
~ The overall stack delta of this sequence is 0.
|
|
offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer)
|
|
here @ s" lit" packstring 8 packalign here !
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-find-execution-token #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-comma #-- (codeword pointer)
|
|
offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer)
|
|
swap ~ : provide-hex
|
|
, ~ : -8 # #-- (integer literal)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-comma #-- (codeword pointer)
|
|
|
|
log-load-unroll-log-address ;
|
|
|
|
|
|
~ This is the alternate version of "create" for use with the log-load
|
|
~ transform. This one is quite unlike the regular "create"; rather than
|
|
~ creating an entry on the log directly, its job is to output words which,
|
|
~ when they're later executed, will do create's job.
|
|
~
|
|
~ In practice that means outputting a codeword pointer to run a
|
|
~ statically-compiled word that does the work. The implementation of
|
|
~ log-load-create is in log-load.e.
|
|
~
|
|
~ It's worth keeping in mind that this alternate only gets called for
|
|
~ manual invocations of "create". It isn't called from the colon alternate.
|
|
: log-load-create-alternate
|
|
~ In immediate mode, we have special behavior because this is fundamental
|
|
~ to bootstrapping the log. In compile mode, we compile a dynamic call,
|
|
~ which is the same thing that would happen if we didn't have an alternate
|
|
~ at all.
|
|
interpreter-flags @ 0x01 & {
|
|
~ Notice that when we're in compile mode, we aren't actually defining a
|
|
~ word at the time the log-load routine runs, so we don't have magic
|
|
~ comments.
|
|
s" create" log-load-compile-dynamic-word
|
|
} {
|
|
~ : blank-line
|
|
~ : create
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-create
|
|
L@' swap
|
|
swap-transform-variables
|
|
|
|
~ The overall stack delta of this sequence is 0.
|
|
offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-create #-- (codeword pointer)
|
|
|
|
~ We've consumed a string pointer from the stack, so that's a delta of -1.
|
|
-1 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
~ : blank-line
|
|
} if-else ;
|
|
|
|
|
|
~ This is the alternate version of ":" for use with the log-load transform.
|
|
~ Its code is the same as the regular ":" except as noted below. It is likely
|
|
~ to be extremely useful to read and understand ":" in dynamic.e before
|
|
~ attempting to understand "log-load-colon-alternate".
|
|
: log-load-colon-alternate
|
|
word value@
|
|
~ : blank-line
|
|
~ : blank-line
|
|
~ : provide-string-copy
|
|
~ : # is defined here via the log-load transform.
|
|
~ : indent
|
|
|
|
~ Calling log-load-create-alternate would result in some redundant rolling
|
|
~ and unrolling, so we do it together like this instead.
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-create
|
|
L@' litstring
|
|
swap-transform-variables
|
|
|
|
~ The overall stack delta of this sequence is 0.
|
|
offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer)
|
|
swap here @ swap packstring 8 packalign here !
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-create #-- (codeword pointer)
|
|
|
|
log-load-unroll-log-address
|
|
|
|
dropstring
|
|
|
|
~ We generate code that looks up "docol" by name, runs it to get the
|
|
~ codeword pointer, then finally appends it to the entry.
|
|
log-load-compile-docol
|
|
|
|
~ This is where we would mark the entry hidden, but we don't do that. It
|
|
~ won't shadow anything and it won't be called until the entire log-load
|
|
~ routine has finished.
|
|
|
|
~ Switching between immediate and compile mode is one of the very few
|
|
~ things that happens NOW, while the log-load transform is actually running.
|
|
]
|
|
;
|
|
|
|
|
|
~ See notes on label-self-codeword-alternate for what problem this is
|
|
~ solving.
|
|
~
|
|
~ Since self-codeword's real definition is in dynamic.e, which absolutely
|
|
~ cannot be loaded yet at the time we output docol at the very beginning of
|
|
~ core.e, we need to provide an alternate for the log-load transform as well,
|
|
~ even though only the label transform has the reproducibility issue.
|
|
: log-load-self-codeword-alternate
|
|
~ It's important to remember, this is not an immediate word! It needs to
|
|
~ produce correct compiled output, when invoked in compile mode. Since it's
|
|
~ also a regular word that exists, correct output is a reference to the
|
|
~ non-alternate version.
|
|
interpreter-flags @ 0x01 & {
|
|
s" self-codeword" log-load-compile-dynamic-word
|
|
} {
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-self-codeword
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-self-codeword #-- (codeword pointer)
|
|
|
|
log-load-unroll-log-address
|
|
} if-else
|
|
; make-immediate
|
|
|
|
|
|
~ This is the alternate version of ";" for use with the log-load transform.
|
|
~ Its code is the same as the regular ";" except as noted below. It is
|
|
~ likely to be extremely useful to read and understand ";" in dynamic.e
|
|
~ before attempting to understand "log-load-semicolon-alternate".
|
|
: log-load-semicolon-alternate
|
|
~ We generate code that looks up "exit" by name and appends it to the
|
|
~ entry.
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
~ As usual, we do these in reverse.
|
|
L@' log-load-comma
|
|
L@' log-load-find-execution-token
|
|
L@' litstring
|
|
swap-transform-variables
|
|
|
|
~ The overall stack delta of this sequence is 0.
|
|
offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer)
|
|
here @ s" exit" packstring 8 packalign here !
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-find-execution-token #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-comma #-- (codeword pointer)
|
|
|
|
log-load-unroll-log-address
|
|
|
|
~ : deindent
|
|
|
|
~ This is where we would unhide the entry, but again, we don't do that.
|
|
|
|
~ Since [ is an immediate word, we have to go to extra trouble to compile
|
|
~ it as part of ;.
|
|
[ ' [ entry-to-execution-token , ]
|
|
; make-immediate
|
|
|
|
|
|
~ This is the alternate version of ";asm" for use with the log-load
|
|
~ transform. Its code is the same as the regular "create" except as noted
|
|
~ below. It is likely to be extremely useful to read and understand ";asm" in
|
|
~ dynamic.e before attempting to understand "log-load;asm".
|
|
: log-load-semicolon-assembly-alternate
|
|
~ We generate code that statically invokes log-load-semicolon-assembly,
|
|
~ which does all the actual work. There's quite a few steps, so it makes
|
|
~ sense to have a word that bundles them up.
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
~ As usual, we do these in reverse.
|
|
L@' log-load-semicolon-assembly
|
|
swap-transform-variables
|
|
|
|
~ The stack delta of this call is 0.
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-semicolon-assembly #-- (codeword pointer)
|
|
|
|
log-load-unroll-log-address
|
|
|
|
~ : deindent
|
|
|
|
~ This is where we would unhide the entry, but again, we don't do that.
|
|
|
|
~ Since [ is an immediate word, we have to go to extra trouble to compile
|
|
~ it as part of ;.
|
|
[ ' [ entry-to-execution-token , ]
|
|
; make-immediate
|
|
|
|
|
|
~ This just does the same thing [ always does, but having it as an alternate
|
|
~ means it happens at transformation time, which is sooner than "immediate"
|
|
~ time. The log load transform is weird like that, it has three different
|
|
~ times things can happen, rather than the usual two.
|
|
: log-load-left-square-brace-alternate
|
|
~ Since [ is an immediate word, we have to go to extra trouble to compile
|
|
~ it as part of the alternate.
|
|
[ ' [ entry-to-execution-token , ]
|
|
; make-immediate
|
|
|
|
~ We need this one, too. It's not even an immediate word normally!
|
|
: log-load-right-square-brace-alternate ] ; make-immediate
|
|
|
|
|
|
: log-load-comma-alternate
|
|
~ In immediate mode, we have special behavior because of the "here" magic.
|
|
~ In compile mode, we compile a dynamic call, which is the same thing that
|
|
~ would happen if we didn't have an alternate at all.
|
|
interpreter-flags @ 0x01 & {
|
|
s" ," log-load-compile-dynamic-word
|
|
} {
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-comma
|
|
L@' swap
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-comma #-- (codeword pointer)
|
|
|
|
~ We consumed the value, so we apply a delta.
|
|
-1 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
} if-else
|
|
; make-immediate
|
|
|
|
|
|
: log-load-variable-alternate
|
|
~ In immediate mode, we have special behavior because of the "here" magic.
|
|
~ In compile mode, we compile a dynamic call, which is the same thing that
|
|
~ would happen if we didn't have an alternate at all.
|
|
interpreter-flags @ 0x01 & {
|
|
s" variable" log-load-compile-dynamic-word
|
|
} {
|
|
~ Calling log-load-create-alternate would result in some redundant rolling
|
|
~ and unrolling, so we do it together like this instead.
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-variable
|
|
L@' 3unroll
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space , ~ : -8 3unroll #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-variable #-- (codeword pointer)
|
|
|
|
~ We consumed the string and address, so we apply a delta.
|
|
-2 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
} if-else
|
|
; make-immediate
|
|
|
|
|
|
: log-load-keyword-alternate
|
|
~ In immediate mode, we have special behavior because of the "here" magic.
|
|
~ In compile mode, we compile a dynamic call, which is the same thing that
|
|
~ would happen if we didn't have an alternate at all.
|
|
interpreter-flags @ 0x01 & {
|
|
s" keyword" log-load-compile-dynamic-word
|
|
} {
|
|
~ Calling log-load-create-alternate would result in some redundant rolling
|
|
~ and unrolling, so we do it together like this instead.
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-keyword
|
|
L@' swap
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-keyword #-- (codeword pointer)
|
|
|
|
~ We consumed the string, so we apply a delta.
|
|
-1 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
} if-else
|
|
; make-immediate
|
|
|
|
|
|
~ Yeah comments have to go.
|
|
: log-load-tilde-alternate
|
|
' ~ entry-to-execution-token execute
|
|
; make-immediate
|
|
|
|
|
|
~ Strings are important and must happen now, now, now.
|
|
: log-load-string-alternate
|
|
~ Wrapping s" is surprisingly difficult; see label-string-alternate
|
|
~ for detailed notes on how that works. Once we've finished the
|
|
~ transform-time part, our implementations will diverge, but this first bit
|
|
~ is the same.
|
|
interpreter-flags @
|
|
' s" entry-to-execution-token
|
|
swap-transform-variables
|
|
~ Since [ is an immediate word, we have to go to extra trouble to compile
|
|
~ it as part of the alternate.
|
|
[ ' [ entry-to-execution-token , ]
|
|
execute
|
|
swap-transform-variables
|
|
swap interpreter-flags !
|
|
|
|
~ Nope, doing it twice didn't make that any less of a mouthful.
|
|
~
|
|
~ Having done this, we have the string pointer on the stack at transform
|
|
~ time (not, mind you, at log-load time, as yet). Now it is our job to
|
|
~ either compile it, or invoke it "immediately". Recall that the log-load
|
|
~ transform's "immediate" time, which we also call log-load time, is
|
|
~ analogous to the label transform's "compile" time. The log-load
|
|
~ transform's "compile" time is an additional layer of indirection.
|
|
~
|
|
~ No matter which mode we're in, the first thing we want to do is get the
|
|
~ string onto the value stack at log-load time. So we compile code to do
|
|
~ that, first. We do that using the static "litstring", which we find by
|
|
~ label.
|
|
~
|
|
~ If this is all too twisty, it might be helpful to go re-read the
|
|
~ definition of log-load-compile-literal, which does a simpler version of
|
|
~ this same task (because integers are easier than strings).
|
|
|
|
swap-transform-variables
|
|
L@' litstring
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer)
|
|
here @ swap packstring 8 packalign here !
|
|
|
|
~ Now the string pointer is on the stack at log-load time, so we apply a
|
|
~ delta for it.
|
|
1 transform-apply-stack-delta
|
|
|
|
~ If we're in immediate mode, we're done! Yay! Putting the string on the
|
|
~ stack at log-load time is what we wanted. If not...
|
|
interpreter-flags @ 0x01 & {
|
|
~ We're in compile mode, so we need to look up the ultimate, dynamic,
|
|
~ log-based, super-atomic space rocket copy of "litstring" and use that.
|
|
~ We could call log-load-compile-dynamic-word here, but, as usual, it
|
|
~ would produce some excessive rolling and unrolling, so we do its job
|
|
~ ourselves instead.
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
~ As usual, we do these in reverse.
|
|
L@' log-load-comma-string
|
|
L@' swap
|
|
L@' log-load-comma
|
|
L@' log-load-find-execution-token
|
|
L@' litstring
|
|
swap-transform-variables
|
|
|
|
~ The overall stack delta of this sequence is 0.
|
|
offset-to-target-address-space ,
|
|
~ : -8 litstring #-- (codeword pointer)
|
|
here @ s" litstring" packstring 8 packalign here !
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-find-execution-token #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-comma #-- (codeword pointer)
|
|
offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-comma-string #-- (codeword pointer)
|
|
|
|
~ We consumed the string pointer at log-load time, so we apply a delta
|
|
~ for it.
|
|
~
|
|
~ Notice by the way how the nearby calls to log-load-unroll-log-address
|
|
~ rely on this being split into two deltas like this, even though they
|
|
~ net out to zero; we aren't doing it just for kicks.
|
|
-1 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
} if
|
|
; make-immediate
|
|
|
|
|
|
: log-load-dot-string-alternate
|
|
' log-load-string-alternate entry-to-execution-token execute
|
|
|
|
interpreter-flags @ 0x01 & {
|
|
~ Hey look, it's the one time we're doing something simple enough that
|
|
~ we can actually benefit from log-load-compile-dynamic-word as something
|
|
~ more than an example to start from. :)
|
|
s" emitstring" log-load-compile-dynamic-word
|
|
} {
|
|
swap-transform-variables
|
|
L@' emitstring
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space ,
|
|
~ : -8 emitstring #-- (codeword pointer)
|
|
} if-else
|
|
; make-immediate
|
|
|
|
|
|
~ No matter what mode we're in, we read a name at transform time. Then we
|
|
~ look up the name at either log-load time or runtime, depending.
|
|
: log-load-tick-alternate
|
|
~ Read the name.
|
|
word value@
|
|
|
|
~ Get the name onto the stack at log-load time.
|
|
swap-transform-variables
|
|
L@' litstring
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer)
|
|
here @ swap packstring 8 packalign here !
|
|
|
|
~ Apply a delta for the string pointer.
|
|
1 transform-apply-stack-delta
|
|
|
|
dropstring
|
|
|
|
~ Now break out the remaining behavior based on mode.
|
|
interpreter-flags @ 0x01 & {
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-comma
|
|
L@' log-load-find-execution-token
|
|
L@' litstring
|
|
L@' log-load-comma-string
|
|
L@' swap
|
|
L@' log-load-comma
|
|
L@' log-load-find-execution-token
|
|
L@' litstring
|
|
swap-transform-variables
|
|
|
|
~ The overall stack delta of this sequence is 0.
|
|
offset-to-target-address-space ,
|
|
~ : -8 litstring #-- (codeword pointer)
|
|
here @ s" litstring" packstring 8 packalign here !
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-find-execution-token #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-comma #-- (codeword pointer)
|
|
offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-comma-string #-- (codeword pointer)
|
|
|
|
offset-to-target-address-space ,
|
|
~ : -8 litstring #-- (codeword pointer)
|
|
here @ s" find" packstring 8 packalign here !
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-find-execution-token #-- (codeword pointer)
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-comma #-- (codeword pointer)
|
|
|
|
~ We consumed the string pointer at log-load time, so we apply a delta
|
|
~ for it. As in log-load-string-alternate, this needs to be split into
|
|
~ two parts like this.
|
|
-1 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
} {
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-find
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-find #-- (codeword pointer)
|
|
|
|
~ We leave an execution token on the log-load-time stack, so no delta
|
|
~ needed.
|
|
|
|
log-load-unroll-log-address
|
|
} if-else
|
|
; make-immediate
|
|
|
|
|
|
~ Because docol requires it, we provide a special mini-version of the label
|
|
~ system. We only do L@' and L!', because that's all we need. Unlike the
|
|
~ version of this feature for the label transform, for the log-load transform,
|
|
~ we heavily restrict the use-case.
|
|
~
|
|
~ The implementation strategy is that we ignore the label name, and store
|
|
~ the value on the stack when the generated log-load routine runs. So, each
|
|
~ instance of L@' must be closely followed by a matching instance of L!'. Each
|
|
~ label can only ever be used exactly once, and it must be a backward
|
|
~ reference. Furthermore, the stack is used in a very specific way, which the
|
|
~ transformed code must be compatible with. The easiest way to explain it is
|
|
~ by showing the interface of these words from the transformed code's
|
|
~ perspective:
|
|
~
|
|
~ L!' is (preserved values, ..., ..., value of label
|
|
~ -- value of label, preserved values, ..., ...)
|
|
~ L@' is (value of label, preserved values, ..., ...)
|
|
~ -- preserved values, ..., ..., value of label)
|
|
~
|
|
~ The preserved values are simply more items on the stack, which the
|
|
~ alternates take pains not to interfere with. The alternates output a roll or
|
|
~ unroll of an appropriate size. Hopefully, in reading this, you have the
|
|
~ question: How can the alternates possibly know what size is appropriate?
|
|
~ The answer is that the log-load transform carefully tracks how many items
|
|
~ the transformed code is expected to have on the stack, based on its
|
|
~ hardcoded understanding of each word that's expected to be relevant, looked
|
|
~ up by the word's name. The number of items is stored in the user-stack-depth
|
|
~ field of transformation-state.
|
|
~
|
|
~ There is no adjustment done on the saved value, since it's created in the
|
|
~ target address space and then also used in the target address space. It
|
|
~ wouldn't actually be necessary to use this at all, since checking "here"
|
|
~ would be sufficient, but then the code would have to do something different
|
|
~ depending on which transform it's running under, and there'd have to be a
|
|
~ mechanism for that.
|
|
~
|
|
~ This is sufficient to implement docol, and that's probably the only thing
|
|
~ it should be used for.
|
|
: log-load-L@'-alternate
|
|
word dropstring
|
|
log-load-roll-saved-label
|
|
~ We now begin thinking of the label value as user data, so we need to
|
|
~ notate that appropriately.
|
|
1 transform-apply-stack-delta
|
|
; make-immediate
|
|
|
|
: log-load-L!'-alternate
|
|
word dropstring
|
|
~ We cease to think of the label value as user data, so we need to notate
|
|
~ that appropriately.
|
|
-1 transform-apply-stack-delta
|
|
log-load-unroll-saved-label
|
|
; make-immediate
|
|
|
|
|
|
~ Not to be outdone by the label transform, the log-load transform also
|
|
~ offers alternates of all the high-level flow-control words: if, unless,
|
|
~ if-else, forever, and while. Unlike the label transform, we also need to
|
|
~ implement alternates of { and }, because their values need to be on the
|
|
~ stack at log-load "immediate" time, not at transform time.
|
|
~
|
|
~ Anyway, most of the implementation is deferred to pre-packaged words in
|
|
~ log-load.e.
|
|
: log-load-left-curly-brace-alternate
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-left-curly-brace
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-left-curly-brace #-- (codeword pointer)
|
|
|
|
~ It pushes a start pointer onto the stack.
|
|
1 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
~ : {
|
|
~ : indent
|
|
; make-immediate
|
|
|
|
|
|
: log-load-right-curly-brace-alternate
|
|
~ : deindent
|
|
~ : }
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-right-curly-brace
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-right-curly-brace #-- (codeword pointer)
|
|
|
|
~ It pushes a length value onto the stack.
|
|
1 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
; make-immediate
|
|
|
|
|
|
~ (start pointer, length --)
|
|
: log-load-if-alternate
|
|
~ : if
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-if
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-if #-- (codeword pointer)
|
|
|
|
~ It pops the start and length.
|
|
-2 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
~ : blank-line
|
|
; make-immediate
|
|
|
|
|
|
~ (start pointer, length)
|
|
: log-load-unless-alternate
|
|
~ : unless
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-unless
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-unless #-- (codeword pointer)
|
|
|
|
~ It pops the start and length.
|
|
-2 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
~ : blank-line
|
|
; make-immediate
|
|
|
|
|
|
~ (true start, true length, false start, false length)
|
|
: log-load-if-else-alternate
|
|
~ : if-else
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-if-else
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-if-else #-- (codeword pointer)
|
|
|
|
~ It pops two pairs of start and length.
|
|
-4 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
~ : blank-line
|
|
; make-immediate
|
|
|
|
|
|
~ (start, length --)
|
|
: log-load-forever-alternate
|
|
~ : forever
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-forever
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-forever #-- (codeword pointer)
|
|
|
|
~ It pops the start and length.
|
|
-2 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
~ : blank-line
|
|
; make-immediate
|
|
|
|
|
|
~ (test start, test length, body start, body length --)
|
|
: log-load-while-alternate
|
|
~ : while
|
|
log-load-roll-log-address
|
|
|
|
swap-transform-variables
|
|
L@' log-load-while
|
|
swap-transform-variables
|
|
|
|
offset-to-target-address-space ,
|
|
~ : -8 log-load-while #-- (codeword pointer)
|
|
|
|
~ It pops two pairs of start and length.
|
|
-4 transform-apply-stack-delta
|
|
|
|
log-load-unroll-log-address
|
|
~ : blank-line
|
|
; make-immediate
|
|
|
|
|
|
~ This implements the log-load transform for a single word. It is directly
|
|
~ analogous to "interpret", and reading interpret.e may help in understanding
|
|
~ it, though it's meant to still make sense on its own.
|
|
~
|
|
~ It expects to be called from "log-load-transform", below, which loops.
|
|
~
|
|
~ (-- done)
|
|
: log-load-transform-one
|
|
word
|
|
|
|
~ If no word was returned, end the transformation.
|
|
dup 0 = { drop 1 exit } if
|
|
|
|
~ The string is on the top of the stack, so to get a pointer to it we get
|
|
~ the stack address.
|
|
~ (string)
|
|
value@
|
|
|
|
~ Check whether it's one of the words we have alternates for, and look up
|
|
~ the alternate if so.
|
|
0 swap
|
|
~ (name as stack string, placeholder, name pointer)
|
|
dup s" create" stringcmp 0 = {
|
|
swap drop ' log-load-create-alternate swap } if
|
|
dup s" :" stringcmp 0 = {
|
|
swap drop ' log-load-colon-alternate swap } if
|
|
dup s" self-codeword" stringcmp 0 = {
|
|
swap drop ' log-load-self-codeword-alternate swap } if
|
|
dup s" ;" stringcmp 0 = {
|
|
swap drop ' log-load-semicolon-alternate swap } if
|
|
dup s" ;asm" stringcmp 0 = {
|
|
swap drop ' log-load-semicolon-assembly-alternate swap } if
|
|
dup s" [" stringcmp 0 = {
|
|
swap drop ' log-load-left-square-brace-alternate swap } if
|
|
dup s" ]" stringcmp 0 = {
|
|
swap drop ' log-load-right-square-brace-alternate swap } if
|
|
dup s" ," stringcmp 0 = { swap drop ' log-load-comma-alternate swap } if
|
|
dup s" variable" stringcmp 0 = {
|
|
swap drop ' log-load-variable-alternate swap } if
|
|
dup s" keyword" stringcmp 0 = {
|
|
swap drop ' log-load-keyword-alternate swap } if
|
|
dup s" ~" stringcmp 0 = {
|
|
swap drop ' log-load-tilde-alternate swap } if
|
|
~ It is nontrivial to construct a string with a double-quote in it.
|
|
dup ' s" entry-to-name stringcmp 0 = {
|
|
swap drop ' log-load-string-alternate swap } if
|
|
dup ' ." entry-to-name stringcmp 0 = {
|
|
swap drop ' log-load-dot-string-alternate swap } if
|
|
dup ' ' entry-to-name stringcmp 0 = {
|
|
swap drop ' log-load-tick-alternate swap } if
|
|
dup s" L@'" stringcmp 0 = { swap drop ' log-load-L@'-alternate swap } if
|
|
dup s" L!'" stringcmp 0 = { swap drop ' log-load-L!'-alternate swap } if
|
|
dup s" {" stringcmp 0 = {
|
|
swap drop ' log-load-left-curly-brace-alternate swap } if
|
|
dup s" }" stringcmp 0 = {
|
|
swap drop ' log-load-right-curly-brace-alternate swap } if
|
|
dup s" if" stringcmp 0 = { swap drop ' log-load-if-alternate swap } if
|
|
dup s" unless" stringcmp 0 = {
|
|
swap drop ' log-load-unless-alternate swap } if
|
|
dup s" if-else" stringcmp 0 = {
|
|
swap drop ' log-load-if-else-alternate swap } if
|
|
dup s" forever" stringcmp 0 = {
|
|
swap drop ' log-load-forever-alternate swap } if
|
|
dup s" while" stringcmp 0 = { swap drop ' log-load-while-alternate swap } if
|
|
~ (name as stack string, 0 or alternate entry pointer, name pointer)
|
|
|
|
~ If we have an alternate, we want to run that now, regardless of what
|
|
~ mode we're in. They're all flagged as immediate, but we don't even bother
|
|
~ checking, because it doesn't fully describe their behavior anyway. With
|
|
~ this transform there's three potential times at which we might execute
|
|
~ things, not two. The alternates are more immediate than immediate; they
|
|
~ run NOW, during the transformation.
|
|
over {
|
|
drop dropstring-with-result
|
|
entry-to-execution-token execute
|
|
0 exit
|
|
} if
|
|
drop drop
|
|
~ (name as stack string)
|
|
|
|
~ Now we might have a compiled word, an immediate word, or an integer
|
|
~ literal. Recall that the word won't actually be looked up until the
|
|
~ routine we're producing is run - that's the whole point - so there's no
|
|
~ check we can perform now that will tell us whether the word we have exists
|
|
~ in the eventual log. Instead, we invert the usual fallback order and
|
|
~ check whether the word could be an integer literal. If it is, we'll
|
|
~ handle that; if not, we'll assume it'll eventually exist.
|
|
~
|
|
~ This means that code that's run with the log-load transform can't
|
|
~ shadow an integer literal with a word definition. Oh, so limiting.
|
|
value@ read-integer 0 = {
|
|
~ It's a number.
|
|
~
|
|
~ (name as stack string, integer value)
|
|
dropstring-with-result
|
|
~ (integer value)
|
|
|
|
interpreter-flags @ 0x01 & {
|
|
~ We're in compile mode, so we want to generate code which will compile
|
|
~ the number.
|
|
log-load-compile-literal
|
|
0 exit
|
|
} if
|
|
|
|
~ We're in interpret mode, so we want to generate code which will push
|
|
~ the number to the stack.
|
|
~
|
|
~ This is an immediate effect, so once we've done it, we update the user
|
|
~ stack depth. An integer literal is a stack-depth delta of 1.
|
|
swap-transform-variables L@' lit swap-transform-variables
|
|
offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer)
|
|
~ : provide-hex
|
|
, ~ : -8 # #-- (integer literal)
|
|
1 transform-apply-stack-delta
|
|
0 exit
|
|
} if
|
|
~ (name as stack string)
|
|
|
|
~ We know it's a regular word, and we're assuming it will exist at
|
|
~ runtime. We of course have no way to check what flags it will have, which
|
|
~ means immediate words don't work with this transform. We still treat it
|
|
~ differently based on whether we're in compile mode.
|
|
interpreter-flags @ 0x01 & {
|
|
~ We're in compile mode. We compile code that compiles the word.
|
|
~
|
|
~ Since that's not an immediate effect, we don't need to update the
|
|
~ user stack depth. Instead, this is a key spot where we rely on that
|
|
~ knowledge, to roll and unroll the log address.
|
|
value@ log-load-compile-dynamic-word
|
|
dropstring 0 exit
|
|
} if
|
|
~ (name as stack string)
|
|
|
|
~ At this point we know we're in immediate mode and have a regular word.
|
|
~ While we still have the name pointer handy, we check what delta this word
|
|
~ will cause for the user stack depth, when run. See
|
|
~ transform-get-stack-delta for more explanation of this. We keep track of
|
|
~ the proposed delta until we actually process the word, down below.
|
|
value@ dup transform-get-stack-delta swap
|
|
~ (name as stack string, proposed stack depth delta, name pointer)
|
|
|
|
~ We're in immediate mode. We compile code that runs the word immediately.
|
|
~ We check whether there's a label for the word; if there is, we'll output
|
|
~ that. Otherwise we'll output code that looks it up in the log and runs it.
|
|
~
|
|
~ Just like in label-transform, we use find-label to check whether a label
|
|
~ exists without declaring a dependency on it, then if it does, we do
|
|
~ use-label to ask for its value.
|
|
~
|
|
~ There's one additional wrinkle to remember here: We're running inside
|
|
~ the label loop, and warm-start appears before all the normal words in the
|
|
~ executable. So all the labels we'll be checking are forwared references,
|
|
~ and on the very first pass they definitely won't be defined. That's fine
|
|
~ though, they will exist on all subsequent passes, so things will
|
|
~ definitely still converge.
|
|
~
|
|
~ The first pass will never accidentally think it succeeded, because even
|
|
~ the reference to L' cold-start from the ELF header is a forward reference
|
|
~ and won't exist on the first pass.
|
|
dup
|
|
swap-transform-variables
|
|
find-label
|
|
swap-transform-variables
|
|
{
|
|
~ Again just like in label-transform, we declare our use of the label
|
|
~ and get a value for it.
|
|
~ : provide-string-copy
|
|
swap-transform-variables
|
|
intern-label use-label
|
|
swap-transform-variables
|
|
~ (name as stack string, proposed stack depth delta, label value)
|
|
|
|
~ Like in label-transform, this is a codeword pointer, so we just output
|
|
~ it directly. Also as before, because we don't have to examine it, we
|
|
~ don't have to do anything special in the case where it's zero due to the
|
|
~ way the label loop works.
|
|
~
|
|
~ This is an immediate effect, so once we've done that, we update the
|
|
~ user stack depth.
|
|
offset-to-target-address-space ,
|
|
~ : -8 # #-- (codeword pointer)
|
|
transform-apply-stack-delta
|
|
dropstring 0 exit
|
|
} if
|
|
~ (name as stack string, proposed stack depth delta, name pointer)
|
|
|
|
~ There's no label for the word; that means it wasn't statically
|
|
~ compiled-in to the target executable. So we output code that looks up the
|
|
~ word by name on the log, then calls it.
|
|
~
|
|
~ This is also an immediate effect, despite being distinct from the above
|
|
~ case, so once we've done that, we update the user stack depth.
|
|
~
|
|
~ There's no such thing as not finding the word, with this transform. So
|
|
~ once we're done, we just exit.
|
|
log-load-execute-dynamic-word
|
|
transform-apply-stack-delta
|
|
dropstring 0 ;
|
|
|
|
|
|
~ This implements the log-load transform for all words in a region given as
|
|
~ an input string. It is directly analogous to "quit", in interpret.e, but is
|
|
~ far more complex.
|
|
~
|
|
~ (output buffer start, output point, input string pointer
|
|
~ -- output buffer start, output point)
|
|
: log-load-transform
|
|
~ : blank-line
|
|
~ : This is the start of the log-load routine, which is a long block of
|
|
~ : code that has been processed by the log-load transform. It is part of
|
|
~ : the warm-start routine, which does other things before and after it.
|
|
~ : For clarity's sake, to avoid weird nesting, the section header above
|
|
~ : calls this the warm-start section of the executable, but in a sense it
|
|
~ : might be more accurate to call it the log-load section.
|
|
~ :
|
|
~ : The routine is interpreted Forth code, just as the warm-start routine
|
|
~ : as a whole is; see above.
|
|
~ :
|
|
~ : The job of the log-load routine is to create runnable code in the
|
|
~ : dynamic log, at runtime. The normal way to create a Forth executable
|
|
~ : is to use label-transformed code to implement a minimal set of
|
|
~ : functionality needed for the log-load routine to run, then invoke the
|
|
~ : log-load routine to copy a more complete set of functionality into
|
|
~ : memory.
|
|
~ :
|
|
~ : The log-load routine is super important, but also extremely verbose,
|
|
~ : which necessarily makes it hard to read. If you're skimming this file
|
|
~ : for the first time to get a sense of what it contains, you might want
|
|
~ : to search for the words "label transform" to get to the stuff that makes
|
|
~ : better introductory reading.
|
|
~ : blank-line
|
|
|
|
main-input-buffer dup push-input-buffer
|
|
swap attach-string-to-input-buffer
|
|
|
|
~ Save the old values of "here" and "latest", and set the initial values
|
|
~ of the internal ones. These values need to persist across iterations,
|
|
~ since client code will make its own updates to them and then rely on those
|
|
~ updates having taken effect. So we do the swap just once, here outside the
|
|
~ loop, and set it back when the loop ends.
|
|
~
|
|
~ We also take this opportunity to initialize the output-buffer-start and
|
|
~ user-stack-depth fields of transformation-state.
|
|
here @ transformation-state transformation-state-saved-here !
|
|
latest @ transformation-state transformation-state-saved-latest !
|
|
swap transformation-state transformation-state-output-buffer-start !
|
|
0 transformation-state transformation-state-user-stack-depth !
|
|
here !
|
|
0 latest !
|
|
~ Now the stack has nothing of ours on it, so client code can do its thing.
|
|
|
|
~ It's important that the stack has nothing of ours on it that persists
|
|
~ across iterations, so that client code can add and remove stuff there as
|
|
~ it sees fit.
|
|
{ log-load-transform-one
|
|
~ (..., done)
|
|
|
|
~ When the loop is done, get the real values of "here" and "latest"
|
|
~ back. The internal "here" is also the output point, and will become our
|
|
~ return value. The internal "latest" is discarded.
|
|
{ transformation-state transformation-state-output-buffer-start @
|
|
here @
|
|
transformation-state transformation-state-saved-here @ here !
|
|
transformation-state transformation-state-saved-latest @ latest !
|
|
~ (output buffer start, output point)
|
|
|
|
~ Though we don't actually use transformation-state outside of this
|
|
~ invocation, for tidiness we zero it out.
|
|
0 transformation-state transformation-state-saved-here !
|
|
0 transformation-state transformation-state-saved-latest !
|
|
0 transformation-state transformation-state-output-buffer-start !
|
|
0 transformation-state transformation-state-user-stack-depth !
|
|
|
|
~ Also put the input source back how it was.
|
|
main-input-buffer pop-input-buffer
|
|
|
|
exit } if } forever ;
|
|
|
|
|
|
~ Hex transform implementation
|
|
~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
~
|
|
~ The following code is all part of implementing the hex transform. For
|
|
~ conceptual overview, see the top of this file.
|
|
~
|
|
~ The hex transform operates under some very complex memory-management
|
|
~ assumptions, even compared to the other transforms, so it's worth going over
|
|
~ all that and studying how it comes together, even though much of it is
|
|
~ material that has been explained elsewhere. This explanation is here with
|
|
~ the implementation details rather than at the top of the file, because it's
|
|
~ only necessary to understanding how to modify the transform, not how to use
|
|
~ it.
|
|
~
|
|
~ This is the bit of the hex transform where all the memory-management
|
|
~ assumptions are in play at once, so, a quick refresher. The transform
|
|
~ itself is running in the outer context; hex-trace and its siblings are
|
|
~ part of Evocation's main log and dictionary. This is also true for the
|
|
~ label and log-load transforms. Evocation has two global variables,
|
|
~ "here" and "latest", which are the root of all references to the log and
|
|
~ dictionary, respectively. Remember, the log is the structure used for
|
|
~ memory allocation, and the dictionary, which forms the majority of the
|
|
~ log, is the structure used for looking up words by name.
|
|
~
|
|
~ Every transform, in its various ways, is changing what it means to
|
|
~ "execute" and "compile" code; therefore, when the transforms are invoked,
|
|
~ they are passed an "output buffer" which is used as the destination for
|
|
~ any compilation that occurs, and any scratch space that is needed. When
|
|
~ more than one transform is running at once (such as when the hex transform
|
|
~ operates on code that is itself running the label transform), each
|
|
~ transform has its own separate output buffer.
|
|
~
|
|
~ Furthermore, the transformation facility helps each transform to swap out
|
|
~ the values of "here" and "latest", and restore them later, so that the code
|
|
~ being transformed will see the output buffer as if it is the "real" log, and
|
|
~ will see the separate dictionary stored within the output buffer as if it is
|
|
~ the "real" dictionary.
|
|
~
|
|
~ All this stuff about the output buffer applies to every transform. The
|
|
~ hex transform takes it one step further, and as such there are two
|
|
~ additional memory regions that are important to understanding it. The first
|
|
~ is the label-loop buffer, which is allocated out of the inner log, and used
|
|
~ to hold draft versions of the binary output that the inner compilation
|
|
~ process would eventually emit to the standard output stream, if it were
|
|
~ being allowed to emit output in the normal way. The second is the output
|
|
~ metadata buffer, which is allocated out of the outer log, and used to hold
|
|
~ metadata such as comments and formatting pertaining to code structure, which
|
|
~ will need to be referenced when actually outputting the final hex dump.
|
|
~
|
|
~ So, the label-loop buffer can be thought of as scratch space for the
|
|
~ compiled binary output from the code being transformed, and the output
|
|
~ metadata buffer can be thought of as the scratch space for the formatted hex
|
|
~ dump that will be made out of that output. It's important not to confuse
|
|
~ either of them with the output buffer, which is the scratch space used as
|
|
~ part of the compilation process.
|
|
~
|
|
~ Confusingly, the output buffer and the label-loop buffer both contain
|
|
~ logs and dictionaries, at least potentially, if the code being compiled is
|
|
~ Forth code. It is also possible to use the hex transform on assembly code,
|
|
~ in which case the label-loop buffer won't have a log in it but the output
|
|
~ buffer still will. In practice, the hex transform frequently winds up
|
|
~ needing to be careful about the log and dictionary in the output buffer, but
|
|
~ rarely does anything that directly touches the log and dictionary in the
|
|
~ label-loop buffer, so you can usually ignore the latter when reading this
|
|
~ code.
|
|
~
|
|
~ Allocating the output buffer and output metadata buffer is the
|
|
~ responsibility of the caller of hex-transform. Allocating the label-loop
|
|
~ buffer is the responsibility of label-loop, which is called by the code
|
|
~ being transformed, but the hex transform intervenes in that allocation to
|
|
~ save information about it.
|
|
~
|
|
~ The output buffer is referenced during the transform via the
|
|
~ transformation-state-output-buffer-start field of the global
|
|
~ "transformation-state" variable, and the output metadata buffer is
|
|
~ referenced via the transformation-state-output-metadata field of that same
|
|
~ variable. The label-loop buffer is referenced from the
|
|
~ hex-output-metadata-label-loop-buffer-start and -length fields of the
|
|
~ output metadata's top-level header, and the code being transformed passes
|
|
~ around its own reference to that same buffer.
|
|
~
|
|
~ Finally, recall that, when Evocation itself is the thing being
|
|
~ transformed, the code under transformation includes its own copy of the
|
|
~ transformation facility, along with all the rest of Evocation. When the code
|
|
~ under transformation invokes the label and log-load transforms, it will do
|
|
~ so using the copies of those transforms which have been transformed by the
|
|
~ hex transform. The same goes for most Evocation internals invoked by the
|
|
~ compilation process, except for whatever specific exceptions the hex
|
|
~ transform creates. Do not confuse the inner copies of anything with the
|
|
~ outer copies. Also try not to worry too much about the inner-inner copies,
|
|
~ let the inner transforms deal with them.
|
|
~
|
|
~ Got all that background fresh in your mind? Okay, time to get concrete!
|
|
~ The output metadata is a header structure followed by an array of entry
|
|
~ structures, as follows:
|
|
~
|
|
~ (header start)
|
|
~ 0x00 - 0x07 Label-loop buffer start
|
|
~ 0x08 - 0x0f Label-loop buffer length
|
|
~ (entry start)
|
|
~ ... + 0x00 - ... + 0x07 Data pointer
|
|
~ ... + 0x08 - ... + 0x0f Referenced data length
|
|
~ ... + 0x10 - ... + 0x17 String pointer
|
|
~ (entry fields repeat at successive offsets, until...)
|
|
~ ... + 0x00 - ... + 0x07 (end) Zero, used as a delimiter
|
|
~
|
|
~
|
|
~ Magic comment syntax
|
|
~ ~~~~~~~~~~~~~~~~~~~~
|
|
~
|
|
~ How, the sufficiently determined reader may ask, does all this output
|
|
~ metadata get created? Surely, the reader may rightly think, creating
|
|
~ metadata entries which fully describe a compilation process must entail
|
|
~ gathering and synthesizing information from disparate stages of that
|
|
~ process, which seems quite involved.
|
|
~
|
|
~ That is correct: It is quite involved. It would be nice if there were a
|
|
~ simple trick, but this appears to be essential complexity. Several
|
|
~ approaches were considered. In principle it would be possible to have a
|
|
~ specific trap defined here in this file for every word that generates
|
|
~ nontrivial output, and keep knowledge of what information to gather from
|
|
~ those words in the trap definitions. However, that would bind the important
|
|
~ semantics quite closely to the already-overwhelming topic of the
|
|
~ transformation data structures, and make it all but impossible to port
|
|
~ Evocation to a new architecture. The knowledge we wish to capture is really
|
|
~ knowledge about an instruction set architecture, not about data structures.
|
|
~
|
|
~ Instead, following the principle that different kinds of knowledge on the
|
|
~ same topic should live close together, we've defined a magic-comment syntax
|
|
~ which allows the assembly-language words in amd64.e to describe their own
|
|
~ metadata, and is versatile enough to do the same for future architectures.
|
|
~
|
|
~ When the compiler operates normally, without the hex transform, these
|
|
~ magic comments are simply regular comments, and are discarded as the
|
|
~ interpreter finds them. When the compiler runs under the hex transform, they
|
|
~ are instead recognized as commands to be processed by the hex transform.
|
|
~ Magic comments can only appear in the body of a word being compiled, not at
|
|
~ the top level. The hex transform intervenes in the compilation process to
|
|
~ insert calls to its own internal words, which are executed, not when the
|
|
~ comment is read, but later, when the word it was compiled into is called.
|
|
~ When the word in question is itself part of the compiler, the magic comments
|
|
~ will be able to see and work with all the state that exists as it runs, and
|
|
~ gather it as they wish.
|
|
~
|
|
~ There are several kinds of magic comment. All of them begin with the
|
|
~ characters : and space as the first two characters of the comment body (and
|
|
~ don't forget that there's a space after ~, as well). The syntax on the rest
|
|
~ of the line determines what type of command it is.
|
|
~
|
|
~ Here are some examples:
|
|
~
|
|
~ ~ : Intriguing commentary goes here.
|
|
~ ~ : 5 This comment describes the next five bytes of output.
|
|
~ 777 pack32 ~ : -4 This comment describes the previous four bytes.
|
|
~
|
|
~ ~ : indent
|
|
~ ~ : deindent
|
|
~ ~ : fresh-line
|
|
~ ~ : blank-line
|
|
~
|
|
~ ~ : 1 adjust-length
|
|
~ ~ : -10 adjust-start
|
|
~ ~ : 1 data-adjust-length
|
|
~ ~ : -1 data-adjust-start
|
|
~
|
|
~ ~ : 0x1000 set-output-point
|
|
~ ~ : 8 adjust-output-point
|
|
~ ~ : data-set-output-point
|
|
~ ~ : 1 data-adjust-output-point
|
|
~
|
|
~ ~ : 1 suppress
|
|
~ ~ : delete-first-comment-at-output-point
|
|
~ ~ : delete-last-comment-at-output-point
|
|
~
|
|
~ ~ : Do a thing with # and # ?
|
|
~ ~ : provide-decimal
|
|
~ ~ : provide-hex
|
|
~ ~ : provide-hex8
|
|
~ ~ : provide-hex16
|
|
~ ~ : provide-hex32
|
|
~ ~ : provide-hex64
|
|
~ ~ : provide-string
|
|
~ ~ : provide-string-copy
|
|
~ ~ : provide-keyword
|
|
~ ~ : provide-data
|
|
~ ~ : drop-subitem
|
|
~ ~ : swap-subitems
|
|
~ ~ : 3 roll-subitems
|
|
~
|
|
~ By the way, the reason it's possible to write these examples is that
|
|
~ they're all embedded within an outer comment, the text you're reading, so
|
|
~ they don't look like real magic comments to the hex transform. Hopefully
|
|
~ that's not too confusing; there isn't really another way.
|
|
~
|
|
~ So. You'll have noticed that some magic comments seem to be descriptive
|
|
~ text, and others seem to be commands. Every magic comment, in one way or
|
|
~ another, creates or manipulates the metadata entries, which are stored in
|
|
~ an array inside the output metadata as global mutable state. There are
|
|
~ several phases of processing, and if you've gotten this far, you likely need
|
|
~ to understand what they are and what order they happen in.
|
|
~
|
|
~ The simplest kind of comment is the "line comment", the first example
|
|
~ above. Any comment that doesn't match some more-specific syntax is treated
|
|
~ as a line comment. It has not escaped Irenes' notice that this means your
|
|
~ syntax errors will seem to half-work; sorry about that. When a line comment
|
|
~ is executed, it creates a metadata entry at the end of the array of entries,
|
|
~ of -entry-type-line-comment, attached to the latest output point.
|
|
~
|
|
~ This is the general pattern: Any magic comment that creates a metadata
|
|
~ entry will always create it at the end of the entry array, and will always
|
|
~ attach it to the latest output point as of the time the comment executes.
|
|
~ Notice that, although the entry array will eventually be sorted by the
|
|
~ addresses entries are attached to, at the time entries are created they're
|
|
~ simply appended. This is rarely an important distinction, but when it is, it
|
|
~ is.
|
|
~
|
|
~ What is the latest output point? Well, the hex transform has trapped all
|
|
~ the words from core that compilation processes use to directly append bytes
|
|
~ to the label-loop buffer, including pack8, packstring, and the variants
|
|
~ thereof. The traps are able to tell when the destination is in the
|
|
~ label-loop buffer, and they ignore any writes that aren't. The traps keep
|
|
~ track of the next address AFTER whatever was just written, and store that
|
|
~ in the output metadata header so magic comments can make use of it.
|
|
~
|
|
~ It's necessary to take this sneaky approach, because the compiler is free
|
|
~ to write things in any order it wants; the label loop goes back to the start
|
|
~ every so often, and the high-level flow-control words even slide things
|
|
~ around after the fact. The compiler is also free to pass around addresses
|
|
~ however it wants within itself, and without restricting that, there's no way
|
|
~ for the hex transform to know which value represents the place stuff MIGHT
|
|
~ be written to.
|
|
~
|
|
~ The semantics of the latest output point are simple enough that they're
|
|
~ easy to keep in mind while writing magic comments. In practice, the output
|
|
~ point is almost never the cause of confusion about the behavior of magic
|
|
~ comments, but it's important to know about since it's the input the whole
|
|
~ thing starts with.
|
|
~
|
|
~ Now, one thing to keep in mind is that every metadata entry has both an
|
|
~ address in the label-loop buffer that it attaches to, and a length field.
|
|
~ Line comments insert themselves in between lines of output in the hex dump,
|
|
~ and don't otherwise affect the surrounding formatting, so they don't need to
|
|
~ make use of the length and it's always set to zero.
|
|
~
|
|
~ Now the second example above, which starts with the number 5 before its
|
|
~ descriptive text. When the first space-separated word of a magic comment's
|
|
~ body is a valid integer literal, this is taken as a parameter; different
|
|
~ types of magic comment use that parameter in different ways. The parameter
|
|
~ can be positive or negative, and can be written in any base Evocation
|
|
~ normally supports.
|
|
~
|
|
~ When a parameter is given (even if it's zero), and the comment doesn't
|
|
~ match some other more-specific syntax, it's treated as a "suffix comment".
|
|
~ Much like a line comment, when a suffix comment is executed, it creates a
|
|
~ metadata entry at the end, of -entry-type-suffix-comment, attached to the
|
|
~ latest output point. The command uses the parameter as the initial value of
|
|
~ the entry's length field, but it's worth being aware that other commands may
|
|
~ change it later.
|
|
~
|
|
~ It's called a suffix comment because, when all the passes described below
|
|
~ have run and the formatting happens, it will appear at the end of a line of
|
|
~ text, after the byte values it's attached to. Things like assembly-language
|
|
~ instructions should almost always be suffix comments, because this makes it
|
|
~ easy for a human reader to see which bytes of machine code go with them.
|
|
~
|
|
~ There's also an implicit way to create a suffix comment, which is to have
|
|
~ non-blank words of any kind on the line prior to the magic comment. In this
|
|
~ case, the default is to be a suffix comment rather than a line comment.
|
|
~ Suffix comments created this way will have zero length.
|
|
~
|
|
~ Before we move on from magic comments that produce descriptive text, also
|
|
~ look at the third example above. This is another suffix comment, but it's
|
|
~ got a negative number as its parameter. It's got a bit of code on the line
|
|
~ before it, to illustrate the typical way these negative parameters are used.
|
|
~ Just as a suffix comment with a positive length describes a span of bytes
|
|
~ with its start anchored at the address the comment is attached to, so when
|
|
~ the length is negative, the span of bytes has its END anchored at the
|
|
~ address.
|
|
~
|
|
~ You can see examples of how this syntax is useful in elf.e, where it
|
|
~ describes fields of various header structures. When it fits the situation,
|
|
~ this notation is concise and easy to visually skim both in the actual source
|
|
~ code, and in the generated hex dump.
|
|
~
|
|
~ Now let's look at some magic comments that do more interesting things.
|
|
~ The two commands "indent" and "deindent" both create an entry of
|
|
~ -entry-type-indent. Neither takes a parameter as part of the comment syntax,
|
|
~ but the entry structure has an internal value which is set to 2 for "indent"
|
|
~ and -2 for "deindent". When output is eventually formatted, these entries
|
|
~ will be used to adjust the amount of space at the beginning of each line,
|
|
~ which can be very useful to visually group code together. The formatting
|
|
~ process has some mutable state of its own, which doesn't exist until this
|
|
~ very late stage (long after magic comments execute); among other things,
|
|
~ there's a notion of current indentation level, which is preserved until
|
|
~ these entries adjust it.
|
|
~
|
|
~ The commands "fresh-line" and "blank-line" create entries of
|
|
~ -entry-type-fresh-line and -entry-type-blank-line, respectively. Just as the
|
|
~ output formatting knows how deeply indented it is, it also knows whether
|
|
~ it's at the start of a line. A fresh-line entry will insert a line break,
|
|
~ but only if we're somewhere deep in a line; if we're already at the start,
|
|
~ it does nothing. A blank-line entry will do the same thing as fresh-line,
|
|
~ then it will add another line break, so that the result is to output a fully
|
|
~ blank line in the hex dump. This can be useful to break things up visually.
|
|
~
|
|
~ Thus far, though we've taken pains to allude to the fact that there are
|
|
~ many stages of processing of metadata entries after they're created, we
|
|
~ haven't introduced any interesting features that rely on that. That changes
|
|
~ with the "adjust-line" command. When this command executes, it doesn't
|
|
~ create a new metadata entry. Rather, it scans backwards from the end of the
|
|
~ entry array, to find the most recently-created entry which is a line or
|
|
~ suffix comment. It skips over entries of other types. Then it adjusts the
|
|
~ length of that entry, in-place! The parameter of adjust-line may be positive
|
|
~ or negative, and either way it's added to the pre-existing length of the
|
|
~ entry it modifies.
|
|
~
|
|
~ If that doesn't sound confusing, you may not have fully appreciated that
|
|
~ adjust-line commands don't have to come in the same word as the command that
|
|
~ created the entry they're modifying. For example, in amd64.e, rex-w is a
|
|
~ common helper word called as part of many assembly instructions. It always
|
|
~ outputs a single byte. Commentary in that file describes an accounting
|
|
~ convention whereby keeping track of this byte is rex-w's job, so rex-w also
|
|
~ has a magic comment with an adjust-length command. Whatever word calls rex-w
|
|
~ will have already created a suffix comment giving the name of the
|
|
~ instruction it's implementing, by the time this is called, and rex-w's
|
|
~ call to adjust-length will find that comment's entry and modify it.
|
|
~
|
|
~ The use of this may not seem like much for a word like rex-w, which always
|
|
~ outputs the same number of bytes, but now look at the definition of
|
|
~ addressing-indirect-reg64. This is a common addressing mode shared by many
|
|
~ instructions, and called as a helper from various instruction words. Notice
|
|
~ how it has to generate a different encoding when it's given the register
|
|
~ :rsp, which has an extra SIB byte that's not needed for any other register.
|
|
~ There's no magic comments in addressing-indirect-reg64 itself, but the word
|
|
~ "sib" is another helper which does an appropriate adjust-length, if and only
|
|
~ if sib is actually called.
|
|
~
|
|
~ You can see how it might become quite confusing trying to decide which
|
|
~ word should take responsibility for a particular byte, when there are
|
|
~ multiple layers of abstraction like this. It's especially confusing because
|
|
~ this is an extra form of side-effect which acts on global mutable state, and
|
|
~ is out-of-band compared to the normal Forth value stack. When you're
|
|
~ implementing an instruction set architecture, you should strongly consider
|
|
~ defining an accounting convention which makes that clear and unambiguous.
|
|
~ Feel free to consult the convention described at the top of amd64.e for
|
|
~ inspiration.
|
|
~
|
|
~ All the adjust-* commands change something immediately, as they execute.
|
|
~ What they adjust differs. In the cases of adjust-length and adjust-start,
|
|
~ it's a field of a recent entry. Notionally, adjust-start does the same thing
|
|
~ as adjust-length but for the start address the entry is attached to, rather
|
|
~ than the length of the attachment. Also, while adjust-length only affects
|
|
~ comment entries, adjust-start affects any entry that produces output, such
|
|
~ as fresh-line.
|
|
~
|
|
~ The various -output-point commands are used to directly interact with the
|
|
~ notion of the latest output point, which can be useful if a location has
|
|
~ been skipped over and there are commands which should be run before
|
|
~ outputting anything at the new location. The simplest variant is
|
|
~ set-output-point, which sets it to the parameter value. The data-set-
|
|
~ variant obtains a value in the manner of the other data-* commands, adds it
|
|
~ to the parameter value, and sets the latest output point to the result. The
|
|
~ adjust- and data-adjust- variants, like other adjust commands, add a value
|
|
~ to the existing one.
|
|
~
|
|
~ Notice that the general rule is that data-set-* commands use their
|
|
~ parameter as an addend, while data-adjust-* commands use it as a multiplier.
|
|
~
|
|
~ The data-adjust-* variants deserve further commentary, though you may find
|
|
~ it more productive to read and understand the entire explanation about
|
|
~ provide-* commands before worrying about these. These variants adjust the
|
|
~ same things as the non-data ones, but instead of adjusting by a fixed
|
|
~ amount, they look for the most recent -entry-type-saved-data metadata entry.
|
|
~ They delete that entry from the entry array entirely, and use the value
|
|
~ saved in it as the amount to adjust by. Such entries are created by the
|
|
~ provide-data command, on which more below. Additionally, the data-adjust-*
|
|
~ commands use their parameters as scaling factors to the adjustment, and
|
|
~ these factors may be negative. You'll usually specify a parameter of 1 or
|
|
~ -1.
|
|
~
|
|
~ We will revisit the topic of adjust-length later, when we describe the
|
|
~ comment template feature, but for now we'll leave it there.
|
|
~
|
|
~ Direct your attention to the "suppress" command. Sometimes, you intend to
|
|
~ call a helper word which is going to create its own entries, but you know
|
|
~ that those entries don't suit your purpose, and you want to ignore them.
|
|
~ For example, you may be calling a word which outputs a binary string and
|
|
~ creates entries describing the string, but you're doing something more
|
|
~ specific and would prefer to create entries that describe your special case,
|
|
~ instead.
|
|
~
|
|
~ When you need this, you can call "suppress" with an integer parameter. If
|
|
~ the parameter is 1, the next time a metadata entry would have been created,
|
|
~ it won't; then things go back to normal. If you want to suppress more than
|
|
~ one entry in a row, you can pass it a larger number. If you change your
|
|
~ mind, you can pass it a negative number. At the time magic comments are
|
|
~ executing, there's a running count of how many entries should be suppressed,
|
|
~ which is decremented any time it's greater than zero and an entry would be
|
|
~ created, and adjusted every time a call to "suppress" is executed.
|
|
~
|
|
~ Sometimes, an entry has already been created, and you now need to get rid
|
|
~ of it. While there are reasons to be cautious of more-general mechanisms,
|
|
~ the commands delete-*-comment-at-output-point will search for a metadata
|
|
~ entry which is one of the comment types and which has its start position set
|
|
~ to the same address as the current output point. The -first- variant will
|
|
~ search forward from the start of the array, while -last- will search
|
|
~ backward from the end; both will stop as soon as they encounter one. This is
|
|
~ usually desired when overwriting a location that has already been written
|
|
~ to.
|
|
~
|
|
~ Take a quick look at the remaining examples. These are part of the comment
|
|
~ template feature. We'll need to describe the other phases of processing
|
|
~ before we can talk about how they work, but notice that one of them has the
|
|
~ space-separated word # inside it, while the others are commands whose names
|
|
~ start with provide-. Any line or suffix comment can have # in it, which will
|
|
~ consume a subitem from somewhere else, replacing the # like it's a template.
|
|
~ The various provide- commands are the origins of those subitems. Which #
|
|
~ goes with which provide- command? Thereby hangs a tale.
|
|
~
|
|
~ So. Let's pretend for the moment that we've finished talking about things
|
|
~ that happen when magic comments execute. We haven't, quite, but to finish it
|
|
~ out you'll need the full picture in your head.
|
|
~
|
|
~ All this time, the hex transform has been executing the compiler, which
|
|
~ is running its guts inside a utility called the label loop (see labels.e).
|
|
~ The compiler guts have been calling their own various internal words and
|
|
~ accumulating their binary output in the label-loop buffer. While this is
|
|
~ happening, the hex transform's various traps have been tracking the latest
|
|
~ output point, executing magic comments, and doing other vital but simpler
|
|
~ tasks.
|
|
~
|
|
~ Eventually the label-loop will reach the end of its iteration, and then it
|
|
~ will either conclude that all the labels in the program have been resolved
|
|
~ successfully, or it will notice that some of them were given addresses that
|
|
~ don't work. If the labels aren't all resolved, the label loop will start
|
|
~ over from the beginning, running all the same compiler guts again. The hex
|
|
~ transform will notice that this happened, clear out all the metadata
|
|
~ entries, and restart its own activities as well.
|
|
~
|
|
~ When the label loop finally declares success, and exits, the compiler will
|
|
~ want to actually produce its binary output. The hex transform has trapped
|
|
~ this, too! Now there's a postprocessing phase which cleans up all the
|
|
~ metadata entries, and then finally there's a formatting phase where the
|
|
~ entries are "run", as if they're a program, and the final hex dump with all
|
|
~ its comments is output.
|
|
~
|
|
~ As a side note, the hex transform doesn't stop the compiler short; it lets
|
|
~ the compiler decide which bytes will be output and in what order. In
|
|
~ practice, Evocation and the various supplemental programs around it only
|
|
~ ever write their output in a single giant chunk, but the formatting phase
|
|
~ actually runs every single time the compiler calls sys-write, and it only
|
|
~ handles the portion of the label-loop buffer which the compiler passed to
|
|
~ sys-write.
|
|
~
|
|
~ The postprocessing phase is idempotent - doing it twice is the same as
|
|
~ doing it once - so it's simply called every time sys-write is, before the
|
|
~ formatting phase starts. Postprocessing considers every metadata entry,
|
|
~ every time it runs, even when sys-write is called on something less than
|
|
~ the whole buffer.
|
|
~
|
|
~ If you add postprocessing features, make sure to keep them idempotent.
|
|
~ While it's possible to imagine reasons one might want to have back-and-forth
|
|
~ interplay between successive formatting and postprocessing phases, Evocation
|
|
~ goes to some trouble to make sure there is none. In Irenes' opinion, this
|
|
~ is already quite enough complexity and is nearing the limit of what humans
|
|
~ will find worthwhile. If you break idempotence, you are hereby warned that
|
|
~ you are at risk of falling into the abyss[1].
|
|
~
|
|
~ Postprocessing re-organizes entries, without changing their meaning, but
|
|
~ in a way that will make them easier to format. There are two things it
|
|
~ does, and they happen simultaneously: The whole array is bubble-sorted;
|
|
~ and some suffix comment entries are split apart.
|
|
~
|
|
~ The bubble sort resolves ordering first by the address each entry is
|
|
~ attached to, low-to-high. As a tiebreaker when two entries have the same
|
|
~ address, a comment entry is sorted after a stack-manipulation entry. The
|
|
~ tiebreaker rule means that stack-manipulation commands can come after the
|
|
~ last byte that's within the comment's span; otherwise they would always have
|
|
~ to be before it. If neither criterion applies, the entries will stay in
|
|
~ whatever order they were in to begin with; that is, it's a stable sort.
|
|
~
|
|
~ The comment splitting applies only to suffix comments, and only when their
|
|
~ length is not zero. They become a fresh-line entry at the start of the span
|
|
~ the comment originally attached to, and a zero-length suffix comment entry
|
|
~ at the end of the span.
|
|
~
|
|
~ Please notice that adjust-length commands happen when magic comments are
|
|
~ executed, which was long, long ago by now. By the time the postprocessing
|
|
~ happens, every entry's length has been as adjusted as it's ever going to be.
|
|
~ This is important, because the order of entries is going to matter during
|
|
~ the formatting phase.
|
|
~
|
|
~ Notice also that the splitting of suffix comment entries changes what
|
|
~ address the comment is attached to (unless it's a negative length, which is
|
|
~ already at the end of its span). Any entries that were attached to output
|
|
~ points somewhere inside the span will now definitely be before the suffix
|
|
~ comment's entry in the entry array, whereas up till now they were likely
|
|
~ somewhere after it, depending on the exact order everything was created in.
|
|
~
|
|
~ The postprocessing phase is conceptually simple - unlike the magic-comment
|
|
~ execution phase before it, and unlike the formatting phase after it, there
|
|
~ isn't any mutable state inside the phase that would make it matter what
|
|
~ order things happen in. Enjoy this, because ordering is about to become
|
|
~ super confusing.
|
|
~
|
|
~ Now let's consider the formatting phase. We've already mentioned that
|
|
~ there is some global state which is tracked throughout the phase, such as
|
|
~ the current indentation level and whether the output is at the start of a
|
|
~ line. The formatting phase is given an overall block of bytes in the
|
|
~ label-loop buffer, which it iterates through in order from beginning to end.
|
|
~ Any time the formatting phase reaches an address which has metadata entries
|
|
~ attached to it, all the entries at that address are executed, in the order
|
|
~ they exist in the entry array.
|
|
~
|
|
~ Yes, that's right, executing an entry is different from executing the
|
|
~ magic comment that created the entry. That's important.
|
|
~
|
|
~ The line-comment and suffix-comment entries do the obvious things: They
|
|
~ print out the appropriate comment text. Suffix comments are also all
|
|
~ horizontally aligned with each other, to make them easier to visually skim.
|
|
~ The two kinds of comment entries also do a less-obvious thing, which is fill
|
|
~ in any # template items that are part of the comment text, in order from
|
|
~ left to right.
|
|
~
|
|
~ Where do those items come from? Well, there's a separate stack, the
|
|
~ subitem entry stack, which is kept in the hex output metadata header. The
|
|
~ subitem entry stack has an extremely small, fixed maximum depth. The maximum
|
|
~ depth is deliberately small, so that any leaks onto it will be detected
|
|
~ somewhere close to their root causes, for ease of diagnosis. Unusually for
|
|
~ Evocation, if you underflow or overflow it, you'll get a friendly error
|
|
~ message rather than a segfault - how nice! Of course, the error message will
|
|
~ appear in the middle of your regular output and corrupt it, but you can't
|
|
~ have everything...
|
|
~
|
|
~ Each time a comment template is being filled and encounters a #
|
|
~ placeholder, an item is popped off the subitem entry stack and formatted
|
|
~ according to what type of entry it is. It's called an "entry stack" for a
|
|
~ reason: it's a stack of pointers to metadata entries, whose backing store
|
|
~ is in this very same entry array that we're executing. So, all the various
|
|
~ internal fields of an entry are available to provide rich behavior which
|
|
~ allows different kinds of values to be formatted in different ways.
|
|
~
|
|
~ For those used to languages with automatic memory management, keep in mind
|
|
~ that there's no language-provided guarantee that the thing a pointer points
|
|
~ to still exists, and hasn't been replaced with some other
|
|
~ misleadingly-similar thing. The separation of all this stuff into phases
|
|
~ provides that guarantee, because there's nothing in the formatting phase
|
|
~ that destroys or moves metadata entries in the array, but if that separation
|
|
~ were to break down, astonishingly complex wrong behavior would be entirely
|
|
~ likely. If you're reading all this, it's probably to touch that code, so
|
|
~ please keep those consequences in mind.
|
|
~
|
|
~ How do entry pointers get pushed onto the subitem entry stack, and where
|
|
~ do the values inside them come from? Okay, now this is the payoff, the part
|
|
~ where you need to understand all these phases at once. Cast your mind all
|
|
~ the way back to the magic-comment execution, and take another look at the
|
|
~ provide-* examples above. Recall that magic comment commands execute when
|
|
~ the word they're contained in is running. For the other comment commands,
|
|
~ this is mostly a curiosity; we talked about adjust-length, above, but that's
|
|
~ still just recording the fact that the word did or didn't run.
|
|
~
|
|
~ The provide-* commands are deeper than that. They peek at the top item on
|
|
~ the stack OF THE COMPILER, the code being transformed. The -decimal and
|
|
~ -hex* variants create a corresponding -entry-type-push-subitem- metadata
|
|
~ entry of the matching type, and copy the numeric value into it.
|
|
~
|
|
~ The -string variant expects to find a pointer to a null-terminated string;
|
|
~ -string-copy does too, but copies the contents of it to a safe place
|
|
~ immediately, on the assumption they'll be overwritten. The -keyword variant
|
|
~ expects to find a keyword (a word which, when executed, pushes its own
|
|
~ execution token onto the stack); the command extracts the name of the
|
|
~ keyword from the dictionary entry header. All three of these save pointer to
|
|
~ their respective strings in a push-subitem-string metadata entry.
|
|
~
|
|
~ Admit it, you thought writing out "metadata entry" so many times instead
|
|
~ of just "entry" was silly because there was no other kind of entry in
|
|
~ consideration, right up until you got to "dictionary entry". If so, hey
|
|
~ look, neat, right? ;)
|
|
~
|
|
~ The -data variant treats the value as opaque, and creates an
|
|
~ -entry-type-saved-data metadata entry. Unlike the others, these entries do
|
|
~ not affect the subitem entry stack; they're consumed and removed from the
|
|
~ entry array before entry execution even starts, by the matching data-*
|
|
~ command.
|
|
~
|
|
~ Anyway, notice that when the various provide-* commands execute, all
|
|
~ they're doing is capturing values and creating metadata entries. Like all
|
|
~ metadata entries, these are attached to the latest output point as of the
|
|
~ time the magic comment executes. In particular, the subitem entry stack
|
|
~ isn't touched until all the way at the end, in the formatting phase. It's
|
|
~ only when the formatting reaches the address the entry is attached to that
|
|
~ the entry is executed, which has the effect of pushing a pointer to the
|
|
~ entry onto the subitem entry stack.
|
|
~
|
|
~ It's been said already, but just to bring it all full circle, the life
|
|
~ cycle of a push-* entry ends later in the formatting phase, when a comment
|
|
~ entry pops it off the subitem entry stack and pretty-prints the value it
|
|
~ holds.
|
|
~
|
|
~ With all this context, it likely doesn't need much explanation, but the
|
|
~ drop-subitem command will create an -entry-type-drop-subitem entry. When
|
|
~ this entry is executed, it will discard an item from the subitem entry
|
|
~ stack. Similarly, swap-subitems creates an -entry-type-swap-subitems, which
|
|
~ swaps the top two items, and roll-subitems creates an
|
|
~ -entry-type-roll-subitems, which rolls them, or unrolls them with a negative
|
|
~ parameter.
|
|
|
|
~ In general, the order in which provide-* commands execute will most likely
|
|
~ match the order in which the corresponding bytes are output. This may not
|
|
~ always match the order in which the comment template wants to pretty-print
|
|
~ them. Therefore, you will want to use these commands to get the subitem
|
|
~ stack in the proper order.
|
|
~
|
|
~ In using these commands that manipulate the subitem stack, it's important
|
|
~ to remember that, when formatting happens, the left-to-right output of
|
|
~ subitems in the final output comment is top-to-bottom on the subitem stack,
|
|
~ because they're popped in order. This is the opposite of the usual visual
|
|
~ representation of stacks, and can easily be confusing.
|
|
~
|
|
~ It's probably clear from the extreme emphasis this documentation has taken
|
|
~ on describing the order things happen in, but it is quite common to define
|
|
~ a suffix comment at the start of an assembly-instruction word; adjust its
|
|
~ length as other words are called; accumulate push-* entries; then rely
|
|
~ on the address sorting to make sure the push-* entries are executed
|
|
~ before the suffix comment entry, even though the suffix-comment command
|
|
~ executed before the others, and even though the adjust-length commands may
|
|
~ have come before or after the provide-* commands that go with the same
|
|
~ suffix comment.
|
|
~
|
|
~ Now that you have this full picture in your head, you finally also have
|
|
~ the background to understand the data-adjust-* commands. You may find it
|
|
~ helpful to go re-read the explanation of them, above, to let it sink in.
|
|
~
|
|
~ This is the kind of forwards-and-backwards thinking which humans are
|
|
~ surprisingly good at when reading and writing software, but which it's
|
|
~ quite difficult to formalize in a way that lets a computer share that
|
|
~ understanding. If you've read this far, Irenes would absolutely adore
|
|
~ hearing about how you found the explanation and whether you did anything
|
|
~ with it; don't be shy!
|
|
~
|
|
~ [1] https://katalepsis.net/
|
|
|
|
~ We have a bunch of accessors and traversers for the output metadata, which
|
|
~ are all functions from pointers to pointers. Don't confuse these with the
|
|
~ accessors for the transformation state, defined far, far above.
|
|
: hex-output-metadata-label-loop-buffer-start ;
|
|
: hex-output-metadata-label-loop-buffer-length 8 + ;
|
|
: hex-output-metadata-latest-output-point 2 8 * + ;
|
|
: hex-output-metadata-has-non-space-this-input-line 3 8 * + ;
|
|
: hex-output-metadata-suppression-count 4 8 * + ;
|
|
: hex-output-metadata-is-fresh-line 5 8 * + ;
|
|
: hex-output-metadata-indentation-depth 6 8 * + ;
|
|
: hex-output-metadata-current-column 7 8 * + ;
|
|
: hex-output-metadata-n-bytes-this-line 8 8 * + ;
|
|
: hex-output-metadata-subitem-entry-stack-depth 9 8 * + ;
|
|
: hex-output-metadata-subitem-entry-stack-zero 10 8 * + ;
|
|
: hex-output-metadata-subitem-entry-stack-capacity 8 ;
|
|
: hex-output-metadata-first-entry
|
|
10 hex-output-metadata-subitem-entry-stack-capacity + 8 * + ;
|
|
: hex-output-metadata-entry-data-start ;
|
|
: hex-output-metadata-entry-data-length 8 + ;
|
|
: hex-output-metadata-entry-type 2 8 * + ;
|
|
: hex-output-metadata-entry-content 3 8 * + ;
|
|
: hex-output-metadata-next-entry 4 8 * + ;
|
|
: hex-output-metadata-previous-entry 4 8 * - ;
|
|
: hex-output-metadata-entry-type-line-comment 0 ;
|
|
: hex-output-metadata-entry-type-suffix-comment 1 ;
|
|
: hex-output-metadata-entry-type-fresh-line 2 ;
|
|
: hex-output-metadata-entry-type-blank-line 3 ;
|
|
: hex-output-metadata-entry-type-indent 4 ;
|
|
: hex-output-metadata-entry-type-string-literal 5 ;
|
|
: hex-output-metadata-entry-type-raw-string-literal 6 ;
|
|
: hex-output-metadata-entry-type-push-subitem-decimal 7 ;
|
|
: hex-output-metadata-entry-type-push-subitem-hex 8 ;
|
|
: hex-output-metadata-entry-type-push-subitem-hex8 9 ;
|
|
: hex-output-metadata-entry-type-push-subitem-hex16 10 ;
|
|
: hex-output-metadata-entry-type-push-subitem-hex32 11 ;
|
|
: hex-output-metadata-entry-type-push-subitem-hex64 12 ;
|
|
: hex-output-metadata-entry-type-push-subitem-string 13 ;
|
|
: hex-output-metadata-entry-type-saved-data 14 ;
|
|
: hex-output-metadata-entry-type-drop-subitem 15 ;
|
|
: hex-output-metadata-entry-type-swap-subitems 16 ;
|
|
: hex-output-metadata-entry-type-roll-subitems 17 ;
|
|
|
|
~ Initialize the contents of the output metadata to all zeroes. This is
|
|
~ called from hex-transform at its top level, at the very start, to make sure
|
|
~ everything is structurally valid. We can't store real values at that point,
|
|
~ because they don't exist yet. The actual label-loop buffer, per its name,
|
|
~ won't be allocated until label-loop is called, so we can't possibly know its
|
|
~ address till then.
|
|
: zero-hex-output-metadata
|
|
transformation-state transformation-state-output-metadata @
|
|
dup hex-output-metadata-label-loop-buffer-start 0 swap !
|
|
dup hex-output-metadata-label-loop-buffer-length 0 swap !
|
|
dup hex-output-metadata-latest-output-point 0 swap !
|
|
dup hex-output-metadata-has-non-space-this-input-line 0 swap !
|
|
dup hex-output-metadata-suppression-count 0 swap !
|
|
dup hex-output-metadata-is-fresh-line 1 swap !
|
|
dup hex-output-metadata-indentation-depth 0 swap !
|
|
dup hex-output-metadata-current-column 0 swap !
|
|
dup hex-output-metadata-n-bytes-this-line 0 swap !
|
|
dup hex-output-metadata-subitem-entry-stack-depth 0 swap !
|
|
dup hex-output-metadata-first-entry 0 swap ! ;
|
|
|
|
~ (pointer -- boolean)
|
|
: is-in-label-loop-buffer
|
|
dup
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-label-loop-buffer-start @
|
|
<=
|
|
swap
|
|
transformation-state transformation-state-output-metadata @
|
|
dup hex-output-metadata-label-loop-buffer-start @
|
|
swap hex-output-metadata-label-loop-buffer-length @ +
|
|
> && ;
|
|
|
|
: has-non-space-this-input-line@
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-has-non-space-this-input-line @ ;
|
|
|
|
: has-non-space-this-input-line!
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-has-non-space-this-input-line ! ;
|
|
|
|
: is-comment-entry
|
|
hex-output-metadata-entry-type @
|
|
dup hex-output-metadata-entry-type-line-comment = swap
|
|
hex-output-metadata-entry-type-suffix-comment = || ;
|
|
|
|
: is-output-producing-entry
|
|
dup is-comment-entry swap
|
|
hex-output-metadata-entry-type @
|
|
dup hex-output-metadata-entry-type-fresh-line = 3roll || swap
|
|
hex-output-metadata-entry-type-blank-line = || ;
|
|
|
|
: is-saved-data-entry
|
|
hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-saved-data = ;
|
|
|
|
: is-push-subitem-entry
|
|
~ Notably, the subitem swap, drop, and roll entry types are not
|
|
~ push-subitem entries.
|
|
hex-output-metadata-entry-type @
|
|
dup hex-output-metadata-entry-type-push-subitem-decimal = swap
|
|
dup hex-output-metadata-entry-type-push-subitem-hex = 3roll || swap
|
|
dup hex-output-metadata-entry-type-push-subitem-hex8 = 3roll || swap
|
|
dup hex-output-metadata-entry-type-push-subitem-hex16 = 3roll || swap
|
|
dup hex-output-metadata-entry-type-push-subitem-hex32 = 3roll || swap
|
|
dup hex-output-metadata-entry-type-push-subitem-hex64 = 3roll || swap
|
|
hex-output-metadata-entry-type-push-subitem-string = || ;
|
|
|
|
: is-subitem-stack-manipulation-entry
|
|
hex-output-metadata-entry-type @
|
|
dup hex-output-metadata-entry-type-drop-subitem = swap
|
|
dup hex-output-metadata-entry-type-swap-subitems = 3roll || swap
|
|
hex-output-metadata-entry-type-roll-subitems = || ;
|
|
|
|
: is-fresh-line@
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-is-fresh-line @ ;
|
|
|
|
: is-fresh-line!
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-is-fresh-line ! ;
|
|
|
|
: fresh-line is-fresh-line@ not { newline } if ;
|
|
|
|
: indentation-depth@
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-indentation-depth @ ;
|
|
|
|
: indentation-depth!
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-indentation-depth ! ;
|
|
|
|
: current-column@
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-current-column @ ;
|
|
|
|
: current-column!
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-current-column ! ;
|
|
|
|
: advance-current-column current-column@ + current-column! ;
|
|
|
|
: n-bytes-this-line@
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-n-bytes-this-line @ ;
|
|
|
|
: n-bytes-this-line!
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-n-bytes-this-line ! ;
|
|
|
|
: increment-bytes-this-line n-bytes-this-line@ 1+ n-bytes-this-line! ;
|
|
|
|
: describe-subitem-entry-stack
|
|
transformation-state transformation-state-output-metadata @
|
|
." depth "
|
|
dup hex-output-metadata-subitem-entry-stack-depth @ .hex64 newline
|
|
." capacity "
|
|
hex-output-metadata-subitem-entry-stack-capacity .hex64 newline
|
|
hex-output-metadata-subitem-entry-stack-zero
|
|
hex-output-metadata-subitem-entry-stack-capacity 8 * hexdump-from ;
|
|
|
|
: subitem-entry-stack-depth@
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-subitem-entry-stack-depth @ ;
|
|
|
|
: subitem-entry-stack-depth!
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-subitem-entry-stack-depth ! ;
|
|
|
|
: is-subitem-entry-stack-empty
|
|
subitem-entry-stack-depth@ 0 = ;
|
|
|
|
: is-subitem-entry-stack-full
|
|
subitem-entry-stack-depth@
|
|
hex-output-metadata-subitem-entry-stack-capacity = ;
|
|
|
|
: push-subitem-entry-stack
|
|
is-subitem-entry-stack-full not {
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-subitem-entry-stack-zero
|
|
subitem-entry-stack-depth@ 8 * + !
|
|
|
|
subitem-entry-stack-depth@ 1+ subitem-entry-stack-depth!
|
|
} {
|
|
~ We still consume the value, so that our caller doesn't crash.
|
|
drop
|
|
|
|
." Subitem entry stack overflow." newline
|
|
} if-else ;
|
|
|
|
: pop-subitem-entry-stack
|
|
is-subitem-entry-stack-empty not {
|
|
subitem-entry-stack-depth@ 1- subitem-entry-stack-depth!
|
|
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-subitem-entry-stack-zero
|
|
subitem-entry-stack-depth@ 8 * + @
|
|
} {
|
|
." Subitem entry stack underflow." newline
|
|
|
|
~ We still return a value, so that our caller doesn't crash.
|
|
0
|
|
} if-else ;
|
|
|
|
~ (data start, data length, entry type, string pointer, entry pointer --)
|
|
: hex-output-metadata-entry!
|
|
dup hex-output-metadata-entry-content 3roll swap !
|
|
dup hex-output-metadata-entry-type 3roll swap !
|
|
dup hex-output-metadata-entry-data-length 3roll swap !
|
|
dup hex-output-metadata-entry-data-start 3roll swap !
|
|
drop ;
|
|
|
|
~ (entry pointer, data start, data length, entry type, string pointer
|
|
~ -- next entry pointer)
|
|
: pack-hex-output-metadata-entry
|
|
4 pick hex-output-metadata-entry!
|
|
hex-output-metadata-next-entry ;
|
|
|
|
~ (data start, data length, entry type, string pointer --)
|
|
: add-hex-output-metadata-entry
|
|
~ If the suppression count is greater than zero, decrement it.
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-suppression-count @
|
|
dup 0 < {
|
|
1-
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-suppression-count !
|
|
4 ndrop exit
|
|
} { drop } if-else
|
|
|
|
3 pick is-in-label-loop-buffer {
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-first-entry
|
|
{ dup @ dup { dup 3 pick >= drop } if } {
|
|
hex-output-metadata-next-entry
|
|
} while
|
|
|
|
5 unroll pack-hex-output-metadata-entry
|
|
0 pack64 drop
|
|
} { drop drop drop drop } if-else ;
|
|
|
|
~ (entry pointer --)
|
|
: delete-metadata-entry
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-first-entry
|
|
{ dup @ } { hex-output-metadata-next-entry } while
|
|
~ (entry pointer, array-end marker pointer)
|
|
over hex-output-metadata-next-entry - 8 +
|
|
~ (entry pointer, length of block to move)
|
|
swap dup hex-output-metadata-next-entry swap 3roll memmove ;
|
|
|
|
|
|
~ (-- entry pointer or 0)
|
|
: find-latest-metadata-entry
|
|
~ Loop forward from the beginning of the entry array to find the last
|
|
~ actual entry.
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-first-entry
|
|
dup @ {
|
|
{ dup hex-output-metadata-next-entry @ }
|
|
{ hex-output-metadata-next-entry } while
|
|
} if ;
|
|
|
|
~ (-- entry pointer or 0)
|
|
: find-latest-comment-metadata-entry
|
|
find-latest-metadata-entry
|
|
~ (entry pointer or 0)
|
|
|
|
~ If and only if we actually found one, now loop backwards to find the
|
|
~ most recent one that's a comment entry. All length adjustments apply to
|
|
~ comment entries, anything else needs to be skipped for this purpose.
|
|
{ dup { dup is-comment-entry not } { 0 } if-else }
|
|
{ transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-first-entry
|
|
over > {
|
|
hex-output-metadata-previous-entry } { drop 0 } if-else } while
|
|
~ (entry pointer or 0)
|
|
;
|
|
|
|
~ (-- entry pointer or 0)
|
|
: find-latest-output-producing-metadata-entry
|
|
find-latest-metadata-entry
|
|
~ (entry pointer or 0)
|
|
|
|
~ If and only if we actually found one, now loop backwards to find the
|
|
~ most recent one that's an output-producing entry.
|
|
{ dup { dup is-output-producing-entry not } { 0 } if-else }
|
|
{ transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-first-entry
|
|
over > {
|
|
hex-output-metadata-previous-entry } { drop 0 } if-else } while
|
|
~ (entry pointer or 0)
|
|
;
|
|
|
|
~ (-- entry pointer or 0)
|
|
: find-latest-saved-data-metadata-entry
|
|
find-latest-metadata-entry
|
|
~ (entry pointer or 0)
|
|
|
|
~ If and only if we actually found one, now loop backwards to find the
|
|
~ most recent one that's a comment entry. All length adjustments apply to
|
|
~ comment entries, anything else needs to be skipped for this purpose.
|
|
{ dup { dup is-saved-data-entry not } { 0 } if-else }
|
|
{ transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-first-entry
|
|
over > {
|
|
hex-output-metadata-previous-entry } { drop 0 } if-else } while
|
|
~ (entry pointer or 0)
|
|
;
|
|
|
|
~ (target start location -- entry pointer or 0)
|
|
: find-first-comment-metadata-entry-with-start
|
|
~ Find the first entry, but if it doesn't exist, we want 0 instead.
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-first-entry
|
|
~ (target start location, entry pointer)
|
|
|
|
~ Now loop forwards to find the first that's a comment entry and has the
|
|
~ desired start location.
|
|
{ dup @ } {
|
|
dup is-comment-entry
|
|
over hex-output-metadata-entry-data-start @ 3 pick =
|
|
&& { swap drop exit } if
|
|
hex-output-metadata-next-entry
|
|
} while drop drop 0 ;
|
|
|
|
|
|
~ (target start location -- entry pointer or 0)
|
|
: find-latest-comment-metadata-entry-with-start
|
|
find-latest-metadata-entry
|
|
~ (target start location, entry pointer or 0)
|
|
|
|
dup {
|
|
{ dup @ } {
|
|
dup is-comment-entry
|
|
over hex-output-metadata-entry-data-start @ 3 pick =
|
|
&& { swap drop exit } if
|
|
|
|
dup
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-first-entry
|
|
= { drop drop 0 exit } if
|
|
|
|
hex-output-metadata-previous-entry
|
|
} while
|
|
} if swap drop ;
|
|
|
|
|
|
~ (length adjustment --)
|
|
: adjust-latest-comment-metadata-entry-length
|
|
find-latest-comment-metadata-entry
|
|
|
|
~ We've found the entry we want to act on, if it exists, so do it.
|
|
dup {
|
|
hex-output-metadata-entry-data-length dup @ 3roll + swap !
|
|
} {
|
|
drop
|
|
|
|
~ If we get here, that's a problem. Emit an error message to make sure
|
|
~ it's easy to diagnose.
|
|
." No pre-existing metadata entry to adjust." newline
|
|
crash
|
|
} if-else ;
|
|
|
|
~ (length adjustment --)
|
|
: adjust-latest-output-producing-metadata-entry-start
|
|
find-latest-output-producing-metadata-entry
|
|
|
|
~ We've found the entry we want to act on, if it exists, so do it.
|
|
dup {
|
|
hex-output-metadata-entry-data-start dup @ 3roll + swap !
|
|
} {
|
|
drop
|
|
|
|
~ If we get here, that's a problem. Emit an error message to make sure
|
|
~ it's easy to diagnose.
|
|
." No pre-existing metadata entry to adjust." newline
|
|
crash
|
|
} if-else ;
|
|
|
|
|
|
~ (target start location --)
|
|
: delete-first-comment-metadata-entry-with-start
|
|
find-first-comment-metadata-entry-with-start
|
|
dup { delete-metadata-entry } { drop } if-else ;
|
|
|
|
~ (target start location --)
|
|
: delete-latest-comment-metadata-entry-with-start
|
|
find-latest-comment-metadata-entry-with-start
|
|
dup { delete-metadata-entry } { drop } if-else ;
|
|
|
|
: delete-first-comment-metadata-entry-at-output-point
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-latest-output-point @
|
|
delete-first-comment-metadata-entry-with-start ;
|
|
|
|
: delete-latest-comment-metadata-entry-at-output-point
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-latest-output-point @
|
|
delete-latest-comment-metadata-entry-with-start ;
|
|
|
|
|
|
~ (value --)
|
|
: set-latest-output-point
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-latest-output-point ! ;
|
|
|
|
~ (adjustment --)
|
|
: adjust-latest-output-point
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-latest-output-point
|
|
dup 3unroll @ + swap ! ;
|
|
|
|
~ (-- data value)
|
|
: data-consume
|
|
find-latest-saved-data-metadata-entry
|
|
~ (entry pointer or 0)
|
|
|
|
dup {
|
|
dup hex-output-metadata-entry-content @ swap
|
|
~ (data value, entry pointer)
|
|
|
|
delete-metadata-entry
|
|
} {
|
|
drop
|
|
|
|
~ If we get here, that's a problem. Emit an error message to make sure
|
|
~ it's easy to diagnose.
|
|
." No saved-data metadata entry to take a value from." newline
|
|
|
|
~ We still return a value, so that our caller doesn't crash.
|
|
0
|
|
} if-else ;
|
|
|
|
~ (adjustment scale factor --)
|
|
: data-adjust-latest-comment-metadata-entry-length
|
|
~ All the entry array manipulation happens in data-consume. Once we're
|
|
~ done doing that, the array is now in a consistent state, so we can hand
|
|
~ off to the non-data implementation to do the rest of the work.
|
|
data-consume * adjust-latest-comment-metadata-entry-length ;
|
|
~ (adjustment scale factor --)
|
|
: data-adjust-latest-output-producing-metadata-entry-start
|
|
~ Same as for adjusting the entry length.
|
|
data-consume * adjust-latest-output-producing-metadata-entry-start ;
|
|
|
|
~ (value offset --)
|
|
: data-set-latest-output-point
|
|
data-consume + set-latest-output-point ;
|
|
~ (adjustment scale factor --)
|
|
: data-adjust-latest-output-point
|
|
data-consume * adjust-latest-output-point ;
|
|
|
|
|
|
~ (count adjustment --)
|
|
: adjust-hex-output-suppression-count
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-suppression-count dup @ 3roll + swap ! ;
|
|
|
|
~ This is the followup to zero-hex-output-metadata, above. Once we do have
|
|
~ the label-loop buffer, we need to create some default entries. This is
|
|
~ called in the first label-loop iteration by hex-allocate-replacement, and
|
|
~ it's called before subsequent iterations by the hook on reset-labels defined
|
|
~ in hex-colon-alternate.
|
|
~
|
|
~ This overwrites whatever entries currently exist with the new ones, and
|
|
~ adds a zero delimiter at the end.
|
|
~
|
|
~ In addition to setting up the entries, we also set latest-output-point to
|
|
~ the start of the label-loop buffer here. This needs to happen at the start
|
|
~ of each pass, so although it doesn't quite fit the name, we do it here.
|
|
~
|
|
~ It requires the header to have already been initialized; in particular it
|
|
~ requires the label-loop buffer start pointer to be valid.
|
|
: create-hex-output-metadata-top-of-file-entries
|
|
transformation-state transformation-state-output-metadata @
|
|
dup hex-output-metadata-label-loop-buffer-start @
|
|
swap hex-output-metadata-first-entry
|
|
~ (label buffer start, metadata output point)
|
|
|
|
~ This likely won't affect anything, because every call to pack*
|
|
~ overwrites it, but we initialize the latest output point to the start of
|
|
~ the label loop buffer here. That way, in the event the very first thing in
|
|
~ the output is something that's supposed to have a magic comment on it,
|
|
~ hex-tilde-replacement will know where to attach the metadata entry.
|
|
~
|
|
~ If that was word soup, go read about hex-tilde-replacement and
|
|
~ hex-tilde-alternate and come back. :)
|
|
over
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-latest-output-point !
|
|
0 has-non-space-this-input-line!
|
|
|
|
over 0 hex-output-metadata-entry-type-line-comment
|
|
s" This file is a commented hexadecimal representation of a compiled"
|
|
pack-hex-output-metadata-entry
|
|
|
|
over 0 hex-output-metadata-entry-type-line-comment
|
|
s" program, the output of Evocation's hex transform. The comments are"
|
|
pack-hex-output-metadata-entry
|
|
|
|
over 0 hex-output-metadata-entry-type-line-comment
|
|
s" intended to allow a human reader to audit it. You can convert it to a"
|
|
pack-hex-output-metadata-entry
|
|
|
|
over 0 hex-output-metadata-entry-type-line-comment
|
|
s" runnable executable by piping it through the program named 'hex' and"
|
|
pack-hex-output-metadata-entry
|
|
|
|
over 0 hex-output-metadata-entry-type-line-comment
|
|
s" chmodding the output 755. The difference between a source and a binary"
|
|
pack-hex-output-metadata-entry
|
|
|
|
over 0 hex-output-metadata-entry-type-line-comment
|
|
s" is comments! Enjoy. :)"
|
|
pack-hex-output-metadata-entry
|
|
|
|
over 0 hex-output-metadata-entry-type-blank-line 0
|
|
pack-hex-output-metadata-entry
|
|
|
|
0 swap ! ~ End-of-entries delimiter
|
|
drop ;
|
|
|
|
: hex-self-codeword-alternate self-codeword ;
|
|
|
|
: hex-string-alternate
|
|
~ The technique we use to wrap s" is analogous to how we do it in the
|
|
~ label transform, but with one critical decision different.
|
|
~
|
|
~ In the label transform, the output buffer is going to be written
|
|
~ directly into the final executable at some point, and we'd really rather
|
|
~ not scribble temporary values into it, even if we expect to overwrite them
|
|
~ later. Additionally, everything the label transform does runs inside the
|
|
~ label loop, so the code it's transforming isn't expected to do any sort of
|
|
~ miscellaneous setup things, just define a bunch of words. In that
|
|
~ situation, making sure to use temporary space from the outer, "real" log
|
|
~ is helpful.
|
|
~
|
|
~ In the hex transform, most of that is different. The output buffer will
|
|
~ include all sorts of things that don't become part of the final
|
|
~ executable, though they're used in producing it. So, it's fine to use it
|
|
~ for scratch space. Additionally, using the outer log for string literals
|
|
~ gets us into trouble, since some of these temporary strings need to be
|
|
~ made more durable by calling allocate-string on them. If we do that with
|
|
~ a string pointer backed by the outer log, the inner "here" will wind up
|
|
~ pointing to the end of the outer log, and all sorts of things will start
|
|
~ scribbling atop each other.
|
|
~
|
|
~ We do still benefit from using the interpreted version of s" rather than
|
|
~ the compiled one; as with the label transform, it's convenient to handle
|
|
~ the litstring dance ourselves.
|
|
~
|
|
~ If we're in compile mode, we have reinvented a problem which the
|
|
~ regular, non-transformed s" already deals with: The temporary space we're
|
|
~ writing to is in the same place as the code we're compiling. We solve it
|
|
~ the same way: Check beforehand and write out the call to litstring if we
|
|
~ need it, so that we won't have to slide things around later.
|
|
interpreter-flags @ 0x01 & {
|
|
~ We look up the inner version of litstring to reference here. This is
|
|
~ similar to what the label transform does, except we don't use a label
|
|
~ for it.
|
|
s" litstring" find entry-to-execution-token ,
|
|
} if
|
|
|
|
~ Now, regardless of what mode we're actually in, call the interpreted
|
|
~ version of s" to read the actual string and its null terminator.
|
|
interpreter-flags @
|
|
' s" entry-to-execution-token
|
|
[ ' [ entry-to-execution-token , ]
|
|
execute
|
|
swap interpreter-flags !
|
|
|
|
~ Now we have a string pointer on the stack at transform time. If we're in
|
|
~ immediate mode, that's sufficient. If we're in compile mode, we also
|
|
~ already output a litstring invocation, and the string is in the right
|
|
~ place, but "here" is pointing before it and needs to point after it, then
|
|
~ we also still need to add alignment padding. Plus, we need to be sure to
|
|
~ not leave the string pointer itself on the stack.
|
|
interpreter-flags @ 0x01 & {
|
|
dup stringlen 1+ + 8 packalign here !
|
|
} if
|
|
; make-immediate
|
|
|
|
: hex-dot-string-alternate
|
|
' hex-string-alternate entry-to-execution-token execute
|
|
|
|
interpreter-flags @ 0x01 & {
|
|
~ We look up the inner version of emitstring, too.
|
|
s" emitstring" find entry-to-execution-token ,
|
|
} { emitstring } if-else
|
|
; make-immediate
|
|
|
|
: hex-create-alternate create ;
|
|
|
|
~ This is a helper called from the patched version of "variable", described
|
|
~ in more detail in hex-colon-alternate, below. It expects to be called after
|
|
~ outputting the entry header for "variable", during the body of the
|
|
~ definition, so that it can output compiled code which will run as part of
|
|
~ the transformed "variable".
|
|
~
|
|
~ The helper accepts a string pointer giving a variable name. The code it
|
|
~ produces checks the name of the variable being defined and, if the two names
|
|
~ match, alters the resulting inner variable to point to the same backing
|
|
~ store as the outer variable of the same name.
|
|
~
|
|
~ In many ways the hex transform is the trippiest one. To wit, there's two
|
|
~ layers of compilation happening here... so don't get confused. When the
|
|
~ helper is called, we're compiling the inner "variable", but "variable"
|
|
~ itself is a word-defining word which also has the task of compilation...
|
|
~ which we're modifying.
|
|
~
|
|
~ (name pointer --)
|
|
: hex-variable-use-outer
|
|
~ The actual payload here is that we check whether we're defining the
|
|
~ word described by the name pointer we were given, and, if so, we make it
|
|
~ reference the outer backing store instead of the inner one.
|
|
~
|
|
~ We want to do this all as references to inner words, which fortunately
|
|
~ have been defined by now, but we have to do that a bit indirectly...
|
|
s" dup" find entry-to-execution-token ,
|
|
s" litstring" find entry-to-execution-token ,
|
|
here @ over packstring 8 packalign here !
|
|
s" stringcmp" find entry-to-execution-token ,
|
|
s" lit" find entry-to-execution-token , 0 ,
|
|
s" =" find entry-to-execution-token ,
|
|
|
|
~ Also, we don't have high-level flow control yet, and even if we did,
|
|
~ it would be awkward to use it here. So we count the branch by hand. Ah
|
|
~ well. As always, remember that with forward branches, the offset to
|
|
~ branch by is the first word to be skipped, and is included in the count.
|
|
s" 0branch" find entry-to-execution-token , 6 8 * ,
|
|
|
|
~ If control reaches here in the generated code, the string matched.
|
|
s" swap" find entry-to-execution-token ,
|
|
s" drop" find entry-to-execution-token ,
|
|
|
|
~ To get the value of the outer variable, we just call it. Of course,
|
|
~ looking up an outer entry is a pain, but at least it's a pain in a way
|
|
~ that should be familiar by now.
|
|
s" lit" find entry-to-execution-token ,
|
|
swap-transform-variables
|
|
find
|
|
swap-transform-variables
|
|
entry-to-execution-token execute ,
|
|
|
|
s" swap" find entry-to-execution-token , ;
|
|
|
|
~ This is a helper used by postprocess-metadata-entries, below. It
|
|
~ duplicates the entry it's given, creating a second identical copy
|
|
~ immediately after it in the entry array, sliding everything else forward to
|
|
~ make room.
|
|
~
|
|
~ (entry pointer --)
|
|
: dup-metadata-entry
|
|
~ Find all the remaining entries, and the final terminator, and slide
|
|
~ them forward by the length of one entry.
|
|
dup dup
|
|
~ (entry pointer, entry pointer, entry pointer)
|
|
|
|
{ dup @ } { hex-output-metadata-next-entry } while 8 +
|
|
~ (entry pointer, entry pointer, entry array end pointer)
|
|
swap -
|
|
~ (entry pointer, entry array tail length)
|
|
swap dup hex-output-metadata-next-entry 3roll
|
|
~ (entry pointer, adjusted entry pointer, entry array tail length)
|
|
memmove ;
|
|
|
|
~ This is a helper used by postprocess-metadata-entries, below. It swaps
|
|
~ the contents of the entry it's given with the contents of the entry
|
|
~ immediately after it in the entry array.
|
|
~
|
|
~ (entry pointer --)
|
|
: swap-metadata-entries
|
|
~ Copy the current entry to a scratch area.
|
|
dup dup dup hex-output-metadata-next-entry swap -
|
|
~ (entry pointer, entry pointer, entry length)
|
|
swap-transform-variables here @ swap-transform-variables swap
|
|
~ (entry pointer, entry pointer, scratch pointer, entry length)
|
|
memcopy
|
|
~ (entry pointer)
|
|
|
|
~ Copy the next entry over the current entry.
|
|
dup dup hex-output-metadata-next-entry dup
|
|
~ (entry pointer, entry pointer, next entry pointer, next entry pointer)
|
|
3roll -
|
|
~ (entry pointer, next entry pointer, entry length)
|
|
2 pick swap
|
|
~ (entry pointer, next entry pointer, entry pointer, entry length)
|
|
memcopy
|
|
~ (entry pointer)
|
|
|
|
~ Copy the scratch area over the next entry.
|
|
dup hex-output-metadata-next-entry dup
|
|
~ (entry pointer, next entry pointer, next entry pointer)
|
|
3roll -
|
|
~ (next entry pointer, entry length)
|
|
swap-transform-variables here @ swap-transform-variables 3unroll
|
|
~ (scratch pointer, next entry pointer, entry length)
|
|
memcopy ;
|
|
|
|
~ Metadata entries are post-processed before they're output, in order to
|
|
~ make the structure of the output code simpler. The post-processing won't
|
|
~ happen until output actually occurs, which is important for operations that
|
|
~ modify entries in-place.
|
|
~
|
|
~ Any time output is performed, all existing entries are post-processed.
|
|
~ Therefore, the post-processing is required to be idempotent, and is.
|
|
: postprocess-metadata-entries
|
|
1 { } {
|
|
0
|
|
~ (did anything this iteration)
|
|
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-first-entry
|
|
{ dup @ } {
|
|
~ (did anything, entry pointer)
|
|
|
|
~ Is the entry a suffix comment with a non-zero data length?
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-suffix-comment =
|
|
over hex-output-metadata-entry-data-length @ 0 != && {
|
|
~ Split it into two entries so as not to rely on data length for
|
|
~ formatting.
|
|
dup dup-metadata-entry
|
|
~ (did anything, entry pointer)
|
|
~ Now we have the original entry at the original location, and a copy
|
|
~ of it at the next location.
|
|
|
|
~ We have a feature which lets a suffix comment be created with a
|
|
~ negative length, which means it covers bytes before the current output
|
|
~ point rather than after it. This logic here is the implementation of
|
|
~ that feature.
|
|
dup hex-output-metadata-entry-data-start @ dup
|
|
2 pick hex-output-metadata-entry-data-length @ +
|
|
2dup min 3unroll max
|
|
~ (..., entry pointer, low end of data, high end of data)
|
|
|
|
~ Now we modify the original in-place to turn it into a fresh-line
|
|
~ entry at the low end of the data...
|
|
2 pick hex-output-metadata-entry-type
|
|
hex-output-metadata-entry-type-fresh-line swap !
|
|
~ (..., entry pointer, low end of data, high end of data)
|
|
|
|
2 pick hex-output-metadata-entry-data-start 3roll swap !
|
|
~ (..., entry pointer, high end of data)
|
|
over hex-output-metadata-entry-data-length 0 swap !
|
|
~ (..., entry pointer, high end of data)
|
|
|
|
~ ... then we modify the next entry in-place to set its location to
|
|
~ the end of the data instead of the beginning, and its length to zero.
|
|
over hex-output-metadata-next-entry
|
|
~ (..., entry pointer, high end of data, next entry pointer)
|
|
|
|
dup hex-output-metadata-entry-data-start 3roll swap !
|
|
~ (..., entry pointer, next entry pointer)
|
|
hex-output-metadata-entry-data-length 0 swap !
|
|
~ (..., entry pointer)
|
|
|
|
~ This rule won't fire again on the fresh-line entry because it's of a
|
|
~ a different type, and it won't fire on the modified suffix-comment
|
|
~ entry because its data length is zero.
|
|
~
|
|
~ It's possible that one or the other of the bubble-sort rules will
|
|
~ fire on either of them.
|
|
|
|
~ (did anything, entry pointer)
|
|
swap drop 1 swap
|
|
} if
|
|
~ (did anything, entry pointer)
|
|
|
|
~ Do this entry and the next entry both exist, and they're out of
|
|
~ order based on their data starts?
|
|
dup hex-output-metadata-next-entry dup @
|
|
{ hex-output-metadata-entry-data-start @
|
|
over hex-output-metadata-entry-data-start @ > }
|
|
{ drop 0 } if-else
|
|
{
|
|
~ Swap the order of the two entries. Since this whole thing is in a
|
|
~ loop, this functions as a bubble sort.
|
|
dup swap-metadata-entries
|
|
swap drop 1 swap
|
|
|
|
~ This rule won't fire again on the same pair of entries because now
|
|
~ they're in the correct order. It may fire again next iteration,
|
|
~ but only until everything is sorted.
|
|
~
|
|
~ This rule does nothing to alter whether the suffix-comment rule
|
|
~ will fire on either of the entries it swapped, so there's no
|
|
~ possibility of an infinite loop through that one.
|
|
} if
|
|
~ (did anything, entry pointer)
|
|
|
|
~ Do this entry and the next entry both exist, and they have the same
|
|
~ data start, and this one is a comment entry, and the next one is a
|
|
~ stack-manipulation entry with zero length?
|
|
dup is-comment-entry over hex-output-metadata-next-entry @ &&
|
|
{ ~ (did anything, entry pointer)
|
|
dup hex-output-metadata-next-entry
|
|
over hex-output-metadata-entry-data-start @
|
|
over hex-output-metadata-entry-data-start @ =
|
|
swap dup hex-output-metadata-entry-data-length @ 0 = 3roll && swap
|
|
is-subitem-stack-manipulation-entry && }
|
|
{ 0 } if-else
|
|
{
|
|
~ Swap the order of the two entries. Since this whole thing is in a
|
|
~ loop, this functions as a bubble sort.
|
|
dup swap-metadata-entries
|
|
swap drop 1 swap
|
|
|
|
~ This rule can't fire in the same iteration as the previous swap,
|
|
~ because that one doesn't fire when the starts are equal. It also
|
|
~ won't fire again on the same pair of entries, again because now
|
|
~ they're in the correct order. If it fires again in the next
|
|
~ iteration that'll only be in the usual way it does for a bubble
|
|
~ sort.
|
|
~
|
|
~ As with the other swap rule, this rule also does nothing to alter
|
|
~ whether the suffix-comment rule will fire on either entry it
|
|
~ touches, so it won't loop through that one.
|
|
} if
|
|
~ (did anything, entry pointer)
|
|
|
|
hex-output-metadata-next-entry
|
|
} while drop
|
|
} while ;
|
|
|
|
: hex-comment-first-tab-stop 36 ;
|
|
: hex-comment-second-tab-stop 58 ;
|
|
|
|
~ This is a helper called from hex-emit-template-string. The word pointer
|
|
~ is in the outer log's scratch space, and must not be overwritten.
|
|
~
|
|
~ (queued space count, word pointer -- should ignore space)
|
|
: hex-emit-template-string-word
|
|
dup s" #" stringcmp 0 = {
|
|
~ (queued space count, word pointer)
|
|
drop
|
|
|
|
pop-subitem-entry-stack
|
|
~ (queued space count, subitem entry)
|
|
|
|
~ If we underflowed the stack, we got zero back, so make sure not to
|
|
~ crash. A crash here would be a pain to debug because it would be
|
|
~ unclear how much of the overall system is working, and it's a
|
|
~ complex system.
|
|
dup {
|
|
~ (queued space count, subitem entry)
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-push-subitem-decimal = {
|
|
swap dup indent advance-current-column 0 swap
|
|
|
|
dup hex-output-metadata-entry-content @
|
|
dup 10 swap logfloor 1+ advance-current-column
|
|
.
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-push-subitem-hex = {
|
|
swap dup indent advance-current-column 0 swap
|
|
|
|
." 0x"
|
|
dup hex-output-metadata-entry-content @
|
|
dup 16 swap logfloor 1+ 2 + advance-current-column
|
|
.hex
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-push-subitem-hex8 = {
|
|
swap dup indent advance-current-column 0 swap
|
|
|
|
." 0x"
|
|
dup hex-output-metadata-entry-content @ .hex8
|
|
4 advance-current-column
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-push-subitem-hex16 = {
|
|
swap dup indent advance-current-column 0 swap
|
|
|
|
." 0x"
|
|
dup hex-output-metadata-entry-content @ .hex16
|
|
6 advance-current-column
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-push-subitem-hex32 = {
|
|
swap dup indent advance-current-column 0 swap
|
|
|
|
." 0x"
|
|
dup hex-output-metadata-entry-content @ .hex32
|
|
10 advance-current-column
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-push-subitem-hex64 = {
|
|
swap dup indent advance-current-column 0 swap
|
|
|
|
." 0x"
|
|
dup hex-output-metadata-entry-content @ .hex64
|
|
18 advance-current-column
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-push-subitem-string = {
|
|
swap dup indent advance-current-column 0 swap
|
|
|
|
dup hex-output-metadata-entry-content @
|
|
dup stringlen advance-current-column
|
|
emitstring
|
|
} if
|
|
} if
|
|
|
|
drop drop 0 exit
|
|
} if
|
|
|
|
dup s" #--" stringcmp 0 = {
|
|
~ (queued space count, word pointer)
|
|
|
|
hex-comment-second-tab-stop current-column@
|
|
2dup > {
|
|
drop drop swap drop 0 swap
|
|
newline
|
|
hex-comment-first-tab-stop indent ." ~"
|
|
hex-comment-second-tab-stop hex-comment-first-tab-stop 1+ - indent
|
|
hex-comment-second-tab-stop current-column!
|
|
} {
|
|
- dup indent advance-current-column
|
|
swap drop 0 swap
|
|
} if-else
|
|
|
|
drop drop 1 exit
|
|
} if
|
|
|
|
~ (queued space count, word pointer)
|
|
swap dup indent advance-current-column
|
|
dup stringlen advance-current-column
|
|
emitstring 0 ;
|
|
|
|
|
|
~ (string pointer --)
|
|
: hex-emit-template-string
|
|
0 swap
|
|
~ (queued space count, input point)
|
|
|
|
{ unpack8 dup } {
|
|
~ (queued space count, input point, latest character)
|
|
dup is-space {
|
|
~ Instead of outputting space characters as we reach them, we keep a
|
|
~ count of how many are pending. This allows us to do word-wrapping
|
|
~ without having to worry about trailing spaces.
|
|
3roll 1+ 3unroll drop
|
|
} {
|
|
~ (queued space count, input point, first word character)
|
|
~ We use the outer log's scratch space to accumulate each word in.
|
|
swap-transform-variables here @ swap-transform-variables
|
|
swap
|
|
pack8
|
|
swap
|
|
~ (queued space count, scratch output point, input point)
|
|
|
|
~ Scan forward and find a space-separated word.
|
|
{ unpack8 dup dup is-space not && } {
|
|
~ (queued space count, scratch output point, adjusted input point,
|
|
~ next character)
|
|
3roll swap pack8 swap
|
|
~ (queued space count, adjusted scratch output point,
|
|
~ adjusted input point)
|
|
} while
|
|
~ (queued space count, scratch output point, input point,
|
|
~ first non-word character or 0)
|
|
3roll 0 pack8 drop
|
|
~ (queued space count, input point, first non-word character or 0)
|
|
|
|
swap-transform-variables here @ swap-transform-variables
|
|
~ (queued space count, input point, first non-word character or 0,
|
|
~ word pointer)
|
|
|
|
4 roll swap 1 max hex-emit-template-string-word 0 4 unroll
|
|
~ (queued space count, input point, first non-word character,
|
|
~ should ignore space)
|
|
|
|
over {
|
|
~ If the character is non-zero, it's a space, so it can't be part of
|
|
~ a word, so we can queue it for later output... unless we were asked
|
|
~ to skip it, of course.
|
|
not {
|
|
~ (queued space count, input point, first non-word character)
|
|
3roll 1+ 3unroll
|
|
} if
|
|
drop
|
|
} {
|
|
~ If this is the end of the string, we can discard the 0, but then
|
|
~ we need to nudge the input point back so the loop will terminate.
|
|
drop drop 1-
|
|
} if-else
|
|
~ (queued space count, input point)
|
|
} if-else
|
|
} while drop drop drop ;
|
|
|
|
|
|
~ (string pointer --)
|
|
: hex-emit-comment
|
|
hex-comment-second-tab-stop current-column@ > {
|
|
newline
|
|
hex-comment-first-tab-stop dup indent current-column!
|
|
1 is-fresh-line!
|
|
0 n-bytes-this-line!
|
|
} if
|
|
|
|
." ~"
|
|
1 advance-current-column
|
|
|
|
dup @ {
|
|
space
|
|
1 advance-current-column
|
|
} if
|
|
|
|
hex-emit-template-string ;
|
|
|
|
|
|
~ This "replacement" is a little different from an alternate: When the code
|
|
~ under transformation attempts to compile its own version of sys-write, it
|
|
~ gets a stub that calls this word instead. It's swapped out by
|
|
~ hex-colon-alternate, whereas the regular alternates are swapped out by
|
|
~ hex-transform-one.
|
|
~
|
|
~ In the programs we're actually running the transform on, there's only ever
|
|
~ a single call to sys-write which is the whole binary in one go, but we don't
|
|
~ want to require that, so we keep all the formatting state in the output
|
|
~ metadata header.
|
|
~
|
|
~ (file descriptor, base address, length to write -- length written)
|
|
: hex-sys-write-replacement
|
|
~ In intended operation, the code under transformation is a compilation
|
|
~ process, and it won't output anything that isn't executable binary.
|
|
~ However, while developing, it's common to have crashes, and it's nice to
|
|
~ get the crash dump as ASCII rather than hex.
|
|
over is-in-label-loop-buffer not {
|
|
sys-write exit
|
|
} if
|
|
3roll drop dup 3roll
|
|
~ The result should be the length written. We just proactively declare
|
|
~ that we'll write the full length we were asked to, threading that through
|
|
~ as the result we'll eventually return.
|
|
~ (result, length to write, base address)
|
|
|
|
postprocess-metadata-entries
|
|
|
|
~ Importantly, postprocessing leaves the entries sorted, which means we
|
|
~ can go back and forth in a linear scan through the entry array while we
|
|
~ also do a linear scan of the output data. It's fiddly, but we can't afford
|
|
~ to be O(n^2) here, it adds up to quite a lot of runtime.
|
|
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-first-entry
|
|
~ (result, length to write, base address, initial metadata scan pointer)
|
|
{ 2 pick 0 <= } {
|
|
~ (result, length remaining, current output address,
|
|
~ metadata scan pointer)
|
|
|
|
~ Keep inspecting entries as long as the output address is greater than
|
|
~ or equal to the entry address. If we're looking at the entries that come
|
|
~ before the output, this will scan through all of them first, then
|
|
~ eventually catch up. Since the scan pointer is kept across iterations,
|
|
~ it's important we not go beyond that point.
|
|
{ dup @ dup
|
|
~ (result, length remaining, current output address,
|
|
~ metadata scan pointer, entry's first field, entry's first field)
|
|
{
|
|
~ This is an nop, but for clarity's sake it's best to not depend on
|
|
~ details of the structure layout that perhaps not everyone has
|
|
~ memorized...
|
|
~
|
|
~ To get into this block, we tested for the array end indicator, but
|
|
~ now that we know we have an entry here, we're looking at its
|
|
~ contents.
|
|
hex-output-metadata-entry-data-start
|
|
|
|
dup 3 pick
|
|
~ (result, length remaining, current output address,
|
|
~ metadata scan pointer, entry's data start, entry's data start,
|
|
~ current output address)
|
|
>= swap drop
|
|
} if
|
|
} {
|
|
dup @
|
|
2 pick = {
|
|
~ We found a matching metadata entry.
|
|
~ (result, length remaining, current output address,
|
|
~ metadata scan pointer)
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-line-comment = {
|
|
fresh-line
|
|
indentation-depth@ dup indent advance-current-column
|
|
|
|
dup hex-output-metadata-entry-content @ hex-emit-comment
|
|
newline
|
|
|
|
1 is-fresh-line!
|
|
0 n-bytes-this-line!
|
|
0 current-column!
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-suffix-comment = {
|
|
hex-comment-first-tab-stop current-column@ - 1 max
|
|
dup indent advance-current-column
|
|
|
|
dup hex-output-metadata-entry-content @ hex-emit-comment
|
|
newline
|
|
|
|
1 is-fresh-line!
|
|
0 n-bytes-this-line!
|
|
0 current-column!
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-fresh-line = {
|
|
fresh-line
|
|
1 is-fresh-line!
|
|
0 n-bytes-this-line!
|
|
0 current-column!
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-blank-line = {
|
|
fresh-line
|
|
newline
|
|
1 is-fresh-line!
|
|
0 n-bytes-this-line!
|
|
0 current-column!
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-indent = {
|
|
dup hex-output-metadata-entry-content @
|
|
indentation-depth@ + indentation-depth!
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-string-literal = {
|
|
fresh-line
|
|
indentation-depth@ dup indent advance-current-column
|
|
|
|
." ~ "
|
|
0x22 value@ emitstring drop
|
|
dup hex-output-metadata-entry-content @ emitstring
|
|
0x22 value@ emitstring drop
|
|
." (string literal with null)"
|
|
|
|
newline
|
|
1 is-fresh-line!
|
|
0 n-bytes-this-line!
|
|
0 current-column!
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-raw-string-literal = {
|
|
fresh-line
|
|
indentation-depth@ dup indent advance-current-column
|
|
|
|
." ~ "
|
|
0x22 value@ emitstring drop
|
|
dup hex-output-metadata-entry-content @ emitstring
|
|
0x22 value@ emitstring drop
|
|
." (raw string literal)"
|
|
|
|
newline
|
|
1 is-fresh-line!
|
|
0 n-bytes-this-line!
|
|
0 current-column!
|
|
} if
|
|
|
|
dup is-push-subitem-entry {
|
|
dup push-subitem-entry-stack
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-saved-data = {
|
|
~ It's not valid to execute these, so print a diagnostic. They're
|
|
~ supposed to always be consumed by data-* commands.
|
|
." A saved-data metadata entry leaked." newline
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-drop-subitem = {
|
|
pop-subitem-entry-stack drop
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-swap-subitems = {
|
|
~ If we underflow the stack, we'll get zeroes back here. In order
|
|
~ to avoid causing more confusing problems later, we make sure to
|
|
~ discard the zeroes instead of pushing them. Just like in
|
|
~ hex-emit-template-string, the reasoning is that it's easier to
|
|
~ diagnose what's wrong with this subsystem when it runs to
|
|
~ completion.
|
|
pop-subitem-entry-stack
|
|
pop-subitem-entry-stack
|
|
swap
|
|
dup { push-subitem-entry-stack } { drop } if-else
|
|
dup { push-subitem-entry-stack } { drop } if-else
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
hex-output-metadata-entry-type-roll-subitems = {
|
|
~ The parameter giving the amount to roll by is in the content
|
|
~ field.
|
|
dup hex-output-metadata-entry-content @
|
|
~ (... amount to roll by)
|
|
|
|
~ We resist the temptation to do the memcopy math. We don't need
|
|
~ to, since the regular Forth roll and unroll do it for us.
|
|
dup 0 < {
|
|
~ In this scenario, we're rolling. The amount to roll by is also
|
|
~ the number of items.
|
|
|
|
0 { 2dup < } { pop-subitem-entry-stack 3unroll 1+ } while
|
|
drop
|
|
~ (... items, amount to roll by / number of items)
|
|
|
|
~ Please notice that the items we have popped from the subitem
|
|
~ entry stack are now, on the value stack, in the reverse of the
|
|
~ order they were on the entry stack. They will reverse again when
|
|
~ we push them back.
|
|
~
|
|
~ The amount to roll by is positive, so the desired operation is
|
|
~ a regular roll. Since the entries are reversed right now, we
|
|
~ unroll them, which will be what we want when we put them back.
|
|
~
|
|
~ Try it out interactively with a toy example and convince
|
|
~ yourself. It's hard to really model in your head, but it's true.
|
|
~ The intuition is that, if you're looking at the value stack,
|
|
~ the bottommost item there will be the topmost one after
|
|
~ re-reversing, so we think of our operations as proceeding
|
|
~ up-stack from there, instead of the usual operations that start
|
|
~ at the topmost item and proceed downwards.
|
|
~
|
|
~ Anyway, this little trick does a regular unroll, which acts as
|
|
~ a roll, and keeps the value around.
|
|
dup 3unroll 1+ unroll
|
|
} if
|
|
~ (... items if positive, amount to roll by)
|
|
|
|
~ We did the positive case first, which means the amount to roll
|
|
~ by is still its original value, regardless of whether that case
|
|
~ ran or not. So, we can check if it's negative to see if we need
|
|
~ to do the negative case.
|
|
dup 0 > {
|
|
~ In this scenario, we're unrolling. We negate the amount to
|
|
~ roll by to get the amount to unroll by, which is also the number
|
|
~ of items.
|
|
negate
|
|
|
|
0 { 2dup < } { pop-subitem-entry-stack 3unroll 1+ } while
|
|
drop
|
|
~ (... items, number of items)
|
|
|
|
~ The parameter was negative, so we were asked to do an unroll.
|
|
~ This trick does a roll, and keeps the value. Notice that "roll"
|
|
~ always needs a positive amount.
|
|
dup 1+ roll swap
|
|
} if
|
|
~ (... items, number of items)
|
|
|
|
~ Now, regardless of which case ran, we have the items and we have
|
|
~ a non-negative count of them. Notice that if we were asked to roll
|
|
~ by zero, neither case ran, but that still describes what we have
|
|
~ accurately.
|
|
|
|
~ Now we push them back.
|
|
0 { 2dup < } {
|
|
3roll
|
|
|
|
~ Again, if we underflowed we got zeros, and we discard them.
|
|
dup { push-subitem-entry-stack } { drop } if-else
|
|
|
|
1+
|
|
} while
|
|
drop drop
|
|
} if
|
|
} if
|
|
hex-output-metadata-next-entry
|
|
} while
|
|
~ (result, length remaining, current output address,
|
|
~ metadata scan pointer)
|
|
|
|
2 pick {
|
|
n-bytes-this-line@ 16 = {
|
|
newline
|
|
1 is-fresh-line!
|
|
0 n-bytes-this-line!
|
|
0 current-column!
|
|
} if
|
|
|
|
is-fresh-line@ {
|
|
indentation-depth@ dup indent advance-current-column
|
|
} {
|
|
space
|
|
1 advance-current-column
|
|
} if-else
|
|
|
|
over 8@ .hex8
|
|
|
|
2 advance-current-column
|
|
increment-bytes-this-line
|
|
0 is-fresh-line!
|
|
} if
|
|
~ (result, length remaining, current output address,
|
|
~ metadata scan pointer)
|
|
|
|
3unroll 1+ swap 1- swap 3roll
|
|
} while drop ;
|
|
|
|
~ This has complex logic, so we do it as a trace rather than with magic
|
|
~ comments.
|
|
~
|
|
~ (new label value, label entry pointer --)
|
|
: hex-set-label-trace
|
|
~ If the value is zero, don't bother making an entry. There's a bunch of
|
|
~ unused labels set to zero and even if they were used, showing them at the
|
|
~ start of the file would not provide useful information.
|
|
over 0 = { drop drop exit } if
|
|
|
|
~ Similarly, if the label has its non-offset bit set, we don't need an
|
|
~ entry for that, either
|
|
~
|
|
~ It's worth noting that this bit is set by the code being compiled,
|
|
~ potentially after it has already called label-set, and therefore after
|
|
~ this trace. This introduces an ordering dependency, though it's unlikely
|
|
~ to come up in practice because the bit is kept across label-loop passes
|
|
~ and as long as there are any forward references there will always be at
|
|
~ least two passes.
|
|
dup is-label-non-offset { drop drop exit } if
|
|
|
|
~ Recall that label values are offsets within the output file. This is not
|
|
~ otherwise a requirement, compiled code can use their values for anything
|
|
~ it wants, but the label transform treats them as offsets and so does the
|
|
~ ELF code.
|
|
~
|
|
~ We want to create metadata entries associated with that offset; recall
|
|
~ also that entries' data starts are host addresses which must be within
|
|
~ the label-loop buffer. So...
|
|
over
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-label-loop-buffer-start @ +
|
|
0
|
|
~ (new label value, label entry pointer, entry data start,
|
|
~ entry data length)
|
|
|
|
2dup hex-output-metadata-entry-type-push-subitem-hex64 7 roll
|
|
add-hex-output-metadata-entry
|
|
~ (label entry pointer, entry data start, entry data length)
|
|
|
|
2dup hex-output-metadata-entry-type-push-subitem-string
|
|
6 roll entry-to-name
|
|
|
|
swap-transform-variables here @ swap-transform-variables dup 3unroll
|
|
~ (copy, original, copy)
|
|
over stringlen 1+ memcopy
|
|
swap-transform-variables allocate-string swap-transform-variables
|
|
add-hex-output-metadata-entry
|
|
|
|
hex-output-metadata-entry-type-line-comment
|
|
s" label # at offset # is here."
|
|
add-hex-output-metadata-entry ;
|
|
|
|
~ (data start, data length --)
|
|
: hex-pack-trace
|
|
~ We keep a running tally of the next address in the output, for the
|
|
~ benefit of hex-tilde-replacement, which needs to know where to attach its
|
|
~ metadata entries.
|
|
+
|
|
dup is-in-label-loop-buffer {
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-latest-output-point !
|
|
} { drop } if-else ;
|
|
|
|
~ (output point, string pointer --)
|
|
: hex-packstring-trace
|
|
dup stringlen 1+
|
|
~ (output point, string pointer, string length)
|
|
2 pick over hex-pack-trace
|
|
swap
|
|
~ (output point, string length, string pointer)
|
|
drop over
|
|
hex-output-metadata-entry-type-string-literal swap
|
|
add-hex-output-metadata-entry ;
|
|
|
|
~ The purpose of this word is to make sure that the memory-sliding
|
|
~ techniques used by the high-level flow control words are appropriately
|
|
~ reflected in the output metadata. This is accomplished by finding all
|
|
~ entries whose data start pointer or string content pointer is within the
|
|
~ slid region, and adjusting the relevant pointer appropriately.
|
|
~
|
|
~ Notice that this strategy means there's no metadata entry describing the
|
|
~ old location of the slid memory, though sliding is non-destructive. The
|
|
~ assumption is that that location is going to be overwritten with new code,
|
|
~ which will have its own metadata entries created as the new code is written.
|
|
~ Otherwise, since we don't do anything to erase metadata entries pertaining
|
|
~ to overwritten locations, old and new metadata entries would overlap and
|
|
~ cause confusion. The assumption is correct for all existing uses of
|
|
~ memory-sliding as of the time this was written, but it's possible it will
|
|
~ need to be revisited someday.
|
|
~
|
|
~ This word is called for both memcopy and memmove. It's called by
|
|
~ hex-memory-slide-replacement, which is itself installed by a variety of
|
|
~ means for different situations; see its documentation for more detail.
|
|
~
|
|
~ (source, destination, length --)
|
|
: hex-memory-slide-trace
|
|
2 pick is-in-label-loop-buffer
|
|
2 pick is-in-label-loop-buffer &&
|
|
{
|
|
~ At the time this runs, the metadata entry array isn't sorted, so we
|
|
~ check the whole thing.
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-first-entry
|
|
~ (source, destination, length, initial metadata scan pointer)
|
|
{ dup @ } {
|
|
~ (source, destination, length, metadata scan pointer)
|
|
|
|
dup hex-output-metadata-entry-data-start @ 4 pick <=
|
|
~ (source, destination, length, metadata scan pointer, lower bound okay)
|
|
over hex-output-metadata-entry-data-start @ 5 pick 4 pick + >
|
|
&& {
|
|
~ (source, destination, length, metadata scan pointer)
|
|
dup hex-output-metadata-entry-data-start @ 4 pick - 3 pick +
|
|
over hex-output-metadata-entry-data-start !
|
|
} if
|
|
|
|
dup hex-output-metadata-entry-type @
|
|
dup hex-output-metadata-entry-type-string-literal =
|
|
swap hex-output-metadata-entry-type-raw-string-literal = || {
|
|
dup hex-output-metadata-entry-content @
|
|
~ (source, destination, length, scan pointer, content pointer)
|
|
dup 5 pick <=
|
|
~ (source, destination, length, scan pointer, content pointer,
|
|
~ lower bound okay)
|
|
over 6 pick 5 pick + > && {
|
|
~ (source, destination, length, scan pointer, content pointer)
|
|
4 pick - 3 pick +
|
|
over hex-output-metadata-entry-content !
|
|
} { drop } if-else
|
|
} if
|
|
|
|
hex-output-metadata-next-entry
|
|
} while 4 ndrop
|
|
} { drop drop drop } if-else ;
|
|
|
|
|
|
~ By overriding colon, we can special-case the definitions of particular
|
|
~ words. It's very metacircular.
|
|
~
|
|
~ This lets us prepend trap code to the original definition. For those not
|
|
~ familiar, a "trap" in systems programming is code that runs instead of some
|
|
~ other, pre-existing code, by violating the usual abstractions in some way.
|
|
~ We implement our traps by creating the word header, including the docol
|
|
~ pointer, then compiling the trap code before we return from the colon
|
|
~ alternate, so that it's already been output before the original word's body
|
|
~ starts to compile.
|
|
~
|
|
~ Prepending our trap code to the original code like this can also be used
|
|
~ to get the effect of replacing the original code entirely by calling "exit"
|
|
~ at the end of our trap. The original code will still be compiled, after the
|
|
~ trap code, but doing this will make sure it doesn't run. Most of the time,
|
|
~ though, we do want to run the original code, so we allow the trap to fall
|
|
~ through to it. We carefully note fall-through with comments, to make the
|
|
~ traps easier to maintain.
|
|
~
|
|
~ The kinds of side-effects we care about can all be written this way,
|
|
~ though occasionally we wind up having to compute an intermediate value that
|
|
~ the code we're trapping will then compute independently, and it's important
|
|
~ to keep those implementations in sync.
|
|
~
|
|
~ The most significant challenge is that, because our trap will be defined
|
|
~ at the same point in loading as the original word would be, it can only use
|
|
~ words that are available at that point. Occasionally this results in some
|
|
~ awkwardness.
|
|
~
|
|
~ Code for these traps winds up looking a lot like code written for log-load
|
|
~ alternates, in that we have to do the dictionary lookups and other
|
|
~ compilation ourselves.
|
|
~
|
|
~ At times, we also need to trap words that are implemented in assembler.
|
|
~ The most notable of these is "sys-write", which is fundamental to what the
|
|
~ hex transform does. The details of how we make our traps work with assembler
|
|
~ words are explained below, as they arise.
|
|
: hex-colon-alternate
|
|
word value@
|
|
|
|
~ The word "variable" is itself a word-defining word, and we will
|
|
~ special-case its definition to special-case the definitions of particular
|
|
~ variables. It's very very metacircular.
|
|
dup s" variable" stringcmp 0 = {
|
|
~ Don't lose track of the layering happening here. The word "variable"
|
|
~ is a regular docol word; it's defining a word that's implemented in
|
|
~ assembly, but it can use whatever Forthy logic it wants to do so. In
|
|
~ this case we're going to have it run a little extra logic, then continue
|
|
~ with the rest of its usual definition.
|
|
|
|
~ Before we get to the extra logic, we do want an entry header for
|
|
~ "variable" itself, so we do that... This takes care of all of colon's
|
|
~ responsibilities except switching to compile mode; we'll do that part
|
|
~ after we've output our payload.
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
~ There's two variables that we want to point to the outer backing
|
|
~ stores, rather than the inner ones. The code for that is a bit
|
|
~ repetitive, so we have a helper for it; see above.
|
|
~
|
|
~ It is worth stopping to contemplate the meaning of sharing these two
|
|
~ variables in particular between the inner and outer contexts.
|
|
~ Essentially this says that they're both reading the same input stream,
|
|
~ and the two copies of the interpreter both share the same state. Thus,
|
|
~ trading off responsibility for lexing between inner and outer contexts
|
|
~ works just like trading off responsibility between two interpreters
|
|
~ when there's no transformation involved, or between a regular
|
|
~ interpreter and a transform.
|
|
~
|
|
~ If we didn't do this, we'd still have to invent some way to control
|
|
~ what input the inner context sees, and the concept of "the next
|
|
~ character" would become more complex during the transform and require
|
|
~ care and attention. Sharing this stuff keeps it simple.
|
|
s" interpreter-flags" hex-variable-use-outer
|
|
s" main-input-buffer" hex-variable-use-outer
|
|
~ After this, we can return control to the regularly-scheduled
|
|
~ "variable", which will do the "create" and all that. That stuff isn't
|
|
~ colon's responsibility, so it isn't our responsibility, it'll happen
|
|
~ regardless.
|
|
|
|
~ Notably, we do NOT share transformation-state. There are at least a
|
|
~ hundred places where it would need to be carefully swapped, and we
|
|
~ already have quite enough of that kind of brittleness in the log-load
|
|
~ transform. Plus, there's no obvious way to do a real push/pop notion for
|
|
~ it, so we wouldn't get arbitrary nesting of transforms anyway. By
|
|
~ letting the code inside the hex transform have its own, separate copy of
|
|
~ transformation-state, we avoid that problem entirely, and it's still not
|
|
~ hard to access the "other" one when circumstances require.
|
|
|
|
~ Now we close out colon's responsibilities by switching to compile
|
|
~ mode. We return from colon after this. The hex transform will continue
|
|
~ by processing the source words that form the regular body of "variable",
|
|
~ eventually hitting the matching semicolon. Our friendly tampering is
|
|
~ now complete!
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
~ Now we want to override s". As usual, that's the single most annoying
|
|
~ string to quote, so we cheat.
|
|
dup ' s" entry-to-name stringcmp 0 = {
|
|
~ Create the word header. It's a normal docol word, so that much is
|
|
~ simple.
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
~ This time around we would really rather just always use the alternate,
|
|
~ which already untangles the layered nonsense. So we have the payload
|
|
~ call the alternate directly, then exit. We could come up with a way to
|
|
~ then skip forward in the code under transformation, but that would be
|
|
~ complex, and it's unnecessary: We let it keep running, outputting the
|
|
~ usual body of s", which we know will never be reached.
|
|
' hex-string-alternate entry-to-execution-token ,
|
|
s" exit" find entry-to-execution-token ,
|
|
|
|
~ As before, finish up colon's responsibilities, then return control to
|
|
~ the code under transformation.
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
~ Same deal for .". Hey, we're getting good at this!
|
|
dup ' ." entry-to-name stringcmp 0 = {
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
' hex-dot-string-alternate entry-to-execution-token ,
|
|
s" exit" find entry-to-execution-token ,
|
|
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
~ We want to suppress the behavior of relink-main-input-buffer-to-stdin
|
|
~ entirely. Happily, that's easy. We need to do this because otherwise the
|
|
~ transformed code will mess with our outer interpreter!
|
|
dup s" relink-main-input-buffer-to-stdin" stringcmp 0 = {
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
~ Return before doing anything.
|
|
s" exit" find entry-to-execution-token ,
|
|
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
~ We are entirely replacing sys-write with our own version. It's an
|
|
~ assembly word, and we're replacing it with a Forth word, so there's some
|
|
~ matching code in the ;asm alternate that makes sure to not mess that up.
|
|
dup s" sys-write" stringcmp 0 = {
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
' hex-sys-write-replacement entry-to-execution-token ,
|
|
s" exit" find entry-to-execution-token ,
|
|
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
~ Now we have a bunch of patches that keep track of output metadata. These
|
|
~ are all Forth words, nothing too complicated about the actual patching.
|
|
dup s" reset-labels" stringcmp 0 = {
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
~ This is only ever called in one place, the end of a failed iteration
|
|
~ of label-loop. We need to reinitialize all the metadata entries whenever
|
|
~ that happens, and reset-labels is a good semantic match for that
|
|
~ behavior, so it's a good place for the hook.
|
|
' create-hex-output-metadata-top-of-file-entries
|
|
entry-to-execution-token ,
|
|
~ Fall through to the inner implementation.
|
|
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
dup s" set-label" stringcmp 0 = {
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
~ (new label value, label entry pointer --)
|
|
s" 2dup" find entry-to-execution-token ,
|
|
' hex-set-label-trace entry-to-execution-token ,
|
|
~ Fall through to the inner implementation.
|
|
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
|
|
dup s" packstring" stringcmp 0 = {
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
~ (output point, string pointer)
|
|
s" 2dup" find entry-to-execution-token ,
|
|
~ This one's a lot of work, so we defer to a single-purpose word.
|
|
' hex-packstring-trace entry-to-execution-token ,
|
|
~ Fall through to the inner implementation.
|
|
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
~ This is highly similar to packstring.
|
|
dup s" pack-raw-string" stringcmp 0 = {
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
~ (output point, string pointer)
|
|
s" 2dup" find entry-to-execution-token ,
|
|
s" dup" find entry-to-execution-token ,
|
|
s" stringlen" find entry-to-execution-token ,
|
|
~ (output point, string pointer, string length NOT including terminator)
|
|
|
|
~ Before we add the metadata entry, we also want to call hex-pack-trace
|
|
~ to make sure latest-output-point gets adjusted for the string.
|
|
~ Otherwise, we'd see magic comments in the wrong place.
|
|
s" 3roll" find entry-to-execution-token ,
|
|
s" dup" find entry-to-execution-token ,
|
|
s" lit" find entry-to-execution-token ,
|
|
4 ,
|
|
s" unroll" find entry-to-execution-token ,
|
|
s" swap" find entry-to-execution-token ,
|
|
s" dup" find entry-to-execution-token ,
|
|
s" 3unroll" find entry-to-execution-token ,
|
|
~ (output point, string pointer, string length NOT including terminator,
|
|
~ output point, string length NOT including terminator)
|
|
' hex-pack-trace entry-to-execution-token ,
|
|
|
|
~ (output point, string pointer, string length including terminator)
|
|
s" swap" find entry-to-execution-token ,
|
|
' hex-output-metadata-entry-type-raw-string-literal
|
|
entry-to-execution-token ,
|
|
s" swap" find entry-to-execution-token ,
|
|
' add-hex-output-metadata-entry entry-to-execution-token ,
|
|
~ (output point, string pointer)
|
|
~ Fall through to the inner implementation.
|
|
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
|
|
dup s" pack8" stringcmp 0 = {
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
~ We can't use over because this patch happens at the time pack8 is
|
|
~ being defined, and it would be a forward reference. We do the equivalent
|
|
~ by hand.
|
|
~ (output point, value)
|
|
s" swap" find entry-to-execution-token ,
|
|
s" dup" find entry-to-execution-token ,
|
|
s" 3unroll" find entry-to-execution-token ,
|
|
~ (output point, value, output point)
|
|
s" lit" find entry-to-execution-token ,
|
|
1 ,
|
|
' hex-pack-trace entry-to-execution-token ,
|
|
~ Fall through to the inner implementation.
|
|
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
~ Extremely similar to the pack8 patch.
|
|
dup s" pack16" stringcmp 0 = {
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
~ We can't use over because this patch happens at the time pack8 is
|
|
~ being defined, and it would be a forward reference. We do the equivalent
|
|
~ by hand.
|
|
~ (output point, value)
|
|
s" swap" find entry-to-execution-token ,
|
|
s" dup" find entry-to-execution-token ,
|
|
s" 3unroll" find entry-to-execution-token ,
|
|
~ (output point, value, output point)
|
|
s" lit" find entry-to-execution-token ,
|
|
2 ,
|
|
' hex-pack-trace entry-to-execution-token ,
|
|
~ Fall through to the inner implementation.
|
|
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
~ Extremely similar to the pack8 patch.
|
|
dup s" pack32" stringcmp 0 = {
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
~ We can't use over because this patch happens at the time pack8 is
|
|
~ being defined, and it would be a forward reference. We do the equivalent
|
|
~ by hand.
|
|
~ (output point, value)
|
|
s" swap" find entry-to-execution-token ,
|
|
s" dup" find entry-to-execution-token ,
|
|
s" 3unroll" find entry-to-execution-token ,
|
|
~ (output point, value, output point)
|
|
s" lit" find entry-to-execution-token ,
|
|
4 ,
|
|
' hex-pack-trace entry-to-execution-token ,
|
|
~ Fall through to the inner implementation.
|
|
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
~ Extremely similar to the pack8 patch.
|
|
dup s" pack64" stringcmp 0 = {
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
|
|
~ We can't use over because this patch happens at the time pack8 is
|
|
~ being defined, and it would be a forward reference. We do the equivalent
|
|
~ by hand.
|
|
~ (output point, value)
|
|
s" swap" find entry-to-execution-token ,
|
|
s" dup" find entry-to-execution-token ,
|
|
s" 3unroll" find entry-to-execution-token ,
|
|
~ (output point, value, output point)
|
|
s" lit" find entry-to-execution-token ,
|
|
8 ,
|
|
' hex-pack-trace entry-to-execution-token ,
|
|
~ Fall through to the inner implementation.
|
|
|
|
' ] entry-to-execution-token execute
|
|
exit
|
|
} if
|
|
|
|
~ If no special case matches, we fall back to just being a regular colon.
|
|
~ We already read the word name above, so we have to do the rest of the
|
|
~ steps ourselves as well.
|
|
create dropstring
|
|
s" docol" find entry-to-execution-token execute ,
|
|
make-hidden
|
|
' ] entry-to-execution-token execute
|
|
;
|
|
|
|
|
|
~ This word gets installed as a trap at the beginning of every Forth word,
|
|
~ so that it can examine the control stack and produce kinds of metadata that
|
|
~ require information that only exists at runtime. See
|
|
~ hex-semicolon-alterante, below, for details of how it's installed.
|
|
~
|
|
~ It is worth noting that hex-trap can coexist with the more-targeted traps
|
|
~ installed by hex-colon-alternate, above. It runs before them, because
|
|
~ hex-colon-alternate prepends its stuff first and then
|
|
~ hex-semicolon-alternate slides that all forward to prepend the call to
|
|
~ hex-trace.
|
|
~
|
|
~ TODO this probably doesn't serve a purpose in the end, and should go away,
|
|
~ but the actual stack-walking code is useful and should be kept until it's
|
|
~ been refactored into something worth keeping.
|
|
: hex-trace
|
|
exit
|
|
~ value@ here @ swap 0 hex-output-metadata-entry-type-line-comment
|
|
~ add-hex-output-metadata-entry
|
|
newline
|
|
~ This stack-walking code is modeled off the code in list-callers, in
|
|
~ dynamic.e.
|
|
~
|
|
|
|
~ This is the bit of the hex transform where all the memory-management
|
|
~ assumptions are in play at once, so, in understanding it, it's probably
|
|
~ a good idea to skim back over the background described under "hex
|
|
~ transform implementation", above, and make sure it's fresh in your mind.
|
|
~
|
|
~ It's important to notice that, as we walk it, the values of "here" and
|
|
~ "latest" reflect the log and dictionary of the code being transformed, ie.
|
|
~ they are the ones in the output buffer, not the log and dictionary of the
|
|
~ outer program. Therefore, we can use containing-entry to find the entry
|
|
~ headers for words inside the transform, and if we want to look at words
|
|
~ outside the transform we can wrap containing-entry in
|
|
~ swap-transform-variables. We can't use is-in-log, though, because the
|
|
~ label-loop buffer is inside the output buffer, which is inside the outer
|
|
~ log, so it doesn't make the distinctions we need it to.
|
|
~
|
|
~ Every word inside the transform will have hex-transform-one exactly once
|
|
~ in its call chain, so we walk the control stack only up to that point.
|
|
control@
|
|
{ ~ First, check to make sure we haven't run off the bottom of the control
|
|
~ stack. Remember, the control stack is an array of pointers, so this is a
|
|
~ simple bounds check.
|
|
dup r0 @ >
|
|
|
|
~ If it is, we also want to look at what it points to.
|
|
dup {
|
|
~ Dereference the pointer we've been iterating (... we're actually
|
|
~ looking at a pointer to a pointer ...), and check that it's not inside
|
|
~ hex-transform-one's body.
|
|
drop dup @
|
|
|
|
~ The inner dictionary is inside the outer log, so we'll get an entry
|
|
~ header regardless of which dictionary we consider, but it may not be
|
|
~ the one we care about. If we want to get the correct entry pointer, we
|
|
~ have to make sure we're looking at the outer dictionary.
|
|
swap-transform-variables
|
|
|
|
~ Check what entry the control pointer is in.
|
|
containing-entry
|
|
|
|
~ Get the entry for hex-transform-one to compare against. This would
|
|
~ be a forward reference, so we need to look it up at runtime.
|
|
s" hex-transform-one" find
|
|
|
|
~ Now switch back.
|
|
swap-transform-variables
|
|
|
|
~ If they're equal, we want to stop the loop.
|
|
!=
|
|
} if }
|
|
{ dup @
|
|
|
|
~ TODO this isn't in quine.asm, so if we keep this code at all, that needs
|
|
~ to be dealt with
|
|
~ symbolize-pointer space
|
|
|
|
~ Iterate to the next pointer in the control stack. It's an array of
|
|
~ pointers, so this is just arithmetic.
|
|
8 + } while
|
|
drop ;
|
|
|
|
|
|
~ We want to trace every call to a Forth word, for use in generating
|
|
~ metadata. To do this, we want to add a prefix trap to the calls, but we
|
|
~ can't put the logic in hex-colon-alternate because we don't know which
|
|
~ words are Forth words and which are assembly words until we see the
|
|
~ semicolon.
|
|
~
|
|
~ So, we do it here in hex-semicolon-alternate. The word body has already
|
|
~ been compiled at this point, so we slide the whole body forward to make
|
|
~ room. This is explicitly allowed by our compilation model; you may be
|
|
~ aware that it's also how high-level flow control is implemented.
|
|
~
|
|
~ You might find it useful to compare this code to the implementations of
|
|
~ high-level flow-control utilities in log-load.e; it operates under a very
|
|
~ similar set of constraints, except that fortunately we don't have the
|
|
~ nightmare multi-dictionary situation that the log-load transform does.
|
|
: hex-semicolon-alternate
|
|
latest @ entry-to-execution-token 8 +
|
|
dup dup dup
|
|
~ (start, start, start, start)
|
|
|
|
~ The actual body of the trap is just a single word long (see below). If
|
|
~ that ever changes, make sure to keep the amount we slide by in sync with
|
|
~ it.
|
|
8 + swap ~ TODO change number of words
|
|
~ (start, start, adjusted start, start)
|
|
|
|
here @ swap -
|
|
~ (start, start, adjusted start, length)
|
|
|
|
memmove
|
|
~ (start)
|
|
|
|
~ We're going to use comma to append compiled code, so let's swap out the
|
|
~ value of "here" to point to the space we just opened up.
|
|
here @ swap here !
|
|
~ (old "here")
|
|
|
|
~ This applies to every single word terminated with semicolon, which is
|
|
~ all the Forth words that are created directly rather than with "variable"
|
|
~ or some similar high-level facility. Because we also can't have forward
|
|
~ references, that means we can't assume we'll have any available words in
|
|
~ the transformed code to call, at all. So, the only thing we can usefully
|
|
~ have the trap do is call a word that's defined as part of the transform.
|
|
~
|
|
~ Fortunately, we do get to assume there will be a normal entry header in
|
|
~ place for the word we're trapping. So we don't need to scrounge up any
|
|
~ runtime data for the trap's benefit; the trap will be able to get what it
|
|
~ needs by inspecting the control stack and the log.
|
|
' hex-trace entry-to-execution-token ,
|
|
|
|
~ We're done compiling the trap's contents, so swap "here" back. Again,
|
|
~ keep this in sync with the length of the trap.
|
|
8 + here !
|
|
|
|
~ Now we do the regular semicolon stuff.
|
|
[ ' ; entry-to-execution-token , ]
|
|
; make-immediate
|
|
|
|
|
|
: hex-semicolon-assembly-alternate
|
|
latest @ entry-to-name
|
|
dup s" sys-write" stringcmp 0 = {
|
|
~ As detailed in hex-colon-alternate, above, sys-write is implemented in
|
|
~ assembly but we replace it with Forth. This logic here collaborates with
|
|
~ the logic there to make that work.
|
|
~
|
|
~ The transformed code will still have compiled some assembly, though it
|
|
~ won't be reached and would crash, so we need to fix alignment before we
|
|
~ call semicolon.
|
|
drop
|
|
here @ 8 packalign here !
|
|
[ ' ; entry-to-execution-token , ]
|
|
exit
|
|
} if
|
|
drop
|
|
|
|
~ If no special case matches, we fall back to the regular behavior.
|
|
[ ' ;asm entry-to-execution-token , ]
|
|
; make-immediate
|
|
|
|
|
|
~ Because docol requires it, we provide a special mini-version of the label
|
|
~ system. We only do L@' and L!', because that's all we need. Unlike with the
|
|
~ label transform, these are NOT real labels; they're restricted similarly to
|
|
~ how they are for the log-load transform.
|
|
~
|
|
~ Per the precedence rules in hex-transform-one, this version will apply to
|
|
~ all invocations, regardless of compile mode vs. immediate execution.
|
|
~ However, its own logic defers to the inner label system when that exists.
|
|
: hex-L@'-alternate
|
|
~ If there's an inner copy of L@' defined, defer to it.
|
|
s" L@'" find dup {
|
|
entry-to-execution-token execute
|
|
exit
|
|
} { drop } if-else
|
|
|
|
word dropstring
|
|
transformation-state transformation-state-label-scratch @
|
|
; make-immediate
|
|
|
|
: hex-L!'-alternate
|
|
~ If there's an inner copy of L!' defined, defer to it.
|
|
s" L!'" find dup {
|
|
entry-to-execution-token execute
|
|
exit
|
|
} { drop } if-else
|
|
|
|
word dropstring
|
|
transformation-state transformation-state-label-scratch !
|
|
; make-immediate
|
|
|
|
|
|
~ The code we're compiling may try to exit when it's done. We want to return
|
|
~ to our caller instead; we turn that into an nop. This isn't quite correct,
|
|
~ but it will work as long as the inner code doesn't try to do anything else
|
|
~ after.
|
|
: hex-bye-alternate ;
|
|
|
|
|
|
~ Okay, now here's an interesting one. We need to provide additional
|
|
~ behavior for "allocate", but only when it is called directly from the body
|
|
~ of label-loop. That condition of being in the body is only testable
|
|
~ immediately, though "allocate" is not an immediate word and the effect of it
|
|
~ needs to happen later. This is crucial functionality that we can't work
|
|
~ without. So, we use a replacement and an alternate that work in tandem.
|
|
~
|
|
~ First, we define the replacement...
|
|
~
|
|
~ (size -- pointer)
|
|
: hex-allocate-replacement
|
|
dup allocate swap
|
|
~ (result pointer, size)
|
|
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-label-loop-buffer-length !
|
|
~ (result pointer)
|
|
|
|
dup
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-label-loop-buffer-start !
|
|
~ (result pointer)
|
|
|
|
create-hex-output-metadata-top-of-file-entries ;
|
|
|
|
~ ... then, we define the alternate.
|
|
~
|
|
~ The alternate is flagged as immediate, which means hex-transform-one will
|
|
~ treat it as always having the highest priority. It checks what mode we're
|
|
~ in; if we're immediate, it runs the inner "allocate" if it exists or the
|
|
~ outer one if not. If we're compiling, it checks if we're in the body of
|
|
~ label-loop and compiles an execution token for the replacement if so, or the
|
|
~ inner "allocate" if not.
|
|
~
|
|
~ If that was confusing: The point is, by having the immediate effect be
|
|
~ compilation, we get to have it both ways.
|
|
: hex-allocate-alternate
|
|
interpreter-flags @ 0x01 & {
|
|
~ Compile mode.
|
|
latest @ entry-to-name dup s" label-loop" stringcmp 0 = {
|
|
~ In label-loop.
|
|
drop
|
|
' hex-allocate-replacement entry-to-execution-token ,
|
|
} {
|
|
~ Not in label-loop.
|
|
drop
|
|
s" allocate" find entry-to-execution-token ,
|
|
} if-else
|
|
} {
|
|
~ Immediate mode.
|
|
s" allocate" find
|
|
dup { entry-to-execution-token execute } { drop allocate } if-else
|
|
} if-else ; make-immediate
|
|
|
|
|
|
~ In order to handle code that slides compiled code around, most notably the
|
|
~ high-level flow-control words, we trap memcopy and memmove. These are
|
|
~ assembly words, so trapping them with hex-colon-alternate is inconvenient;
|
|
~ instead we patch their callers. This is like the "allocate" trap, but
|
|
~ simpler. There's no special logic needed here, we just unconditionally
|
|
~ install the trap.
|
|
~
|
|
~ This word is responsible for processing the hook. For code running
|
|
~ directly under the hex transform, it's installed by hex-memcopy-alternate
|
|
~ and hex-memmove-alternate, immediately below. For code running in a nested
|
|
~ label transform, see hex-label-word-replacement, further down. Note
|
|
~ carefully that when it's in a nested transform, the hook only runs in
|
|
~ immediate mode; running it in compile mode would affect the program being
|
|
~ compiled.
|
|
~
|
|
~ It is worth noting that, as of the time this code was written, there is
|
|
~ never actually any memory sliding of compiled code that occurs outside of a
|
|
~ nested transform. This aligns with intuition, since sliding is really only
|
|
~ done in the high-level flow-control words. However, should it happen in the
|
|
~ future, we still want it to work, so it's implemented.
|
|
~
|
|
~ The actual metadata handling is done by hex-memory-slide-trace, which is
|
|
~ above, near the other words that trace memory operations. We let the
|
|
~ replacement handle preserving the parameters so that the trace doesn't need
|
|
~ to, since that would be a difference between it and the other words similar
|
|
~ to it.
|
|
~
|
|
~ (source, destination, length -- source, destination, length)
|
|
: hex-memory-slide-replacement
|
|
2 pick 2 pick 2 pick hex-memory-slide-trace ;
|
|
|
|
~ These two alternates are responsible for installing
|
|
~ hex-memory-slide-replacement, immediately above, in invocations of memcopy
|
|
~ and memmove that occur directly under the hex transform. For invocations
|
|
~ that occur in nested transforms, see hex-label-word-replacement, further
|
|
~ down.
|
|
: hex-memcopy-alternate
|
|
interpreter-flags @ 0x01 & {
|
|
' hex-memory-slide-replacement entry-to-execution-token ,
|
|
s" memcopy" find entry-to-execution-token ,
|
|
} {
|
|
hex-memory-slide-replacement
|
|
s" memcopy" find entry-to-execution-token execute
|
|
} if-else ; make-immediate
|
|
: hex-memmove-alternate
|
|
interpreter-flags @ 0x01 & {
|
|
' hex-memory-slide-replacement entry-to-execution-token ,
|
|
s" memmove" find entry-to-execution-token ,
|
|
} {
|
|
hex-memory-slide-replacement
|
|
s" memmove" find entry-to-execution-token execute
|
|
} if-else ; make-immediate
|
|
|
|
|
|
~ Similar to how we handle "allocate" as a replacement which is installed by
|
|
~ an alternate, we do the same for tilde, but for a different reason. The
|
|
~ semantics of ordinary, non-transformed tilde skip over comment text while
|
|
~ compiling, and discard it. We need to do processing of that text later, when
|
|
~ the comment's position would be reached in running the word it's part of, so
|
|
~ the alternate compiles it appropriately.
|
|
~
|
|
~ Importantly, the replacement is only used for comments that have a special
|
|
~ comment syntax unique to the hex transform, as described in more detail in
|
|
~ the alternate, below. If it were used for all comments, it would interfere
|
|
~ with the distance of branches, which could get quite complex to work around.
|
|
~ It is the responsibility of words that use the hex-transform comment syntax
|
|
~ to avoid placing such comments within the scope of a branch. This applies
|
|
~ only to explicit, precomputed branches using the words "branch" and
|
|
~ "branch0". Fortunately, implicit branches that are part of high-level
|
|
~ flow-control words such as "if" and "while" will work fine, since the
|
|
~ substitution occurs before the flow control words start sliding code around,
|
|
~ and it updates "here" appropriately.
|
|
~
|
|
~ Because hex-tilde-replacement is called in various situations during
|
|
~ various phases of compilation and interpreting, it can't take responsibility
|
|
~ for knowing how the string pointer it's given is allocated. It assumes the
|
|
~ string pointer will be valid indefinitely; it's the caller's responsibility
|
|
~ to make sure of that.
|
|
~
|
|
~ (has non-space this line, string pointer --)
|
|
: hex-tilde-replacement
|
|
transformation-state transformation-state-output-metadata @
|
|
hex-output-metadata-latest-output-point @
|
|
swap
|
|
~ (has non-space this line, data start, string pointer)
|
|
|
|
~ If the output wouldn't go in the label-loop buffer, don't do any of
|
|
~ this.
|
|
~
|
|
~ That may seem spurious, but remember, the same assembly instructions
|
|
~ are used for compiling the final binary and defining words within the
|
|
~ compiler. In particular, "variable" will hit this, and there are surely
|
|
~ others.
|
|
over is-in-label-loop-buffer not { 3 ndrop exit } if
|
|
|
|
~ Copy the first space-separated word of the comment body into scratch
|
|
~ space to see if it's a special instruction. To minimize interference with
|
|
~ the program under transformation, we use the outer log's scratch space
|
|
~ rather than the inner one's.
|
|
swap-transform-variables
|
|
dup
|
|
here @
|
|
~ (... source pointer, destination pointer)
|
|
{ over 8@ dup 0x20 != && } {
|
|
swap unpack8 swap 3unroll pack8
|
|
} while
|
|
0 pack8 drop drop
|
|
|
|
here @
|
|
swap-transform-variables
|
|
|
|
~ (has non-space this line, data start, string pointer,
|
|
~ first word string pointer)
|
|
dup read-integer 0 = {
|
|
~ (has non-space, data start, string pointer, first word string pointer,
|
|
~ data length)
|
|
3unroll stringlen 1+ +
|
|
~ (has non-space, data start, data length, adjusted string pointer)
|
|
4 roll drop
|
|
1 swap
|
|
~ (data start, data length, is suffix, adjusted string pointer)
|
|
} {
|
|
drop 0 swap
|
|
~ (has non-space, data start, data length, string pointer)
|
|
4 roll swap
|
|
~ (data start, data length, is suffix, string pointer)
|
|
} if-else
|
|
~ (data start, data length, is suffix, adjusted string pointer)
|
|
|
|
~ Now look for instruction keywords. These keywords are expected to be the
|
|
~ entire line, except that a length field can come before them.
|
|
dup s" adjust-length" stringcmp 0 = {
|
|
~ Modify the most recent comment entry by adjusting its length.
|
|
drop drop swap drop adjust-latest-comment-metadata-entry-length
|
|
exit
|
|
} if
|
|
dup s" adjust-start" stringcmp 0 = {
|
|
~ Modify the most recent output-producing entry by adjusting its start.
|
|
drop drop swap drop adjust-latest-output-producing-metadata-entry-start
|
|
exit
|
|
} if
|
|
dup s" set-output-point" stringcmp 0 = {
|
|
~ Override the latest output point.
|
|
drop drop swap drop set-latest-output-point
|
|
exit
|
|
} if
|
|
dup s" adjust-output-point" stringcmp 0 = {
|
|
~ Modify the latest output point.
|
|
drop drop swap drop adjust-latest-output-point
|
|
exit
|
|
} if
|
|
|
|
dup s" data-adjust-length" stringcmp 0 = {
|
|
~ Modify the most recent comment entry by adjusting its length, also
|
|
~ using data from the most recent data entry.
|
|
drop drop swap drop data-adjust-latest-comment-metadata-entry-length
|
|
exit
|
|
} if
|
|
dup s" data-adjust-start" stringcmp 0 = {
|
|
~ Modify the most recent output-producing entry by adjusting its start,
|
|
~ also using data from the most recent data entry.
|
|
drop drop swap drop
|
|
data-adjust-latest-output-producing-metadata-entry-start
|
|
exit
|
|
} if
|
|
dup s" data-set-output-point" stringcmp 0 = {
|
|
~ Override the latest output point, also using data from the most recent
|
|
~ data entry.
|
|
drop drop swap drop data-set-latest-output-point
|
|
exit
|
|
} if
|
|
dup s" data-adjust-output-point" stringcmp 0 = {
|
|
~ Modify the latest output point, also using data from the most recent
|
|
~ data entry.
|
|
drop drop swap drop data-adjust-latest-output-point
|
|
exit
|
|
} if
|
|
|
|
dup s" suppress" stringcmp 0 = {
|
|
~ Suppress the next N entries, or adjust the remaining count of entries
|
|
~ to suppress.
|
|
drop drop swap drop adjust-hex-output-suppression-count
|
|
exit
|
|
} if
|
|
|
|
dup s" delete-first-comment-at-output-point" stringcmp 0 = {
|
|
4 ndrop delete-first-comment-metadata-entry-at-output-point
|
|
exit
|
|
} if
|
|
|
|
dup s" delete-last-comment-at-output-point" stringcmp 0 = {
|
|
4 ndrop delete-latest-comment-metadata-entry-at-output-point
|
|
exit
|
|
} if
|
|
|
|
dup s" fresh-line" stringcmp 0 = {
|
|
~ Create a new fresh-line entry.
|
|
drop drop hex-output-metadata-entry-type-fresh-line 0
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
|
|
dup s" blank-line" stringcmp 0 = {
|
|
~ Create a new blank-line entry.
|
|
drop drop hex-output-metadata-entry-type-blank-line 0
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
|
|
dup s" indent" stringcmp 0 = {
|
|
~ Create a new indent entry with a positive indentation delta.
|
|
drop drop hex-output-metadata-entry-type-indent 2
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
|
|
dup s" deindent" stringcmp 0 = {
|
|
~ Create a new indent entry with a negative indentation delta.
|
|
drop drop hex-output-metadata-entry-type-indent -2
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
|
|
~ Now we have some commands for the various -provide-subitem- variants.
|
|
~ Notice with all of these that we intentionally read one stack level deeper
|
|
~ than anything of ours, which will be a value provided by the code the
|
|
~ magic comment is embedded in.
|
|
dup s" provide-decimal" stringcmp 0 = {
|
|
~ Create a new "push subitem decimal" entry.
|
|
drop drop
|
|
2 pick hex-output-metadata-entry-type-push-subitem-decimal swap
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
dup s" provide-hex" stringcmp 0 = {
|
|
~ Create a new "push subitem hex" entry.
|
|
drop drop
|
|
2 pick hex-output-metadata-entry-type-push-subitem-hex swap
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
dup s" provide-hex8" stringcmp 0 = {
|
|
~ Create a new "push subitem hex8" entry.
|
|
drop drop
|
|
2 pick hex-output-metadata-entry-type-push-subitem-hex8 swap
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
dup s" provide-hex16" stringcmp 0 = {
|
|
~ Create a new "push subitem hex16" entry.
|
|
drop drop
|
|
2 pick hex-output-metadata-entry-type-push-subitem-hex16 swap
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
dup s" provide-hex32" stringcmp 0 = {
|
|
~ Create a new "push subitem hex32" entry.
|
|
drop drop
|
|
2 pick hex-output-metadata-entry-type-push-subitem-hex32 swap
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
dup s" provide-hex64" stringcmp 0 = {
|
|
~ Create a new "push subitem hex64" entry.
|
|
drop drop
|
|
2 pick hex-output-metadata-entry-type-push-subitem-hex64 swap
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
dup s" provide-string" stringcmp 0 = {
|
|
drop drop
|
|
2 pick hex-output-metadata-entry-type-push-subitem-string swap
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
dup s" provide-string-copy" stringcmp 0 = {
|
|
drop drop
|
|
2 pick hex-output-metadata-entry-type-push-subitem-string swap
|
|
swap-transform-variables here @ swap-transform-variables dup 3unroll
|
|
~ (copy, original, copy)
|
|
over stringlen 1+ memcopy
|
|
swap-transform-variables allocate-string swap-transform-variables
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
dup s" provide-keyword" stringcmp 0 = {
|
|
~ Create a new "push subitem string" entry given a keyword pointer.
|
|
drop drop
|
|
2 pick execution-token-to-entry entry-to-name
|
|
hex-output-metadata-entry-type-push-subitem-string swap
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
dup s" provide-data" stringcmp 0 = {
|
|
~ Create a new "push subitem data" entry.
|
|
drop drop
|
|
2 pick hex-output-metadata-entry-type-saved-data swap
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
|
|
~ Next are the subitem stack manipulation commands. These deal with the
|
|
~ subitem entry stack, just as the provide-* commands do, but at this phase
|
|
~ of processing the effect is just to create an entry in the entry array,
|
|
~ not to do any actual stack manipulation, so their implementations are
|
|
~ quite simple.
|
|
dup s" drop-subitem" stringcmp 0 = {
|
|
~ Create a new "drop subitem" entry.
|
|
drop drop hex-output-metadata-entry-type-drop-subitem 0
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
dup s" swap-subitems" stringcmp 0 = {
|
|
~ Create a new "swap subitem" entry.
|
|
drop drop hex-output-metadata-entry-type-swap-subitems 0
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
dup s" roll-subitems" stringcmp 0 = {
|
|
~ Create a new "roll subitem" entry. The parameter goes in the content
|
|
~ field, and the length is always zero.
|
|
drop drop 0 swap hex-output-metadata-entry-type-roll-subitems swap
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
|
|
~ If it's flagged as a suffix by the logic above, create a new
|
|
~ suffix-comment entry.
|
|
swap {
|
|
hex-output-metadata-entry-type-suffix-comment swap
|
|
add-hex-output-metadata-entry
|
|
exit
|
|
} if
|
|
|
|
~ Create a new line-comment entry.
|
|
hex-output-metadata-entry-type-line-comment swap
|
|
add-hex-output-metadata-entry ;
|
|
|
|
|
|
~ We need to define a few helpers for use in
|
|
~ hex-read-magic-comment-introducer, below. The string pointers these return
|
|
~ are allocated in the manner described there.
|
|
~
|
|
~ (first key -- body-string-pointer)
|
|
: hex-read-nonempty-comment-body
|
|
~ This is the rare case in the transforms where we want to get into the
|
|
~ nitty-gritty of lexing. Normally we rely on the upstream implementations,
|
|
~ even when we have to go out of our way to do so, because we don't want to
|
|
~ have to update the transforms every time there's a new syntax feature.
|
|
~ Here, however, we've got a syntax that only has meaning to the transform,
|
|
~ so there's no choice.
|
|
swap-transform-variables here @ swap-transform-variables
|
|
|
|
~ This little loop is a modified version of the original tilde loop.
|
|
swap { dup dup 0x0a != && } { pack8 key } while drop
|
|
|
|
0 pack8
|
|
8 packalign
|
|
|
|
drop
|
|
swap-transform-variables here @ swap-transform-variables ;
|
|
|
|
: hex-read-empty-comment-body
|
|
swap-transform-variables here @ swap-transform-variables
|
|
|
|
0 pack8
|
|
8 packalign
|
|
|
|
drop
|
|
swap-transform-variables here @ swap-transform-variables ;
|
|
|
|
|
|
~ This is called from a tilde alternate (such as hex-tilde-alternate, but
|
|
~ there are several). Its purpose is to do the lexical analysis of the
|
|
~ sequence that introduces a magic comment; it assumes that the leading tilde
|
|
~ character has just been consumed from the main input, leaving the separating
|
|
~ space as the next character ready to be read.
|
|
~
|
|
~ Recall that the delimiter for a regular comment is "~ " (the trailing
|
|
~ space is part of it for this purpose). The delimiter for a magic comment is
|
|
~ "~ : ". A regular comment may also have a linefeed instead of a space,
|
|
~ indicating that it's empty; magic comments likewise can be empty, by ending
|
|
~ the line immediately after the colon.
|
|
~
|
|
~ This word does the necessary reading, then leaves the input pointing at
|
|
~ the body of the comment and returns a value indicating what type of comment
|
|
~ this is. A result code of 0 indicates it's a regular comment and the input
|
|
~ now points immediately after its ending delimiter; that is, to the start of
|
|
~ the next line of text. A value of 1 indicates it's a magic comment with
|
|
~ non-zero length and the input points immediately after the delimiter. A
|
|
~ value of 2 indicates it's a magic comment with zero length, and the input
|
|
~ again points to the start of the next line.
|
|
~
|
|
~ Our caller will want to do things with the comment body, so we also return
|
|
~ a pointer to a string in temporary storage, for use in further processing.
|
|
~ This temporary storage is taken from the "real" log, outside the transform's
|
|
~ scope. It's not allocated, merely using the space right after "here",
|
|
~ because the caller may or may not wish to allocate it for the long term, and
|
|
~ may prefer that its long-term location be elsewhere.
|
|
~
|
|
~ Some of the various magic-comment syntaxes care about spacing within the
|
|
~ comment body, so it's important to notice that only the first space after
|
|
~ the colon is consumed. Any subsequent spaces are part of the body.
|
|
~
|
|
~ (-- body string pointer, result code)
|
|
: hex-read-magic-comment-introducer
|
|
~ The original code goes byte-by-byte, checks that the value is nonzero
|
|
~ and not equal to 0x0a (linefeed), and exits when either property fails.
|
|
~ We want to do something different based on the very first characters of
|
|
~ the comment body. So, we unroll the first few iterations of the loop so we
|
|
~ can do that test before we fall back to the normal behavior.
|
|
~
|
|
~ Specifically, we want to recognize a colon (0x3a) with a space (0x20)
|
|
~ immediately after it. Since the interpeter peeked at the space delimiter,
|
|
~ but didn't consume it, we also need to check for a space before the colon,
|
|
~ for a total sequence of three bytes we need to match. We can't just skip
|
|
~ over the space with "consume", because it might also be a linefeed, which
|
|
~ would satisfy the exit criterion. We need to properly match it.
|
|
~
|
|
~ We also recognize a colon followed immediately by a linefeed, as
|
|
~ denoting an empty comment.
|
|
key dup dup 0x0a != && {
|
|
~ If we got here, the first byte was not 0 or 0x0a. Now we check if it's
|
|
~ colon.
|
|
0x20 = {
|
|
~ The first byte was 0x20. Now check the second.
|
|
key dup dup 0x0a != && {
|
|
dup 0x3a = {
|
|
~ The second byte was 0x3a. Now check the third.
|
|
drop key dup {
|
|
~ The third byte is not 0.
|
|
dup 0x20 = {
|
|
~ We have a magic comment with a nonempty body. We must save
|
|
~ the rest of it so we can return it.
|
|
drop key hex-read-nonempty-comment-body 1
|
|
} {
|
|
~ The third byte is not 0 or 0x20.
|
|
dup 0x0a = {
|
|
~ We have a magic comment with an empty body, ending at a
|
|
~ linefeed. As with nonempty ones, we prepare a temporary
|
|
~ string to return.
|
|
drop hex-read-empty-comment-body 2
|
|
} {
|
|
~ The third byte was not 0, 0x0a, or 0x20. We got a space,
|
|
~ a colon, and something else. So our special test failed, but
|
|
~ the exit condition isn't met. So we're done unrolling.
|
|
hex-read-nonempty-comment-body 0
|
|
} if-else
|
|
} if-else
|
|
} {
|
|
~ We got a colon and a zero. This is a magic comment with an
|
|
~ empty body, ending at the end of the file.
|
|
drop hex-read-empty-comment-body 2
|
|
} if-else
|
|
} {
|
|
~ Again, the special test failed but the exit condition isn't met.
|
|
hex-read-nonempty-comment-body 0
|
|
} if-else
|
|
} {
|
|
~ Again, the exit condition is met.
|
|
drop hex-read-empty-comment-body 0
|
|
} if-else
|
|
} {
|
|
~ Once more, the special test failed but the exit condition isn't met.
|
|
hex-read-nonempty-comment-body 0
|
|
} if-else
|
|
} {
|
|
~ For the last time, the exit condition is met.
|
|
drop hex-read-empty-comment-body 0
|
|
} if-else ;
|
|
|
|
|
|
|
|
~ The tilde alternate is a very important word for the hex transform; it has
|
|
~ the task of hooking comment processing to detect a special comment syntax
|
|
~ which can be used by words that generate binary output, to define comments
|
|
~ which will appear as part of the hex-dump version of that output, but which
|
|
~ will be ignored in normal execution.
|
|
~
|
|
~ This mechanism allows us, for example, to avoid putting detailed knowledge
|
|
~ of the amd64 Evocation-assembly instructions in the hex transform; instead
|
|
~ all the details are kept in one place, the authoritative implementations of
|
|
~ those instructions. This will substantially improve the maintainability of
|
|
~ the code, especially when adding new architectures.
|
|
~
|
|
~ This word hex-tilde-alternate only applies to code that is running
|
|
~ directly within the hex transform. When an inner transform runs within the
|
|
~ hex transform, the inner transform is responsible for lexical processing, so
|
|
~ this word never gets invoked. There is an additional variant word
|
|
~ hex-*-tilde-alternate for each inner transform that the hex transform
|
|
~ supports, responsible for conducting the analogous task within the rules of
|
|
~ that inner transform.
|
|
: hex-tilde-alternate
|
|
~ The original tilde is already an immediate word, so we can take over
|
|
~ those responsibilities directly without needing to do any extra work to
|
|
~ check the mode we're in or anything like that.
|
|
hex-read-magic-comment-introducer
|
|
~ (body string pointer, result code)
|
|
|
|
{
|
|
~ It's a magic comment, which may or may not be empty. We want to either
|
|
~ compile or execute a call to hex-tilde-replacement.
|
|
interpreter-flags @ 0x01 & {
|
|
~ We're in compile mode.
|
|
~
|
|
~ Fortunately, we can pack the string directly into the output buffer,
|
|
~ so we don't need to mess around with accumulate-string.
|
|
s" lit" find entry-to-execution-token ,
|
|
has-non-space-this-input-line@ ,
|
|
|
|
s" litstring" find entry-to-execution-token ,
|
|
here @
|
|
swap packstring
|
|
8 packalign
|
|
here !
|
|
|
|
' hex-tilde-replacement entry-to-execution-token ,
|
|
} {
|
|
~ We're in interpret mode.
|
|
has-non-space-this-input-line@ swap
|
|
hex-tilde-replacement
|
|
} if-else
|
|
} {
|
|
~ If it's a regular comment, we just ignore it.
|
|
drop
|
|
} if-else
|
|
|
|
~ Regardless of what path we took, we just consumed a newline, so make
|
|
~ note of the fact.
|
|
0 has-non-space-this-input-line!
|
|
; make-immediate
|
|
|
|
|
|
~ This word runs whenever the label transform, running inside the hex
|
|
~ transform, encounters a tilde. It completely replaces the normal invocation
|
|
~ of tilde, just as hex-tilde-alternate does. It has the same responsibilities
|
|
~ around magic comments as hex-tilde-alternate, but for code which is
|
|
~ lexically processed by label-transform-one rather than by hex-transform-one.
|
|
~
|
|
~ The actions it takes upon finding various sorts of comments differ from
|
|
~ hex-tilde-alternate, because the behavior of the label transform is
|
|
~ different from the behavior of the hex transform.
|
|
~
|
|
~ This is installed by hex-label-word-replacement, bypassing the label
|
|
~ transform's normal precedence rules, so there's no need for it to be
|
|
~ immediate.
|
|
~
|
|
~ Installing this word is the most significant change the hex transform
|
|
~ makes to the behavior of the label transform.
|
|
: hex-label-tilde-alternate
|
|
hex-read-magic-comment-introducer
|
|
~ (body string pointer, result code)
|
|
|
|
{
|
|
~ It's a magic comment, which may or may not be empty.
|
|
interpreter-flags @ 0x01 & {
|
|
~ We're in compile mode. We ignore magic comments in compile mode,
|
|
~ because they shouldn't become part of the program being compiled.
|
|
drop
|
|
} {
|
|
~ We're in interpret mode. We run the magic comment immediately.
|
|
has-non-space-this-input-line@ swap
|
|
swap-transform-variables allocate-string swap-transform-variables
|
|
hex-tilde-replacement
|
|
} if-else
|
|
} {
|
|
~ If it's a regular comment, we just ignore it.
|
|
drop
|
|
} if-else
|
|
|
|
~ Regardless of what path we took, we just consumed a newline, so make
|
|
~ note of the fact.
|
|
0 has-non-space-this-input-line! ;
|
|
|
|
|
|
~ This word runs whenever the log-load transform, running inside the hex
|
|
~ transform, encounters a tilde. It completely replaces the normal invocation
|
|
~ of tilde, just as hex-tilde-alternate does. It has the same responsibilities
|
|
~ around magic comments as hex-tilde-alternate, but for code which is
|
|
~ lexically processed by log-load-transform-one rather than by
|
|
~ hex-transform-one.
|
|
~
|
|
~ The actions it takes upon finding various sorts of comments differ from
|
|
~ hex-tilde-alternate, because the behavior of the log-load transform is
|
|
~ different from the behavior of the hex transform.
|
|
~
|
|
~ This is installed by hex-log-load-word-replacement, bypassing the log-load
|
|
~ transform's normal precedence rules, so there's no need for it to be
|
|
~ immediate.
|
|
~
|
|
~ Installing this word is the most significant change the hex transform
|
|
~ makes to the behavior of the log-load transform.
|
|
: hex-log-load-tilde-alternate
|
|
hex-read-magic-comment-introducer
|
|
~ (body string pointer, result code)
|
|
|
|
{
|
|
~ It's a magic comment, which may or may not be empty.
|
|
interpreter-flags @ 0x01 & {
|
|
~ We're in compile mode. We ignore magic comments in compile mode,
|
|
~ because they shouldn't become part of the program being compiled.
|
|
drop
|
|
} {
|
|
~ We're in interpret mode. We run the magic comment immediately.
|
|
has-non-space-this-input-line@ swap
|
|
swap-transform-variables allocate-string swap-transform-variables
|
|
hex-tilde-replacement
|
|
} if-else
|
|
} {
|
|
~ If it's a regular comment, we just ignore it.
|
|
drop
|
|
} if-else
|
|
|
|
~ Regardless of what path we took, we just consumed a newline, so make
|
|
~ note of the fact.
|
|
0 has-non-space-this-input-line! ;
|
|
|
|
|
|
~ This input helper is a very unusual thing: It's used by hex-transform-one,
|
|
~ hex-label-word-replacement, and hex-log-load-word-replacement to skip the
|
|
~ space between words. That's necessary because we need to keep track of
|
|
~ whether we've had any non-blank stuff on each line yet, so that the tilde
|
|
~ replacement can figure out certain cases where a magic comment needs to be a
|
|
~ suffix comment rather than a line comment.
|
|
: hex-skip-space
|
|
{ peek dup is-space }
|
|
{ consume
|
|
~ This will set the flag once for each newline, if we have multiple
|
|
~ consecutive ones or something like that, but that's harmless.
|
|
0x0a = { 0 has-non-space-this-input-line! } if
|
|
} while drop ;
|
|
|
|
|
|
|
|
~ This word is installed into label-transform-one by the hex-word-alternate,
|
|
~ when the label transform runs inside the hex transform. It has the job of
|
|
~ performing substantive changes to the label transform's behavior, as
|
|
~ required by the hex transform.
|
|
~
|
|
~ The most important changes to the base language that this word makes are
|
|
~ to call hex-label-tilde-alternate any time a tilde is encountered as a word,
|
|
~ and to call hex-skip-space before reading a word.
|
|
~
|
|
~ This word is also responsible for invoking hex-memory-slide-replacement
|
|
~ when memcopy or memmove are encountered in immediate mode. Note that this
|
|
~ really pushes right up against the limit of what it's possible for a
|
|
~ transform to do without altering the compilation's output; invoking the
|
|
~ replacement in compile mode would do so.
|
|
: hex-label-word-replacement
|
|
hex-skip-space
|
|
word
|
|
|
|
value@
|
|
dup s" ~" stringcmp 0 = {
|
|
~ We won't be going back to label-transform-one; clear away its state.
|
|
drop dropstring
|
|
|
|
hex-label-tilde-alternate
|
|
|
|
~ Return directly to label-transform, faking the "not done" return value
|
|
~ from label-transform-one.
|
|
0
|
|
2 nexit
|
|
} if
|
|
dup s" memcopy" stringcmp 0 = {
|
|
interpreter-flags @ 0x01 & not {
|
|
drop hex-memory-slide-replacement exit
|
|
~ Fall through, returning control to label-transform-one.
|
|
} if
|
|
} if
|
|
dup s" memmove" stringcmp 0 = {
|
|
interpreter-flags @ 0x01 & not {
|
|
drop hex-memory-slide-replacement exit
|
|
~ Fall through, returning control to label-transform-one.
|
|
} if
|
|
} if
|
|
drop ;
|
|
|
|
|
|
~ This word is installed into log-load-transform-one by the
|
|
~ hex-word-alternate, when the log-load transform runs inside the hex
|
|
~ transform. It has the job of performing substantive changes to the log-load
|
|
~ transform's behavior, as required by the hex transform.
|
|
~
|
|
~ The most important changes to the base language that this word makes are
|
|
~ to call hex-log-load-tilde-alternate any time a tilde is encountered as a
|
|
~ word, and to call hex-skip-space before reading a word.
|
|
: hex-log-load-word-replacement
|
|
hex-skip-space
|
|
word
|
|
|
|
value@
|
|
dup s" ~" stringcmp 0 = {
|
|
~ We won't be going back to log-load-transform-one; clear away its state.
|
|
drop dropstring
|
|
|
|
hex-log-load-tilde-alternate
|
|
|
|
~ Return directly to log-load-transform, faking the "not done" return
|
|
~ value from log-load-transform-one.
|
|
0
|
|
2 nexit
|
|
} if
|
|
drop ;
|
|
|
|
|
|
~ Just as hex-allocate-alternate has the job of installing
|
|
~ hex-allocate-replacement in only one single spot, so hex-word-alternate has
|
|
~ the job of installing hex-label-word-replacement. It gets installed when
|
|
~ "word" is called from lexically within label-transform-one, and at no other
|
|
~ time.
|
|
~
|
|
~ Notice how the job of each transform's inner bits can be thought of as
|
|
~ calling "word" and doing something with the result, with all the lexical
|
|
~ processing delegated to "word". This makes "word" a good place to install a
|
|
~ modification to the transform's behavior.
|
|
~
|
|
~ Its structure is highly similar to that of hex-allocate-alternate.
|
|
: hex-word-alternate
|
|
interpreter-flags @ 0x01 & {
|
|
~ Compile mode.
|
|
latest @ entry-to-name
|
|
|
|
dup s" label-transform-one" stringcmp 0 = {
|
|
drop
|
|
' hex-label-word-replacement entry-to-execution-token ,
|
|
exit
|
|
} if
|
|
|
|
dup s" log-load-transform-one" stringcmp 0 = {
|
|
drop
|
|
' hex-log-load-word-replacement entry-to-execution-token ,
|
|
exit
|
|
} if
|
|
|
|
~ Not in a word we install stuff into.
|
|
drop
|
|
s" word" find entry-to-execution-token ,
|
|
} {
|
|
~ Immediate mode.
|
|
s" word" find
|
|
dup { entry-to-execution-token execute } { drop allocate } if-else
|
|
} if-else ; make-immediate
|
|
|
|
|
|
~ This implements the hex transform for a single word. It is directly
|
|
~ analogous to "interpret", and reading interpret.e may help in understanding
|
|
~ it, though it's meant to still make sense on its own.
|
|
~
|
|
~ The hex transform runs code immediately. Whereas most transforms alter
|
|
~ what the transformed code compiles into, the hex transform alters what it
|
|
~ outputs. It's assumed that the output is a binary file of some sort; the
|
|
~ binary is output as hexadecimal, interspersed with comments describing the
|
|
~ code that produced it, including descriptions of what was executed, along
|
|
~ with any comments from the original code.
|
|
~
|
|
~ The hex transform's alternates take priority over words defined under
|
|
~ the transform when running immediately, but for compilation, words defined
|
|
~ under the transform take precedence. In the event that neither an alternate
|
|
~ nor an entry in the inner dictionary is found, the outer dictionary is
|
|
~ checked; otherwise it's irrelevant.
|
|
~
|
|
~ The point of this precedence rule is that string literals, which require
|
|
~ special treatment, will be using the inner implementation by the time it
|
|
~ gets to actually generating an executable image. It's important that there
|
|
~ not be any alternates altering the generated code, only the program actually
|
|
~ being compiled. Other literal syntaxes, such as tick, don't have alternates
|
|
~ at all (the hex transform manages to be more parsimonious with alternates
|
|
~ than other transforms), and will always be using inner versions.
|
|
~
|
|
~ The precedence rule does fail to have the desired effect for label
|
|
~ references. For these, the alternates take the unusual step of manually
|
|
~ calling the inner versions when they exist.
|
|
~ TODO think through whether the precedence rule is actually doing anything...
|
|
~
|
|
~ It expects to be called from "hex-transform", below, which loops.
|
|
~
|
|
~ (-- done)
|
|
: hex-transform-one
|
|
hex-skip-space
|
|
word
|
|
|
|
~ If no word was returned, end the transformation.
|
|
dup 0 = { drop 1 exit } if
|
|
|
|
~ The string is on the top of the stack, so to get a pointer to it we get
|
|
~ the stack address.
|
|
~ (string)
|
|
value@
|
|
|
|
~ If it's anything but tilde, set the input state flag accordingly.
|
|
dup s" ~" stringcmp 0 != { 1 has-non-space-this-input-line! } if
|
|
|
|
~ Check whether it's one of the words we have alternates for, and look up
|
|
~ the alternate if so.
|
|
0 swap
|
|
~ (name as stack string, placeholder, name pointer)
|
|
dup s" self-codeword" stringcmp 0 = {
|
|
swap drop ' hex-self-codeword-alternate swap } if
|
|
~ It is nontrivial to construct a string with a double-quote in it.
|
|
dup ' s" entry-to-name stringcmp 0 = {
|
|
swap drop ' hex-string-alternate swap } if
|
|
dup ' ." entry-to-name stringcmp 0 = {
|
|
swap drop ' hex-dot-string-alternate swap } if
|
|
dup s" create" stringcmp 0 = { swap drop ' hex-create-alternate swap } if
|
|
dup s" :" stringcmp 0 = { swap drop ' hex-colon-alternate swap } if
|
|
dup s" ;" stringcmp 0 = { swap drop ' hex-semicolon-alternate swap } if
|
|
dup s" ;asm" stringcmp 0 = {
|
|
swap drop ' hex-semicolon-assembly-alternate swap } if
|
|
dup s" L@'" stringcmp 0 = { swap drop ' hex-L@'-alternate swap } if
|
|
dup s" L!'" stringcmp 0 = { swap drop ' hex-L!'-alternate swap } if
|
|
dup s" bye" stringcmp 0 = { swap drop ' hex-bye-alternate swap } if
|
|
dup s" allocate" stringcmp 0 = {
|
|
swap drop ' hex-allocate-alternate swap } if
|
|
dup s" memcopy" stringcmp 0 = { swap drop ' hex-memcopy-alternate swap } if
|
|
dup s" memmove" stringcmp 0 = { swap drop ' hex-memmove-alternate swap } if
|
|
dup s" word" stringcmp 0 = { swap drop ' hex-word-alternate swap } if
|
|
dup s" ~" stringcmp 0 = { swap drop ' hex-tilde-alternate swap } if
|
|
~ (name as stack string, 0 or alternate entry pointer, name pointer)
|
|
|
|
find
|
|
~ (stack string, 0 or alternate entry pointer, 0 or inner entry pointer)
|
|
|
|
interpreter-flags @ 0x01 & {
|
|
~ We're in compile mode. An alternate immediate entry has the highest
|
|
~ precedence; an inner entry of any kind has second-highest.
|
|
over {
|
|
~ An alternate entry exists; check its flags.
|
|
over entry-flags@ 0x01 & {
|
|
~ It's an immediate entry, so it has precedence, regardless of
|
|
~ what's up with the inner entry. Execute it.
|
|
drop dropstring-with-result
|
|
entry-to-execution-token execute
|
|
0 exit
|
|
} {
|
|
~ The alternate is not immediate, so check if there's an inner entry.
|
|
dup {
|
|
~ There is also an inner entry. Check its flags.
|
|
dup entry-flags@ 0x01 & {
|
|
~ The inner entry is immediate, so it has precedence. Execute it.
|
|
swap drop dropstring-with-result
|
|
entry-to-execution-token execute
|
|
0 exit
|
|
} {
|
|
~ The inner entry is not immediate, so the alternate has
|
|
~ precedence. Compile it.
|
|
~
|
|
~ Watch this space closely for correctness issues, it's a rare
|
|
~ codepath.
|
|
drop dropstring-with-result
|
|
entry-to-execution-token ,
|
|
0 exit
|
|
} if-else
|
|
} {
|
|
~ There's no inner entry. Compile the alternate.
|
|
~
|
|
~ This path, too, is rare and should get close scrutiny for
|
|
~ correctness.
|
|
drop dropstring-with-result
|
|
entry-to-execution-token ,
|
|
0 exit
|
|
} if-else
|
|
} if-else
|
|
} {
|
|
~ There is no alternate entry; check for an inner entry.
|
|
dup {
|
|
~ An inner entry exists; check its flags.
|
|
dup entry-flags@ 0x01 & {
|
|
~ It's an immediate entry. Execute it.
|
|
swap drop dropstring-with-result
|
|
entry-to-execution-token execute
|
|
0 exit
|
|
} {
|
|
~ It's not an immediate entry. Compile it.
|
|
swap drop dropstring-with-result
|
|
entry-to-execution-token ,
|
|
0 exit
|
|
} if-else
|
|
} if
|
|
~ If we got here, there's no inner or alternate entry; fall through.
|
|
} if-else
|
|
} {
|
|
~ We're in immediate mode. An alternate entry of any kind has precedence.
|
|
over {
|
|
~ There's an alternate entry. Execute it.
|
|
drop dropstring-with-result
|
|
entry-to-execution-token execute
|
|
0 exit
|
|
} {
|
|
~ There's no alternate entry. Check for an inner entry.
|
|
dup {
|
|
~ An inner entry exists. Execute it.
|
|
swap drop dropstring-with-result
|
|
entry-to-execution-token execute
|
|
0 exit
|
|
} if
|
|
~ If we got here, there's no inner or alternate; fall through.
|
|
} if-else
|
|
} if-else
|
|
drop drop
|
|
~ (stack string)
|
|
|
|
~ As a final fallback, we also check the outer dictionary, for immediate
|
|
~ use only. This will allow things like assembly words to work.
|
|
value@
|
|
swap-transform-variables
|
|
find
|
|
swap-transform-variables
|
|
dup {
|
|
~ There's an outer entry; check the mode.
|
|
interpreter-flags @ 0x01 & {
|
|
~ We're in compile mode; check the outer entry's flags.
|
|
dup entry-flags@ 0x01 & {
|
|
~ It's an immediate word; execute it.
|
|
dropstring-with-result
|
|
entry-to-execution-token
|
|
execute
|
|
0 exit
|
|
} {
|
|
~ It's not an immediate word. Pretend it doesn't exist, and fall
|
|
~ through.
|
|
drop
|
|
} if-else
|
|
} {
|
|
~ We're in immediate mode. Execute the outer entry.
|
|
dropstring-with-result
|
|
entry-to-execution-token
|
|
execute
|
|
0 exit
|
|
} if-else
|
|
} {
|
|
~ There's no outer entry. Fall through.
|
|
drop
|
|
} if-else
|
|
~ (stack string)
|
|
|
|
~ Check whether it's a number literal.
|
|
value@ read-integer 0 = {
|
|
~ It's a number.
|
|
~
|
|
~ (name as stack string, integer value)
|
|
dropstring-with-result
|
|
~ (integer value)
|
|
|
|
interpreter-flags @ 0x01 & {
|
|
~ TODO this probably needs a lit alternate (!)
|
|
' lit entry-to-execution-token , ,
|
|
0 exit
|
|
} if
|
|
|
|
0 exit
|
|
} if
|
|
~ (stack string)
|
|
|
|
." No such word: " value@ emitstring newline dropstring 0 ;
|
|
|
|
|
|
~ This implements the hex transform for all words in a region given as
|
|
~ an input string. It is directly analogous to "quit", in interpret.e, but is
|
|
~ more complex.
|
|
~
|
|
~ (output metadata buffer start, output buffer start, output point,
|
|
~ input string pointer -- output buffer start, output point)
|
|
: hex-transform
|
|
main-input-buffer dup push-input-buffer
|
|
swap attach-string-to-input-buffer
|
|
~ (output metadata buffer start, output buffer start, output point)
|
|
|
|
~ Save the old values of "here" and "latest", and set the initial values
|
|
~ of the internal ones. These values need to persist across iterations,
|
|
~ since client code will make its own updates to them and then rely on those
|
|
~ updates having taken effect. So we do the swap just once, here outside the
|
|
~ loop, and set it back when the loop ends.
|
|
~
|
|
~ We also take this opportunity to initialize the other fields of
|
|
~ transformation-state. While it might be nice to do these in some sort of
|
|
~ logical order, it gets unreadable quickly, so we initialize them in the
|
|
~ most convenient order given how we received our parameters.
|
|
here @ transformation-state transformation-state-saved-here !
|
|
latest @ transformation-state transformation-state-saved-latest !
|
|
here !
|
|
0 latest !
|
|
transformation-state transformation-state-output-buffer-start !
|
|
0 transformation-state transformation-state-user-stack-depth !
|
|
transformation-state transformation-state-output-metadata !
|
|
~ Now the stack has nothing of ours on it, so client code can do its thing.
|
|
|
|
~ We don't have the real values yet, so we can't create the initial
|
|
~ entries in the output metadata, but we can and should zero it out to make
|
|
~ sure everything else operating on it finds it well-formed.
|
|
zero-hex-output-metadata
|
|
|
|
~ The code under the hex transform never gets a real copy of warm-start,
|
|
~ so it doesn't have the globals "here" and so on. It wants to have the
|
|
~ globals, but it can't, not without our help. Why aren't we helping?
|
|
~
|
|
~ Oh, right, we're helping right here. We just write them into the inner
|
|
~ log and dictionary directly, by using our outer copy of "variable". These
|
|
~ definitions don't have to do anything special; we point them to the same
|
|
~ addresses as the outer ones. Note though that the actual values the
|
|
~ transformed code sees sees are the wrapped, inner ones, since we swapped
|
|
~ the values out elsewhere.
|
|
~
|
|
~ If we provided these as alternates instead, that would work for code
|
|
~ that doesn't have a nested transform, but the inner transforms want to be
|
|
~ able to look them up by name.
|
|
swap-transform-variables log swap-transform-variables s" log" variable
|
|
swap-transform-variables s0 swap-transform-variables s" s0" variable
|
|
swap-transform-variables r0 swap-transform-variables s" r0" variable
|
|
swap-transform-variables latest swap-transform-variables s" latest" variable
|
|
swap-transform-variables here swap-transform-variables s" here" variable
|
|
|
|
~ It's important that the stack has nothing of ours on it that persists
|
|
~ across iterations, so that client code can add and remove stuff there as
|
|
~ it sees fit.
|
|
{ hex-transform-one
|
|
~ (done)
|
|
|
|
~ When the loop is done, get the real values of "here" and "latest"
|
|
~ back. The internal "here" is also the output point, and will become our
|
|
~ return value. The internal "latest" is discarded.
|
|
{ transformation-state transformation-state-output-buffer-start @
|
|
here @
|
|
transformation-state transformation-state-saved-here @ here !
|
|
transformation-state transformation-state-saved-latest @ latest !
|
|
~ (output point)
|
|
|
|
~ Though we don't actually use transformation-state outside of this
|
|
~ invocation, for tidiness we zero it out.
|
|
0 transformation-state transformation-state-saved-here !
|
|
0 transformation-state transformation-state-saved-latest !
|
|
0 transformation-state transformation-state-output-buffer-start !
|
|
0 transformation-state transformation-state-user-stack-depth !
|
|
|
|
~ Also put the input source back how it was.
|
|
main-input-buffer pop-input-buffer
|
|
|
|
exit } if } forever ;
|
|
|