Here it is, the complete source.
Eventually, I intend to have the source more intricately formatted in literate-programming style, but for now you get it in one great glob:
( - 120-C-muf.muf -- Compile "Multi-User Forth". )
( - This file is formatted for outline-minor-mode in emacs19. )
( -^C^O^A shows All of file. )
( ^C^O^Q Quickfolds entire file. (Leaves only top-level headings.) )
( ^C^O^T hides all Text. (Leaves all headings.) )
( ^C^O^I shows Immediate children of node. )
( ^C^O^S Shows all of a node. )
( ^C^O^D hiDes all of a node. )
( ^HFoutline-mode gives more details. )
( (Or do ^HI and read emacs:outline mode.) )
( ===================================================================== )
( - Dedication and Copyright. )
( ------------------------------------------------------------------- )
( )
( For Firiss: Aefrit, a friend. )
( )
( ------------------------------------------------------------------- )
( ------------------------------------------------------------------- )
( Author: Jeff Prothero )
( Created: 96May26 )
( Modified: )
( Language: MUF )
( Package: N/A )
( Status: )
( )
( Copyright (c) 1997, by Jeff Prothero. )
( )
( This program is free software; you may use, distribute and/or modify )
( it under the terms of the GNU Library General Public License as )
( published by the Free Software Foundation; either version 2, or at )
( your option any later version FOR NONCOMMERCIAL PURPOSES. )
( )
( COMMERCIAL operation allowable at $100/CPU/YEAR. )
( COMMERCIAL distribution (e.g., on CD-ROM) is UNRESTRICTED. )
( Other commercial arrangements NEGOTIABLE. )
( Contact cynbe@eskimo.com for a COMMERCIAL LICENSE. )
( )
( This program is distributed in the hope that it will be useful, )
( but WITHOUT ANY WARRANTY; without even the implied warranty of )
( MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the )
( GNU Library General Public License for more details. )
( )
( You should have received a copy of the GNU General Public License )
( along with this program: COPYING.LIB; if not, write to: )
( Free Software Foundation, Inc. )
( 675 Mass Ave, Cambridge, MA 02139, USA. )
( )
( Jeff Prothero DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, )
( INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN )
( NO EVENT SHALL JEFF PROTHERO BE LIABLE FOR ANY SPECIAL, INDIRECT OR )
( CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS )
( OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, )
( NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION )
( WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. )
( )
( Please send bug reports/fixes etc to bugs@muq.org. )
( ------------------------------------------------------------------- )
( ===================================================================== )
( - Epigram. )
( "Notice that most things that call themselves sciences, aren't: )
( Military science, political science, computer science... )
( Real sciences don't need to call themselves that: )
( Physics, biology..." *grin* )
( -- Fred Brooks, 94Jan27 talk at UW. )
( )
( NB: Fred is father to IBM's 360, OS/360, the computer graphics dept )
( at University of North Carolina, Chapel Hill -- dept head for 20 )
( years -- and of the virtual reality program there. No hacker should )
( miss reading Fred's "The Mythical Man-Month". -- Cynbe )
( ===================================================================== )
( - Select MUF Package: )
"muf" inPackage
( ===================================================================== )
( - Types - )
( ===================================================================== )
( - compileDoubleQuote -- Compile token starting with " )
: compileDoubleQuote { $ $ -> } -> ctx -> mode
[ ctx.mss '"' '\\' | |scanTokenToChar
|pop --> ctx.line ( Line number string started on. )
|readTokenChars ( Get string chars as block. )
|popp ( Drop terminal doubleQuote. )
|doCBackslashes ( Expand '\' '0' to \0 &tc )
]join ( Reduce result to a string. )
ctx.asm assembleConstant ( Assemble string as const )
;
'compileDoubleQuote export
( ===================================================================== )
( - compileSymbol -- Compile given symbol )
: compileSymbol { $ $ $ -> } -> ctx -> mode -> sym
ctx.asm -> asm
( Unpack 'mode' bitbucket: )
mode compile:modeSet logand 0 != -> gotSet ( --> path )
mode compile:modeGet logand 0 != -> gotGet ( path )
mode compile:modeDel logand 0 != -> gotDel ( delete: path )
mode compile:modeFn logand 0 != -> gotFn ( #'path )
mode compile:modeQuote logand 0 != -> gotQuote ( 'path )
mode compile:modeConst logand 0 != -> gotConst ( -->constant )
mode compile:modeInc logand 0 != -> gotInc ( ++ )
mode compile:modeDec logand 0 != -> gotDec ( -- )
( Handle function calls: )
gotQuote not
gotFn not and
gotGet and if
sym symbolFunction -> cfn
cfn compiledFunction? if
cfn.compileTime? if
( "compileSymbol doing compileTime fn...\n" , )
ctx cfn call{ $ -> }
return
else
( "compileSymbol assembling call...\n" , )
sym asm assembleCall
return
fi
fi
fi
( Handle loads: )
gotGet if
( Save an instruction by loading consts )
( directly at runtime, instead of doing )
( fetch from symbol: )
sym constant? gotQuote not and if
( "compileSymbol assembling const...\n" , )
sym symbolValue asm assembleConstant
return
fi
( Assemble code to load symbol onto stack: )
sym asm assembleConstant
( Handle #'xxx loads of function value: )
gotFn if
( "compileSymbol assembling symbolFunction...\n" , )
'symbolFunction asm assembleCall
return
fi
( Handle vanilla loads of symbol value: )
gotQuote not if
( "compileSymbol assembling symbolValue call...\n" , )
'symbolValue asm assembleCall
fi
return
fi
( Handle stores: )
gotSet if
( "compileSymbol assembling store...\n" , )
( Sanity check: )
gotQuote if "Can't do exp --> 'sym" simpleError fi
( Deposit code to load symbol on stack: )
sym asm assembleConstant
( Deposit code to do appropriate kind of store: )
gotFn if 'setSymbolFunction asm assembleCall
return
fi
gotConst if 'setSymbolConstant asm assembleCall
else 'setSymbolValue asm assembleCall fi
return
fi
( Handle ++ and --: )
gotInc gotDec or if
( "compileSymbol assembling inc/dec...\n" , )
( Sanity check: )
gotQuote if "Can't do ++ 'sym" simpleError fi
( Load symbol onto stack: )
sym asm assembleConstant
( Get value of symbol: )
'symbolValue asm assembleCall
( Get constant 1: )
1 asm assembleConstant
( Bump it: )
gotInc if '+ else '- fi asm assembleCall
( Load symbol onto stack again: )
sym asm assembleConstant
( Store new value into it: )
'setSymbolValue asm assembleCall
return
fi
gotDel if
( "compileSymbol assembling delete...\n" , )
""delete: symbol" not supported" simpleError
fi
"internal err" simpleError
;
( ===================================================================== )
( - compileHash -- Compile token starting with # )
: compileHash { $ $ -> $ } -> ctx -> mode
[ ctx.mss '\\' | |scanTokenToWhitespace
|pop --> ctx.line ( Line number token started on. )
|readTokenChars ( Get string chars as block. )
( # Followed by whitespace is comment to end of line: )
|length 0 = if
]pop
[ ctx.mss '\n' | |scanTokenToChar ]pop
[ ctx.mss | |unreadTokenChar ]pop
t return
fi
( Should check here for #: yielding uninterned symbol )
( Get 1st char, check it is ' )
|shift -> c
c '\" != if
c |unshift ]join
"Unrecognized syntax: #" swap join simpleError
fi
( Complain if using number syntax to name a function: )
|backslashesToHighbit
( |downcase )
|potentialNumber? if
]join
"#'<number> isn't supported. Try using || or \\ quotes: #'"
swap join simpleError
fi
( Look up given symbol: )
mode compile:modeSet logand 0 != if
ctx.package ]makeSymbol -> sym
else
ctx.package |findSymbol? -> sym not if
]join "No such symbol: #'" swap join simpleError
fi
]pop
fi
sym mode compile:modeFn logior ctx compileSymbol
nil
;
'compileHash export
( ===================================================================== )
( - compileVanilla -- Compile token not starting with # ' or " )
: compileVanilla { $ $ -> } -> ctx -> mode
ctx.asm -> asm
( Read to next whitespace [ ] $ . or ' )
[ ctx.mss
( Special hack mostly so --> and -> parse as one token: )
mode compile:modeSubex logand 0 != if "[]$.'" else "\n\r\t [$.'" fi
'\\'
| |scanTokenToChars
|pop --> ctx.line ( Line number token started on. )
|readTokenChars ( Get token chars as block. )
|pop -> nextchar
( Special case supporting ' ': )
mode compile:modeQuote logand 0 != if
|length 0 = if
nextchar ' ' =
if
( Read a token char: )
[ ctx.mss |
|readTokenChar
|pop -> lineloc lineloc --> ctx.line
|pop -> byteloc lineloc ctx.fnLine - --> ctx.asm.lineInFn
|pop -> c
]pop
c '\" = not if
"Bad syntax following singleQuote (')" simpleError
fi
nextchar ctx.asm assembleConstant ( Assemble char as const )
]pop
return
fi
nextchar '$' =
nextchar '.' = or
nextchar '[' = or
nextchar ']' = or
nextchar '\" = or
if
( Read a token char: )
[ ctx.mss |
|readTokenChar
|pop -> lineloc lineloc --> ctx.line
|pop -> byteloc lineloc ctx.fnLine - --> ctx.asm.lineInFn
|pop -> c
]pop
c '\" = if
nextchar ctx.asm assembleConstant ( Assemble as const )
]pop
return
fi
[ ctx.mss | |unreadTokenChar ]pop
fi fi fi
( Icky special case supporting '[' : )
|length 0 =
nextchar '[' =
and if
]pop
[ ctx.mss
mode compile:modeSubex logand 0 != if "[$.'" else "\n\r\t $.'" fi
'\\'
| |scanTokenToChars
|pop --> ctx.line ( Line number token started on. )
|readTokenChars ( Get token chars as block. )
|pop -> nextchar
'[' |unshift
fi
( Icky special case supporting tokens ending in '[' : )
nextchar '[' = if
( Read a token char: )
[ ctx.mss |
|readTokenChar
|pop -> tmplineloc
|pop -> tmpbyteloc
|pop -> tmpnextchar
]pop
tmpnextchar ' ' =
tmpnextchar '\t' = or
tmpnextchar '\r' = or
tmpnextchar '\n' = or if
'[' |push
tmpnextchar -> nextchar
tmplineloc -> lineloc
tmpbyteloc -> byteloc
lineloc --> ctx.line
lineloc ctx.fnLine - --> ctx.asm.lineInFn
else
[ ctx.mss | |unreadTokenChar ]pop
fi
fi
( Special case supporting 'a' '\0' '\r' &tc: )
nextchar '\" = if
mode compile:modeQuote logand 0 != if
|doCBackslashes ( Expand '\' '0' to \0 &tc )
|length 1 != if
"Char consts must contain exactly one char" simpleError
fi
|pop -> c ]pop c ( Reduce result to a single char. )
ctx.asm assembleConstant ( Assemble char as const )
return
fi fi
[ ctx.mss | |unreadTokenChar ]pop
( mode compile:modeQuote logand 0 != if )
( "compileVanilla/quote: " , |dup[ ]join , " ...\n" , fi )
|backslashesToHighbit
( |downcase )
( If not at end of path )
( suppress store/delete: )
nextchar whitespace?
nextchar '>' =
or not if
mode compile:modeQuote logand 0 = if
compile:modeGet -> mode
else
compile:modeGet compile:modeQuote logior -> mode
fi
fi
( Numbers are a special case: )
|potentialNumber? if
nextchar '.' = if
( Read rest of potential number: )
[ ctx.mss
"\n\r\t []$/'"
'\\'
| |scanTokenToChars
|popp
|readTokenChars ( Get token chars as block. )
|pop -> nextchar
|backslashesToHighbit
]|join
[ ctx.mss | |unreadTokenChar ]pop
( "number = '" , |for i do{ i , ", " , } "'\n" , )
fi
]makeNumber -> val -> typ
( "val = '" , val , "'\n" , )
( "typ = '" , typ , "'\n" , )
typ lisp:lispBadnum = if "bad number syntax" simpleError fi
val asm assembleConstant
return
fi
( Is it a local variable? )
ctx compile:|findLocal? -> val -> typ -> nam -> pos
pos
mode compile:modeQuote logand 0 =
and if
typ case{
on: :var
pos ctx.symbolsSp >= if
mode compile:modeGet logand 0 != if
val asm assembleVariableGet
]pop
return
fi
mode compile:modeSet logand 0 != if
"Use -> not --> to set local variables." simpleError
fi
mode compile:modeInc logand 0 != if
val asm assembleVariableGet
1 asm assembleConstant
'+ asm assembleCall
val asm assembleVariableSet
]pop
return
fi
mode compile:modeDec logand 0 != if
val asm assembleVariableGet
1 asm assembleConstant
'- asm assembleCall
val asm assembleVariableSet
]pop
return
fi
fi
on: :fn
val not if
( Recursive call to function being compiled. )
( Create a symbol to represent function, and )
( indirect call through it. compileSemi will )
( fix up the function slot of the symbol: )
makeSymbol -> val
val --> ctx.symbols[pos]
fi
val callable? if
val asm assembleCall
]pop
return
fi
]join
"Compiler bug: Local fn has unknown val type: "
swap join simpleError
on: :tag
val asm assembleLabel
]pop
return
else:
]join "Compiler bug: Local has unknown type: " swap join simpleError
}
fi
( Here's an ugly specialCase hack for ']' )
( which is a normal user fn except for )
( having to match '[': )
nil -> rbracket
"]" |= if t -> rbracket fi
"]l" |= if t -> rbracket fi
"]v" |= if t -> rbracket fi
"]i16" |= if t -> rbracket fi
"]i32" |= if t -> rbracket fi
"]f32" |= if t -> rbracket fi
"]f64" |= if t -> rbracket fi
rbracket if
mode compile:modeQuote logand 0 = if ( Don't fire on '] export )
ctx compile:popLbracket pop
fi fi
( Find/create symbol: )
mode compile:modeSet logand 0 !=
mode compile:modeQuote logand 0 != or if
ctx.package ]makeSymbol -> sym
else
ctx.package |findSymbol? -> sym not if
]join "Undefined identifier: " swap join simpleError
fi
]pop
fi
( Compile symbol op: )
sym mode ctx compileSymbol
;
'compileVanilla export
( ===================================================================== )
( - compilePath -- code for $ . and [...] parts of paths )
: compilePath { $ $ -> ! } -> ctx -> mode ( '!' for recursion )
ctx.asm -> asm
( Find non-whitespace: )
do{
( Read a token char: )
[ ctx.mss |
|readTokenChar
|pop -> lineloc lineloc --> ctx.line
|pop -> byteloc lineloc ctx.fnLine - --> ctx.asm.lineInFn
|pop -> c
]pop
( We ignore whitespace, except that we )
( return and prompt if we find a newline: )
c '\n' = if t --> ctx.ateNewline return fi
c whitespace? not until
( Eat all the whitespace: )
[ ctx.mss | |scanTokenToNonwhitespace
|pop -> seenEoln
]pop
seenEoln if t --> ctx.ateNewline return fi
}
( Compile part of path preceding )
( first $ . or [ (if any): )
c case{
on: '$'
( Path starting with null name of root: )
'root asm assembleCall
[ ctx.mss | |unreadTokenChar ]pop
on: '.'
( Path starting with null name of root: )
'root asm assembleCall
[ ctx.mss | |unreadTokenChar ]pop
on: '"' mode ctx compileDoubleQuote
on: '\"
( Parse normally, except )
( with modeQuote flag set: )
mode compile:modeQuote logior ctx compileVanilla
on: '#' mode ctx compileHash if t --> ctx.ateNewline return fi
else:
[ ctx.mss | |unreadTokenChar ]pop
mode ctx compileVanilla
}
( Compile parts of path following the first )
( $ . or [ -- done when we reach whitespace: )
do{
( Read a token char: )
[ ctx.mss |
|readTokenChar
|pop -> lineloc lineloc --> ctx.line
|pop -> byteloc lineloc ctx.fnLine - --> ctx.asm.lineInFn
|pop -> c
]pop
( Whitespace or '>' means we're done: )
c whitespace?
c '>' = or ( buggo, phasing out > )
c ']' = or if
[ ctx.mss | |unreadTokenChar ]pop
return
fi
( Figure out whether we are about to read )
( the public, hidden, admins, or system )
( part of the object. We do this )
( by assuming PUBLIC unless prefix is one )
( of $h[idden] $s[system]... )
'get -> getVal
'set -> setVal
'delKey -> delVal
c '$' = if
[ ctx.mss ".[" | |scanTokenToChars
|popp ( Line number )
|readTokenChars
|pop -> c ( Save terminal . or [ )
( |downcase )
|shift -> c1 ( Get first char )
]pop ( Buggo, should check rest of field )
c1 case{
on: 'a'
'adminsGet -> getVal
'adminsSet -> setVal
'adminsDelKey -> delVal
on: 'h'
'hiddenGet -> getVal
'hiddenSet -> setVal
'hiddenDelKey -> delVal
( on: 'm' )
( 'methodGet -> getVal )
( 'methodSet -> setVal )
( 'methodDelKey -> delVal )
on: 'p'
'get -> getVal
'set -> setVal
'delKey -> delVal
on: 's'
'systemGet -> getVal
'systemSet -> setVal
'systemDelKey -> delVal
else:
"Bad $ field" simpleError
}
fi
c case{
on: '.'
( Read keyword chars: )
( Read to next whitespace [ ] $ or . )
[ ctx.mss
( Special hack mostly so --> and -> parse as one token: )
mode compile:modeSubex logand 0 != if
"[]$."
else
"\n\r\t [$."
fi
'\\'
| |scanTokenToChars
|popp ( Line number )
|readTokenChars ( Get token chars as block. )
|pop -> nextchar
[ ctx.mss | |unreadTokenChar ]pop
( Handle special cases like . by itself: )
|length 0 = if
nextchar whitespace? if ]pop return fi
( We currently don' allow null path components: )
"bad syntax after ." simpleError
fi
( Add initial ':' for keyword syntax: )
':' |unshift
( Find/make keyword: )
|backslashesToHighbit
( |downcase )
ctx.package ]makeSymbol -> sym
( Deposit code to put keyword on stack: )
sym asm assembleConstant
on: '['
( Compile subPath recursively: )
compile:modeGet compile:modeSubex logior ctx compilePath
( Eat following ']', error if missing: )
[ ctx.mss |
|readTokenChar
|pop -> lineloc lineloc --> ctx.line
|pop -> byteloc lineloc ctx.fnLine - --> ctx.asm.lineInFn
|pop -> c
]pop
c ']' != if "Couldn't find ']' matching '['" simpleError fi
( Validate nextchar: )
[ ctx.mss |
|readTokenChar
|pop -> lineloc lineloc --> ctx.line
|pop -> byteloc lineloc ctx.fnLine - --> ctx.asm.lineInFn
|pop -> nextchar
]pop
[ ctx.mss | |unreadTokenChar ]pop
else:
"Unrecognized path syntax" simpleError
}
( Deposit appropriate load/store/delete: )
( If we're not at end of path, )
( we always want to do a fetch: )
nextchar whitespace? not if
getVal asm assembleCall
loopNext
fi
( We are at end of path, so pick )
( load/store/delete per mode: )
mode compile:modeGet logand 0 != if
getVal asm assembleCall
return
fi
mode compile:modeSet logand 0 != if
setVal asm assembleCall
return
fi
mode compile:modeInc logand 0 != if
'dup2nd asm assembleCall
'dup2nd asm assembleCall
getVal asm assembleCall
1 asm assembleConstant
'+ asm assembleCall
'rot asm assembleCall
'rot asm assembleCall
setVal asm assembleCall
return
fi
mode compile:modeDec logand 0 != if
'dup2nd asm assembleCall
'dup2nd asm assembleCall
getVal asm assembleCall
1 asm assembleConstant
'- asm assembleCall
'rot asm assembleCall
'rot asm assembleCall
setVal asm assembleCall
return
fi
mode compile:modeDel logand 0 != if
delVal asm assembleCall
return
fi
"Internal err: bad mode" simpleError
}
;
'compilePath export
( ===================================================================== )
( - ]reportCompileError -- to print line # &tc )
: ]reportCompileError { [] -> [] ! }
:formatString |get -> msg
]pop
@.compiler -> ctx
ctx.mss.twin -> mss
mss.line -> line
"***** " , line 1+ , ": " , msg , "\n" ,
'abort invokeRestart
;
']reportCompileError export
( ===================================================================== )
( - compileFile -- Simple muf file compiler. )
: compileFile { -> ? }
( This is basically just like muf:]shell )
( except for not issuing any prompts: )
( Get stream to read from: )
@.standardInput -> mss
mss isAMessageStream
[ :ephemeral t
:mss mss
:package @.lib["muf"]
:outermost t
| 'compile:context ]makeStructure -> ctx
makeFunction -> fun
( -- BEGIN BOILERPLATE -- )
( Establish a restart letting users )
( to kill the job from the debugger: )
[ :function :: { -> ! } nil endJob ;
:name 'endJob
:reportFunction "Terminate job."
| ]withRestartDo{ ( 1 )
( Establish a handler letting users )
( terminate a job with a signal )
( -- via 'killJob' say: )
[ .e.kill :: { [] -> [] ! } :why |get endJob ;
| ]withHandlerDo{ ( 2 )
( Establish a restart letting users )
( return to the main shell prompt )
( from the debugger: )
[ :function :: { -> ! } 'abrt goto ;
:name 'abort
:reportFunction "Return to main mufShell prompt."
| ]withRestartDo{ ( 3 )
( Establish a handler letting users )
( abort a job with a signal )
( -- via 'abortJob' say: )
[ .e.abort :: { [] -> [] ! } 'abort invokeRestart ;
| ]withHandlerDo{ ( 4 )
withTag abrt do{ ( 8 ) ( Trap compile errs etc )
abrt ( Continuation from errors )
( -- END BOILERPLATE -- )
( Establish handler to report errors: )
[ .e.error ( simpleError or serverError, presumably )
']reportCompileError
| ]withHandlersDo{ ( 5 )
( Central readEvalPrint loop: )
do{
( Save compile context where )
( user code &tc can find it: )
ctx --> @.compiler
( Reset assembler for new function: )
[ ctx | compile:resetContext ]pop
( Loop accumulating tokens until we reach )
( an \n with no control structures open: )
nil --> ctx.ateNewline
do{
compile:modeGet ctx compilePath
ctx.syntax length 0 = ctx.ateNewline and until
}
ctx.asm.bytecodes 0 != if
( Complete assembly: )
t 0 fun ctx.asm finishAssembly -> cfn
( Plug source and executable into fn: )
"" --> fun.source
cfn --> fun.executable
( Execute compiled function: )
cfn call{ -> }
fi
}
} ( 8 )
} ( 5 )
} ( 4 )
} ( 3 )
} ( 2 )
} ( 1 )
;
'compileFile export
( - File variables )
( Local variables: )
( mode: outline-minor )
( outline-regexp: "( -+" )
( End: )
Go to the first, previous, next, last section, table of contents.